fpc/compiler/temp_gen.pas

{
    $Id$
    Copyright (C) 1993-98 by Florian Klaempfl

    This unit handles the temporary variables stuff for i386

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

  interface

    uses
{$ifdef i386}
{$ifndef OLDASM}
      i386base,i386asm,
{$else}
      i386,
{$endif}
{$endif i386}
{$ifdef m68k}
      m68k,
{$endif m68k}
       cobjects,globals,tree,hcodegen,verbose,files,aasm;

    type
      ttemptype = (tt_none,tt_free,tt_normal,tt_persistant,tt_ansistring,tt_freeansistring,tt_widestring,tt_freewidestring);
      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;

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

    { generates temporary variables }
    procedure resettempgen;
    procedure setfirsttemp(l : longint);
    function gettempsize : longint;
    function newtempofsize(size : longint) : longint;
    function gettempofsize(size : longint) : longint;
    { special call for inlined procedures }
    function gettempofsizepersistant(size : longint) : longint;
    { for parameter func returns }
    procedure normaltemptopersistant(pos : longint);
    procedure persistanttemptonormal(pos : longint);
    {procedure ungettemp(pos : longint;size : longint);}
    procedure ungetpersistanttemp(pos : longint);
    procedure gettempofsizereference(l : longint;var ref : treference);
    function istemp(const ref : treference) : boolean;
    procedure ungetiftemp(const ref : treference);
    function ungetiftempansi(const ref : treference) : boolean;
    procedure gettempansistringreference(var ref : treference);

  implementation

    uses
       scanner,systems
{$ifdef i386}
       ,cgai386
{$endif i386}
{$ifdef m68k}
       ,cga68k
{$endif m68k}
       ;


    procedure 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');
           end;
{$endif}
           hp:=templist;
           templist:=hp^.next;
           dispose(hp);
         end;
        templist:=nil;
        tempfreelist:=nil;
        firsttemp:=0;
        lasttemp:=0;
      end;


    procedure 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 newtempofsize(size : longint) : longint;
      var
        tl : ptemprecord;
      begin
        { 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 gettempofsize(size : longint) : longint;
      var
         tl,
         bestslot,bestprev,
         hprev,hp : ptemprecord;
         bestsize,ofs : longint;
      begin
         bestprev:=nil;
         bestslot:=nil;
         bestsize:=0;
         { 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:=size;
                      end;
                   end;
                end;
               hprev:=hp;
               hp:=hp^.nextfree;
             end;
          end;
         { Reuse an old temp ? }
         if assigned(bestslot) then
          begin
            ofs:=bestslot^.pos;
            if bestsize=size then
             begin
               bestslot^.temptype:=tt_normal;
               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;
               tl^.size:=size;
               tl^.nextfree:=nil;
               { link the new block }
               tl^.next:=bestslot^.next;
               bestslot^.next:=tl;
             end;
          end
         else
          begin
             ofs:=newtempofsize(size);
{$ifdef EXTDEBUG}
             tl:=templist;
{$endif}
          end;
{$ifdef EXTDEBUG}
         tl^.posinfo:=aktfilepos;
{$endif}
         exprasmlist^.concat(new(paitempalloc,alloc(ofs,size)));
         gettempofsize:=ofs;
      end;


    function gettempofsizepersistant(size : longint) : longint;
      var
         l : longint;
      begin
         l:=gettempofsize(size);
         templist^.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 gettempsize : longint;
      begin
        gettempsize:=-lasttemp;
      end;


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


    function gettempansioffset : longint;
      var
         ofs      : longint;
         foundslot,tl : ptemprecord;
      begin
         { Reuse old ansi slot ? }
         foundslot:=nil;
         tl:=templist;
         while assigned(tl) do
          begin
            if tl^.temptype=tt_freeansistring then
             begin
               foundslot:=tl;
               break;
             end;
            tl:=tl^.next;
          end;
         if assigned(foundslot) then
          begin
            foundslot^.temptype:=tt_ansistring;
            ofs:=foundslot^.pos;
          end
         else
          begin
            ofs:=newtempofsize(target_os.size_of_pointer);
            templist^.temptype:=tt_ansistring;
          end;
         exprasmlist^.concat(new(paitempalloc,alloc(ofs,target_os.size_of_pointer)));
         gettempansioffset:=ofs;
      end;


    procedure gettempansistringreference(var ref : treference);
      begin
         { do a reset, because the reference isn't used }
         reset_reference(ref);
         ref.offset:=gettempansioffset;
         ref.base:=procinfo.framepointer;
      end;


    function ungetiftempansi(const ref : treference) : boolean;
      var
         tl : ptemprecord;
      begin
        ungetiftempansi:=false;
        tl:=templist;
        while assigned(tl) do
         begin
           if tl^.pos=ref.offset then
            begin
              if tl^.temptype=tt_ansistring then
               begin
                 tl^.temptype:=tt_freeansistring;
                 ungetiftempansi:=true;
                 exprasmlist^.concat(new(paitempalloc,dealloc(tl^.pos,tl^.size)));
                 exit;
{$ifdef EXTDEBUG}
               end
              else
               begin
                 Comment(V_Debug,'temp ansi managment problem : ungetiftempansi()'+
                     ' at pos '+tostr(ref.offset)+ ' already free !');
{$endif}
               end;
            end;
           tl:=tl^.next;
         end;
      end;

    function 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
                  (ref.index=R_NO) and
                  (ref.offset<firsttemp));
      end;


    procedure 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 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 ungettemp(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;
               exprasmlist^.concat(new(paitempalloc,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;


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


    procedure ungetiftemp(const ref : treference);
      var
         tt : ttemptype;
      begin
         if istemp(ref) then
           begin
              { first check if ansistring }
              if ungetiftempansi(ref) then
                exit;
              tt:=ungettemp(ref.offset,tt_normal);
{$ifdef EXTDEBUG}
              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;


   procedure inittemps;
     begin
       tempfreelist:=nil;
       templist:=nil;
     end;

begin
  InitTemps;
end.
{
  $Log$
  Revision 1.25  1999-05-17 23:51:47  peter
    * with temp vars now use a reference with a persistant temp instead
      of setting datasize

  Revision 1.24  1999/05/17 21:57:17  florian
    * new temporary ansistring handling

  Revision 1.23  1999/05/17 12:49:16  pierre
    * several problems with EXTDEBUG fixed

  Revision 1.22  1999/05/15 21:33:21  peter
    * redesigned temp_gen temp allocation so temp allocation for
      ansistring works correct. It also does a best fit instead of first fit

  Revision 1.21  1999/05/01 13:24:59  peter
    * merged nasm compiler
    * old asm moved to oldasm/

  Revision 1.20  1999/04/19 09:30:48  pierre
   + added warning for unreleased ANSI temp

  Revision 1.19  1999/04/16 20:44:38  florian
    * the boolean operators =;<>;xor with LOC_JUMP and LOC_FLAGS
      operands fixed, small things for new ansistring management

  Revision 1.18  1999/04/16 14:03:39  pierre
   * added paitempalloc for tempansi

  Revision 1.17  1999/04/16 11:49:45  peter
    + tempalloc
    + -at to show temp alloc info in .s file

  Revision 1.16  1999/04/14 09:10:46  peter
    * fixed tempansi which set wrong pos in free temp

  Revision 1.15  1999/04/09 13:05:45  pierre
   * Minenumsize=1 under TEST_ENUMSIZE cond because buggy

  Revision 1.14  1999/04/09 09:55:20  peter
    * typo fixed

  Revision 1.13  1999/04/09 08:39:20  peter
    * fixed reuse position

  Revision 1.12  1999/04/08 23:52:59  pierre
   + tempansilist and gettempansistringreference

  Revision 1.11  1999/04/08 20:59:44  florian
    * fixed problem with default properties which are a class
    * case bug (from the mailing list with -O2) fixed, the
      distance of the case labels can be greater than the positive
      range of a longint => it is now a dword for fpc

  Revision 1.10  1999/04/06 11:19:49  peter
    * fixed temp reuse

  Revision 1.9  1999/02/22 02:15:56  peter
    * updates for ag386bin

  Revision 1.8  1999/02/11 09:35:19  pierre
   * ExtDebug conditionnal infinite loop on temp problem removed

  Revision 1.7  1999/02/02 23:52:33  florian
    * problem with calls to method pointers in methods fixed
    - double ansistrings temp management removed

  Revision 1.6  1999/01/15 11:34:23  pierre
   + better info for temp allocation debugging

  Revision 1.5  1998/11/30 09:43:24  pierre
    * some range check bugs fixed (still not working !)
    + added DLL writing support for win32 (also accepts variables)
    + TempAnsi for code that could be used for Temporary ansi strings
      handling

  Revision 1.4  1998/10/09 08:56:32  pierre
    * several memory leaks fixed

  Revision 1.3  1998/07/16 08:01:42  pierre
    * small bug correction due to newinput
      (only with tempdebug conditionnal)

  Revision 1.2  1998/07/10 10:51:05  peter
    * m68k updates

  Revision 1.1  1998/06/08 16:07:41  pierre
    * temp_gen contains all temporary var functions
      (processor independent)

}