freepascal.compiler/compiler/tgobj.pas

{
    $Id$
    Copyright (c) 1998-2002 by Florian Klaempfl

    This unit implements the base object for temp. generator

    This program is free software; you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation; either version 2 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program; if not, write to the Free Software
    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

 ****************************************************************************
}

unit tgobj;

{$i defines.inc}

  interface

    uses
      globals,
      cpubase,
      cpuinfo,
      cpuasm,
      tainst,
      cclasses,globtype,cgbase,aasm;

    type
      ttemptype = (tt_none,tt_free,tt_normal,tt_persistant,
                   tt_ansistring,tt_freeansistring,tt_widestring,tt_freewidestring,
                   tt_interfacecom,tt_freeinterfacecom);

      ttemptypeset = set of ttemptype;

      ptemprecord = ^ttemprecord;
      ttemprecord = record
         temptype   : ttemptype;
         pos        : longint;
         size       : longint;
         next       : ptemprecord;
         nextfree   : ptemprecord; { for faster freeblock checking }
{$ifdef EXTDEBUG}
         posinfo,
         releaseposinfo : tfileposinfo;
{$endif}
      end;


       ttgobj = class
          { contains all temps }
          templist      : ptemprecord;
          { contains all free temps using nextfree links }
          tempfreelist  : ptemprecord;
          { Offsets of the first/last temp }
          firsttemp,
          lasttemp      : longint;
          lasttempofsize : ptemprecord;

          { tries to hold the amount of times which the current tree is processed  }
          t_times: longint;

          constructor create;

          { generates temporary variables }
          procedure resettempgen;
          procedure setfirsttemp(l : longint);
          function gettempsize : longint;
          function gettempofsize(list: taasmoutput; size : longint) : longint;
          { special call for inlined procedures }
          function gettempofsizepersistant(list: taasmoutput; size : longint) : longint;
          procedure gettempofsizereferencepersistant(list: taasmoutput; l : longint;var ref : treference);

          procedure gettemppointerreferencefortype(list: taasmoutput; var ref : treference; const usedtype, freetype: ttemptype);
          function ungettemppointeriftype(list: taasmoutput; const ref : treference; const usedtype, freetype: ttemptype) : boolean;

          { for parameter func returns }
          procedure normaltemptopersistant(pos : longint);
          procedure persistanttemptonormal(pos : longint);

          {procedure ungettemp(pos : longint;size : longint);}
          procedure ungetpersistanttemp(list: taasmoutput; pos : longint);
          procedure ungetpersistanttempreference(list: taasmoutput; const ref : treference);

          procedure gettempofsizereference(list: taasmoutput; l : longint;var ref : treference);
          function istemp(const ref : treference) : boolean;
          procedure ungetiftemp(list: taasmoutput; const ref : treference);
          function getsizeoftemp(const ref: treference): longint;

          function ungetiftempansi(list: taasmoutput; const ref : treference) : boolean;
          procedure gettempansistringreference(list: taasmoutput; var ref : treference);

          function ungetiftempwidestr(list: taasmoutput; const ref : treference) : boolean;
          procedure gettempwidestringreference(list: taasmoutput; var ref : treference);

          function ungetiftempintfcom(list: taasmoutput; const ref : treference) : boolean;
          procedure gettempintfcomreference(list: taasmoutput; var ref : treference);

       private
          function ungettemp(list: taasmoutput; pos:longint;allowtype:ttemptype):ttemptype;
          function newtempofsize(size : longint) : longint;
       end;

     var
       tg: ttgobj;


  implementation

    uses
       systems,
       verbose,cutils;

    constructor ttgobj.create;

     begin
       tempfreelist:=nil;
       templist:=nil;
       lasttempofsize := nil;
     end;


    procedure ttgobj.resettempgen;
      var
         hp : ptemprecord;
      begin
        { Clear the old templist }
        while assigned(templist) do
         begin
{$ifdef EXTDEBUG}
           case templist^.temptype of
             tt_normal,
             tt_persistant :
               Comment(V_Warning,'temporary assignment of size '+
                       tostr(templist^.size)+' from pos '+tostr(templist^.posinfo.line)+
                       ':'+tostr(templist^.posinfo.column)+
                       ' at pos '+tostr(templist^.pos)+
                       ' not freed at the end of the procedure');
             tt_ansistring :
               Comment(V_Warning,'temporary ANSI assignment of size '+
                       tostr(templist^.size)+' from pos '+tostr(templist^.posinfo.line)+
                       ':'+tostr(templist^.posinfo.column)+
                       ' at pos '+tostr(templist^.pos)+
                     ' not freed at the end of the procedure');
             tt_widestring :
               Comment(V_Warning,'temporary WIDE assignment of size '+
                       tostr(templist^.size)+' from pos '+tostr(templist^.posinfo.line)+
                       ':'+tostr(templist^.posinfo.column)+
                       ' at pos '+tostr(templist^.pos)+
                     ' not freed at the end of the procedure');
           end;
{$endif}
           hp:=templist;
           templist:=hp^.next;
           dispose(hp);
         end;
        templist:=nil;
        tempfreelist:=nil;
        firsttemp:=0;
        lasttemp:=0;
      end;


    procedure ttgobj.setfirsttemp(l : longint);
      begin
         { this is a negative value normally }
         if l < 0 then
          Begin
            if odd(l) then
             Dec(l);
          end
         else
          Begin
            if odd(l) then
             Inc(l);
          end;
         firsttemp:=l;
         lasttemp:=l;
      end;


    function ttgobj.newtempofsize(size : longint) : longint;
      var
        tl : ptemprecord;
      begin
        { we need to allocate at least a minimum of 4 bytes, else
          we get two temps at the same position resulting in problems
          when finding the corresponding temprecord }
        if size=0 then
         size:=4;
        { Just extend the temp, everything below has been use
          already }
        dec(lasttemp,size);
        { now we can create the templist entry }
        new(tl);
        tl^.temptype:=tt_normal;
        tl^.pos:=lasttemp;
        tl^.size:=size;
        tl^.next:=templist;
        tl^.nextfree:=nil;
        templist:=tl;
        newtempofsize:=tl^.pos;
      end;

    function ttgobj.gettempofsize(list: taasmoutput; size : longint) : longint;
      var
         tl,
         bestslot,bestprev,
         hprev,hp : ptemprecord;
         bestsize,ofs : longint;
      begin
         bestprev:=nil;
         bestslot:=nil;
         tl:=nil;
         bestsize:=0;
{$ifdef EXTDEBUG}
         if size=0 then
          Comment(V_Warning,'Temp of size 0 requested');
{$endif}
         { Align needed size on 4 bytes }
         if (size mod 4)<>0 then
           size:=size+(4-(size mod 4));
         { First check the tmpfreelist }
         if assigned(tempfreelist) then
          begin
            { Check for a slot with the same size first }
            hprev:=nil;
            hp:=tempfreelist;
            while assigned(hp) do
             begin
{$ifdef EXTDEBUG}
               if hp^.temptype<>tt_free then
                 Comment(V_Warning,'Temp in freelist is not set to tt_free');
{$endif}
               if hp^.size>=size then
                begin
                  { Slot is the same size, then leave immediatly }
                  if hp^.size=size then
                   begin
                     bestprev:=hprev;
                     bestslot:=hp;
                     bestsize:=size;
                     break;
                   end
                  else
                   begin
                     if (bestsize=0) or (hp^.size<bestsize) then
                      begin
                        bestprev:=hprev;
                        bestslot:=hp;
                        bestsize:=hp^.size;
                      end;
                   end;
                end;
               hprev:=hp;
               hp:=hp^.nextfree;
             end;
          end;
         { Reuse an old temp ? }
         if assigned(bestslot) then
          begin
            if bestsize=size then
             begin
               bestslot^.temptype:=tt_normal;
               ofs:=bestslot^.pos;
               tl:=bestslot;
               { Remove from the tempfreelist }
               if assigned(bestprev) then
                 bestprev^.nextfree:=bestslot^.nextfree
               else
                 tempfreelist:=bestslot^.nextfree;
             end
            else
             begin
               { Resize the old block }
               dec(bestslot^.size,size);
               { Create new block and link after bestslot }
               new(tl);
               tl^.temptype:=tt_normal;
               tl^.pos:=bestslot^.pos+bestslot^.size;
               ofs:=tl^.pos;
               tl^.size:=size;
               tl^.nextfree:=nil;
               { link the new block }
               tl^.next:=bestslot^.next;
               bestslot^.next:=tl;
             end;
          end
         else
          begin
             ofs:=newtempofsize(size);
             tl:=templist;
          end;
         lasttempofsize:=tl;
{$ifdef EXTDEBUG}
         tl^.posinfo:=aktfilepos;
{$endif}
         list.concat(Taitempalloc.alloc(ofs,size));
         gettempofsize:=ofs;
      end;


    function ttgobj.gettempofsizepersistant(list: taasmoutput; size : longint) : longint;
      var
         l : longint;
      begin
         l:=gettempofsize(list, size);
         lasttempofsize^.temptype:=tt_persistant;
{$ifdef EXTDEBUG}
         Comment(V_Debug,'temp managment  : call to gettempofsizepersistant()'+
                     ' with size '+tostr(size)+' returned '+tostr(l));
{$endif}
         gettempofsizepersistant:=l;
      end;


    function ttgobj.gettempsize : longint;
      var
        _align : longint;
      begin
        { align to 4 bytes at least
          otherwise all those subl $2,%esp are meaningless PM }
        _align:=target_info.alignment.localalignmin;
        if _align<4 then
          _align:=4;
        gettempsize:=Align(-lasttemp,_align);
      end;


    procedure ttgobj.gettempofsizereference(list: taasmoutput; l : longint;var ref : treference);
      begin
         { do a reset, because the reference isn't used }
         FillChar(ref,sizeof(treference),0);
         ref.offset:=gettempofsize(list,l);
         ref.base:=procinfo^.framepointer;
      end;

    procedure ttgobj.gettempofsizereferencepersistant(list: taasmoutput; l : longint;var ref : treference);
      begin
         { do a reset, because the reference isn't used }
         FillChar(ref,sizeof(treference),0);
         ref.offset:=gettempofsizepersistant(list,l);
         ref.base:=procinfo^.framepointer;
      end;


    procedure ttgobj.gettemppointerreferencefortype(list: taasmoutput; var ref : treference; const usedtype, freetype: ttemptype);
      var
         foundslot,tl : ptemprecord;
      begin
         { do a reset, because the reference isn't used }
         FillChar(ref,sizeof(treference),0);
         ref.base:=procinfo^.framepointer;
         { Reuse old slot ? }
         foundslot:=nil;
         tl:=templist;
         while assigned(tl) do
          begin
            if tl^.temptype=freetype then
             begin
               foundslot:=tl;
{$ifdef EXTDEBUG}
               tl^.posinfo:=aktfilepos;
{$endif}
               break;
             end;
            tl:=tl^.next;
          end;
         if assigned(foundslot) then
          begin
            foundslot^.temptype:=usedtype;
            ref.offset:=foundslot^.pos;
          end
         else
          begin
            ref.offset:=newtempofsize(target_info.size_of_pointer);
{$ifdef EXTDEBUG}
            templist^.posinfo:=aktfilepos;
{$endif}
            templist^.temptype:=usedtype;
          end;
         list.concat(Taitempalloc.alloc(ref.offset,target_info.size_of_pointer));
      end;

    function ttgobj.ungettemppointeriftype(list: taasmoutput; const ref : treference; const usedtype, freetype: ttemptype) : boolean;
      var
         tl : ptemprecord;
      begin
        ungettemppointeriftype:=false;
        tl:=templist;
        while assigned(tl) do
         begin
           if tl^.pos=ref.offset then
            begin
              if tl^.temptype=usedtype then
               begin
                 tl^.temptype:=freetype;
                 ungettemppointeriftype:=true;
                 list.concat(Taitempalloc.dealloc(tl^.pos,tl^.size));
                 exit;
{$ifdef EXTDEBUG}
               end
              else if (tl^.temptype=freetype) then
               begin
                 Comment(V_Debug,'temp managment problem : ungettemppointeriftype()'+
                     ' at pos '+tostr(ref.offset)+ ' already free !');
{$endif}
               end;
            end;
           tl:=tl^.next;
         end;
      end;


    procedure ttgobj.gettempansistringreference(list: taasmoutput; var ref : treference);
      begin
        gettemppointerreferencefortype(list,ref,tt_ansistring,tt_freeansistring);
      end;

    procedure ttgobj.gettempwidestringreference(list: taasmoutput; var ref : treference);
      begin
        gettemppointerreferencefortype(list,ref,tt_widestring,tt_freewidestring);
      end;

    function ttgobj.ungetiftempansi(list: taasmoutput; const ref : treference) : boolean;
      begin
        ungetiftempansi:=ungettemppointeriftype(list,ref,tt_ansistring,tt_freeansistring);
      end;

    function ttgobj.ungetiftempwidestr(list: taasmoutput; const ref : treference) : boolean;
      begin
        ungetiftempwidestr:=ungettemppointeriftype(list,ref,tt_widestring,tt_freewidestring);
      end;


    procedure ttgobj.gettempintfcomreference(list: taasmoutput; var ref : treference);
      begin
        gettemppointerreferencefortype(list,ref,tt_interfacecom,tt_freeinterfacecom);
      end;


    function ttgobj.ungetiftempintfcom(list: taasmoutput; const ref : treference) : boolean;
      begin
        ungetiftempintfcom:=ungettemppointeriftype(list,ref,tt_ansistring,tt_freeansistring);
      end;

    function ttgobj.istemp(const ref : treference) : boolean;

      begin
         { ref.index = R_NO was missing
           led to problems with local arrays
           with lower bound > 0 (PM) }
         istemp:=((ref.base=procinfo^.framepointer) and
{$ifdef i386}
                  (ref.index=R_NO) and
{$endif}
                  (ref.offset<firsttemp));
      end;


    procedure ttgobj.persistanttemptonormal(pos : longint);
      var
        hp : ptemprecord;
      begin
         hp:=templist;
         while assigned(hp) do
           if (hp^.pos=pos) and (hp^.temptype=tt_persistant) then
             begin
{$ifdef EXTDEBUG}
               Comment(V_Debug,'temp managment : persistanttemptonormal()'+
                  ' at pos '+tostr(pos)+ ' found !');
{$endif}
                hp^.temptype:=tt_normal;
                exit;
             end
           else
             hp:=hp^.next;
{$ifdef EXTDEBUG}
         Comment(V_Debug,'temp managment problem : persistanttemptonormal()'+
            ' at pos '+tostr(pos)+ ' not found !');
{$endif}
      end;


    procedure ttgobj.normaltemptopersistant(pos : longint);
      var
        hp : ptemprecord;
      begin
         hp:=templist;
         while assigned(hp) do
           if (hp^.pos=pos) and (hp^.temptype=tt_normal) then
             begin
{$ifdef EXTDEBUG}
               Comment(V_Debug,'temp managment : normaltemptopersistant()'+
                  ' at pos '+tostr(pos)+ ' found !');
{$endif}
                hp^.temptype:=tt_persistant;
                exit;
             end
           else
             hp:=hp^.next;
{$ifdef EXTDEBUG}
         Comment(V_Debug,'temp managment problem : normaltemptopersistant()'+
            ' at pos '+tostr(pos)+ ' not found !');
{$endif}
      end;


    function ttgobj.ungettemp(list: taasmoutput; pos:longint;allowtype:ttemptype):ttemptype;
      var
         hp,hnext,hprev,hprevfree : ptemprecord;
      begin
         ungettemp:=tt_none;
         hp:=templist;
         hprev:=nil;
         hprevfree:=nil;
         while assigned(hp) do
          begin
            if (hp^.pos=pos) then
             begin
               { check type }
               ungettemp:=hp^.temptype;
               if hp^.temptype<>allowtype then
                begin
                  exit;
                end;
               list.concat(Taitempalloc.dealloc(hp^.pos,hp^.size));
               { set this block to free }
               hp^.temptype:=tt_free;
               { Update tempfreelist }
               if assigned(hprevfree) then
                begin
                  { Connect with previous? }
                  if assigned(hprev) and (hprev^.temptype=tt_free) then
                   begin
                     inc(hprev^.size,hp^.size);
                     hprev^.next:=hp^.next;
                     dispose(hp);
                     hp:=hprev;
                   end
                  else
                   hprevfree^.nextfree:=hp;
                end
               else
                begin
                  hp^.nextfree:=tempfreelist;
                  tempfreelist:=hp;
                end;
               { Next block free ? Yes, then concat }
               hnext:=hp^.next;
               if assigned(hnext) and (hnext^.temptype=tt_free) then
                begin
                  inc(hp^.size,hnext^.size);
                  hp^.nextfree:=hnext^.nextfree;
                  hp^.next:=hnext^.next;
                  dispose(hnext);
                end;
               exit;
             end;
            if (hp^.temptype=tt_free) then
             hprevfree:=hp;
            hprev:=hp;
            hp:=hp^.next;
          end;
        ungettemp:=tt_none;
      end;

    function ttgobj.getsizeoftemp(const ref: treference): longint;
      var
         hp : ptemprecord;
      begin
        hp:=templist;
        while assigned(hp) do
          begin
            if (hp^.pos=ref.offset) then
              begin
                getsizeoftemp := hp^.size;
                exit;
              end;
            hp := hp^.next;
          end;
        getsizeoftemp := -1;
      end;

    procedure ttgobj.ungetpersistanttemp(list: taasmoutput; pos : longint);
      begin
{$ifdef EXTDEBUG}
        if ungettemp(list,pos,tt_persistant)<>tt_persistant then
          Comment(V_Warning,'temp managment problem : ungetpersistanttemp()'+
                  ' at pos '+tostr(pos)+ ' not found !');
{$else}
        ungettemp(list,pos,tt_persistant);
{$endif}
      end;

    procedure ttgobj.ungetpersistanttempreference(list: taasmoutput; const ref : treference);

      begin
         ungetpersistanttemp(list, ref.offset);
      end;

    procedure ttgobj.ungetiftemp(list: taasmoutput; const ref : treference);
{$ifdef EXTDEBUG}
      var
         tt : ttemptype;
{$endif}
      begin
         if istemp(ref) then
           begin
              { first check if ansistring }
              if ungetiftempansi(list,ref) or
                 ungetiftempwidestr(list,ref) or
                 ungetiftempintfcom(list,ref) then
                exit;
{$ifndef EXTDEBUG}
              ungettemp(list,ref.offset,tt_normal);
{$else}
              tt:=ungettemp(list,ref.offset,tt_normal);
              if tt=tt_persistant then
                Comment(V_Debug,'temp at pos '+tostr(ref.offset)+ ' not released because persistant!');
              if tt=tt_none then
                Comment(V_Warning,'temp not found for release at offset '+tostr(ref.offset));
{$endif}
           end;
      end;


initialization
  tg := ttgobj.create;
finalization
  tg.free;
end.
{
  $Log$
  Revision 1.3  2002-04-04 19:06:06  peter
    * removed unused units
    * use tlocation.size in cg.a_*loc*() routines

  Revision 1.2  2002/04/02 17:11:32  peter
    * tlocation,treference update
    * LOC_CONSTANT added for better constant handling
    * secondadd splitted in multiple routines
    * location_force_reg added for loading a location to a register
      of a specified size
    * secondassignment parses now first the right and then the left node
      (this is compatible with Kylix). This saves a lot of push/pop especially
      with string operations
    * adapted some routines to use the new cg methods

  Revision 1.1  2002/03/31 20:26:37  jonas
    + a_loadfpu_* and a_loadmm_* methods in tcg
    * register allocation is now handled by a class and is mostly processor
      independent (+rgobj.pas and i386/rgcpu.pas)
    * temp allocation is now handled by a class (+tgobj.pas, -i386\tgcpu.pas)
    * some small improvements and fixes to the optimizer
    * some register allocation fixes
    * some fpuvaroffset fixes in the unary minus node
    * push/popusedregisters is now called rg.save/restoreusedregisters and
      (for i386) uses temps instead of push/pop's when using -Op3 (that code is
      also better optimizable)
    * fixed and optimized register saving/restoring for new/dispose nodes
    * LOC_FPU locations now also require their "register" field to be set to
      R_ST, not R_ST0 (the latter is used for LOC_CFPUREGISTER locations only)
    - list field removed of the tnode class because it's not used currently
      and can cause hard-to-find bugs

  Revision 1.1  2000/07/13 06:30:09  michael
  + Initial import

  Revision 1.10  2000/02/17 14:48:36  florian
     * updated to use old firstpass

  Revision 1.9  2000/01/07 01:14:55  peter
    * updated copyright to 2000

  Revision 1.8  1999/10/14 14:57:54  florian
    - removed the hcodegen use in the new cg, use cgbase instead

  Revision 1.7  1999/10/12 21:20:47  florian
    * new codegenerator compiles again

  Revision 1.6  1999/09/10 18:48:11  florian
    * some bug fixes (e.g. must_be_valid and procinfo.funcret_is_valid)
    * most things for stored properties fixed

  Revision 1.5  1999/08/06 16:04:06  michael
  + introduced tainstruction

  Revision 1.4  1999/08/03 00:33:23  michael
  + Added cpuasm for alpha

  Revision 1.3  1999/08/03 00:32:13  florian
    * reg_vars and reg_pushes is now in tgobj

  Revision 1.2  1999/08/02 23:13:22  florian
    * more changes to compile for the Alpha

  Revision 1.1  1999/08/02 17:14:12  florian
    + changed the temp. generator to an object

}