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.

 ****************************************************************************
}
{#@abstract(Temporary reference allocator unit)
  Temporary reference allocator unit. This unit contains
  all which is related to allocating temporary memory
  space on the stack, as required, by the code generator.
}

unit tgobj;

{$i fpcdefs.inc}

  interface

    uses
      cclasses,
      globals,globtype,
      cpubase,cpuinfo,cgbase,
      aasmbase,aasmtai,aasmcpu;

    type
      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;


       {# Generates temporary variables }
       ttgobj = class
       private
          { contains all free temps using nextfree links }
          tempfreelist  : ptemprecord;
          function alloctemp(list: taasmoutput; size : longint; temptype : ttemptype) : longint;
          procedure freetemp(list: taasmoutput; pos:longint;temptypes:ttemptypeset);
       public
          { contains all temps }
          templist      : ptemprecord;
          { Offsets of the first/last temp }
          firsttemp,
          lasttemp      : longint;
          direction : shortint;
          constructor create;
          {# Clear and free the complete linked list of temporary memory
             locations. The list is set to nil.}
          procedure resettempgen;
          {# Sets the first offset from the frame pointer or stack pointer where
             the temporary references will be allocated. It is to note that this
             value should always be negative.

             @param(l start offset where temps will start in stack)
          }
          procedure setfirsttemp(l : longint);

          procedure gettemp(list: taasmoutput; size : longint;temptype:ttemptype;var ref : treference);
          procedure ungettemp(list: taasmoutput; const ref : treference);

          function sizeoftemp(list: taasmoutput; const ref: treference): longint;
          function changetemptype(list: taasmoutput; const ref:treference;temptype:ttemptype):boolean;

          {# Returns TRUE if the reference ref is allocated in temporary volatile memory space,
             otherwise returns FALSE.

             @param(ref reference to verify)
          }
          function istemp(const ref : treference) : boolean;
          {# Frees a reference @var(ref) which was allocated in the volatile temporary memory space.
             The freed space can later be reallocated and reused. If this reference
             is not in the temporary memory, it is simply not freed.
          }
          procedure ungetiftemp(list: taasmoutput; const ref : treference);

          { Allocate space for a local }
          procedure getlocal(list: taasmoutput; size : longint;var ref : tparareference);
          procedure UnGetLocal(list: taasmoutput; const ref : tparareference);
       end;

     var
       tg: ttgobj;


    implementation

    uses
       cutils,
       systems,verbose,
       procinfo
       ;


    const
      FreeTempTypes = [tt_free,tt_freenoreuse,tt_freeansistring,
                       tt_freewidestring,tt_freeinterfacecom];

{$ifdef EXTDEBUG}
      TempTypeStr : array[ttemptype] of string[18] = (
          '<none>',
          'free','normal','persistant',
          'noreuse','freenoreuse',
          'ansistring','freeansistring',
          'widestring','freewidestring',
          'interfacecom','freeinterfacecom'
      );
{$endif EXTDEBUG}

      Used2Free : array[ttemptype] of ttemptype = (
        tt_none,
        tt_none,tt_free,tt_free,
        tt_freenoreuse,tt_none,
        tt_freeansistring,tt_none,
        tt_freewidestring,tt_none,
        tt_freeinterfacecom,tt_none);


{*****************************************************************************
                                    TTGOBJ
*****************************************************************************}

    constructor ttgobj.create;

     begin
       tempfreelist:=nil;
       templist:=nil;
       { we could create a new child class for this but I don't if it is worth the effort (FK) }
{$ifdef powerpc}
       direction:=1;
{$else powerpc}
       direction:=-1;
{$endif powerpc}
     end;


    procedure ttgobj.resettempgen;
      var
         hp : ptemprecord;
      begin
        { Clear the old templist }
        while assigned(templist) do
         begin
{$ifdef EXTDEBUG}
           if not(templist^.temptype in FreeTempTypes) then
            begin
              Comment(V_Warning,'tgobj: (ResetTempgen) temp at pos '+tostr(templist^.pos)+
                      ' with size '+tostr(templist^.size)+' and type '+TempTypeStr[templist^.temptype]+
                      ' from pos '+tostr(templist^.posinfo.line)+':'+tostr(templist^.posinfo.column)+
                      ' 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*direction>=0 then
          begin
            if odd(l) then
             inc(l,direction);
          end
         else
           internalerror(200204221);
         firsttemp:=l;
         lasttemp:=l;
      end;


    function ttgobj.AllocTemp(list: taasmoutput; size : longint; temptype : ttemptype) : longint;
      var
         tl,
         bestslot,bestprev,
         hprev,hp : ptemprecord;
         bestsize : longint;
         freetype : ttemptype;
      begin
         AllocTemp:=0;
         bestprev:=nil;
         bestslot:=nil;
         tl:=nil;
         bestsize:=0;

         if size=0 then
          begin
{$ifdef EXTDEBUG}
            Comment(V_Warning,'tgobj: (AllocTemp) temp of size 0 requested, allocating 4 bytes');
{$endif}
            size:=4;
          end;

         freetype:=Used2Free[temptype];
         if freetype=tt_none then
          internalerror(200208201);
         { Align needed size on 4 bytes }
         size:=align(size,4);
         { First check the tmpfreelist, but not when
           we don't want to reuse an already allocated block }
         if assigned(tempfreelist) and
            (temptype<>tt_noreuse) then
          begin
            { Check for a slot with the same size first }
            hprev:=nil;
            hp:=tempfreelist;
            while assigned(hp) do
             begin
{$ifdef EXTDEBUG}
               if not(hp^.temptype in FreeTempTypes) then
                 Comment(V_Warning,'tgobj: (AllocTemp) temp at pos '+tostr(hp^.pos)+ ' in freelist is not set to tt_free !');
{$endif}
               if (hp^.temptype=freetype) and
                  (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
               tl:=bestslot;
               tl^.temptype:=temptype;
               { Remove from the tempfreelist }
               if assigned(bestprev) then
                 bestprev^.nextfree:=tl^.nextfree
               else
                 tempfreelist:=tl^.nextfree;
               tl^.nextfree:=nil;
             end
            else
             begin
               { Resize the old block }
               dec(bestslot^.size,size);
               { Create new block and link after bestslot }
               new(tl);
               tl^.temptype:=temptype;
               if direction=1 then
                 begin
                   tl^.pos:=bestslot^.pos;
                   inc(bestslot^.pos,size);
                 end
               else
                 tl^.pos:=bestslot^.pos+bestslot^.size;
               tl^.size:=size;
               tl^.nextfree:=nil;
               { link the new block }
               tl^.next:=bestslot^.next;
               bestslot^.next:=tl;
             end;
          end
         else
          begin
            { create a new temp, 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<4 then
             size:=4;
            { now we can create the templist entry }
            new(tl);
            tl^.temptype:=temptype;

            if direction=-1 then
              begin
                 { Extend the temp }
                 dec(lasttemp,size);
                 tl^.pos:=lasttemp;
              end
            else
              begin
                 tl^.pos:=lasttemp;
                 { Extend the temp }
                 inc(lasttemp,size);
              end;

            tl^.size:=size;
            tl^.next:=templist;
            tl^.nextfree:=nil;
            templist:=tl;
          end;
{$ifdef EXTDEBUG}
         tl^.posinfo:=aktfilepos;
         list.concat(tai_tempalloc.allocinfo(tl^.pos,tl^.size,'allocated with type '+TempTypeStr[tl^.temptype]));
{$else}
         list.concat(tai_tempalloc.alloc(tl^.pos,tl^.size));
{$endif}
         AllocTemp:=tl^.pos;
      end;


    procedure ttgobj.FreeTemp(list: taasmoutput; pos:longint;temptypes:ttemptypeset);
      var
         hp,hnext,hprev,hprevfree : ptemprecord;
      begin
         hp:=templist;
         hprev:=nil;
         hprevfree:=nil;
         while assigned(hp) do
          begin
            if (hp^.pos=pos) then
             begin
               { check if already freed }
               if hp^.temptype in FreeTempTypes then
                begin
{$ifdef EXTDEBUG}
                  Comment(V_Warning,'tgobj: (FreeTemp) temp at pos '+tostr(pos)+ ' is already free !');
                  list.concat(tai_tempalloc.allocinfo(hp^.pos,hp^.size,'temp is already freed'));
{$endif}
                  exit;
                end;
               { check type that are allowed to be released }
               if not(hp^.temptype in temptypes) then
                begin
{$ifdef EXTDEBUG}
                  Comment(V_Debug,'tgobj: (Freetemp) temp at pos '+tostr(pos)+ ' has different type ('+TempTypeStr[hp^.temptype]+'), not releasing');
                  list.concat(tai_tempalloc.allocinfo(hp^.pos,hp^.size,'temp has wrong type ('+TempTypeStr[hp^.temptype]+') not releasing'));
{$endif}
                  exit;
                end;
               list.concat(tai_tempalloc.dealloc(hp^.pos,hp^.size));
               { set this block to free }
               hp^.temptype:=Used2Free[hp^.temptype];
               { Update tempfreelist }
               if assigned(hprevfree) then
                begin
                  { Connect With previous tt_free block? }
                  if assigned(hprev) and
                     (hp^.temptype=tt_free) and
                     (hprev^.temptype=tt_free) then
                   begin
                     inc(hprev^.size,hp^.size);
                     if direction=1 then
                       hprev^.pos:=hp^.pos;
                     hprev^.next:=hp^.next;
                     dispose(hp);
                     hp:=hprev;
                   end
                  else
                   hprevfree^.nextfree:=hp;
                end
               else
                begin
                  hp^.nextfree:=tempfreelist;

                  tempfreelist:=hp;
                end;
               { Next block tt_free ? Yes, then concat }
               hnext:=hp^.next;
               if assigned(hnext) and
                  (hp^.temptype=tt_free) and
                  (hnext^.temptype=tt_free) then
                begin
                  inc(hp^.size,hnext^.size);
                  if direction=1 then
                    hp^.pos:=hnext^.pos;
                  hp^.nextfree:=hnext^.nextfree;
                  hp^.next:=hnext^.next;
                  dispose(hnext);
                end;
               { Stop }
               exit;
             end;
            if (hp^.temptype=tt_free) then
              hprevfree:=hp;
            hprev:=hp;
            hp:=hp^.next;
          end;
      end;


    procedure ttgobj.gettemp(list: taasmoutput; size : longint;temptype:ttemptype;var ref : treference);
      begin
        { can't use reference_reset_base, because that will let tgobj depend
          on rgobj (PFV) }
        fillchar(ref,sizeof(ref),0);
        ref.base:=current_procinfo.framepointer;
        ref.offset:=alloctemp(list,size,temptype);
      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) }
         if direction = 1 then
           begin
             istemp:=(ref.base=current_procinfo.framepointer) and
                     (ref.index=NR_NO) and
                     (ref.offset>=firsttemp);
           end
        else
           begin
             istemp:=(ref.base=current_procinfo.framepointer) and
                     (ref.index=NR_NO) and
                     (ref.offset<firsttemp);
           end;
      end;


    function ttgobj.sizeoftemp(list: taasmoutput; const ref: treference): longint;
      var
         hp : ptemprecord;
      begin
         SizeOfTemp := -1;
         hp:=templist;
         while assigned(hp) do
           begin
             if (hp^.pos=ref.offset) then
               begin
                 sizeoftemp := hp^.size;
                 exit;
               end;
             hp := hp^.next;
           end;
{$ifdef EXTDEBUG}
         comment(v_debug,'tgobj: (SizeOfTemp) temp at pos '+tostr(ref.offset)+' not found !');
         list.concat(tai_tempalloc.allocinfo(ref.offset,0,'temp not found'));
{$endif}
      end;


    function ttgobj.ChangeTempType(list: taasmoutput; const ref:treference;temptype:ttemptype):boolean;
      var
        hp : ptemprecord;
      begin
         ChangeTempType:=false;
         hp:=templist;
         while assigned(hp) do
          begin
            if (hp^.pos=ref.offset) then
             begin
               if not(hp^.temptype in [tt_free,tt_freeansistring,tt_freewidestring,tt_freeinterfacecom]) then
                begin
{$ifdef EXTDEBUG}
                  if hp^.temptype=temptype then
                    Comment(V_Warning,'tgobj: (ChangeTempType) temp'+
                       ' at pos '+tostr(ref.offset)+ ' is already of the correct type !');
                  list.concat(tai_tempalloc.allocinfo(hp^.pos,hp^.size,'type changed to '+TempTypeStr[temptype]));
{$endif}
                  ChangeTempType:=true;
                  hp^.temptype:=temptype;
                end
               else
                begin
{$ifdef EXTDEBUG}
                   Comment(V_Warning,'tgobj: (ChangeTempType) temp'+
                      ' at pos '+tostr(ref.offset)+ ' is already freed !');
                  list.concat(tai_tempalloc.allocinfo(hp^.pos,hp^.size,'temp is already freed'));
{$endif}
                end;
               exit;
             end;
            hp:=hp^.next;
          end;
{$ifdef EXTDEBUG}
         Comment(V_Warning,'tgobj: (ChangeTempType) temp'+
            ' at pos '+tostr(ref.offset)+ ' not found !');
         list.concat(tai_tempalloc.allocinfo(ref.offset,0,'temp not found'));
{$endif}
      end;


    procedure ttgobj.UnGetTemp(list: taasmoutput; const ref : treference);
      begin
        FreeTemp(list,ref.offset,[tt_normal,tt_noreuse,tt_persistent,tt_ansistring,tt_widestring,tt_interfacecom]);
      end;


    procedure ttgobj.UnGetIfTemp(list: taasmoutput; const ref : treference);
      begin
        if istemp(ref) then
          FreeTemp(list,ref.offset,[tt_normal,tt_ansistring,tt_widestring,tt_interfacecom]);
      end;


    procedure ttgobj.getlocal(list: taasmoutput; size : longint;var ref : tparareference);
      begin
        ref.index:=current_procinfo.framepointer;
        ref.offset:=alloctemp(list,size,tt_persistent);
      end;


    procedure ttgobj.UnGetLocal(list: taasmoutput; const ref : tparareference);
      begin
        FreeTemp(list,ref.offset,[tt_persistent]);
      end;


end.
{
  $Log$
  Revision 1.40  2003-10-01 20:34:49  peter
    * procinfo unit contains tprocinfo
    * cginfo renamed to cgbase
    * moved cgmessage to verbose
    * fixed ppc and sparc compiles

  Revision 1.39  2003/09/23 17:56:06  peter
    * locals and paras are allocated in the code generation
    * tvarsym.localloc contains the location of para/local when
      generating code for the current procedure

  Revision 1.38  2003/09/03 15:55:01  peter
    * NEWRA branch merged

  Revision 1.37.2.2  2003/08/31 15:46:26  peter
    * more updates for tregister

  Revision 1.37.2.1  2003/08/29 17:28:59  peter
    * next batch of updates

  Revision 1.37  2003/08/20 17:48:49  peter
    * fixed stackalloc to not allocate localst.datasize twice
    * order of stackalloc code fixed for implicit init/final

  Revision 1.36  2003/07/06 17:58:22  peter
    * framepointer fixes for sparc
    * parent framepointer code more generic

  Revision 1.35  2003/06/03 13:01:59  daniel
    * Register allocator finished

  Revision 1.34  2003/05/17 13:30:08  jonas
    * changed tt_persistant to tt_persistent :)
    * tempcreatenode now doesn't accept a boolean anymore for persistent
      temps, but a ttemptype, so you can also create ansistring temps etc

  Revision 1.33  2003/05/13 20:13:41  florian
    * fixed temp. management for CPUs were the temp. space grows upwards

  Revision 1.32  2003/05/12 21:29:59  peter
    * extdebug info temp alloc type was wrong

  Revision 1.31  2003/04/27 11:21:35  peter
    * aktprocdef renamed to current_procdef
    * procinfo renamed to current_procinfo
    * procinfo will now be stored in current_module so it can be
      cleaned up properly
    * gen_main_procsym changed to create_main_proc and release_main_proc
      to also generate a tprocinfo structure
    * fixed unit implicit initfinal

  Revision 1.30  2003/04/25 20:59:35  peter
    * removed funcretn,funcretsym, function result is now in varsym
      and aliases for result and function name are added using absolutesym
    * vs_hidden parameter for funcret passed in parameter
    * vs_hidden fixes
    * writenode changed to printnode and released from extdebug
    * -vp option added to generate a tree.log with the nodetree
    * nicer printnode for statements, callnode

  Revision 1.29  2003/04/23 08:40:39  jonas
    * fixed istemp() when tg.direction = 1

  Revision 1.28  2003/04/22 09:46:17  peter
    * always allocate 4 bytes when 0 bytes are asked

  Revision 1.27  2003/03/11 21:46:24  jonas
    * lots of new regallocator fixes, both in generic and ppc-specific code
      (ppc compiler still can't compile the linux system unit though)

  Revision 1.26  2003/02/19 22:00:15  daniel
    * Code generator converted to new register notation
    - Horribily outdated todo.txt removed

  Revision 1.25  2003/02/03 23:10:39  daniel
    * Fixed last commit

  Revision 1.24  2003/02/03 23:07:39  daniel
    * Made gettemp use intended procedure for setting reference

  Revision 1.23  2003/01/08 18:43:57  daniel
   * Tregister changed into a record

  Revision 1.22  2002/12/01 18:58:26  carl
    * fix bugs with istemp() was wrong, and every reference was a temp

  Revision 1.21  2002/11/24 18:18:04  carl
    - remove some unused defines

  Revision 1.20  2002/11/17 17:49:08  mazen
  + return_result_reg and function_result_reg are now used, in all plateforms, to pass functions result between called function and its caller. See the explanation of each one

  Revision 1.19  2002/11/15 01:58:54  peter
    * merged changes from 1.0.7 up to 04-11
      - -V option for generating bug report tracing
      - more tracing for option parsing
      - errors for cdecl and high()
      - win32 import stabs
      - win32 records<=8 are returned in eax:edx (turned off by default)
      - heaptrc update
      - more info for temp management in .s file with EXTDEBUG

  Revision 1.18  2002/10/11 11:57:43  florian
  *** empty log message ***

  Revision 1.16  2002/09/07 18:25:00  florian
    + added tcg.direction to allow upwards growing temp areas
      i.e. temps with positive index

  Revision 1.15  2002/09/01 18:42:50  peter
    * reduced level of comment that type is wrong for release

  Revision 1.14  2002/09/01 12:14:53  peter
    * fixed some wrong levels in extdebug comments

  Revision 1.13  2002/08/24 18:35:04  peter
    * when reusing a block also update the temptype instead of forcing it
      to tt_normal

  Revision 1.12  2002/08/23 16:14:49  peter
    * tempgen cleanup
    * tt_noreuse temp type added that will be used in genentrycode

  Revision 1.11  2002/08/17 09:23:44  florian
    * first part of procinfo rewrite

  Revision 1.10  2002/07/01 18:46:29  peter
    * internal linker
    * reorganized aasm layer

  Revision 1.9  2002/05/18 13:34:21  peter
    * readded missing revisions

  Revision 1.8  2002/05/16 19:46:45  carl
  + defines.inc -> fpcdefs.inc to avoid conflicts if compiling by hand
  + try to fix temp allocation (still in ifdef)
  + generic constructor calls
  + start of tassembler / tmodulebase class cleanup

  Revision 1.7  2002/05/14 19:34:52  peter
    * removed old logs and updated copyright year

  Revision 1.6  2002/04/15 19:08:22  carl
  + target_info.size_of_pointer -> pointer_size
  + some cleanup of unused types/variables

  Revision 1.5  2002/04/07 13:38:48  carl
  + update documentation

  Revision 1.4  2002/04/07 09:17:17  carl
  + documentation
  - clean-up

  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

}