freepascal.compiler/compiler/cgobj.pas

{
    $Id$
    Copyright (c) 1998-2000 by Florian Klaempfl
    Member of the Free Pascal development team

    This unit implements the basic code generator object

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

{$i defines.inc}

  interface

    uses
       cclasses,aasm,symtable,cpuasm,cpubase,cgbase,cpuinfo,
       symconst,symbase,symtype;

    type
       talignment = (AM_NATURAL,AM_NONE,AM_2BYTE,AM_4BYTE,AM_8BYTE);

       tcg = class
          scratch_register_array_pointer : aword;
          unusedscratchregisters : tregisterset;

          alignment : talignment;
          {************************************************}
          {                 basic routines                 }
          constructor create;

          procedure a_label(list : taasmoutput;l : tasmlabel);virtual;

          { allocates register r by inserting a pai_realloc record }
          procedure a_reg_alloc(list : taasmoutput;r : tregister);
          { deallocates register r by inserting a pa_regdealloc record}
          procedure a_reg_dealloc(list : taasmoutput;r : tregister);

          { returns a register for use as scratch register }
          function get_scratch_reg(list : taasmoutput) : tregister;
          { releases a scratch register }
          procedure free_scratch_reg(list : taasmoutput;r : tregister);

          {************************************************}
          { code generation for subroutine entry/exit code }

          { initilizes data of type t                           }
          { if is_already_ref is true then the routines assumes }
          { that r points to the data to initialize             }
          procedure g_initialize(list : taasmoutput;t : tdef;const ref : treference;is_already_ref : boolean);

          { finalizes data of type t                            }
          { if is_already_ref is true then the routines assumes }
          { that r points to the data to finalizes              }
          procedure g_finalize(list : taasmoutput;t : tdef;const ref : treference;is_already_ref : boolean);

          { helper routines }
          procedure g_initialize_data(list : taasmoutput;p : tsym);
          procedure g_incr_data(list : taasmoutput;p : tsym);
          procedure g_finalize_data(list : taasmoutput;p : tnamedindexitem);
          procedure g_copyvalueparas(list : taasmoutput;p : tnamedindexitem);
          procedure g_finalizetempansistrings(list : taasmoutput);

          procedure g_entrycode(alist : TAAsmoutput;make_global:boolean;
                           stackframe:longint;
                           var parasize:longint;var nostackframe:boolean;
                           inlined : boolean);

          procedure g_exitcode(list : taasmoutput;parasize : longint;
            nostackframe,inlined : boolean);

          { string helper routines }
          procedure g_decrstrref(list : taasmoutput;const ref : treference;t : tdef);

          procedure g_removetemps(list : taasmoutput;p : tlinkedlist);

          { passing parameters, per default the parameter is pushed }
          { nr gives the number of the parameter (enumerated from   }
          { left to right), this allows to move the parameter to    }
          { register, if the cpu supports register calling          }
          { conventions                                             }
          procedure a_param_reg(list : taasmoutput;size : tcgsize;r : tregister;nr : longint);virtual; abstract;
          procedure a_param_const(list : taasmoutput;size : tcgsize;a : aword;nr : longint);virtual;
          procedure a_param_ref(list : taasmoutput;size : tcgsize;const r : treference;nr : longint);virtual;
          procedure a_paramaddr_ref(list : taasmoutput;const r : treference;nr : longint);virtual;

          {**********************************}
          { these methods must be overriden: }

          { Remarks:
            * If a method specifies a size you have only to take care
              of that number of bits, i.e. load_const_reg with OP_8 must
              only load the lower 8 bit of the specified register
              the rest of the register can be undefined
              if  necessary the compiler will call a method
              to zero or sign extend the register
            * The a_load_XX_XX with OP_64 needn't to be
              implemented for 32 bit
              processors, the code generator takes care of that
            * the addr size is for work with the natural pointer
              size
            * the procedures without fpu/mm are only for integer usage
            * normally the first location is the source and the
              second the destination
          }

          procedure a_call_name(list : taasmoutput;const s : string;
            offset : longint);virtual; abstract;

          { move instructions }
          procedure a_load_const_reg(list : taasmoutput;size : tcgsize;a : aword;register : tregister);virtual; abstract;
          procedure a_load_const_ref(list : taasmoutput;size : tcgsize;a : aword;const ref : treference);virtual;
          procedure a_load_reg_ref(list : taasmoutput;size : tcgsize;register : tregister;const ref : treference);virtual; abstract;
          procedure a_load_ref_reg(list : taasmoutput;size : tcgsize;const ref : treference;register : tregister);virtual; abstract;
          procedure a_load_reg_reg(list : taasmoutput;size : tcgsize;reg1,reg2 : tregister);virtual; abstract;
          procedure a_load_loc_reg(list : taasmoutput;size : tcgsize;const loc: tlocation; reg : tregister);
          procedure a_load_loc_ref(list : taasmoutput;size : tcgsize;const loc: tlocation; const ref : treference);
          procedure a_load_sym_ofs_reg(list: taasmoutput; const sym: tasmsymbol; ofs: longint; reg: tregister);virtual; abstract;


          { basic arithmetic operations }
          { note: for operators which require only one argument (not, neg), use }
          { the op_reg_reg, op_reg_reg or op_reg_loc methods and keep in mind   }
          { that in this case the *second* operand is used as both source and   }
          { destination (JM)                                                    }
          procedure a_op_const_reg(list : taasmoutput; Op: TOpCG; a: AWord; reg: TRegister); virtual; abstract;
          procedure a_op_const_ref(list : taasmoutput; Op: TOpCG; size: TCGSize; a: AWord; const ref: TReference); virtual;
          procedure a_op_const_loc(list : taasmoutput; Op: TOpCG; size: TCGSize; a: AWord; const loc: tlocation);
          procedure a_op_reg_reg(list : taasmoutput; Op: TOpCG; size: TCGSize; reg1, reg2: TRegister); virtual; abstract;
          procedure a_op_reg_ref(list : taasmoutput; Op: TOpCG; size: TCGSize; reg: TRegister; const ref: TReference); virtual;
          procedure a_op_ref_reg(list : taasmoutput; Op: TOpCG; size: TCGSize; const ref: TReference; reg: TRegister); virtual;
          procedure a_op_reg_loc(list : taasmoutput; Op: TOpCG; size: TCGSize; reg: tregister; const loc: tlocation);
          procedure a_op_ref_loc(list : taasmoutput; Op: TOpCG; size: TCGSize; const ref: TReference; const loc: tlocation);

          {  comparison operations }
          procedure a_cmp_const_reg_label(list : taasmoutput;size : tcgsize;cmp_op : topcmp;a : aword;reg : tregister;
            l : tasmlabel);virtual; abstract;
          procedure a_cmp_const_ref_label(list : taasmoutput;size : tcgsize;cmp_op : topcmp;a : aword;const ref : treference;
            l : tasmlabel); virtual;
          procedure a_cmp_const_loc_label(list: taasmoutput; size: tcgsize;cmp_op: topcmp; a: aword; const loc: tlocation;
            l : tasmlabel); virtual;
          procedure a_cmp_reg_reg_label(list : taasmoutput;size : tcgsize;cmp_op : topcmp;reg1,reg2 : tregister;l : tasmlabel); virtual; abstract;
          procedure a_cmp_ref_reg_label(list : taasmoutput;size : tcgsize;cmp_op : topcmp; const ref: treference; reg : tregister; l : tasmlabel); virtual;
          procedure a_cmp_ref_loc_label(list: taasmoutput; size: tcgsize;cmp_op: topcmp; const ref: treference; const loc: tlocation;
            l : tasmlabel);

          procedure a_jmp_cond(list : taasmoutput;cond : TOpCmp;l: tasmlabel); virtual; abstract;

          procedure g_flags2reg(list: taasmoutput; const f: tresflags; reg: TRegister); virtual; abstract;

          procedure a_loadaddress_ref_reg(list : taasmoutput;const ref : treference;r : tregister);virtual; abstract;
          procedure g_stackframe_entry(list : taasmoutput;localsize : longint);virtual; abstract;
          { restores the frame pointer at procedure exit, for the }
          { i386 it generates a simple leave                      }
          procedure g_restore_frame_pointer(list : taasmoutput);virtual; abstract;

          { some processors like the PPC doesn't allow to change the stack in }
          { a procedure, so we need to maintain an extra stack for the        }
          { result values of setjmp in exception code                         }
          { this two procedures are for pushing an exception value,           }
          { they can use the scratch registers                                }
          procedure g_push_exception_value_reg(list : taasmoutput;reg : tregister);virtual; abstract;
          procedure g_push_exception_value_const(list : taasmoutput;reg : tregister);virtual; abstract;
          { that procedure pops a exception value                             }
          procedure g_pop_exception_value_reg(list : taasmoutput;reg : tregister);virtual; abstract;
          procedure g_return_from_proc(list : taasmoutput;parasize : aword);virtual; abstract;
          {********************************************************}
          { these methods can be overriden for extra functionality }

          { the following methods do nothing: }
          procedure g_interrupt_stackframe_entry(list : taasmoutput);virtual;
          procedure g_interrupt_stackframe_exit(list : taasmoutput);virtual;

          procedure g_profilecode(list : taasmoutput);virtual;
          procedure g_stackcheck(list : taasmoutput;stackframesize : longint);virtual;

          procedure g_maybe_loadself(list : taasmoutput);virtual; abstract;
          { copies len bytes from the source to destination, if }
          { loadref is true, it assumes that it first must load }
          { the source address from the memory location where   }
          { source points to                                    }
          procedure g_concatcopy(list : taasmoutput;const source,dest : treference;len : aword;delsource,loadref : boolean);virtual; abstract;

{$ifdef i386}
         { this one is only necessary due the the restrictions of the 80x86, }
         { so make it a special case (JM)                                    }
          function makeregsize(var reg: tregister; size: tcgsize): topsize; virtual; abstract;
{$endif i386}
       end;

    var
       cg : tcg; { this is the main code generator class }

  implementation

    uses
       strings,globals,globtype,options,{files,}gdb,systems,
       ppu,verbose,types,{tgobj,}tgcpu,symdef,symsym,cga;

    const
      max_scratch_regs = high(scratch_regs) - low(scratch_regs) + 1;

{*****************************************************************************
                            basic functionallity
******************************************************************************}

    constructor tcg.create;

      var
         i : longint;

      begin
         scratch_register_array_pointer:=1;
         for i:=low(scratch_regs) to high(scratch_regs) do
           include(unusedscratchregisters,scratch_regs[i]);
      end;

    procedure tcg.a_reg_alloc(list : taasmoutput;r : tregister);

      begin
         list.concat(tairegalloc.alloc(r));
      end;

    procedure tcg.a_reg_dealloc(list : taasmoutput;r : tregister);

      begin
         list.concat(tairegalloc.dealloc(r));
      end;

    procedure tcg.a_label(list : taasmoutput;l : tasmlabel);

      begin
         list.concat(tai_label.create(l));
      end;

    function tcg.get_scratch_reg(list : taasmoutput) : tregister;

      var
         r : tregister;
         i : longint;

      begin
         if unusedscratchregisters=[] then
           internalerror(68996);

         for i:=scratch_register_array_pointer to
                (scratch_register_array_pointer+max_scratch_regs-1) do
           if scratch_regs[(i mod max_scratch_regs)+1] in unusedscratchregisters then
             begin
                r:=scratch_regs[(i mod max_scratch_regs)+1];
                break;
             end;
         exclude(unusedscratchregisters,r);
         inc(scratch_register_array_pointer);
         if scratch_register_array_pointer>max_scratch_regs then
           scratch_register_array_pointer:=1;
         a_reg_alloc(list,r);
         get_scratch_reg:=r;
      end;

    procedure tcg.free_scratch_reg(list : taasmoutput;r : tregister);

      begin
         include(unusedscratchregisters,makereg32(r));
         a_reg_dealloc(list,r);
      end;

{*****************************************************************************
            this methods must be overridden for extra functionality
******************************************************************************}

    procedure tcg.g_interrupt_stackframe_entry(list : taasmoutput);

      begin
      end;

    procedure tcg.g_interrupt_stackframe_exit(list : taasmoutput);

      begin
      end;

    procedure tcg.g_profilecode(list : taasmoutput);

      begin
      end;

{*****************************************************************************
          for better code generation these methods should be overridden
******************************************************************************}

    procedure tcg.a_param_const(list : taasmoutput;size : tcgsize;a : aword;nr : longint);

      var
         hr : tregister;

      begin
         hr:=get_scratch_reg(list);
         a_load_const_reg(list,size,a,hr);
         a_param_reg(list,size,hr,nr);
         free_scratch_reg(list,hr);
      end;

    procedure tcg.a_param_ref(list : taasmoutput;size : tcgsize;const r : treference;nr : longint);

      var
         hr : tregister;

      begin
         hr:=get_scratch_reg(list);
         a_load_ref_reg(list,size,r,hr);
         a_param_reg(list,size,hr,nr);
         free_scratch_reg(list,hr);
      end;

    procedure tcg.a_paramaddr_ref(list : taasmoutput;const r : treference;nr : longint);

      var
         hr : tregister;

      begin
         hr:=get_scratch_reg(list);
         a_loadaddress_ref_reg(list,r,hr);
         a_param_reg(list,OS_ADDR,hr,nr);
         free_scratch_reg(list,hr);
      end;

    procedure tcg.g_stackcheck(list : taasmoutput;stackframesize : longint);

      begin
         a_param_const(list,OS_32,stackframesize,1);
         a_call_name(list,'FPC_STACKCHECK',0);
      end;

{*****************************************************************************
                         String helper routines
*****************************************************************************}

    procedure tcg.g_removetemps(list : taasmoutput;p : tlinkedlist);

(*
      var
         hp : ptemptodestroy;
         pushedregs : tpushed;
*)

      begin
(*
         hp:=ptemptodestroy(p^.first);
         if not(assigned(hp)) then
           exit;
         tg.pushusedregisters(pushedregs,$ff);
         while assigned(hp) do
           begin
              if is_ansistring(hp^.typ) then
                begin
                   g_decrstrref(list,hp^.address,hp^.typ);
                   tg.ungetiftemp(hp^.address);
                end;
              hp:=ptemptodestroy(hp^.next);
           end;
         tg.popusedregisters(pushedregs);
*)
        runerror(211);
      end;

    procedure tcg.g_decrstrref(list : taasmoutput;const ref : treference;t : tdef);

      var
         pushedregs : tpushed;

      begin
(*
         tg.pushusedregisters(pushedregs,$ff);
         a_param_ref_addr(list,ref,1);
         if is_ansistring(t) then
           a_call_name(list,'FPC_ANSISTR_DECR_REF',0)
         else if is_widestring(t) then
           a_call_name(list,'FPC_WIDESTR_DECR_REF',0)
         else internalerror(58993);
         tg.popusedregisters(pushedregs);
*)
        runerror(211);
      end;

{*****************************************************************************
                  Code generation for subroutine entry- and exit code
 *****************************************************************************}

    { initilizes data of type t                           }
    { if is_already_ref is true then the routines assumes }
    { that r points to the data to initialize             }
    procedure tcg.g_initialize(list : taasmoutput;t : tdef;const ref : treference;is_already_ref : boolean);

      var
         hr : treference;

      begin
(*
         if is_ansistring(t) or
           is_widestring(t) then
           a_load_const_ref(list,OS_8,0,ref)
         else
           begin
              reset_reference(hr);
              hr.symbol:=t^.get_inittable_label;
              a_param_ref_addr(list,hr,2);
              if is_already_ref then
                a_param_ref(list,OS_ADDR,ref,1)
              else
                a_param_ref_addr(list,ref,1);
              a_call_name(list,'FPC_INITIALIZE',0);
           end;
*)
        runerror(211);
      end;

    procedure tcg.g_finalize(list : taasmoutput;t : tdef;const ref : treference;is_already_ref : boolean);

      var
         r : treference;

      begin
(*
         if is_ansistring(t) or
           is_widestring(t) then
           begin
              g_decrstrref(list,ref,t);
           end
         else
           begin
              reset_reference(r);
              r.symbol:=t^.get_inittable_label;
              a_param_ref_addr(list,r,2);
              if is_already_ref then
                a_paramaddr_ref(list,ref,1)
              else
                a_param_ref_addr(list,ref,1);
              a_call_name(list,'FPC_FINALIZE',0);
           end;
*)
        runerror(211);
      end;

    { generates the code for initialisation of local data }
    procedure tcg.g_initialize_data(list : taasmoutput;p : tsym);

      var
         hr : treference;

      begin
(*
         if (tsym(p)^.typ=varsym) and
            assigned(pvarsym(p)^.vartype.def) and
            not((pvarsym(p)^.vartype.def^.deftype=objectdef) and
              pobjectdef(pvarsym(p)^.vartype.def)^.is_class) and
            pvarsym(p)^.vartype.def^.needs_inittable then
           begin
              procinfo^.flags:=procinfo^.flags or pi_needs_implicit_finally;
              reset_reference(hr);
              if tsym(p)^.owner^.symtabletype=localsymtable then
                begin
                   hr.base:=procinfo^.framepointer;
                   hr.offset:=-pvarsym(p)^.address;
                end
              else
                begin
                   hr.symbol:=newasmsymbol(pvarsym(p)^.mangledname);
                end;
              g_initialize(list,pvarsym(p)^.vartype.def,hr,false);
           end;
*)
        runerror(211);
      end;


    { generates the code for incrementing the reference count of parameters }
    procedure tcg.g_incr_data(list : taasmoutput;p : tsym);

      var
         hr : treference;

      begin
(*
         if (tsym(p)^.typ=varsym) and
            not((pvarsym(p)^.vartype.def^.deftype=objectdef) and
              pobjectdef(pvarsym(p)^.vartype.def)^.is_class) and
            pvarsym(p)^.vartype.def^.needs_inittable and
            ((pvarsym(p)^.varspez=vs_value)) then
           begin
              procinfo^.flags:=procinfo^.flags or pi_needs_implicit_finally;
              reset_reference(hr);
              hr.symbol:=pvarsym(p)^.vartype.def^.get_inittable_label;
              a_param_ref_addr(list,hr,2);
              reset_reference(hr);
              hr.base:=procinfo^.framepointer;
              hr.offset:=pvarsym(p)^.address+procinfo^.para_offset;
              a_param_ref_addr(list,hr,1);
              reset_reference(hr);
              a_call_name(list,'FPC_ADDREF',0);
           end;
*)
        runerror(211);
      end;


    { generates the code for finalisation of local data }
    procedure tcg.g_finalize_data(list : taasmoutput;p : tnamedindexitem);

      var
         hr : treference;

      begin
(*
         if (tsym(p)^.typ=varsym) and
            assigned(pvarsym(p)^.vartype.def) and
            not((pvarsym(p)^.vartype.def^.deftype=objectdef) and
            pobjectdef(pvarsym(p)^.vartype.def)^.is_class) and
            pvarsym(p)^.vartype.def^.needs_inittable then
           begin
              { not all kind of parameters need to be finalized  }
              if (tsym(p)^.owner^.symtabletype=parasymtable) and
                ((pvarsym(p)^.varspez=vs_var)  or
                 (pvarsym(p)^.varspez=vs_const) { and
                 (dont_copy_const_param(pvarsym(p)^.definition)) } ) then
                exit;
              procinfo^.flags:=procinfo^.flags or pi_needs_implicit_finally;
              reset_reference(hr);
              case tsym(p)^.owner^.symtabletype of
                 localsymtable:
                   begin
                      hr.base:=procinfo^.framepointer;
                      hr.offset:=-pvarsym(p)^.address;
                   end;
                 parasymtable:
                   begin
                      hr.base:=procinfo^.framepointer;
                      hr.offset:=pvarsym(p)^.address+procinfo^.para_offset;
                   end;
                 else
                   hr.symbol:=newasmsymbol(pvarsym(p)^.mangledname);
              end;
              g_finalize(list,pvarsym(p)^.vartype.def,hr,false);
           end;
*)
        runerror(211);
      end;


    { generates the code to make local copies of the value parameters }
    procedure tcg.g_copyvalueparas(list : taasmoutput;p : tnamedindexitem);
      begin
         runerror(255);
      end;

(*
    var
       _list : taasmoutput;

    { wrappers for the methods, because TP doesn't know procedures }
    { of objects                                                   }

    procedure _copyvalueparas(s : tnamedindexitem);{$ifndef FPC}far;{$endif}

      begin
         cg^.g_copyvalueparas(_list,s);
      end;
*)

    procedure tcg.g_finalizetempansistrings(list : taasmoutput);

(*
      var
         hp : ptemprecord;
         hr : treference;
*)

      begin
(*
         hp:=tg.templist;
         while assigned(hp) do
           begin
              if hp^.temptype in [tt_ansistring,tt_freeansistring] then
                begin
                   procinfo^.flags:=procinfo^.flags or pi_needs_implicit_finally;
                   reset_reference(hr);
                   hr.base:=procinfo^.framepointer;
                   hr.offset:=hp^.pos;
                   a_param_ref_addr(list,hr,1);
                   a_call_name(list,'FPC_ANSISTR_DECR_REF',0);
                end;
              hp:=hp^.next;
           end;
*)
        runerror(211);
     end;

(*
    procedure _finalize_data(s : tnamedindexitem);{$ifndef FPC}far;{$endif}

      begin
         cg^.g_finalize_data(_list,s);
      end;

    procedure _incr_data(s : tnamedindexitem);{$ifndef FPC}far;{$endif}

      begin
         cg^.g_incr_data(_list,tsym(s));
      end;

    procedure _initialize_data(s : tnamedindexitem);{$ifndef FPC}far;{$endif}

      begin
         cg^.g_initialize_data(_list,tsym(s));
      end;
*)

    { generates the entry code for a procedure }
    procedure tcg.g_entrycode(alist : TAAsmoutput;make_global:boolean;
                     stackframe:longint;
                     var parasize:longint;var nostackframe:boolean;
                     inlined : boolean);


(*
      var
         hs : string;
         hp : pused_unit;
         initcode : taasmoutput;
{$ifdef GDB}
         stab_function_name : Pai_stab_function_name;
{$endif GDB}
         hr : treference;
         r : tregister;
*)

      begin
(*
         { Align }
         if (not inlined) then
           begin
              { gprof uses 16 byte granularity !! }
              if (cs_profile in aktmoduleswitches) then
                list^.insert(new(pai_align,init(16)))
              else
                if not(cs_littlesize in aktglobalswitches) then
                  list^.insert(new(pai_align,init(4)));
          end;
         { save registers on cdecl }
         if (po_savestdregs in aktprocsym^.definition^.procoptions) then
           begin
              for r:=firstreg to lastreg do
                begin
                   if (r in registers_saved_on_cdecl) then
                     if (r in (tg.availabletempregsint+
                               tg.availabletempregsfpu+
                               tg.availabletempregsmm)) then
                       begin
                          if not(r in tg.usedinproc) then
                            {!!!!!!!!!!!! a_push_reg(list,r) }
                       end
                     else
                       {!!!!!!!! a_push_reg(list,r) };
                end;
           end;
        { omit stack frame ? }
        if not inlined then
          if procinfo^.framepointer=stack_pointer then
            begin
               CGMessage(cg_d_stackframe_omited);
               nostackframe:=true;
               if (aktprocsym^.definition^.proctypeoption in [potype_unitinit,potype_proginit,potype_unitfinalize]) then
                 parasize:=0
               else
                 parasize:=aktprocsym^.definition^.parast^.datasize+procinfo^.para_offset-pointersize;
            end
          else
            begin
               if (aktprocsym^.definition^.proctypeoption in [potype_unitinit,potype_proginit,potype_unitfinalize]) then
                 parasize:=0
               else
                 parasize:=aktprocsym^.definition^.parast^.datasize+procinfo^.para_offset-pointersize*2;
               nostackframe:=false;
               if (po_interrupt in aktprocsym^.definition^.procoptions) then
                 g_interrupt_stackframe_entry(list);

               g_stackframe_entry(list,stackframe);

               if (cs_check_stack in aktlocalswitches) and
                 (tf_supports_stack_checking in target_info.flags) then
                 g_stackcheck(@initcode,stackframe);
            end;

         if cs_profile in aktmoduleswitches then
           g_profilecode(@initcode);
          if (not inlined) and (aktprocsym^.definition^.proctypeoption in [potype_unitinit]) then
            begin

              { needs the target a console flags ? }
              if tf_needs_isconsole in target_info.flags then
                begin
                   hr.symbol:=newasmsymbol('U_'+target_info.system_unit+'_ISCONSOLE');
                   if apptype=at_cui then
                     a_load_const_ref(list,OS_8,1,hr)
                   else
                     a_load_const_ref(list,OS_8,0,hr);
                   dispose(hr.symbol,done);
                end;

              hp:=pused_unit(usedunits.first);
              while assigned(hp) do
                begin
                   { call the unit init code and make it external }
                   if (hp^.u^.flags and uf_init)<>0 then
                     a_call_name(list,
                       'INIT$$'+hp^.u^.modulename^,0);
                    hp:=Pused_unit(hp^.next);
                end;
           end;

{$ifdef dummy}
         { a constructor needs a help procedure }
         if (aktprocsym^.definition^.options and poconstructor)<>0 then
           begin
             if procinfo^._class^.isclass then
               begin
                 list^.concat(new(paicpu,op_sym(A_CALL,S_NO,newasmsymbol('FPC_NEW_CLASS'))));
                 list^.concat(new(paicpu,op_cond_sym(A_Jcc,C_Z,S_NO,quickexitlabel)));
               end
             else
               begin
                 {
                 list^.insert(new(pai_labeled,init(A_JZ,quickexitlabel)));
                 list^.insert(new(paicpu,op_csymbol(A_CALL,S_NO,
                   newcsymbol('FPC_HELP_CONSTRUCTOR',0))));
                 list^.insert(new(paicpu,op_const_reg(A_MOV,S_L,procinfo^._class^.vmt_offset,R_EDI)));
                 concat_external('FPC_HELP_CONSTRUCTOR',EXT_NEAR);
                 }
               end;
           end;
{$endif dummy}
  {$ifdef GDB}
         if (cs_debuginfo in aktmoduleswitches) then
           list^.insert(new(pai_force_line,init));
  {$endif GDB}

         { initialize return value }
         if assigned(procinfo^.returntype.def) and
           is_ansistring(procinfo^.returntype.def) or
           is_widestring(procinfo^.returntype.def) then
           begin
              reset_reference(hr);
              hr.offset:=procinfo^.return_offset;
              hr.base:=procinfo^.framepointer;
              a_load_const_ref(list,OS_32,0,hr);
           end;

         _list:=list;
         { generate copies of call by value parameters }
         if (po_assembler in aktprocsym^.definition^.procoptions) then
            aktprocsym^.definition^.parast^.foreach({$ifdef FPCPROCVAR}@{$endif}_copyvalueparas);

         { initialisizes local data }
         aktprocsym^.definition^.localst^.foreach({$ifdef FPCPROCVAR}@{$endif}_initialize_data);
         { add a reference to all call by value/const parameters }
         aktprocsym^.definition^.parast^.foreach({$ifdef FPCPROCVAR}@{$endif}_incr_data);

         if (cs_profile in aktmoduleswitches) or
           (aktprocsym^.definition^.owner^.symtabletype=globalsymtable) or
           (assigned(procinfo^._class) and (procinfo^._class^.owner^.symtabletype=globalsymtable)) then
           make_global:=true;
         if not inlined then
           begin
              hs:=proc_names.get;

  {$ifdef GDB}
              if (cs_debuginfo in aktmoduleswitches) and target_os.use_function_relative_addresses then
                stab_function_name := new(pai_stab_function_name,init(strpnew(hs)));
  {$endif GDB}

              { insert the names for the procedure }
              while hs<>'' do
                begin
                   if make_global then
                     exprasmlist^.insert(new(pai_symbol,initname_global(hs,0)))
                   else
                     exprasmlist^.insert(new(pai_symbol,initname(hs,0)));

  {$ifdef GDB}
                   if (cs_debuginfo in aktmoduleswitches) then
                     begin
                       if target_os.use_function_relative_addresses then
                         list^.insert(new(pai_stab_function_name,init(strpnew(hs))));
                    end;
  {$endif GDB}

                  hs:=proc_names.get;
               end;
          end;

  {$ifdef GDB}
         if (not inlined) and (cs_debuginfo in aktmoduleswitches) then
           begin
              if target_os.use_function_relative_addresses then
                  list^.insert(stab_function_name);
              if make_global or ((procinfo^.flags and pi_is_global) <> 0) then
                  aktprocsym^.is_global := True;
              list^.insert(new(pai_stabs,init(aktprocsym^.stabstring)));
              aktprocsym^.isstabwritten:=true;
            end;
  {$endif GDB}
*)
      runerror(211);
    end;

    procedure tcg.g_exitcode(list : taasmoutput;parasize:longint;nostackframe,inlined:boolean);

      var
  {$ifdef GDB}
         mangled_length : longint;
         p : pchar;
  {$endif GDB}
         nofinal,noreraiselabel : tasmlabel;
         hr : treference;
         r : tregister;

      begin
(*
         if aktexitlabel^.is_used then
           list^.insert(new(pai_label,init(aktexitlabel)));

         { call the destructor help procedure }
         if (aktprocsym^.definition^.proctypeoption=potype_destructor) then
           begin
             if procinfo^._class^.is_class then
               a_call_name(list,'FPC_DISPOSE_CLASS',0)
             else
               begin
                  if procinfo^._class^.needs_inittable then
                    begin
                       getlabel(nofinal);
                       {!!!!!!!!!!
                       reset_reference(hr);
                       hr.base:=R_EBP;
                       hr.offset:=8;
                       a_cmp_reg_const_label(list,OS_ADDR,OZ_EQ,
                       }
                       reset_reference(hr);
                       hr.symbol:=procinfo^._class^.get_inittable_label;
                       a_paramaddr_ref(list,hr,2);
                       a_param_reg(list,OS_ADDR,self_pointer,1);
                       a_call_name(list,'FPC_FINALIZE',0);
                       a_label(list,nofinal);
                    end;
                  { vmt_offset_reg can be a scratch register, }
                  { but it must be always the same            }
                  a_reg_alloc(list,vmt_offset_reg);
                  a_load_const_reg(list,OS_32,procinfo^._class^.vmt_offset,vmt_offset_reg);
                  a_call_name(list,'FPC_HELP_DESTRUCTOR',0);
                  a_reg_dealloc(list,vmt_offset_reg);
               end;
           end;

         { finalize temporary data }
         g_finalizetempansistrings(list);

         _list:=list;

         { finalize local data }
         aktprocsym^.definition^.localst^.foreach({$ifdef FPCPROCVAR}@{$endif}_finalize_data);

         { finalize paras data }
         if assigned(aktprocsym^.definition^.parast) then
           aktprocsym^.definition^.parast^.foreach({$ifdef FPCPROCVAR}@{$endif}_finalize_data);

         { do we need to handle exceptions because of ansi/widestrings ? }
         if (procinfo^.flags and pi_needs_implicit_finally)<>0 then
           begin
              getlabel(noreraiselabel);

              a_call_name(list,'FPC_POPADDRSTACK',0);
              a_reg_alloc(list,accumulator);
              g_pop_exception_value_reg(list,accumulator);
              a_cmp_const_reg_label(list,OS_32,OC_EQ,0,accumulator,noreraiselabel);
              a_reg_dealloc(list,accumulator);

              { must be the return value finalized before reraising the exception? }
              if (procinfo^.returntype.def<>tdef(voiddef)) and
                (procinfo^.returntype.def^.needs_inittable) and
                ((procinfo^.returntype.def^.deftype<>objectdef) or
                not(pobjectdef(procinfo^.returntype.def)^.is_class)) then
                begin
                   reset_reference(hr);
                   hr.offset:=procinfo^.return_offset;
                   hr.base:=procinfo^.framepointer;
                   g_finalize(list,procinfo^.returntype.def,hr,ret_in_param(procinfo^.returntype.def));
                end;

              a_call_name(list,'FPC_RERAISE',0);
              a_label(list,noreraiselabel);
           end;

         { call __EXIT for main program }
         if (not DLLsource) and (not inlined) and (aktprocsym^.definition^.proctypeoption=potype_proginit) then
           a_call_name(list,'FPC_DO_EXIT',0);

         { handle return value }
         if not(po_assembler in aktprocsym^.definition^.procoptions) then
             if (aktprocsym^.definition^.proctypeoption<>potype_constructor) then
               { handle_return_value(inlined) }
             else
               begin
                  { return self in EAX }
                  a_label(list,quickexitlabel);
                  a_reg_alloc(list,accumulator);
                  a_load_reg_reg(list,OS_ADDR,self_pointer,accumulator);
                  a_reg_dealloc(list,self_pointer);
                  a_label(list,quickexitlabel);
                  { we can't clear the zero flag because the Alpha     }
                  { for example doesn't have flags, we have to compare }
                  { the accu. in the caller                            }
               end;

         { stabs uses the label also ! }
         if aktexit2label^.is_used or
            ((cs_debuginfo in aktmoduleswitches) and not inlined) then
           a_label(list,aktexit2label);

{$ifdef dummy}
         { should we restore edi ? }
         { for all i386 gcc implementations }
         {!!!!!!!!!!! I don't know how to handle register saving yet }
         if (po_savestdregs in aktprocsym^.definition^.procoptions) then
           begin
             if (aktprocsym^.definition^.usedregisters and ($80 shr byte(R_EBX)))<>0 then
              exprasmlist^.concat(new(paicpu,op_reg(A_POP,S_L,R_EBX)));
             exprasmlist^.concat(new(paicpu,op_reg(A_POP,S_L,R_ESI)));
             exprasmlist^.concat(new(paicpu,op_reg(A_POP,S_L,R_EDI)));
             { here we could reset R_EBX
               but that is risky because it only works
               if genexitcode is called after genentrycode
               so lets skip this for the moment PM
             aktprocsym^.definition^.usedregisters:=
               aktprocsym^.definition^.usedregisters or not ($80 shr byte(R_EBX));
             }
           end;
{$endif dummy}
         if not(nostackframe) and not inlined then
           g_restore_frame_pointer(list);
         { at last, the return is generated }

         if not inlined then
           if po_interrupt in aktprocsym^.definition^.procoptions then
             g_interrupt_stackframe_exit(list)
         else
           g_return_from_proc(list,parasize);
         list^.concat(new(pai_symbol_end,initname(aktprocsym^.definition^.mangledname)));

    {$ifdef GDB}
         if (cs_debuginfo in aktmoduleswitches) and not inlined  then
             begin
                aktprocsym^.concatstabto(list);
                if assigned(procinfo^._class) then
                  if (not assigned(procinfo^.parent) or
                     not assigned(procinfo^.parent^._class)) then
                    list^.concat(new(pai_stabs,init(strpnew(
                     '"$t:v'+procinfo^._class^.numberstring+'",'+
                     tostr(N_PSYM)+',0,0,'+tostr(procinfo^.selfpointer_offset)))));
                  {!!!!!!!!!!!!
                  else
                    list^.concat(new(pai_stabs,init(strpnew(
                     '"$t:r'+procinfo^._class^.numberstring+'",'+
                     tostr(N_RSYM)+',0,0,'+tostr(GDB_i386index[R_ESI])))));
                  }
                if (tdef(aktprocsym^.definition^.rettype.def) <> tdef(voiddef)) then
                  begin
                    if ret_in_param(aktprocsym^.definition^.rettype.def) then
                      list^.concat(new(pai_stabs,init(strpnew(
                       '"'+aktprocsym^.name+':X*'+aktprocsym^.definition^.rettype.def^.numberstring+'",'+
                       tostr(N_PSYM)+',0,0,'+tostr(procinfo^.return_offset)))))
                    else
                      list^.concat(new(pai_stabs,init(strpnew(
                       '"'+aktprocsym^.name+':X'+aktprocsym^.definition^.rettype.def^.numberstring+'",'+
                       tostr(N_PSYM)+',0,0,'+tostr(procinfo^.return_offset)))));
                    if (m_result in aktmodeswitches) then
                      if ret_in_param(aktprocsym^.definition^.rettype.def) then
                        list^.concat(new(pai_stabs,init(strpnew(
                         '"RESULT:X*'+aktprocsym^.definition^.rettype.def^.numberstring+'",'+
                         tostr(N_PSYM)+',0,0,'+tostr(procinfo^.return_offset)))))
                      else
                        list^.concat(new(pai_stabs,init(strpnew(
                         '"RESULT:X'+aktprocsym^.definition^.rettype.def^.numberstring+'",'+
                         tostr(N_PSYM)+',0,0,'+tostr(procinfo^.return_offset)))));
                  end;
                mangled_length:=length(aktprocsym^.definition^.mangledname);
                getmem(p,mangled_length+50);
                strpcopy(p,'192,0,0,');
                strpcopy(strend(p),aktprocsym^.definition^.mangledname);
                list^.concat(new(pai_stabn,init(strnew(p))));
                {list^.concat(new(pai_stabn,init(strpnew('192,0,0,'
                 +aktprocsym^.definition^.mangledname))));
                p[0]:='2';p[1]:='2';p[2]:='4';
                strpcopy(strend(p),'_end');}
                freemem(p,mangled_length+50);
                list^.concat(new(pai_stabn,init(
                  strpnew('224,0,0,'+aktexit2label^.name))));
                 { strpnew('224,0,0,'
                 +aktprocsym^.definition^.mangledname+'_end'))));}
             end;
    {$endif GDB}
*)
        runerror(211);
      end;

{*****************************************************************************
                       some generic implementations
 ****************************************************************************}


    procedure tcg.a_load_const_ref(list : taasmoutput;size : tcgsize;a : aword;const ref : treference);

    var
      tmpreg: tregister;

      begin
        tmpreg := get_scratch_reg(list);
        a_load_const_reg(list,size,a,tmpreg);
        a_load_reg_ref(list,size,tmpreg,ref);
        free_scratch_reg(list,tmpreg);
      end;

    procedure tcg.a_load_loc_reg(list : taasmoutput;size : tcgsize;const loc: tlocation; reg : tregister);

      begin
        case loc.loc of
          LOC_REFERENCE,LOC_MEM:
            a_load_ref_reg(list,size,loc.reference,reg);
          LOC_REGISTER,LOC_CREGISTER:
            a_load_reg_reg(list,size,loc.register,reg);
          else
            internalerror(200109092);
        end;
      end;

    procedure tcg.a_load_loc_ref(list : taasmoutput;size : tcgsize;const loc: tlocation; const ref : treference);

      var
        tmpreg: tregister;

      begin
        case loc.loc of
          LOC_REFERENCE,LOC_MEM:
            begin
{$ifdef i386}
              case size of
                OS_8,OS_S8:
                  tmpreg := reg32toreg8(getregister32);
                OS_16,OS_S16:
                  tmpreg := reg32toreg16(get_scratch_reg(list));
                else
                  tmpreg := get_scratch_reg(list);
              end;
{$else i386}
              tmpreg := get_scratch_reg(list);
{$endif i386}
              a_load_ref_reg(list,size,loc.reference,tmpreg);
              a_load_reg_ref(list,size,tmpreg,ref);
{$ifdef i386}
              if not (size in [OS_32,OS_S32]) then
                ungetregister(tmpreg)
              else
{$endif i386}
              free_scratch_reg(list,tmpreg);
            end;
          LOC_REGISTER,LOC_CREGISTER:
            a_load_reg_ref(list,size,loc.register,ref);
          else
            internalerror(200109302);
        end;
      end;


    procedure tcg.a_op_const_ref(list : taasmoutput; Op: TOpCG; size: TCGSize; a: AWord; const ref: TReference);

      var
        tmpreg: tregister;

      begin
        tmpreg := get_scratch_reg(list);
        a_load_ref_reg(list,size,ref,tmpreg);
        a_op_const_reg(list,op,a,tmpreg);
        a_load_reg_ref(list,size,tmpreg,ref);
        free_scratch_reg(list,tmpreg);
      end;


    procedure tcg.a_op_const_loc(list : taasmoutput; Op: TOpCG; size: TCGSize; a: AWord; const loc: tlocation);

      begin
        case loc.loc of
          LOC_REGISTER, LOC_CREGISTER:
            a_op_const_reg(list,op,a,loc.register);
          LOC_REFERENCE, LOC_MEM:
            a_op_const_ref(list,op,size,a,loc.reference);
          else
            internalerror(200109061);
        end;
      end;


    procedure tcg.a_op_reg_ref(list : taasmoutput; Op: TOpCG; size: TCGSize;reg: TRegister;  const ref: TReference);

      var
        tmpreg: tregister;

      begin
        tmpreg := get_scratch_reg(list);
        a_load_ref_reg(list,size,ref,tmpreg);
        a_op_reg_reg(list,op,size,reg,tmpreg);
        a_load_reg_ref(list,size,tmpreg,ref);
        free_scratch_reg(list,tmpreg);
      end;


    procedure tcg.a_op_ref_reg(list : taasmoutput; Op: TOpCG; size: TCGSize; const ref: TReference; reg: TRegister);

      var
        tmpreg: tregister;

      begin
        case op of
          OP_NOT,OP_NEG:
            { handle it as "load ref,reg; op reg" }
            begin
              a_load_ref_reg(list,size,ref,reg);
              a_op_reg_reg(list,op,size,reg,reg);
            end;
          else
            begin
              tmpreg := get_scratch_reg(list);
              a_load_ref_reg(list,size,ref,tmpreg);
              a_op_reg_reg(list,op,size,tmpreg,reg);
              free_scratch_reg(list,tmpreg);
            end;
        end;
      end;


    procedure tcg.a_op_reg_loc(list : taasmoutput; Op: TOpCG; size: TCGSize; reg: tregister; const loc: tlocation);

      begin
        case loc.loc of
          LOC_REGISTER, LOC_CREGISTER:
            a_op_reg_reg(list,op,size,reg,loc.register);
          LOC_REFERENCE, LOC_MEM:
            a_op_reg_ref(list,op,size,reg,loc.reference);
          else
            internalerror(200109061);
        end;
      end;


    procedure tcg.a_op_ref_loc(list : taasmoutput; Op: TOpCG; size: TCGSize; const ref: TReference; const loc: tlocation);

      var
        tmpreg: tregister;

      begin
        case loc.loc of
          LOC_REGISTER,LOC_CREGISTER:
            a_op_ref_reg(list,op,size,ref,loc.register);
          LOC_REFERENCE,LOC_MEM:
            begin
              tmpreg := get_scratch_reg(list);
{$ifdef i386}
              makeregsize(tmpreg,size);
{$endif i386}
              a_load_ref_reg(list,size,ref,tmpreg);
              a_op_reg_ref(list,op,size,tmpreg,loc.reference);
              free_scratch_reg(list,tmpreg);
            end;
          else
            internalerror(200109061);
        end;
      end;


    procedure tcg.a_cmp_const_ref_label(list : taasmoutput;size : tcgsize;cmp_op : topcmp;a : aword;const ref : treference;
     l : tasmlabel);

      var
        tmpreg: tregister;

      begin
        tmpreg := get_scratch_reg(list);
        a_load_ref_reg(list,size,ref,tmpreg);
        a_cmp_const_reg_label(list,size,cmp_op,a,tmpreg,l);
        free_scratch_reg(list,tmpreg);
      end;

    procedure tcg.a_cmp_const_loc_label(list : taasmoutput;size : tcgsize;cmp_op : topcmp;a : aword;const loc : tlocation;
      l : tasmlabel);

      begin
        case loc.loc of
          LOC_REGISTER,LOC_CREGISTER:
            a_cmp_const_reg_label(list,size,cmp_op,a,loc.register,l);
          LOC_REFERENCE,LOC_MEM:
            a_cmp_const_ref_label(list,size,cmp_op,a,loc.reference,l);
          else
            internalerror(200109061);
        end;
      end;

    procedure tcg.a_cmp_ref_reg_label(list : taasmoutput;size : tcgsize;cmp_op : topcmp; const ref: treference; reg : tregister; l : tasmlabel);

      var
        tmpreg: tregister;

      begin
        tmpreg := get_scratch_reg(list);
        a_load_ref_reg(list,size,ref,tmpreg);
        a_cmp_reg_reg_label(list,size,cmp_op,tmpreg,reg,l);
        free_scratch_reg(list,tmpreg);
      end;

    procedure tcg.a_cmp_ref_loc_label(list : taasmoutput;size : tcgsize;cmp_op : topcmp;const ref: treference;const loc : tlocation;
      l : tasmlabel);

      var
        tmpreg: tregister;

      begin
        case loc.loc of
          LOC_REGISTER,LOC_CREGISTER:
            a_cmp_ref_reg_label(list,size,cmp_op,ref,loc.register,l);
          LOC_REFERENCE,LOC_MEM:
            begin
{$ifdef i386}
              { the following is done with defines to avoid a speed penalty,  }
              { since all this is only necessary for the 80x86 (because EDI   }
              { doesn't have an 8bit component which is directly addressable) }
              if size in [OS_8,OS_S8] then
                tmpreg := getregister32
              else
{$endif i386}
              tmpreg := get_scratch_reg(list);
{$ifdef i386}
              makeregsize(tmpreg,size);
{$endif i386}
              a_load_ref_reg(list,size,loc.reference,tmpreg);
              a_cmp_ref_reg_label(list,size,cmp_op,ref,tmpreg,l);
{$ifdef i386}
              if makereg32(tmpreg) <> R_EDI then
                ungetregister(tmpreg)
              else
{$endif i386}
              free_scratch_reg(list,tmpreg);
            end
          else
            internalerror(200109061);
        end;
      end;

finalization
  cg.free;
end.
{
  $Log$
  Revision 1.4  2001-09-30 21:26:42  peter
    * removed obsolete newst defines

  Revision 1.3  2001/09/30 16:17:17  jonas
    * made most constant and mem handling processor independent

  Revision 1.2  2001/09/28 20:39:32  jonas
    * changed all flow control structures (except for exception handling
      related things) to processor independent code (in new ncgflw unit)
    + generic cgobj unit which contains lots of code generator helpers with
      global "cg" class instance variable
    + cgcpu unit for i386 (implements processor specific routines of the above
      unit)
    * updated cgbase and cpubase for the new code generator units
    * include ncgflw unit in cpunode unit

  Revision 1.5  2001/09/09 17:10:26  jonas
    * some more things implemented

  Revision 1.4  2001/09/06 15:25:55  jonas
    * changed type of tcg from object to class ->  abstract methods are now
      a lot cleaner :)
    + more updates: load_*_loc methods, op_*_* methods, g_flags2reg method
      (if possible with geenric implementation and necessary ppc
       implementations)
    * worked a bit further on cgflw, now working on exitnode

  Revision 1.3  2001/09/05 20:21:03  jonas
    * new cgflow based on n386flw with all nodes until forn "translated"
    + a_cmp_loc_*_label methods for tcg
    + base implementatino for a_cmp_ref_*_label methods
    * small bugfixes to powerpc cg

  Revision 1.2  2001/08/26 13:37:04  florian
    * some cg reorganisation
    * some PPC updates

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

}