{ $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,node; 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); { trinary operations for processors that support them, 'emulated' } { on others. None with "ref" arguments since I don't think there } { are any processors that support it (JM) } procedure a_op_const_reg_reg(list: taasmoutput; op: TOpCg; size: tcgsize; a: aword; src, dst: tregister); virtual; procedure a_op_reg_reg_reg(list: taasmoutput; op: TOpCg; size: tcgsize; src1, src2, dst: tregister); virtual; { 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); 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 a_jmp_flags(list : taasmoutput;const f : TResFlags;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; { generates rangechecking code for a node } procedure g_rangecheck(list: taasmoutput; const p: tnode; const todef: tdef); virtual; { returns the tcgsize corresponding with the size of reg } class function reg_cgsize(const reg: tregister) : tcgsize; virtual; {$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,gdb,systems, ppu,verbose,types,{tgobj,}tgcpu,symdef,symsym,cga,tainst; 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 {$ifdef i386} include(unusedscratchregisters,makereg32(r)); {$else i386} include(unusedscratchregisters,r); {$endif i386} 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(getregisterint); 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_op_const_reg_reg(list: taasmoutput; op: TOpCg; size: tcgsize; a: aword; src, dst: tregister); begin a_load_reg_reg(list,size,src,dst); a_op_const_reg(list,op,a,dst); end; procedure tcg.a_op_reg_reg_reg(list: taasmoutput; op: TOpCg; size: tcgsize; src1, src2, dst: tregister); begin a_load_reg_reg(list,size,src2,dst); a_op_reg_reg(list,op,size,src1,dst); 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 := getregisterint 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; procedure tcg.g_rangecheck(list: taasmoutput; const p: tnode; const todef: tdef); { generate range checking code for the value at location p. The type } { type used is checked against todefs ranges. fromdef (p.resulttype.def) } { is the original type used at that location. When both defs are equal } { the check is also insert (needed for succ,pref,inc,dec) } var neglabel : tasmlabel; hreg : tregister; fromdef : tdef; lto,hto, lfrom,hfrom : TConstExprInt; from_signed: boolean; begin { range checking on and range checkable value? } if not(cs_check_range in aktlocalswitches) or not(todef.deftype in [orddef,enumdef,arraydef]) then exit; { only check when assigning to scalar, subranges are different, } { when todef=fromdef then the check is always generated } fromdef:=p.resulttype.def; getrange(p.resulttype.def,lfrom,hfrom); getrange(todef,lto,hto); { no range check if from and to are equal and are both longint/dword } { (if we have a 32bit processor) or int64/qword, since such } { operations can at most cause overflows (JM) } { Note that these checks are mostly processor independent, they only } { have to be changed once we introduce 64bit subrange types } if (fromdef = todef) and { then fromdef and todef can only be orddefs } (((sizeof(aword) = 4) and (((torddef(fromdef).typ = s32bit) and (lfrom = low(longint)) and (hfrom = high(longint))) or ((torddef(fromdef).typ = u32bit) and (lfrom = low(cardinal)) and (hfrom = high(cardinal))))) or is_64bitint(fromdef)) then exit; if todef<>fromdef then begin { if the from-range falls completely in the to-range, no check } { is necessary } if (lto<=lfrom) and (hto>=hfrom) then exit; end; { generate the rangecheck code for the def where we are going to } { store the result } { use the trick that } { a <= x <= b <=> 0 <= x-a <= b-a <=> cardinal(x-a) <= cardinal(b-a) } { To be able to do that, we have to make sure however that either } { fromdef and todef are both signed or unsigned, or that we leave } { the parts < 0 and > maxlongint out } { is_signed now also works for arrays (it checks the rangetype) (JM) } from_signed := is_signed(fromdef); if from_signed xor is_signed(todef) then if from_signed then { from is signed, to is unsigned } begin { if high(from) < 0 -> always range error } if (hfrom < 0) or { if low(to) > maxlongint also range error } (lto > (high(aword) div 2)) then begin a_call_name(list,'FPC_RANGEERROR',0); exit end; { from is signed and to is unsigned -> when looking at from } { as an unsigned value, it must be < maxlongint (otherwise } { it's negative, which is invalid since "to" is unsigned) } if hto > (high(aword) div 2) then hto := (high(aword) div 2); end else { from is unsigned, to is signed } begin if (lfrom > (high(aword) div 2)) or (hto < 0) then begin a_call_name(list,'FPC_RANGEERROR',0); exit end; { from is unsigned and to is signed -> when looking at to } { as an unsigned value, it must be >= 0 (since negative } { values are the same as values > maxlongint) } if lto < 0 then lto := 0; end; hreg := get_scratch_reg(list); if (p.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then a_op_const_reg_reg(list,OP_SUB,def_cgsize(p.resulttype.def), aword(lto),p.location.register,hreg) else begin a_load_ref_reg(list,def_cgsize(p.resulttype.def), p.location.reference,hreg); a_op_const_reg(list,OP_SUB,aword(lto),hreg); end; getlabel(neglabel); a_cmp_const_reg_label(list,OS_INT,OC_BE,aword(hto-lto),hreg,neglabel); { !!! should happen right after the compare (JM) } free_scratch_reg(list,hreg); a_call_name(list,'FPC_RANGEERROR',0); a_label(list,neglabel); end; function tcg.reg_cgsize(const reg: tregister) : tcgsize; begin reg_cgsize := OS_INT; end; finalization cg.free; end. { $Log$ Revision 1.7 2002-03-04 19:10:11 peter * removed compiler warnings Revision 1.6 2001/12/30 17:24:48 jonas * range checking is now processor independent (part in cgobj, part in cg64f32) and should work correctly again (it needed some changes after the changes of the low and high of tordef's to int64) * maketojumpbool() is now processor independent (in ncgutil) * getregister32 is now called getregisterint Revision 1.5 2001/12/29 15:28:58 jonas * powerpc/cgcpu.pas compiles :) * several powerpc-related fixes * cpuasm unit is now based on common tainst unit + nppcmat unit for powerpc (almost complete) 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 }