diff --git a/compiler/new/cgobj.pas b/compiler/new/cgobj.pas index 853bf822c6..423b691c24 100644 --- a/compiler/new/cgobj.pas +++ b/compiler/new/cgobj.pas @@ -1,1157 +1,1160 @@ -{ - $Id$ - Copyright (c) 1993-99 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; - - interface - - uses - cobjects,aasm,symtable,symconst,cpuasm,cpubase,cgbase,cpuinfo,tainst; - - type - qword = comp; - - talignment = (AM_NATURAL,AM_NONE,AM_2BYTE,AM_4BYTE,AM_8BYTE); - - pcg = ^tcg; - tcg = object - scratch_register_array_pointer : aword; - unusedscratchregisters : tregisterset; - - alignment : talignment; - {************************************************} - { basic routines } - constructor init; - destructor done;virtual; - - procedure a_label(list : paasmoutput;l : pasmlabel);virtual; - - { allocates register r by inserting a pai_realloc record } - procedure a_reg_alloc(list : paasmoutput;r : tregister); - { deallocates register r by inserting a pa_regdealloc record} - procedure a_reg_dealloc(list : paasmoutput;r : tregister); - - { returns a register for use as scratch register } - function get_scratch_reg(list : paasmoutput) : tregister; - { releases a scratch register } - procedure free_scratch_reg(list : paasmoutput;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 : paasmoutput;t : pdef;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 : paasmoutput;t : pdef;const ref : treference;is_already_ref : boolean); - - { helper routines } - procedure g_initialize_data(list : paasmoutput;p : psym); - procedure g_incr_data(list : paasmoutput;p : psym); - procedure g_finalize_data(list : paasmoutput;p : pnamedindexobject); - procedure g_copyvalueparas(list : paasmoutput;p : pnamedindexobject); - procedure g_finalizetempansistrings(list : paasmoutput); - - procedure g_entrycode(list : paasmoutput; - const proc_names : tstringcontainer;make_global : boolean; - stackframe : longint;var parasize : longint; - var nostackframe : boolean;inlined : boolean); - - procedure g_exitcode(list : paasmoutput;parasize : longint; - nostackframe,inlined : boolean); - - { string helper routines } - procedure g_decrstrref(list : paasmoutput;const ref : treference;t : pdef); - - procedure g_removetemps(list : paasmoutput;p : plinkedlist); - - { 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 : paasmoutput;size : tcgsize;r : tregister;nr : longint);virtual; - procedure a_param_const(list : paasmoutput;size : tcgsize;a : aword;nr : longint);virtual; - procedure a_param_ref(list : paasmoutput;size : tcgsize;const r : treference;nr : longint);virtual; - procedure a_paramaddr_ref(list : paasmoutput;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 : paasmoutput;const s : string; - offset : longint);virtual; - - { move instructions } - procedure a_load_const_reg(list : paasmoutput;size : tcgsize;a : aword;register : tregister);virtual; - procedure a_load_reg_ref(list : paasmoutput;size : tcgsize;register : tregister;const ref : treference);virtual; - procedure a_load_ref_reg(list : paasmoutput;size : tcgsize;const ref : treference;register : tregister);virtual; - procedure a_load_reg_reg(list : paasmoutput;size : tcgsize;reg1,reg2 : tregister);virtual; - - { comparison operations } - procedure a_cmp_reg_const_label(list : paasmoutput;size : tcgsize;cmp_op : topcmp;a : aword;reg : tregister; - l : pasmlabel);virtual; - procedure a_cmp_reg_reg_label(list : paasmoutput;size : tcgsize;cmp_op : topcmp;reg1,reg2 : tregister;l : pasmlabel); - procedure a_cmp_reg_ref_label(list : paasmoutput;size : tcgsize;cmp_op : topcmp;reg : tregister;l : pasmlabel); - procedure a_cmp_ref_const_label(list : paasmoutput;size : tcgsize;cmp_op : topcmp;a : aword;reg : tregister; - l : pasmlabel); - - procedure a_loadaddress_ref_reg(list : paasmoutput;const ref : treference;r : tregister);virtual; - procedure g_stackframe_entry(list : paasmoutput;localsize : longint);virtual; - { restores the frame pointer at procedure exit, for the } - { i386 it generates a simple leave } - procedure g_restore_frame_pointer(list : paasmoutput);virtual; - - { 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 : paasmoutput;reg : tregister);virtual; - procedure g_push_exception_value_const(list : paasmoutput;reg : tregister);virtual; - { that procedure pops a exception value } - procedure g_pop_exception_value_reg(list : paasmoutput;reg : tregister);virtual; - procedure g_return_from_proc(list : paasmoutput;parasize : aword);virtual; - {********************************************************} - { these methods can be overriden for extra functionality } - - { the following methods do nothing: } - procedure g_interrupt_stackframe_entry(list : paasmoutput);virtual; - procedure g_interrupt_stackframe_exit(list : paasmoutput);virtual; - - procedure g_profilecode(list : paasmoutput);virtual; - procedure g_stackcheck(list : paasmoutput;stackframesize : longint);virtual; - - procedure a_load_const_ref(list : paasmoutput;size : tcgsize;a : aword;const ref : treference);virtual; - procedure g_maybe_loadself(list : paasmoutput);virtual; - { 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 : paasmoutput;const source,dest : treference;len : aword;loadref : boolean);virtual; - - { uses the addr of ref as param, was emitpushreferenceaddr } - procedure a_param_ref_addr(list : paasmoutput;r : treference;nr : longint);virtual; - end; - - var - cg : pcg; { this is the main code generator class } - - implementation - - uses - globals,globtype,options,files,gdb,systems, - ppu,verbose,types,tgobj,tgcpu; - -{***************************************************************************** - basic functionallity -******************************************************************************} - - constructor tcg.init; - - var - i : longint; - - begin - scratch_register_array_pointer:=1; - for i:=1 to max_scratch_regs do - include(unusedscratchregisters,scratch_regs[i]); - end; - - destructor tcg.done; - - begin - end; - - procedure tcg.a_reg_alloc(list : paasmoutput;r : tregister); - - begin - list^.concat(new(pairegalloc,alloc(r))); - end; - - procedure tcg.a_reg_dealloc(list : paasmoutput;r : tregister); - - begin - list^.concat(new(pairegalloc,dealloc(r))); - end; - - procedure tcg.a_label(list : paasmoutput;l : pasmlabel); - - begin - list^.concat(new(pai_label,init(l))); - end; - - function tcg.get_scratch_reg(list : paasmoutput) : tregister; - - var - r : tregister; - i : longint; - - begin - if unusedscratchregisters=[] then - internalerror(68996); - - for i:=1 to max_scratch_regs do - if scratch_regs[i] in unusedscratchregisters then - begin - r:=scratch_regs[i]; - 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 : paasmoutput;r : tregister); - - begin - include(unusedscratchregisters,r); - a_reg_dealloc(list,r); - end; - -{***************************************************************************** - this methods must be overridden for extra functionality -******************************************************************************} - - procedure tcg.g_interrupt_stackframe_entry(list : paasmoutput); - - begin - end; - - procedure tcg.g_interrupt_stackframe_exit(list : paasmoutput); - - begin - end; - - procedure tcg.g_profilecode(list : paasmoutput); - - begin - end; - -{***************************************************************************** - for better code generation these methods should be overridden -******************************************************************************} - - procedure tcg.a_param_const(list : paasmoutput;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 : paasmoutput;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_param_ref_addr(list : paasmoutput;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 : paasmoutput;stackframesize : longint); - - begin - a_param_const(list,OS_32,stackframesize,1); - a_call_name(list,'FPC_STACKCHECK',0); - end; - - procedure tcg.a_load_const_ref(list : paasmoutput;size : tcgsize;a : aword;const ref : treference); - - var - hr : tregister; - - begin - hr:=get_scratch_reg(list); - a_load_const_reg(list,size,a,hr); - a_load_reg_ref(list,size,hr,ref); - a_reg_dealloc(list,hr); - free_scratch_reg(list,hr); - end; - - - procedure tcg.g_concatcopy(list : paasmoutput;const source,dest : treference;len : aword;loadref : boolean); - - begin - abstract; - end; - - -{***************************************************************************** - String helper routines -*****************************************************************************} - - procedure tcg.g_removetemps(list : paasmoutput;p : plinkedlist); - - 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); - end; - - procedure tcg.g_decrstrref(list : paasmoutput;const ref : treference;t : pdef); - - 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); - 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 : paasmoutput;t : pdef;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; - end; - - procedure tcg.g_finalize(list : paasmoutput;t : pdef;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; - end; - - { generates the code for initialisation of local data } - procedure tcg.g_initialize_data(list : paasmoutput;p : psym); - - var - hr : treference; - - begin - if (psym(p)^.typ=varsym) and - assigned(pvarsym(p)^.definition) and - not((pvarsym(p)^.definition^.deftype=objectdef) and - pobjectdef(pvarsym(p)^.definition)^.is_class) and - pvarsym(p)^.definition^.needs_inittable then - begin - procinfo.flags:=procinfo.flags or pi_needs_implicit_finally; - reset_reference(hr); - if psym(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)^.definition,hr,false); - end; - end; - - - { generates the code for incrementing the reference count of parameters } - procedure tcg.g_incr_data(list : paasmoutput;p : psym); - - var - hr : treference; - - begin - if (psym(p)^.typ=varsym) and - not((pvarsym(p)^.definition^.deftype=objectdef) and - pobjectdef(pvarsym(p)^.definition)^.is_class) and - pvarsym(p)^.definition^.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)^.definition^.get_inittable_label; - a_param_ref_addr(list,hr,2); - reset_reference(hr); - hr.base:=procinfo.framepointer; - hr.offset:=pvarsym(p)^.address+procinfo.call_offset; - a_param_ref_addr(list,hr,1); - reset_reference(hr); - a_call_name(list,'FPC_ADDREF',0); - end; - end; - - - { generates the code for finalisation of local data } - procedure tcg.g_finalize_data(list : paasmoutput;p : pnamedindexobject); - - var - hr : treference; - - begin - if (psym(p)^.typ=varsym) and - assigned(pvarsym(p)^.definition) and - not((pvarsym(p)^.definition^.deftype=objectdef) and - pobjectdef(pvarsym(p)^.definition)^.is_class) and - pvarsym(p)^.definition^.needs_inittable then - begin - { not all kind of parameters need to be finalized } - if (psym(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 psym(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.call_offset; - end; - else - hr.symbol:=newasmsymbol(pvarsym(p)^.mangledname); - end; - g_finalize(list,pvarsym(p)^.definition,hr,false); - end; - end; - - - { generates the code to make local copies of the value parameters } - procedure tcg.g_copyvalueparas(list : paasmoutput;p : pnamedindexobject); - begin - runerror(255); - end; - - var - _list : paasmoutput; - - { wrappers for the methods, because TP doesn't know procedures } - { of objects } - - procedure _copyvalueparas(s : pnamedindexobject);{$ifndef FPC}far;{$endif} - - begin - cg^.g_copyvalueparas(_list,s); - end; - - procedure tcg.g_finalizetempansistrings(list : paasmoutput); - - 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; - end; - - procedure _finalize_data(s : pnamedindexobject);{$ifndef FPC}far;{$endif} - - begin - cg^.g_finalize_data(_list,s); - end; - - procedure _incr_data(s : pnamedindexobject);{$ifndef FPC}far;{$endif} - - begin - cg^.g_incr_data(_list,psym(s)); - end; - - procedure _initialize_data(s : pnamedindexobject);{$ifndef FPC}far;{$endif} - - begin - cg^.g_initialize_data(_list,psym(s)); - end; - - { generates the entry code for a procedure } - procedure tcg.g_entrycode(list : paasmoutput;const proc_names:Tstringcontainer;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.call_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.call_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 is_ansistring(procinfo.retdef) or - is_widestring(procinfo.retdef) then - begin - reset_reference(hr); - hr.offset:=procinfo.retoffset; - 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 FPC}@{$endif FPC}_copyvalueparas); - - { initialisizes local data } - aktprocsym^.definition^.localst^.foreach({$ifdef FPC}@{$endif FPC}_initialize_data); - { add a reference to all call by value/const parameters } - aktprocsym^.definition^.parast^.foreach({$ifdef FPC}@{$endif FPC}_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} - end; - - procedure tcg.g_exitcode(list : paasmoutput;parasize:longint;nostackframe,inlined:boolean); - - var - {$ifdef GDB} - mangled_length : longint; - p : pchar; - {$endif GDB} - noreraiselabel : pasmlabel; - 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 - { 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({$ifndef TP}@{$endif}_finalize_data); - - { finalize paras data } - if assigned(aktprocsym^.definition^.parast) then - aktprocsym^.definition^.parast^.foreach({$ifndef TP}@{$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_reg_const_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.retdef<>pdef(voiddef)) and - (procinfo.retdef^.needs_inittable) and - ((procinfo.retdef^.deftype<>objectdef) or - not(pobjectdef(procinfo.retdef)^.is_class)) then - begin - reset_reference(hr); - hr.offset:=procinfo.retoffset; - hr.base:=procinfo.framepointer; - g_finalize(list,procinfo.retdef,hr,ret_in_param(procinfo.retdef)); - 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(exprasmlist); - 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 (pdef(aktprocsym^.definition^.retdef) <> pdef(voiddef)) then - if ret_in_param(aktprocsym^.definition^.retdef) then - list^.concat(new(pai_stabs,init(strpnew( - '"'+aktprocsym^.name+':X*'+aktprocsym^.definition^.retdef^.numberstring+'",'+ - tostr(N_PSYM)+',0,0,'+tostr(procinfo.retoffset))))) - else - list^.concat(new(pai_stabs,init(strpnew( - '"'+aktprocsym^.name+':X'+aktprocsym^.definition^.retdef^.numberstring+'",'+ - tostr(N_PSYM)+',0,0,'+tostr(procinfo.retoffset))))); - - mangled_length:=length(aktprocsym^.definition^.mangledname); - getmem(p,mangled_length+50); - strpcopy(p,'192,0,0,'); - strpcopy(strend(p),aktprocsym^.definition^.mangledname); - exprasmlist^.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); - exprasmlist^.concat(new(pai_stabn,init( - strpnew('224,0,0,'+aktexit2label^.name)))); - { strpnew('224,0,0,' - +aktprocsym^.definition^.mangledname+'_end'))));} - end; - {$endif GDB} - end; - -{***************************************************************************** - some abstract definitions - ****************************************************************************} - - procedure tcg.a_call_name(list : paasmoutput;const s : string; - offset : longint); - - begin - abstract; - end; - - procedure tcg.g_stackframe_entry(list : paasmoutput;localsize : longint); - - begin - abstract; - end; - - procedure tcg.g_maybe_loadself(list : paasmoutput); - - begin - abstract; - end; - - procedure tcg.g_restore_frame_pointer(list : paasmoutput); - - begin - abstract; - end; - - procedure g_return_from_proc(list : paasmoutput;parasize : aword); - - begin - abstract; - end; - - procedure tcg.a_loadaddress_ref_reg(list : paasmoutput;const ref : treference;r : tregister); - - begin - abstract; - end; - - procedure tcg.g_push_exception_value_reg(list : paasmoutput;reg : tregister); - - begin - abstract; - end; - - procedure tcg.g_push_exception_value_const(list : paasmoutput;reg : tregister); - - begin - abstract; - end; - - procedure tcg.g_pop_exception_value_reg(list : paasmoutput;reg : tregister); - - begin - abstract; - end; - - procedure tcg.a_load_const_reg(list : paasmoutput;size : tcgsize;a : aword;register : tregister); - - begin - abstract; - end; - - procedure tcg.a_load_reg_ref(list : paasmoutput;size : tcgsize;register : tregister;const ref : treference); - - begin - abstract; - end; - - procedure tcg.a_load_ref_reg(list : paasmoutput;size : tcgsize;const ref : treference;register : tregister); - - begin - abstract; - end; - - procedure tcg.a_load_reg_reg(list : paasmoutput;size : tcgsize;reg1,reg2 : tregister); - - begin - abstract; - end; - - procedure tcg.a_cmp_reg_const_label(list : paasmoutput;size : tcgsize;cmp_op : topcmp;a : aword;reg : tregister; - l : pasmlabel); - - begin - abstract; - end; - - procedure tcg.a_cmp_reg_reg_label(list : paasmoutput;size : tcgsize;cmp_op : topcmp;reg1,reg2 : tregister;l : pasmlabel); - - begin - abstract; - end; - - procedure tcg.a_cmp_reg_ref_label(list : paasmoutput;size : tcgsize;cmp_op : topcmp;reg : tregister;l : pasmlabel); - - begin - abstract; - end; - - procedure tcg.a_cmp_ref_const_label(list : paasmoutput;size : tcgsize;cmp_op : topcmp;a : aword;reg : tregister; - l : pasmlabel); - - begin - abstract; - end; - - procedure tcg.g_return_from_proc(list : paasmoutput;parasize : aword); - - begin - abstract; - end; - - procedure tcg.a_param_reg(list : paasmoutput;size : tcgsize;r : tregister;nr : longint); - - begin - abstract; - end; - - procedure tcg.a_paramaddr_ref(list : paasmoutput;const r : treference;nr : longint); - - begin - abstract; - end; - -end. -{ +{ + $Id$ + Copyright (c) 1993-99 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; + + interface + + uses + cobjects,aasm,symtable,symconst,cpuasm,cpubase,cgbase,cpuinfo,tainst; + + type + qword = comp; + + talignment = (AM_NATURAL,AM_NONE,AM_2BYTE,AM_4BYTE,AM_8BYTE); + + pcg = ^tcg; + tcg = object + scratch_register_array_pointer : aword; + unusedscratchregisters : tregisterset; + + alignment : talignment; + {************************************************} + { basic routines } + constructor init; + destructor done;virtual; + + procedure a_label(list : paasmoutput;l : pasmlabel);virtual; + + { allocates register r by inserting a pai_realloc record } + procedure a_reg_alloc(list : paasmoutput;r : tregister); + { deallocates register r by inserting a pa_regdealloc record} + procedure a_reg_dealloc(list : paasmoutput;r : tregister); + + { returns a register for use as scratch register } + function get_scratch_reg(list : paasmoutput) : tregister; + { releases a scratch register } + procedure free_scratch_reg(list : paasmoutput;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 : paasmoutput;t : pdef;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 : paasmoutput;t : pdef;const ref : treference;is_already_ref : boolean); + + { helper routines } + procedure g_initialize_data(list : paasmoutput;p : psym); + procedure g_incr_data(list : paasmoutput;p : psym); + procedure g_finalize_data(list : paasmoutput;p : pnamedindexobject); + procedure g_copyvalueparas(list : paasmoutput;p : pnamedindexobject); + procedure g_finalizetempansistrings(list : paasmoutput); + + procedure g_entrycode(list : paasmoutput; + const proc_names : tstringcontainer;make_global : boolean; + stackframe : longint;var parasize : longint; + var nostackframe : boolean;inlined : boolean); + + procedure g_exitcode(list : paasmoutput;parasize : longint; + nostackframe,inlined : boolean); + + { string helper routines } + procedure g_decrstrref(list : paasmoutput;const ref : treference;t : pdef); + + procedure g_removetemps(list : paasmoutput;p : plinkedlist); + + { 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 : paasmoutput;size : tcgsize;r : tregister;nr : longint);virtual; + procedure a_param_const(list : paasmoutput;size : tcgsize;a : aword;nr : longint);virtual; + procedure a_param_ref(list : paasmoutput;size : tcgsize;const r : treference;nr : longint);virtual; + procedure a_paramaddr_ref(list : paasmoutput;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 : paasmoutput;const s : string; + offset : longint);virtual; + + { move instructions } + procedure a_load_const_reg(list : paasmoutput;size : tcgsize;a : aword;register : tregister);virtual; + procedure a_load_reg_ref(list : paasmoutput;size : tcgsize;register : tregister;const ref : treference);virtual; + procedure a_load_ref_reg(list : paasmoutput;size : tcgsize;const ref : treference;register : tregister);virtual; + procedure a_load_reg_reg(list : paasmoutput;size : tcgsize;reg1,reg2 : tregister);virtual; + + { comparison operations } + procedure a_cmp_reg_const_label(list : paasmoutput;size : tcgsize;cmp_op : topcmp;a : aword;reg : tregister; + l : pasmlabel);virtual; + procedure a_cmp_reg_reg_label(list : paasmoutput;size : tcgsize;cmp_op : topcmp;reg1,reg2 : tregister;l : pasmlabel); + procedure a_cmp_reg_ref_label(list : paasmoutput;size : tcgsize;cmp_op : topcmp;reg : tregister;l : pasmlabel); + procedure a_cmp_ref_const_label(list : paasmoutput;size : tcgsize;cmp_op : topcmp;a : aword;reg : tregister; + l : pasmlabel); + + procedure a_loadaddress_ref_reg(list : paasmoutput;const ref : treference;r : tregister);virtual; + procedure g_stackframe_entry(list : paasmoutput;localsize : longint);virtual; + { restores the frame pointer at procedure exit, for the } + { i386 it generates a simple leave } + procedure g_restore_frame_pointer(list : paasmoutput);virtual; + + { 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 : paasmoutput;reg : tregister);virtual; + procedure g_push_exception_value_const(list : paasmoutput;reg : tregister);virtual; + { that procedure pops a exception value } + procedure g_pop_exception_value_reg(list : paasmoutput;reg : tregister);virtual; + procedure g_return_from_proc(list : paasmoutput;parasize : aword);virtual; + {********************************************************} + { these methods can be overriden for extra functionality } + + { the following methods do nothing: } + procedure g_interrupt_stackframe_entry(list : paasmoutput);virtual; + procedure g_interrupt_stackframe_exit(list : paasmoutput);virtual; + + procedure g_profilecode(list : paasmoutput);virtual; + procedure g_stackcheck(list : paasmoutput;stackframesize : longint);virtual; + + procedure a_load_const_ref(list : paasmoutput;size : tcgsize;a : aword;const ref : treference);virtual; + procedure g_maybe_loadself(list : paasmoutput);virtual; + { 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 : paasmoutput;const source,dest : treference;len : aword;loadref : boolean);virtual; + + { uses the addr of ref as param, was emitpushreferenceaddr } + procedure a_param_ref_addr(list : paasmoutput;r : treference;nr : longint);virtual; + end; + + var + cg : pcg; { this is the main code generator class } + + implementation + + uses + globals,globtype,options,files,gdb,systems, + ppu,verbose,types,tgobj,tgcpu; + +{***************************************************************************** + basic functionallity +******************************************************************************} + + constructor tcg.init; + + var + i : longint; + + begin + scratch_register_array_pointer:=1; + for i:=1 to max_scratch_regs do + include(unusedscratchregisters,scratch_regs[i]); + end; + + destructor tcg.done; + + begin + end; + + procedure tcg.a_reg_alloc(list : paasmoutput;r : tregister); + + begin + list^.concat(new(pairegalloc,alloc(r))); + end; + + procedure tcg.a_reg_dealloc(list : paasmoutput;r : tregister); + + begin + list^.concat(new(pairegalloc,dealloc(r))); + end; + + procedure tcg.a_label(list : paasmoutput;l : pasmlabel); + + begin + list^.concat(new(pai_label,init(l))); + end; + + function tcg.get_scratch_reg(list : paasmoutput) : tregister; + + var + r : tregister; + i : longint; + + begin + if unusedscratchregisters=[] then + internalerror(68996); + + for i:=scratch_reg_array_pointer to (scratch_reg_array_pointer + + max_scratch_regs) 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 : paasmoutput;r : tregister); + + begin + include(unusedscratchregisters,r); + a_reg_dealloc(list,r); + end; + +{***************************************************************************** + this methods must be overridden for extra functionality +******************************************************************************} + + procedure tcg.g_interrupt_stackframe_entry(list : paasmoutput); + + begin + end; + + procedure tcg.g_interrupt_stackframe_exit(list : paasmoutput); + + begin + end; + + procedure tcg.g_profilecode(list : paasmoutput); + + begin + end; + +{***************************************************************************** + for better code generation these methods should be overridden +******************************************************************************} + + procedure tcg.a_param_const(list : paasmoutput;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 : paasmoutput;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_param_ref_addr(list : paasmoutput;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 : paasmoutput;stackframesize : longint); + + begin + a_param_const(list,OS_32,stackframesize,1); + a_call_name(list,'FPC_STACKCHECK',0); + end; + + procedure tcg.a_load_const_ref(list : paasmoutput;size : tcgsize;a : aword;const ref : treference); + + var + hr : tregister; + + begin + hr:=get_scratch_reg(list); + a_load_const_reg(list,size,a,hr); + a_load_reg_ref(list,size,hr,ref); + free_scratch_reg(list,hr); + end; + + + procedure tcg.g_concatcopy(list : paasmoutput;const source,dest : treference;len : aword;loadref : boolean); + + begin + abstract; + end; + + +{***************************************************************************** + String helper routines +*****************************************************************************} + + procedure tcg.g_removetemps(list : paasmoutput;p : plinkedlist); + + 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); + end; + + procedure tcg.g_decrstrref(list : paasmoutput;const ref : treference;t : pdef); + + 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); + 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 : paasmoutput;t : pdef;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; + end; + + procedure tcg.g_finalize(list : paasmoutput;t : pdef;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; + end; + + { generates the code for initialisation of local data } + procedure tcg.g_initialize_data(list : paasmoutput;p : psym); + + var + hr : treference; + + begin + if (psym(p)^.typ=varsym) and + assigned(pvarsym(p)^.definition) and + not((pvarsym(p)^.definition^.deftype=objectdef) and + pobjectdef(pvarsym(p)^.definition)^.is_class) and + pvarsym(p)^.definition^.needs_inittable then + begin + procinfo.flags:=procinfo.flags or pi_needs_implicit_finally; + reset_reference(hr); + if psym(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)^.definition,hr,false); + end; + end; + + + { generates the code for incrementing the reference count of parameters } + procedure tcg.g_incr_data(list : paasmoutput;p : psym); + + var + hr : treference; + + begin + if (psym(p)^.typ=varsym) and + not((pvarsym(p)^.definition^.deftype=objectdef) and + pobjectdef(pvarsym(p)^.definition)^.is_class) and + pvarsym(p)^.definition^.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)^.definition^.get_inittable_label; + a_param_ref_addr(list,hr,2); + reset_reference(hr); + hr.base:=procinfo.framepointer; + hr.offset:=pvarsym(p)^.address+procinfo.call_offset; + a_param_ref_addr(list,hr,1); + reset_reference(hr); + a_call_name(list,'FPC_ADDREF',0); + end; + end; + + + { generates the code for finalisation of local data } + procedure tcg.g_finalize_data(list : paasmoutput;p : pnamedindexobject); + + var + hr : treference; + + begin + if (psym(p)^.typ=varsym) and + assigned(pvarsym(p)^.definition) and + not((pvarsym(p)^.definition^.deftype=objectdef) and + pobjectdef(pvarsym(p)^.definition)^.is_class) and + pvarsym(p)^.definition^.needs_inittable then + begin + { not all kind of parameters need to be finalized } + if (psym(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 psym(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.call_offset; + end; + else + hr.symbol:=newasmsymbol(pvarsym(p)^.mangledname); + end; + g_finalize(list,pvarsym(p)^.definition,hr,false); + end; + end; + + + { generates the code to make local copies of the value parameters } + procedure tcg.g_copyvalueparas(list : paasmoutput;p : pnamedindexobject); + begin + runerror(255); + end; + + var + _list : paasmoutput; + + { wrappers for the methods, because TP doesn't know procedures } + { of objects } + + procedure _copyvalueparas(s : pnamedindexobject);{$ifndef FPC}far;{$endif} + + begin + cg^.g_copyvalueparas(_list,s); + end; + + procedure tcg.g_finalizetempansistrings(list : paasmoutput); + + 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; + end; + + procedure _finalize_data(s : pnamedindexobject);{$ifndef FPC}far;{$endif} + + begin + cg^.g_finalize_data(_list,s); + end; + + procedure _incr_data(s : pnamedindexobject);{$ifndef FPC}far;{$endif} + + begin + cg^.g_incr_data(_list,psym(s)); + end; + + procedure _initialize_data(s : pnamedindexobject);{$ifndef FPC}far;{$endif} + + begin + cg^.g_initialize_data(_list,psym(s)); + end; + + { generates the entry code for a procedure } + procedure tcg.g_entrycode(list : paasmoutput;const proc_names:Tstringcontainer;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.call_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.call_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 is_ansistring(procinfo.retdef) or + is_widestring(procinfo.retdef) then + begin + reset_reference(hr); + hr.offset:=procinfo.retoffset; + 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 FPC}@{$endif FPC}_copyvalueparas); + + { initialisizes local data } + aktprocsym^.definition^.localst^.foreach({$ifdef FPC}@{$endif FPC}_initialize_data); + { add a reference to all call by value/const parameters } + aktprocsym^.definition^.parast^.foreach({$ifdef FPC}@{$endif FPC}_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} + end; + + procedure tcg.g_exitcode(list : paasmoutput;parasize:longint;nostackframe,inlined:boolean); + + var + {$ifdef GDB} + mangled_length : longint; + p : pchar; + {$endif GDB} + noreraiselabel : pasmlabel; + 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 + { 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({$ifndef TP}@{$endif}_finalize_data); + + { finalize paras data } + if assigned(aktprocsym^.definition^.parast) then + aktprocsym^.definition^.parast^.foreach({$ifndef TP}@{$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_reg_const_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.retdef<>pdef(voiddef)) and + (procinfo.retdef^.needs_inittable) and + ((procinfo.retdef^.deftype<>objectdef) or + not(pobjectdef(procinfo.retdef)^.is_class)) then + begin + reset_reference(hr); + hr.offset:=procinfo.retoffset; + hr.base:=procinfo.framepointer; + g_finalize(list,procinfo.retdef,hr,ret_in_param(procinfo.retdef)); + 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(exprasmlist); + 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 (pdef(aktprocsym^.definition^.retdef) <> pdef(voiddef)) then + if ret_in_param(aktprocsym^.definition^.retdef) then + list^.concat(new(pai_stabs,init(strpnew( + '"'+aktprocsym^.name+':X*'+aktprocsym^.definition^.retdef^.numberstring+'",'+ + tostr(N_PSYM)+',0,0,'+tostr(procinfo.retoffset))))) + else + list^.concat(new(pai_stabs,init(strpnew( + '"'+aktprocsym^.name+':X'+aktprocsym^.definition^.retdef^.numberstring+'",'+ + tostr(N_PSYM)+',0,0,'+tostr(procinfo.retoffset))))); + + mangled_length:=length(aktprocsym^.definition^.mangledname); + getmem(p,mangled_length+50); + strpcopy(p,'192,0,0,'); + strpcopy(strend(p),aktprocsym^.definition^.mangledname); + exprasmlist^.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); + exprasmlist^.concat(new(pai_stabn,init( + strpnew('224,0,0,'+aktexit2label^.name)))); + { strpnew('224,0,0,' + +aktprocsym^.definition^.mangledname+'_end'))));} + end; + {$endif GDB} + end; + +{***************************************************************************** + some abstract definitions + ****************************************************************************} + + procedure tcg.a_call_name(list : paasmoutput;const s : string; + offset : longint); + + begin + abstract; + end; + + procedure tcg.g_stackframe_entry(list : paasmoutput;localsize : longint); + + begin + abstract; + end; + + procedure tcg.g_maybe_loadself(list : paasmoutput); + + begin + abstract; + end; + + procedure tcg.g_restore_frame_pointer(list : paasmoutput); + + begin + abstract; + end; + + procedure g_return_from_proc(list : paasmoutput;parasize : aword); + + begin + abstract; + end; + + procedure tcg.a_loadaddress_ref_reg(list : paasmoutput;const ref : treference;r : tregister); + + begin + abstract; + end; + + procedure tcg.g_push_exception_value_reg(list : paasmoutput;reg : tregister); + + begin + abstract; + end; + + procedure tcg.g_push_exception_value_const(list : paasmoutput;reg : tregister); + + begin + abstract; + end; + + procedure tcg.g_pop_exception_value_reg(list : paasmoutput;reg : tregister); + + begin + abstract; + end; + + procedure tcg.a_load_const_reg(list : paasmoutput;size : tcgsize;a : aword;register : tregister); + + begin + abstract; + end; + + procedure tcg.a_load_reg_ref(list : paasmoutput;size : tcgsize;register : tregister;const ref : treference); + + begin + abstract; + end; + + procedure tcg.a_load_ref_reg(list : paasmoutput;size : tcgsize;const ref : treference;register : tregister); + + begin + abstract; + end; + + procedure tcg.a_load_reg_reg(list : paasmoutput;size : tcgsize;reg1,reg2 : tregister); + + begin + abstract; + end; + + procedure tcg.a_cmp_reg_const_label(list : paasmoutput;size : tcgsize;cmp_op : topcmp;a : aword;reg : tregister; + l : pasmlabel); + + begin + abstract; + end; + + procedure tcg.a_cmp_reg_reg_label(list : paasmoutput;size : tcgsize;cmp_op : topcmp;reg1,reg2 : tregister;l : pasmlabel); + + begin + abstract; + end; + + procedure tcg.a_cmp_reg_ref_label(list : paasmoutput;size : tcgsize;cmp_op : topcmp;reg : tregister;l : pasmlabel); + + begin + abstract; + end; + + procedure tcg.a_cmp_ref_const_label(list : paasmoutput;size : tcgsize;cmp_op : topcmp;a : aword;reg : tregister; + l : pasmlabel); + + begin + abstract; + end; + + procedure tcg.g_return_from_proc(list : paasmoutput;parasize : aword); + + begin + abstract; + end; + + procedure tcg.a_param_reg(list : paasmoutput;size : tcgsize;r : tregister;nr : longint); + + begin + abstract; + end; + + procedure tcg.a_paramaddr_ref(list : paasmoutput;const r : treference;nr : longint); + + begin + abstract; + end; + +end. +{ $Log$ - Revision 1.23 1999-08-25 12:00:11 jonas - * changed pai386, paippc and paiapha (same for tai*) to paicpu (taicpu) - - Revision 1.22 1999/08/18 17:05:55 florian - + implemented initilizing of data for the new code generator - so it should compile now simple programs - - Revision 1.21 1999/08/07 14:21:08 florian - * some small problems fixed - - Revision 1.20 1999/08/06 18:05:52 florian - * implemented some stuff for assignments - - Revision 1.19 1999/08/06 17:00:54 florian - + definition of concatcopy - - Revision 1.18 1999/08/06 16:37:45 jonas - * completed bugfix done by Florian o I wouldn't get conflicts :) - - Revision 1.17 1999/08/06 16:27:26 florian - * for Jonas: else he will get conflicts - - Revision 1.16 1999/08/06 16:04:05 michael - + introduced tainstruction - - Revision 1.15 1999/08/06 15:53:50 florian - * made the alpha version compilable - - Revision 1.14 1999/08/06 14:15:51 florian - * made the alpha version compilable - - Revision 1.13 1999/08/06 13:26:50 florian - * more changes ... - - Revision 1.12 1999/08/05 17:10:56 florian - * some more additions, especially procedure - exit code generation - - Revision 1.11 1999/08/05 14:58:11 florian - * some fixes for the floating point registers - * more things for the new code generator - - Revision 1.10 1999/08/04 00:23:52 florian - * renamed i386asm and i386base to cpuasm and cpubase - - Revision 1.9 1999/08/02 23:13:21 florian - * more changes to compile for the Alpha - - Revision 1.8 1999/08/02 17:14:07 florian - + changed the temp. generator to an object - - Revision 1.7 1999/08/01 23:05:55 florian - * changes to compile with FPC - - Revision 1.6 1999/08/01 18:22:33 florian - * made it again compilable - - Revision 1.5 1999/01/23 23:29:46 florian - * first running version of the new code generator - * when compiling exceptions under Linux fixed - - Revision 1.4 1999/01/13 22:52:36 florian - + YES, finally the new code generator is compilable, but it doesn't run yet :( - - Revision 1.3 1998/12/26 15:20:30 florian - + more changes for the new version - - Revision 1.2 1998/12/15 22:18:55 florian - * some code added - - Revision 1.1 1998/12/15 16:32:58 florian - + first version, derived from old routines - -} - + Revision 1.24 1999-08-26 14:51:54 jonas + * changed get_scratch_reg so it actually uses the\n scratch_reg_array_pointer + + Revision 1.23 1999/08/25 12:00:11 jonas + * changed pai386, paippc and paiapha (same for tai*) to paicpu (taicpu) + + Revision 1.22 1999/08/18 17:05:55 florian + + implemented initilizing of data for the new code generator + so it should compile now simple programs + + Revision 1.21 1999/08/07 14:21:08 florian + * some small problems fixed + + Revision 1.20 1999/08/06 18:05:52 florian + * implemented some stuff for assignments + + Revision 1.19 1999/08/06 17:00:54 florian + + definition of concatcopy + + Revision 1.18 1999/08/06 16:37:45 jonas + * completed bugfix done by Florian o I wouldn't get conflicts :) + + Revision 1.17 1999/08/06 16:27:26 florian + * for Jonas: else he will get conflicts + + Revision 1.16 1999/08/06 16:04:05 michael + + introduced tainstruction + + Revision 1.15 1999/08/06 15:53:50 florian + * made the alpha version compilable + + Revision 1.14 1999/08/06 14:15:51 florian + * made the alpha version compilable + + Revision 1.13 1999/08/06 13:26:50 florian + * more changes ... + + Revision 1.12 1999/08/05 17:10:56 florian + * some more additions, especially procedure + exit code generation + + Revision 1.11 1999/08/05 14:58:11 florian + * some fixes for the floating point registers + * more things for the new code generator + + Revision 1.10 1999/08/04 00:23:52 florian + * renamed i386asm and i386base to cpuasm and cpubase + + Revision 1.9 1999/08/02 23:13:21 florian + * more changes to compile for the Alpha + + Revision 1.8 1999/08/02 17:14:07 florian + + changed the temp. generator to an object + + Revision 1.7 1999/08/01 23:05:55 florian + * changes to compile with FPC + + Revision 1.6 1999/08/01 18:22:33 florian + * made it again compilable + + Revision 1.5 1999/01/23 23:29:46 florian + * first running version of the new code generator + * when compiling exceptions under Linux fixed + + Revision 1.4 1999/01/13 22:52:36 florian + + YES, finally the new code generator is compilable, but it doesn't run yet :( + + Revision 1.3 1998/12/26 15:20:30 florian + + more changes for the new version + + Revision 1.2 1998/12/15 22:18:55 florian + * some code added + + Revision 1.1 1998/12/15 16:32:58 florian + + first version, derived from old routines + +} +