123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761 |
- {
- $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.
- ****************************************************************************
- }
- {# @abstract(Abstract code generator unit)
- Abstreact code generator unit. This contains the base class
- to implement for all new supported processors.
- }
- unit cgobj;
- {$i defines.inc}
- interface
- uses
- cclasses,aasm,symtable,
- cpuasm,cpubase,cpuinfo,
- cginfo,
- symconst,symbase,symtype,node;
- type
- talignment = (AM_NATURAL,AM_NONE,AM_2BYTE,AM_4BYTE,AM_8BYTE);
-
-
- {# @abstract(Abstract code generator)
- This class implements an abstract instruction generator. Some of
- the methods of this class are generic, while others must
- be overriden for all new processors which will be supported
- by Free Pascal. For 32-bit processors, the base class
- sould be @link(tcg64f32) and not @var(tcg).
- }
- tcg = class
- scratch_register_array_pointer : aword;
- {# List of currently unused scratch registers }
- unusedscratchregisters : tregisterset;
- alignment : talignment;
- {************************************************}
- { basic routines }
- constructor create;
- {# Emit a label to the instruction stream. }
- 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);
- {# @abstract(Returns a register for use as scratch register)
- This routine returns a register which can be used by
- the code generator as a scratch register. Since
- scratch_registers are scarce resources, the register
- should be freed by calling @link(get_scratch_reg) as
- soon as it is no longer required.
- }
- function get_scratch_reg(list : taasmoutput) : tregister;
- {# @abstract(Releases a scratch register)
-
- Releases a scratch register.
- This routine is used to free a register which
- was previously allocated using @link(get_scratch_reg).
- }
- 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 }
-
- {# Pass a parameter, which is located in a register, to a routine.
-
- This routine should push/send the parameter to the routine, as
- required by the specific processor ABI. This must be overriden for
- each CPU target.
-
- @param(size size of the operand in the register)
- @param(r register source of the operand)
- @param(nr parameter number (starting from one) of routine (from left to right))
- }
- procedure a_param_reg(list : taasmoutput;size : tcgsize;r : tregister;nr : longint);virtual; abstract;
- {# Pass a parameter, which is a constant, to a routine.
-
- A generic version is provided.
-
- @param(size size of the operand in constant)
- @param(a value of constant to send)
- @param(nr parameter number (starting from one) of routine (from left to right))
- }
- procedure a_param_const(list : taasmoutput;size : tcgsize;a : aword;nr : longint);virtual;
- {# Pass the value of a parameter, which is located in memory, to a routine.
-
- A generic version is provided.
-
- @param(size size of the operand in constant)
- @param(r Memory reference of value to send)
- @param(nr parameter number (starting from one) of routine (from left to right))
- }
- procedure a_param_ref(list : taasmoutput;size : tcgsize;const r : treference;nr : longint);virtual;
- {# Pass the value of a parameter, which can be located either in a register or memory location,
- to a routine.
-
- A generic version is provided.
-
- @param(l location of the operand to send)
- @param(nr parameter number (starting from one) of routine (from left to right))
- }
- procedure a_param_loc(list : taasmoutput;const l : tlocation;nr : longint);
- {# Pass the address of a reference to a routine.
-
- A generic version is provided.
-
- @param(r reference to get address from)
- @param(nr parameter number (starting from one) of routine (from left to right))
- }
- 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
- }
- {# Emits instruction to call the method specified by symbol name @var(s) with offset
- to symbol in @var(offset). This routine must be overriden for each new target cpu.
- }
- 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_const_loc(list : taasmoutput;a : aword;const loc : tlocation);
- procedure a_load_reg_ref(list : taasmoutput;size : tcgsize;register : tregister;const ref : treference);virtual; abstract;
- procedure a_load_reg_reg(list : taasmoutput;size : tcgsize;reg1,reg2 : tregister);virtual; abstract;
- procedure a_load_reg_loc(list : taasmoutput;reg : tregister;const loc: tlocation);
- procedure a_load_ref_reg(list : taasmoutput;size : tcgsize;const ref : treference;register : tregister);virtual; abstract;
- procedure a_load_loc_reg(list : taasmoutput;const loc: tlocation; reg : tregister);
- procedure a_load_loc_ref(list : taasmoutput;const loc: tlocation; const ref : treference);
- procedure a_load_sym_ofs_reg(list: taasmoutput; const sym: tasmsymbol; ofs: longint; reg: tregister);virtual; abstract;
- { fpu move instructions }
- procedure a_loadfpu_reg_reg(list: taasmoutput; reg1, reg2: tregister); virtual; abstract;
- procedure a_loadfpu_ref_reg(list: taasmoutput; size: tcgsize; const ref: treference; reg: tregister); virtual; abstract;
- procedure a_loadfpu_reg_ref(list: taasmoutput; size: tcgsize; reg: tregister; const ref: treference); virtual; abstract;
- procedure a_loadfpu_loc_reg(list: taasmoutput; const loc: tlocation; const reg: tregister);
- procedure a_loadfpu_reg_loc(list: taasmoutput; size: tcgsize; const reg: tregister; const loc: tlocation);
- { vector register move instructions }
- procedure a_loadmm_reg_reg(list: taasmoutput; reg1, reg2: tregister); virtual; abstract;
- procedure a_loadmm_ref_reg(list: taasmoutput; const ref: treference; reg: tregister); virtual; abstract;
- procedure a_loadmm_reg_ref(list: taasmoutput; reg: tregister; const ref: treference); virtual; abstract;
- { basic arithmetic operations }
- { note: for operators which require only one argument (not, neg), use }
- { the op_reg_reg, op_reg_ref 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; 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; reg: tregister; const loc: tlocation);
- procedure a_op_ref_loc(list : taasmoutput; Op: TOpCG; 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_loc_reg_label(list : taasmoutput;size : tcgsize;cmp_op : topcmp; const loc: tlocation; reg : tregister; l : tasmlabel);
- 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_loadaddr_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 }
- {# Emits instructions which should be emitted when entering
- a routine declared as @var(interrupt). The default
- behavior does nothing, should be overriden as required.
- }
- procedure g_interrupt_stackframe_entry(list : taasmoutput);virtual;
-
- {# Emits instructions which should be emitted when exiting
- a routine declared as @var(interrupt). The default
- behavior does nothing, should be overriden as required.
- }
- procedure g_interrupt_stackframe_exit(list : taasmoutput);virtual;
-
- {# Emits instructions when compilation is done in profile
- mode (this is set as a command line option). The default
- behavior does nothing, should be overriden as required.
- }
- procedure g_profilecode(list : taasmoutput);virtual;
-
- {# Emits the call to the stack checking routine of
- the runtime library. The default behavior
- does not need to be modified, as it is generic
- for all platforms.
- }
- procedure g_stackcheck(list : taasmoutput;stackframesize : longint);virtual;
- procedure g_maybe_loadself(list : taasmoutput);virtual; abstract;
- {# This should emit the opcode to copy 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.
-
- It must be overriden for each new target processor.
-
- @param(source Source reference of copy)
- @param(dest Destination reference of copy)
- @param(delsource Indicates if the source reference's resources should be freed)
- @param(loadref Is the source reference a pointer to the actual source (TRUE), is it the actual source address (FALSE))
-
- }
- procedure g_concatcopy(list : taasmoutput;const source,dest : treference;len : aword;delsource,loadref : boolean);virtual; abstract;
- {# Generates range checking code. It is to note
- that this routine does not need to be overriden,
- as it takes care of everything.
-
- @param(p Node which contains the value to check)
- @param(todef Type definition of node to range check)
- }
- procedure g_rangecheck(list: taasmoutput; const p: tnode;
- const todef: tdef); virtual;
- { generates overflow checking code for a node }
- procedure g_overflowcheck(list: taasmoutput; const p: tnode); virtual; abstract;
- { 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
- globals,globtype,options,systems,cgbase,
- verbose,types,tgobj,symdef,cga,tainst,rgobj;
- 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_param_loc(list : taasmoutput;const l:tlocation;nr : longint);
- begin
- case l.loc of
- LOC_REGISTER,
- LOC_CREGISTER :
- a_param_reg(list,l.size,l.register,nr);
- LOC_CONSTANT :
- a_param_const(list,l.size,l.value,nr);
- LOC_CREFERENCE,
- LOC_REFERENCE :
- a_param_ref(list,l.size,l.reference,nr);
- else
- internalerror(2002032211);
- end;
- end;
- procedure tcg.a_paramaddr_ref(list : taasmoutput;const r : treference;nr : longint);
- var
- hr : tregister;
- begin
- hr:=get_scratch_reg(list);
- a_loadaddr_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 : tpushedsaved; }
- 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;const loc: tlocation; reg : tregister);
- begin
- case loc.loc of
- LOC_REFERENCE,LOC_CREFERENCE:
- a_load_ref_reg(list,loc.size,loc.reference,reg);
- LOC_REGISTER,LOC_CREGISTER:
- a_load_reg_reg(list,loc.size,loc.register,reg);
- LOC_CONSTANT:
- a_load_const_reg(list,loc.size,loc.value,reg);
- else
- internalerror(200109092);
- end;
- end;
- procedure tcg.a_load_const_loc(list : taasmoutput;a : aword;const loc: tlocation);
- begin
- case loc.loc of
- LOC_REFERENCE,LOC_CREFERENCE:
- a_load_const_ref(list,loc.size,a,loc.reference);
- LOC_REGISTER,LOC_CREGISTER:
- a_load_const_reg(list,loc.size,a,loc.register);
- else
- internalerror(200203272);
- end;
- end;
- procedure tcg.a_load_reg_loc(list : taasmoutput;reg : tregister;const loc: tlocation);
- begin
- case loc.loc of
- LOC_REFERENCE,LOC_CREFERENCE:
- a_load_reg_ref(list,loc.size,reg,loc.reference);
- LOC_REGISTER,LOC_CREGISTER:
- a_load_reg_reg(list,loc.size,reg,loc.register);
- else
- internalerror(200203271);
- end;
- end;
- procedure tcg.a_load_loc_ref(list : taasmoutput;const loc: tlocation; const ref : treference);
- var
- tmpreg: tregister;
- begin
- case loc.loc of
- LOC_REFERENCE,LOC_CREFERENCE:
- begin
- {$ifdef i386}
- case loc.size of
- OS_8,OS_S8:
- tmpreg := reg32toreg8(rg.getregisterint(exprasmlist));
- 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,loc.size,loc.reference,tmpreg);
- a_load_reg_ref(list,loc.size,tmpreg,ref);
- {$ifdef i386}
- if not (loc.size in [OS_32,OS_S32]) then
- rg.ungetregister(exprasmlist,tmpreg)
- else
- {$endif i386}
- free_scratch_reg(list,tmpreg);
- end;
- LOC_REGISTER,LOC_CREGISTER:
- a_load_reg_ref(list,loc.size,loc.register,ref);
- LOC_CONSTANT:
- a_load_const_ref(list,loc.size,loc.value,ref);
- else
- internalerror(200109302);
- end;
- end;
- procedure tcg.a_loadfpu_loc_reg(list: taasmoutput; const loc: tlocation; const reg: tregister);
- begin
- case loc.loc of
- LOC_REFERENCE, LOC_CREFERENCE:
- a_loadfpu_ref_reg(list,loc.size,loc.reference,reg);
- LOC_FPUREGISTER, LOC_CFPUREGISTER:
- a_loadfpu_reg_reg(list,loc.register,reg);
- else
- internalerror(200203301);
- end;
- end;
- procedure tcg.a_loadfpu_reg_loc(list: taasmoutput; size: tcgsize; const reg: tregister; const loc: tlocation);
- begin
- case loc.loc of
- LOC_REFERENCE, LOC_CREFERENCE:
- a_loadfpu_reg_ref(list,size,reg,loc.reference);
- LOC_FPUREGISTER, LOC_CFPUREGISTER:
- a_loadfpu_reg_reg(list,reg,loc.register);
- else
- internalerror(48991);
- 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; 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_CREFERENCE:
- a_op_const_ref(list,op,loc.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; reg: tregister; const loc: tlocation);
- begin
- case loc.loc of
- LOC_REGISTER, LOC_CREGISTER:
- a_op_reg_reg(list,op,loc.size,reg,loc.register);
- LOC_REFERENCE, LOC_CREFERENCE:
- a_op_reg_ref(list,op,loc.size,reg,loc.reference);
- else
- internalerror(200109061);
- end;
- end;
- procedure tcg.a_op_ref_loc(list : taasmoutput; Op: TOpCG; const ref: TReference; const loc: tlocation);
- var
- tmpreg: tregister;
- begin
- case loc.loc of
- LOC_REGISTER,LOC_CREGISTER:
- a_op_ref_reg(list,op,loc.size,ref,loc.register);
- LOC_REFERENCE,LOC_CREFERENCE:
- begin
- tmpreg := get_scratch_reg(list);
- {$ifdef i386}
- makeregsize(tmpreg,loc.size);
- {$endif i386}
- a_load_ref_reg(list,loc.size,ref,tmpreg);
- a_op_reg_ref(list,op,loc.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_CREFERENCE:
- 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_loc_reg_label(list : taasmoutput;size : tcgsize;cmp_op : topcmp; const loc: tlocation; reg : tregister; l : tasmlabel);
- begin
- case loc.loc of
- LOC_REGISTER,
- LOC_CREGISTER:
- a_cmp_reg_reg_label(list,size,cmp_op,loc.register,reg,l);
- LOC_REFERENCE,
- LOC_CREFERENCE :
- a_cmp_ref_reg_label(list,size,cmp_op,loc.reference,reg,l);
- LOC_CONSTANT:
- a_cmp_const_reg_label(list,size,cmp_op,loc.value,reg,l);
- else
- internalerror(200203231);
- end;
- 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_CREFERENCE:
- 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 := rg.getregisterint(exprasmlist)
- 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
- rg.ungetregister(exprasmlist,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) }
- const
- {$ifdef ver1_0}
- awordsignedmax=high(longint);
- {$else}
- awordsignedmax=high(aword) div 2;
- {$endif}
- 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 > awordsignedmax) 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 > awordsignedmax then
- hto := awordsignedmax;
- end
- else
- { from is unsigned, to is signed }
- begin
- if (lfrom > awordsignedmax) 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(longint(lto and $ffffffff)),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(longint(lto and $ffffffff)),hreg);
- end;
- getlabel(neglabel);
- a_cmp_const_reg_label(list,OS_INT,OC_BE,aword(longint((hto-lto) and $ffffffff)),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.13 2002-04-07 13:22:11 carl
- + more documentation
- Revision 1.12 2002/04/07 09:12:46 carl
- + documentation
- Revision 1.11 2002/04/06 18:10:42 jonas
- * several powerpc-related additions and fixes
- Revision 1.10 2002/04/04 19:05:54 peter
- * removed unused units
- * use tlocation.size in cg.a_*loc*() routines
- Revision 1.9 2002/04/02 17:11:27 peter
- * tlocation,treference update
- * LOC_CONSTANT added for better constant handling
- * secondadd splitted in multiple routines
- * location_force_reg added for loading a location to a register
- of a specified size
- * secondassignment parses now first the right and then the left node
- (this is compatible with Kylix). This saves a lot of push/pop especially
- with string operations
- * adapted some routines to use the new cg methods
- Revision 1.8 2002/03/31 20:26:33 jonas
- + a_loadfpu_* and a_loadmm_* methods in tcg
- * register allocation is now handled by a class and is mostly processor
- independent (+rgobj.pas and i386/rgcpu.pas)
- * temp allocation is now handled by a class (+tgobj.pas, -i386\tgcpu.pas)
- * some small improvements and fixes to the optimizer
- * some register allocation fixes
- * some fpuvaroffset fixes in the unary minus node
- * push/popusedregisters is now called rg.save/restoreusedregisters and
- (for i386) uses temps instead of push/pop's when using -Op3 (that code is
- also better optimizable)
- * fixed and optimized register saving/restoring for new/dispose nodes
- * LOC_FPU locations now also require their "register" field to be set to
- R_ST, not R_ST0 (the latter is used for LOC_CFPUREGISTER locations only)
- - list field removed of the tnode class because it's not used currently
- and can cause hard-to-find bugs
- 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
- }
|