diff --git a/compiler/cgi386.pas b/compiler/cgi386.pas index 3bf222f2a8..6bbe52991f 100644 --- a/compiler/cgi386.pas +++ b/compiler/cgi386.pas @@ -58,20 +58,18 @@ implementation uses verbose,cobjects,systems,globals,files, - symtable,types,aasm,i386, - pass_1,hcodegen,tgeni386,cgai386 + symtable,types,aasm, + pass_1,hcodegen {$ifdef GDB} ,gdb {$endif} -{$ifdef TP} - ,cgi3862 +{$ifdef i386} + ,i386,tgeni386,cgai386 + ,cg386con,cg386mat,cg386cnv,cg386set,cg386add + ,cg386mem,cg386cal,cg386ld,cg386flw {$endif} - ,cg386con,cg386mat,cg386cnv ; - const - never_copy_const_param : boolean = false; - {$ifdef test_dest_loc} procedure mov_reg_to_dest(p : ptree; s : topsize; reg : tregister); @@ -95,8 +93,6 @@ implementation {$endif test_dest_loc} - const - bytes2Sxx:array[1..4] of Topsize=(S_B,S_W,S_NO,S_L); procedure message(const t : tmsgconst); @@ -154,9 +150,18 @@ implementation end; end; +{***************************************************************************** + SecondPass +*****************************************************************************} + type secondpassproc = procedure(var p : ptree); + procedure secondnothing(var p : ptree); + begin + end; + + procedure seconderror(var p : ptree); begin @@ -164,4610 +169,49 @@ implementation codegenerror:=true; end; - var - { this is for open arrays and strings } - { but be careful, this data is in the } - { generated code destroyed quick, and also } - { the next call of secondload destroys this } - { data } - { So be careful using the informations } - { provided by this variables } - highframepointer : tregister; - highoffset : longint; - -{$ifndef TP} - -{$I cgi386ad.inc} - -{$endif TP} - - procedure secondload(var p : ptree); - - var - hregister : tregister; - symtabletype : tsymtabletype; - i : longint; - hp : preference; - - begin - simple_loadn:=true; - reset_reference(p^.location.reference); - case p^.symtableentry^.typ of - { this is only for toasm and toaddr } - absolutesym : - begin - stringdispose(p^.location.reference.symbol); - if (pabsolutesym(p^.symtableentry)^.abstyp=toaddr) then - begin - if pabsolutesym(p^.symtableentry)^.absseg then - p^.location.reference.segment:=R_FS; - p^.location.reference.offset:=pabsolutesym(p^.symtableentry)^.address; - end - else - p^.location.reference.symbol:=stringdup(p^.symtableentry^.mangledname); - maybe_concat_external(p^.symtableentry^.owner,p^.symtableentry^.mangledname); - end; - varsym : - begin - hregister:=R_NO; - symtabletype:=p^.symtable^.symtabletype; - { in case it is a register variable: } - if pvarsym(p^.symtableentry)^.reg<>R_NO then - begin - p^.location.loc:=LOC_CREGISTER; - p^.location.register:=pvarsym(p^.symtableentry)^.reg; - unused:=unused-[pvarsym(p^.symtableentry)^.reg]; - end - else - begin - { first handle local and temporary variables } - if (symtabletype in [parasymtable,inlinelocalsymtable, - inlineparasymtable,localsymtable]) then - begin - p^.location.reference.base:=procinfo.framepointer; - p^.location.reference.offset:=pvarsym(p^.symtableentry)^.address; - if (symtabletype=localsymtable) or (symtabletype=inlinelocalsymtable) then - p^.location.reference.offset:=-p^.location.reference.offset; - if (symtabletype=parasymtable) or (symtabletype=inlineparasymtable) then - inc(p^.location.reference.offset,p^.symtable^.call_offset); - if (lexlevel>(p^.symtable^.symtablelevel)) then - begin - hregister:=getregister32; - - { make a reference } - hp:=new_reference(procinfo.framepointer, - procinfo.framepointer_offset); - - - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,hp,hregister))); - - simple_loadn:=false; - i:=lexlevel-1; - while i>(p^.symtable^.symtablelevel) do - begin - { make a reference } - hp:=new_reference(hregister,8); - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,hp,hregister))); - dec(i); - end; - p^.location.reference.base:=hregister; - end; - end - else - case symtabletype of - unitsymtable,globalsymtable, - staticsymtable : begin - stringdispose(p^.location.reference.symbol); - p^.location.reference.symbol:=stringdup(p^.symtableentry^.mangledname); - if symtabletype=unitsymtable then - concat_external(p^.symtableentry^.mangledname,EXT_NEAR); - end; - objectsymtable : begin - if (pvarsym(p^.symtableentry)^.properties and sp_static)<>0 then - begin - stringdispose(p^.location.reference.symbol); - p^.location.reference.symbol:=stringdup(p^.symtableentry^.mangledname); - if p^.symtable^.defowner^.owner^.symtabletype=unitsymtable then - concat_external(p^.symtableentry^.mangledname,EXT_NEAR); - end - else - begin - p^.location.reference.base:=R_ESI; - p^.location.reference.offset:=pvarsym(p^.symtableentry)^.address; - end; - end; - withsymtable: - begin - hregister:=getregister32; - p^.location.reference.base:=hregister; - { make a reference } - { symtable datasize field - contains the offset of the temp - stored } - hp:=new_reference(procinfo.framepointer, - p^.symtable^.datasize); - - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,hp,hregister))); - - p^.location.reference.offset:= - pvarsym(p^.symtableentry)^.address; - end; - end; - { in case call by reference, then calculate: } - if (pvarsym(p^.symtableentry)^.varspez=vs_var) or - ((pvarsym(p^.symtableentry)^.varspez=vs_const) and - dont_copy_const_param(pvarsym(p^.symtableentry)^.definition)) or - { call by value open arrays are also indirect addressed } - is_open_array(pvarsym(p^.symtableentry)^.definition) then - begin - simple_loadn:=false; - if hregister=R_NO then - hregister:=getregister32; - if (p^.location.reference.base=procinfo.framepointer) then - begin - highframepointer:=p^.location.reference.base; - highoffset:=p^.location.reference.offset; - end - else - begin - highframepointer:=R_EDI; - highoffset:=p^.location.reference.offset; - exprasmlist^.concat(new(pai386,op_reg_reg(A_MOV,S_L, - p^.location.reference.base,R_EDI))); - end; - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(p^.location.reference), - hregister))); - clear_reference(p^.location.reference); - p^.location.reference.base:=hregister; - end; - { - if (pvarsym(p^.symtableentry)^.definition^.deftype=objectdef) and - ((pobjectdef(pvarsym(p^.symtableentry)^.definition)^.options and oois_class)<>0) then - begin - simple_loadn:=false; - if hregister=R_NO then - hregister:=getregister32; - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(p^.location.reference), - hregister))); - clear_reference(p^.location.reference); - p^.location.reference.base:=hregister; - end; - } - end; - end; - procsym: - begin - {!!!!! Be aware, work on virtual methods too } - stringdispose(p^.location.reference.symbol); - p^.location.reference.symbol:= - stringdup(pprocsym(p^.symtableentry)^.definition^.mangledname); - maybe_concat_external(p^.symtable,p^.symtableentry^.mangledname); - end; - typedconstsym : - begin - stringdispose(p^.location.reference.symbol); - p^.location.reference.symbol:=stringdup(p^.symtableentry^.mangledname); - maybe_concat_external(p^.symtable,p^.symtableentry^.mangledname); - end; - else internalerror(4); - end; - end; - - procedure secondassignment(var p : ptree); - - var - opsize : topsize; - otlabel,hlabel,oflabel : plabel; - hregister : tregister; - loc : tloc; - - begin - otlabel:=truelabel; - oflabel:=falselabel; - getlabel(truelabel); - getlabel(falselabel); - { calculate left sides } - if not(p^.concat_string) then - secondpass(p^.left); - - if codegenerror then - exit; - - case p^.left^.location.loc of - LOC_REFERENCE : begin - { in case left operator uses to register } - { but to few are free then LEA } - if (p^.left^.location.reference.base<>R_NO) and - (p^.left^.location.reference.index<>R_NO) and - (usablereg32LOC_REFERENCE then - internalerror(10010) - else - floatstore(pfloatdef(p^.left^.resulttype)^.typ, - p^.left^.location.reference); - end; - LOC_JUMP : begin - getlabel(hlabel); - emitl(A_LABEL,truelabel); - if loc=LOC_CREGISTER then - exprasmlist^.concat(new(pai386,op_const_reg(A_MOV,S_B, - 1,p^.left^.location.register))) - else - exprasmlist^.concat(new(pai386,op_const_ref(A_MOV,S_B, - 1,newreference(p^.left^.location.reference)))); - {exprasmlist^.concat(new(pai386,op_const_loc(A_MOV,S_B, - 1,p^.left^.location)));} - emitl(A_JMP,hlabel); - emitl(A_LABEL,falselabel); - if loc=LOC_CREGISTER then - exprasmlist^.concat(new(pai386,op_reg_reg(A_XOR,S_B, - p^.left^.location.register, - p^.left^.location.register))) - else - exprasmlist^.concat(new(pai386,op_const_ref(A_MOV,S_B, - 0,newreference(p^.left^.location.reference)))); - emitl(A_LABEL,hlabel); - end; - LOC_FLAGS : begin - if loc=LOC_CREGISTER then - exprasmlist^.concat(new(pai386,op_reg(flag_2_set[p^.right^.location.resflags],S_B, - p^.left^.location.register))) - else - exprasmlist^.concat(new(pai386,op_ref(flag_2_set[p^.right^.location.resflags],S_B, - newreference(p^.left^.location.reference)))); - end; - end; - truelabel:=otlabel; - falselabel:=oflabel; - end; - - procedure secondaddr(var p : ptree); - - begin - secondpass(p^.left); - p^.location.loc:=LOC_REGISTER; - del_reference(p^.left^.location.reference); - p^.location.register:=getregister32; - {@ on a procvar means returning an address to the procedure that - is stored in it.} - { yes but p^.left^.symtableentry can be nil - for example on @self !! } - { symtableentry can be also invalid, if left is no tree node } - if (p^.left^.treetype=loadn) and - assigned(p^.left^.symtableentry) and - (p^.left^.symtableentry^.typ=varsym) and - (pvarsym(p^.left^.symtableentry)^.definition^.deftype=procvardef) then - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, - newreference(p^.left^.location.reference), - p^.location.register))) - else - exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L, - newreference(p^.left^.location.reference), - p^.location.register))); - { for use of other segments } - if p^.left^.location.reference.segment<>R_DEFAULT_SEG then - p^.location.segment:=p^.left^.location.reference.segment; - end; - - procedure seconddoubleaddr(var p : ptree); - - begin - secondpass(p^.left); - p^.location.loc:=LOC_REGISTER; - del_reference(p^.left^.location.reference); - p^.location.register:=getregister32; - exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L, - newreference(p^.left^.location.reference), - p^.location.register))); - end; - - procedure secondnot(var p : ptree); - - const - flagsinvers : array[F_E..F_BE] of tresflags = - (F_NE,F_E,F_LE,F_GE,F_L,F_G,F_NC,F_C, - F_A,F_AE,F_B,F_BE); - - var - hl : plabel; - opsize : topsize; - begin - if (p^.resulttype^.deftype=orddef) and - (porddef(p^.resulttype)^.typ in [bool8bit,bool16bit,bool32bit]) then - begin - case porddef(p^.resulttype)^.typ of - bool8bit : opsize:=S_B; - bool16bit : opsize:=S_W; - bool32bit : opsize:=S_L; - end; - case p^.location.loc of - LOC_JUMP : begin - hl:=truelabel; - truelabel:=falselabel; - falselabel:=hl; - secondpass(p^.left); - maketojumpbool(p^.left); - hl:=truelabel; - truelabel:=falselabel; - falselabel:=hl; - end; - LOC_FLAGS : begin - secondpass(p^.left); - p^.location.resflags:=flagsinvers[p^.left^.location.resflags]; - end; - LOC_REGISTER : begin - secondpass(p^.left); - p^.location.register:=p^.left^.location.register; - exprasmlist^.concat(new(pai386,op_const_reg(A_XOR,opsize,1,p^.location.register))); - end; - LOC_CREGISTER : begin - secondpass(p^.left); - p^.location.loc:=LOC_REGISTER; - case porddef(p^.resulttype)^.typ of - bool8bit : p^.location.register:=reg32toreg8(getregister32); - bool16bit : p^.location.register:=reg32toreg16(getregister32); - bool32bit : p^.location.register:=getregister32; - end; - emit_reg_reg(A_MOV,opsize,p^.left^.location.register,p^.location.register); - exprasmlist^.concat(new(pai386,op_const_reg(A_XOR,opsize,1,p^.location.register))); - end; - LOC_REFERENCE, - LOC_MEM : begin - secondpass(p^.left); - del_reference(p^.left^.location.reference); - p^.location.loc:=LOC_REGISTER; - case porddef(p^.resulttype)^.typ of - bool8bit : p^.location.register:=reg32toreg8(getregister32); - bool16bit : p^.location.register:=reg32toreg16(getregister32); - bool32bit : p^.location.register:=getregister32; - end; - if p^.left^.location.loc=LOC_CREGISTER then - emit_reg_reg(A_MOV,opsize,p^.left^.location.register,p^.location.register) - else - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,opsize, - newreference(p^.left^.location.reference),p^.location.register))); - exprasmlist^.concat(new(pai386,op_const_reg(A_XOR,opsize,1,p^.location.register))); - end; - end; - end -{$ifdef SUPPORT_MMX} - else if (cs_mmx in aktswitches) and is_mmx_able_array(p^.left^.resulttype) then - begin - secondpass(p^.left); - p^.location.loc:=LOC_MMXREGISTER; - { prepare EDI } - exprasmlist^.concat(new(pai386,op_const_reg(A_MOV,S_L,$ffffffff,R_EDI))); - { load operand } - case p^.left^.location.loc of - LOC_MMXREGISTER: - p^.location:=p^.left^.location; - LOC_CMMXREGISTER: - begin - p^.location.register:=getregistermmx; - emit_reg_reg(A_MOVQ,S_NO,p^.left^.location.register, - p^.location.register); - end; - LOC_REFERENCE,LOC_MEM: - begin - del_reference(p^.left^.location.reference); - p^.location.register:=getregistermmx; - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVQ,S_NO, - newreference(p^.left^.location.reference), - p^.location.register))); - end; - end; - { load mask } - emit_reg_reg(A_MOV,S_D,R_EDI,R_MM7); - { lower 32 bit } - emit_reg_reg(A_PXOR,S_D,R_MM7,p^.location.register); - { shift mask } - exprasmlist^.concat(new(pai386,op_const_reg(A_PSLLQ,S_NO, - 32,R_MM7))); - { higher 32 bit } - emit_reg_reg(A_PXOR,S_D,R_MM7,p^.location.register); - end -{$endif SUPPORT_MMX} - else - begin - secondpass(p^.left); - p^.location.loc:=LOC_REGISTER; - - case p^.left^.location.loc of - LOC_REGISTER : begin - p^.location.register:=p^.left^.location.register; - exprasmlist^.concat(new(pai386,op_reg(A_NOT,S_L,p^.location.register))); - end; - LOC_CREGISTER : begin - p^.location.register:=getregister32; - emit_reg_reg(A_MOV,S_L,p^.left^.location.register, - p^.location.register); - exprasmlist^.concat(new(pai386,op_reg(A_NOT,S_L,p^.location.register))); - end; - LOC_REFERENCE,LOC_MEM : - begin - del_reference(p^.left^.location.reference); - p^.location.register:=getregister32; - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, - newreference(p^.left^.location.reference), - p^.location.register))); - exprasmlist^.concat(new(pai386,op_reg(A_NOT,S_L,p^.location.register))); - end; - end; - {if p^.left^.location.loc=loc_register then - p^.location.register:=p^.left^.location.register - else - begin - del_locref(p^.left^.location); - p^.location.register:=getregister32; - exprasmlist^.concat(new(pai386,op_loc_reg(A_MOV,S_L, - p^.left^.location, - p^.location.register))); - end; - exprasmlist^.concat(new(pai386,op_reg(A_NOT,S_L,p^.location.register)));} - - end; - end; - - procedure secondnothing(var p : ptree); - - begin - end; - - procedure secondderef(var p : ptree); - - var - hr : tregister; - - begin - secondpass(p^.left); - clear_reference(p^.location.reference); - case p^.left^.location.loc of - LOC_REGISTER: - p^.location.reference.base:=p^.left^.location.register; - LOC_CREGISTER: - begin - { ... and reserve one for the pointer } - hr:=getregister32; - emit_reg_reg(A_MOV,S_L,p^.left^.location.register,hr); - p^.location.reference.base:=hr; - end; - else - begin - { free register } - del_reference(p^.left^.location.reference); - - { ...and reserve one for the pointer } - hr:=getregister32; - exprasmlist^.concat(new(pai386,op_ref_reg( - A_MOV,S_L,newreference(p^.left^.location.reference), - hr))); - p^.location.reference.base:=hr; - end; - end; - end; - - procedure secondvecn(var p : ptree); - - var - pushed : boolean; - ind,hr : tregister; - _p : ptree; - - function get_mul_size:longint; - begin - if p^.memindex then - get_mul_size:=1 - else - get_mul_size:=p^.resulttype^.size; - end; - - - procedure calc_emit_mul; - - var - l1,l2 : longint; - - begin - l1:=get_mul_size; - case l1 of - 1,2,4,8 : p^.location.reference.scalefactor:=l1; - else - begin - if ispowerof2(l1,l2) then - exprasmlist^.concat(new(pai386,op_const_reg(A_SHL,S_L,l2,ind))) - else - exprasmlist^.concat(new(pai386,op_const_reg(A_IMUL,S_L,l1,ind))); - end; - end; - end; - - var - extraoffset : longint; - t : ptree; - hp : preference; - tai:Pai386; - - begin - secondpass(p^.left); - set_location(p^.location,p^.left^.location); - - { in ansistrings S[1] is pchar(S)[0] !! } - if is_ansistring(p^.left^.resulttype) then - dec(p^.location.reference.offset); - { offset can only differ from 0 if arraydef } - if p^.left^.resulttype^.deftype=arraydef then - dec(p^.location.reference.offset, - get_mul_size*parraydef(p^.left^.resulttype)^.lowrange); - if p^.right^.treetype=ordconstn then - begin - { offset can only differ from 0 if arraydef } - if (p^.left^.resulttype^.deftype=arraydef) then - begin - if not(is_open_array(p^.left^.resulttype)) then - begin - if (p^.right^.value>parraydef(p^.left^.resulttype)^.highrange) or - (p^.right^.valueLOC_REFERENCE) and - (p^.location.loc<>LOC_MEM) then - Message(cg_e_illegal_expression); - pushed:=maybe_push(p^.right^.registers32,p); - secondpass(p^.right); - if pushed then restore(p); - case p^.right^.location.loc of - LOC_REGISTER: - begin - ind:=p^.right^.location.register; - case p^.right^.resulttype^.size of - 1: - begin - hr:=reg8toreg32(ind); - emit_reg_reg(A_MOVZX,S_BL,ind,hr); - ind:=hr; - end; - 2: - begin - hr:=reg16toreg32(ind); - emit_reg_reg(A_MOVZX,S_WL,ind,hr); - ind:=hr; - end; - end; - end; - LOC_CREGISTER: - begin - ind:=getregister32; - case p^.right^.resulttype^.size of - 1: - emit_reg_reg(A_MOVZX,S_BL,p^.right^.location.register,ind); - 2: - emit_reg_reg(A_MOVZX,S_WL,p^.right^.location.register,ind); - 4: - emit_reg_reg(A_MOV,S_L,p^.right^.location.register,ind); - end; - end; - LOC_FLAGS: - begin - ind:=getregister32; - exprasmlist^.concat(new(pai386,op_reg(flag_2_set[p^.right^.location.resflags],S_B,reg32toreg8(ind)))); - emit_reg_reg(A_MOVZX,S_BL,reg32toreg8(ind),ind); - end - else - begin - del_reference(p^.right^.location.reference); - ind:=getregister32; - { Booleans are stored in an 8 bit memory location, so - the use of MOVL is not correct } - case p^.right^.resulttype^.size of - 1: - tai:=new(pai386,op_ref_reg(A_MOVZX,S_BL,newreference(p^.right^.location.reference),ind)); - 2: - tai:=new(Pai386,op_ref_reg(A_MOVZX,S_WL,newreference(p^.right^.location.reference),ind)); - 4: - tai:=new(Pai386,op_ref_reg(A_MOV,S_L,newreference(p^.right^.location.reference),ind)); - end; - exprasmlist^.concat(tai); - end; - end; - { produce possible range check code: } - if cs_rangechecking in aktswitches then - begin - if p^.left^.resulttype^.deftype=arraydef then - begin - hp:=new_reference(R_NO,0); - parraydef(p^.left^.resulttype)^.genrangecheck; - hp^.symbol:=stringdup('R_'+tostr(parraydef(p^.left^.resulttype)^.rangenr)); - exprasmlist^.concat(new(pai386,op_reg_ref(A_BOUND,S_L,ind,hp))); - end; - end; - if p^.location.reference.index=R_NO then - begin - p^.location.reference.index:=ind; - calc_emit_mul; - end - else - begin - if p^.location.reference.base=R_NO then - begin - case p^.location.reference.scalefactor of - 2 : exprasmlist^.concat(new(pai386,op_const_reg(A_SHL,S_L,1,p^.location.reference.index))); - 4 : exprasmlist^.concat(new(pai386,op_const_reg(A_SHL,S_L,2,p^.location.reference.index))); - 8 : exprasmlist^.concat(new(pai386,op_const_reg(A_SHL,S_L,3,p^.location.reference.index))); - end; - calc_emit_mul; - p^.location.reference.base:=p^.location.reference.index; - p^.location.reference.index:=ind; - end - else - begin - exprasmlist^.concat(new(pai386,op_ref_reg( - A_LEA,S_L,newreference(p^.location.reference), - p^.location.reference.index))); - ungetregister32(p^.location.reference.base); - { the symbol offset is loaded, } - { so release the symbol name and set symbol } - { to nil } - stringdispose(p^.location.reference.symbol); - p^.location.reference.offset:=0; - calc_emit_mul; - p^.location.reference.base:=p^.location.reference.index; - p^.location.reference.index:=ind; - end; - end; - if p^.memseg then - p^.location.reference.segment:=R_FS; - end; - end; - - - - - { save the size of pushed parameter } - var - pushedparasize : longint; - - procedure secondcallparan(var p : ptree;defcoll : pdefcoll; - push_from_left_to_right : boolean - ;inlined : boolean; - para_offset : longint - ); - - procedure maybe_push_open_array_high; - - var - r : preference; - - begin - { open array ? } - { defcoll^.data can be nil for read/write } - if assigned(defcoll^.data) and - is_open_array(defcoll^.data) then - begin - inc(pushedparasize,4); - { push high } - if is_open_array(p^.left^.resulttype) then - begin - r:=new_reference(highframepointer,highoffset+4); - if inlined then - begin - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,r,R_EDI))); - r:=new_reference(procinfo.framepointer,para_offset-pushedparasize); - exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L,R_EDI,r))); - end - else - exprasmlist^.concat(new(pai386,op_ref(A_PUSH,S_L,r))); - end - else - if inlined then - begin - r:=new_reference(procinfo.framepointer,para_offset-pushedparasize); - exprasmlist^.concat(new(pai386,op_const_ref(A_MOV,S_L, - parraydef(p^.left^.resulttype)^.highrange- - parraydef(p^.left^.resulttype)^.lowrange,r))); - end - else - push_int(parraydef(p^.left^.resulttype)^.highrange- - parraydef(p^.left^.resulttype)^.lowrange); - end; - end; - - var - size : longint; - stackref : treference; - otlabel,hlabel,oflabel : plabel; - - - { temporary variables: } - tempdeftype : tdeftype; - tempreference : treference; - r : preference; - s : topsize; - op : tasmop; - - begin - { push from left to right if specified } - if push_from_left_to_right and assigned(p^.right) then - secondcallparan(p^.right,defcoll^.next,push_from_left_to_right - ,inlined,para_offset - ); - otlabel:=truelabel; - oflabel:=falselabel; - getlabel(truelabel); - getlabel(falselabel); - secondpass(p^.left); - { in codegen.handleread.. defcoll^.data is set to nil } - if assigned(defcoll^.data) and - (defcoll^.data^.deftype=formaldef) then - begin - { allow @var } - inc(pushedparasize,4); - if p^.left^.treetype=addrn then - begin - { always a register } - if inlined then - begin - r:=new_reference(procinfo.framepointer,para_offset-pushedparasize); - exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L, - p^.left^.location.register,r))); - end - else - exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,p^.left^.location.register))); - ungetregister32(p^.left^.location.register); - end - else - begin - if (p^.left^.location.loc<>LOC_REFERENCE) and - (p^.left^.location.loc<>LOC_MEM) then - Message(sym_e_type_mismatch) - else - begin - if inlined then - begin - exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L, - newreference(p^.left^.location.reference),R_EDI))); - r:=new_reference(procinfo.framepointer,para_offset-pushedparasize); - exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L, - R_EDI,r))); - end - else - emitpushreferenceaddr(p^.left^.location.reference); - del_reference(p^.left^.location.reference); - end; - end; - end - { handle call by reference parameter } - else if (defcoll^.paratyp=vs_var) then - begin - if (p^.left^.location.loc<>LOC_REFERENCE) then - Message(cg_e_var_must_be_reference); - maybe_push_open_array_high; - inc(pushedparasize,4); - if inlined then - begin - exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L, - newreference(p^.left^.location.reference),R_EDI))); - r:=new_reference(procinfo.framepointer,para_offset-pushedparasize); - exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L, - R_EDI,r))); - end - else - emitpushreferenceaddr(p^.left^.location.reference); - del_reference(p^.left^.location.reference); - end - else - begin - tempdeftype:=p^.resulttype^.deftype; - if tempdeftype=filedef then - Message(cg_e_file_must_call_by_reference); - if (defcoll^.paratyp=vs_const) and - dont_copy_const_param(p^.resulttype) then - begin - maybe_push_open_array_high; - inc(pushedparasize,4); - if inlined then - begin - exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L, - newreference(p^.left^.location.reference),R_EDI))); - r:=new_reference(procinfo.framepointer,para_offset-pushedparasize); - exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L, - R_EDI,r))); - end - else - emitpushreferenceaddr(p^.left^.location.reference); - del_reference(p^.left^.location.reference); - end - else - case p^.left^.location.loc of - LOC_REGISTER, - LOC_CREGISTER: - begin - case p^.left^.location.register of - R_EAX,R_EBX,R_ECX,R_EDX,R_ESI, - R_EDI,R_ESP,R_EBP : - begin - inc(pushedparasize,4); - if inlined then - begin - r:=new_reference(procinfo.framepointer,para_offset-pushedparasize); - exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L, - p^.left^.location.register,r))); - end - else - exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,p^.left^.location.register))); - ungetregister32(p^.left^.location.register); - end; - R_AX,R_BX,R_CX,R_DX,R_SI,R_DI: - begin - inc(pushedparasize,2); - if inlined then - begin - r:=new_reference(procinfo.framepointer,para_offset-pushedparasize); - exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_W, - p^.left^.location.register,r))); - end - else - exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_W,p^.left^.location.register))); - ungetregister32(reg16toreg32(p^.left^.location.register)); - end; - R_AL,R_BL,R_CL,R_DL: - begin - inc(pushedparasize,2); - { we must push always 16 bit } - if inlined then - begin - r:=new_reference(procinfo.framepointer,para_offset-pushedparasize); - exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L, - reg8toreg16(p^.left^.location.register),r))); - end - else - exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_W, - reg8toreg16(p^.left^.location.register)))); - ungetregister32(reg8toreg32(p^.left^.location.register)); - end; - end; - end; - LOC_FPU: - begin - size:=pfloatdef(p^.left^.resulttype)^.size; - inc(pushedparasize,size); { must be before for inlined } - if not inlined then - exprasmlist^.concat(new(pai386,op_const_reg(A_SUB,S_L,size,R_ESP))); - r:=new_reference(R_ESP,0); - floatstoreops(pfloatdef(p^.left^.resulttype)^.typ,op,s); - { this is the easiest case for inlined !! } - if inlined then - begin - r^.base:=procinfo.framepointer; - r^.offset:=para_offset-pushedparasize; - end; - exprasmlist^.concat(new(pai386,op_ref(op,s,r))); - end; - LOC_REFERENCE,LOC_MEM: - begin - tempreference:=p^.left^.location.reference; - del_reference(p^.left^.location.reference); - case p^.resulttype^.deftype of - orddef : - begin - case porddef(p^.resulttype)^.typ of - s32bit,u32bit,bool32bit : - begin - inc(pushedparasize,4); - if inlined then - begin - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, - newreference(tempreference),R_EDI))); - r:=new_reference(procinfo.framepointer,para_offset-pushedparasize); - exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L, - R_EDI,r))); - end - else - emit_push_mem(tempreference); - end; - s8bit,u8bit,uchar,bool8bit,bool16bit,s16bit,u16bit : - begin - inc(pushedparasize,2); - if inlined then - begin - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_W, - newreference(tempreference),R_DI))); - r:=new_reference(procinfo.framepointer,para_offset-pushedparasize); - exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_W, - R_DI,r))); - end - else - exprasmlist^.concat(new(pai386,op_ref(A_PUSH,S_W, - newreference(tempreference)))); - end; - end; - end; - floatdef : - begin - case pfloatdef(p^.resulttype)^.typ of - f32bit, - s32real : - begin - inc(pushedparasize,4); - if inlined then - begin - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, - newreference(tempreference),R_EDI))); - r:=new_reference(procinfo.framepointer,para_offset-pushedparasize); - exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L, - R_EDI,r))); - end - else - emit_push_mem(tempreference); - end; - s64real, - s64bit : begin - inc(pushedparasize,4); - inc(tempreference.offset,4); - if inlined then - begin - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, - newreference(tempreference),R_EDI))); - r:=new_reference(procinfo.framepointer,para_offset-pushedparasize); - exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L, - R_EDI,r))); - end - else - emit_push_mem(tempreference); - inc(pushedparasize,4); - dec(tempreference.offset,4); - if inlined then - begin - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, - newreference(tempreference),R_EDI))); - r:=new_reference(procinfo.framepointer,para_offset-pushedparasize); - exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L, - R_EDI,r))); - end - else - emit_push_mem(tempreference); - end; - s80real : begin - inc(pushedparasize,4); - inc(tempreference.offset,6); - if inlined then - begin - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, - newreference(tempreference),R_EDI))); - r:=new_reference(procinfo.framepointer,para_offset-pushedparasize); - exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L, - R_EDI,r))); - end - else - emit_push_mem(tempreference); - dec(tempreference.offset,4); - inc(pushedparasize,4); - if inlined then - begin - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, - newreference(tempreference),R_EDI))); - r:=new_reference(procinfo.framepointer,para_offset-pushedparasize); - exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L, - R_EDI,r))); - end - else - emit_push_mem(tempreference); - dec(tempreference.offset,2); - inc(pushedparasize,2); - if inlined then - begin - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_W, - newreference(tempreference),R_DI))); - r:=new_reference(procinfo.framepointer,para_offset-pushedparasize); - exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_W, - R_DI,r))); - end - else - exprasmlist^.concat(new(pai386,op_ref(A_PUSH,S_W, - newreference(tempreference)))); - end; - end; - end; - pointerdef,procvardef, - enumdef,classrefdef: - begin - inc(pushedparasize,4); - if inlined then - begin - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, - newreference(tempreference),R_EDI))); - r:=new_reference(procinfo.framepointer,para_offset-pushedparasize); - exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L, - R_EDI,r))); - end - else - emit_push_mem(tempreference); - end; - arraydef,recorddef,stringdef,setdef,objectdef : - begin - { small set ? } - if ((p^.resulttype^.deftype=setdef) and - (psetdef(p^.resulttype)^.settype=smallset)) then - begin - inc(pushedparasize,4); - if inlined then - begin - r:=new_reference(procinfo.framepointer,para_offset-pushedparasize); - concatcopy(tempreference,r^,4,false); - end - else - emit_push_mem(tempreference); - end - { call by value open array ? } - else if (p^.resulttype^.deftype=arraydef) and - assigned(defcoll^.data) and - is_open_array(defcoll^.data) then - begin - { first, push high } - maybe_push_open_array_high; - inc(pushedparasize,4); - if inlined then - begin - exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L, - newreference(p^.left^.location.reference),R_EDI))); - r:=new_reference(procinfo.framepointer,para_offset-pushedparasize); - exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L, - R_EDI,r))); - end - else - emitpushreferenceaddr(p^.left^.location.reference); - end - else - begin - - size:=p^.resulttype^.size; - - { Alignment } - { - if (size>=4) and ((size and 3)<>0) then - inc(size,4-(size and 3)) - else if (size>=2) and ((size and 1)<>0) then - inc(size,2-(size and 1)) - else - if size=1 then size:=2; - } - { create stack space } - if not inlined then - exprasmlist^.concat(new(pai386,op_const_reg(A_SUB,S_L,size,R_ESP))); - inc(pushedparasize,size); - { create stack reference } - stackref.symbol := nil; - if not inlined then - begin - clear_reference(stackref); - stackref.base:=R_ESP; - end - else - begin - clear_reference(stackref); - stackref.base:=procinfo.framepointer; - stackref.offset:=para_offset-pushedparasize; - end; - { produce copy } - if p^.resulttype^.deftype=stringdef then - begin - copystring(stackref,p^.left^.location.reference, - pstringdef(p^.resulttype)^.len); - end - else - begin - concatcopy(p^.left^.location.reference, - stackref,p^.resulttype^.size,true); - end; - end; - end; - else Message(cg_e_illegal_expression); - end; - end; - LOC_JUMP: - begin - getlabel(hlabel); - inc(pushedparasize,2); - emitl(A_LABEL,truelabel); - if inlined then - begin - r:=new_reference(procinfo.framepointer,para_offset-pushedparasize); - exprasmlist^.concat(new(pai386,op_const_ref(A_MOV,S_W, - 1,r))); - end - else - exprasmlist^.concat(new(pai386,op_const(A_PUSH,S_W,1))); - emitl(A_JMP,hlabel); - emitl(A_LABEL,falselabel); - if inlined then - begin - r:=new_reference(procinfo.framepointer,para_offset-pushedparasize); - exprasmlist^.concat(new(pai386,op_const_ref(A_MOV,S_W, - 0,r))); - end - else - exprasmlist^.concat(new(pai386,op_const(A_PUSH,S_W,0))); - emitl(A_LABEL,hlabel); - end; - LOC_FLAGS: - begin - if not(R_EAX in unused) then - exprasmlist^.concat(new(pai386,op_reg_reg(A_MOV,S_L,R_EAX,R_EDI))); - - { clear full EAX is faster } - { but dont you set the equal flag ? } - {exprasmlist^.concat(new(pai386,op_reg_reg(A_XOR,S_L,R_EAX,R_EAX)));} - exprasmlist^.concat(new(pai386,op_reg(flag_2_set[p^.left^.location.resflags],S_B, - R_AL))); - exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVZX,S_BW,R_AL,R_AX))); - {exprasmlist^.concat(new(pai386,op_reg_reg(A_XOR,S_L,R_EAX,R_EAX)));} - inc(pushedparasize,2); - if inlined then - begin - r:=new_reference(procinfo.framepointer,para_offset-pushedparasize); - exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_W, - R_AX,r))); - end - else - exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_W,R_AX))); - { this is also false !!! - if not(R_EAX in unused) then - exprasmlist^.concat(new(pai386,op_reg_reg(A_MOV,S_L,R_EAX,R_EDI)));} - if not(R_EAX in unused) then - exprasmlist^.concat(new(pai386,op_reg_reg(A_MOV,S_L,R_EDI,R_EAX))); - end; -{$ifdef SUPPORT_MMX} - LOC_MMXREGISTER, - LOC_CMMXREGISTER: - begin - inc(pushedparasize,8); { was missing !!! (PM) } - exprasmlist^.concat(new(pai386,op_const_reg( - A_SUB,S_L,8,R_ESP))); - if inlined then - begin - r:=new_reference(procinfo.framepointer,para_offset-pushedparasize); - exprasmlist^.concat(new(pai386,op_reg_ref(A_MOVQ,S_NO, - p^.left^.location.register,r))); - end - else - begin - r:=new_reference(R_ESP,0); - exprasmlist^.concat(new(pai386,op_reg_ref( - A_MOVQ,S_NO,p^.left^.location.register,r))); - end; - end; -{$endif SUPPORT_MMX} - end; - end; - truelabel:=otlabel; - falselabel:=oflabel; - { push from right to left } - if not push_from_left_to_right and assigned(p^.right) then - secondcallparan(p^.right,defcoll^.next,push_from_left_to_right - ,inlined,para_offset - ); - end; - - procedure secondcalln(var p : ptree); - - var - unusedregisters : tregisterset; - pushed : tpushed; - funcretref : treference; - hregister : tregister; - oldpushedparasize : longint; - { true if ESI must be loaded again after the subroutine } - loadesi : boolean; - { true if a virtual method must be called directly } - no_virtual_call : boolean; - { true if we produce a con- or destrutor in a call } - is_con_or_destructor : boolean; - { true if a constructor is called again } - extended_new : boolean; - { adress returned from an I/O-error } - iolabel : plabel; - { lexlevel count } - i : longint; - { help reference pointer } - r : preference; - pp,params : ptree; - inlined : boolean; - inlinecode : ptree; - para_offset : longint; - { instruction for alignement correction } - corr : pai386; - { we must pop this size also after !! } - must_pop : boolean; - pop_size : longint; - - label - dont_call; - - begin - extended_new:=false; - iolabel:=nil; - inlinecode:=nil; - inlined:=false; - loadesi:=true; - no_virtual_call:=false; - unusedregisters:=unused; - - if not assigned(p^.procdefinition) then - exit; - if (p^.procdefinition^.options and poinline)<>0 then - begin - inlined:=true; - inlinecode:=p^.right; - { set it to the same lexical level } - p^.procdefinition^.parast^.symtablelevel:= - aktprocsym^.definition^.parast^.symtablelevel; - if inlinecode^.para_size>0 then - inlinecode^.para_offset:= - gettempofsizepersistant(inlinecode^.para_size); - inlinecode^.retoffset:=inlinecode^.para_offset; - p^.procdefinition^.parast^.call_offset:= - inlinecode^.para_offset; - if ret_in_param(p^.procdefinition^.retdef) then - inc(p^.procdefinition^.parast^.call_offset,sizeof(pointer)); -{$ifdef extdebug} - Comment(V_debug, - 'inlined parasymtable is at offset ' - +tostr(p^.procdefinition^.parast^.call_offset)); - exprasmlist^.concat(new(pai_asm_comment,init( - strpnew('inlined parasymtable is at offset ' - +tostr(p^.procdefinition^.parast^.call_offset))))); -{$endif extdebug} - p^.right:=nil; - { disable further inlining of the same proc - in the args } - p^.procdefinition^.options:=p^.procdefinition^.options and (not poinline); - end; - { only if no proc var } - if not(assigned(p^.right)) then - is_con_or_destructor:=((p^.procdefinition^.options and poconstructor)<>0) - or ((p^.procdefinition^.options and podestructor)<>0); - { proc variables destroy all registers } - if (p^.right=nil) and - { virtual methods too } - ((p^.procdefinition^.options and povirtualmethod)=0) then - begin - if ((p^.procdefinition^.options and poiocheck)<>0) - and (cs_iocheck in aktswitches) then - begin - getlabel(iolabel); - emitl(A_LABEL,iolabel); - end - else iolabel:=nil; - - { save all used registers } - pushusedregisters(pushed,p^.procdefinition^.usedregisters); - - { give used registers through } - usedinproc:=usedinproc or p^.procdefinition^.usedregisters; - end - else - begin - pushusedregisters(pushed,$ff); - usedinproc:=$ff; - { no IO check for methods and procedure variables } - iolabel:=nil; - end; - - { generate the code for the parameter and push them } - oldpushedparasize:=pushedparasize; - pushedparasize:=0; - corr:=new(pai386,op_const_reg(A_SUB,S_L,0,R_ESP)); - exprasmlist^.concat(corr); - if (p^.resulttype<>pdef(voiddef)) and - ret_in_param(p^.resulttype) then - begin - funcretref.symbol:=nil; -{$ifdef test_dest_loc} - if dest_loc_known and (dest_loc_tree=p) and - (dest_loc.loc in [LOC_REFERENCE,LOC_MEM]) then - begin - funcretref:=dest_loc.reference; - if assigned(dest_loc.reference.symbol) then - funcretref.symbol:=stringdup(dest_loc.reference.symbol^); - in_dest_loc:=true; - end - else -{$endif test_dest_loc} - if inlined then - begin - reset_reference(funcretref); - funcretref.offset:=gettempofsizepersistant(p^.procdefinition^.retdef^.size); - funcretref.base:=procinfo.framepointer; - end - else - gettempofsizereference(p^.procdefinition^.retdef^.size,funcretref); - end; - if assigned(p^.left) then - begin - pushedparasize:=0; - { be found elsewhere } - if inlined then - para_offset:=p^.procdefinition^.parast^.call_offset+ - p^.procdefinition^.parast^.datasize - else - para_offset:=0; - if assigned(p^.right) then - secondcallparan(p^.left,pprocvardef(p^.right^.resulttype)^.para1, - (p^.procdefinition^.options and poleftright)<>0 - ,inlined, - para_offset - ) - else - secondcallparan(p^.left,p^.procdefinition^.para1, - (p^.procdefinition^.options and poleftright)<>0 - ,inlined, - para_offset - ); - end; - params:=p^.left; - p^.left:=nil; - if inlined then - begin - inlinecode^.retoffset:=inlinecode^.para_offset; - end; - if ret_in_param(p^.resulttype) then - begin - inc(pushedparasize,4); - if inlined then - begin -{$ifdef extdebug} - exprasmlist^.concat(new(pai_asm_comment,init( - strpnew('inlined func ret address is at offset ' - +tostr(inlinecode^.retoffset))))); -{$endif extdebug} - exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L, - newreference(funcretref),R_EDI))); - - r:=new_reference(procinfo.framepointer,inlinecode^.retoffset); - exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L, - R_EDI,r))); - end - else - emitpushreferenceaddr(funcretref); - end; - { procedure variable ? } - if (p^.right=nil) then - begin - { overloaded operator have no symtable } - { push self } - if assigned(p^.symtable) and - (p^.symtable^.symtabletype=withsymtable) then - begin - { dirty trick to avoid the secondcall below } - p^.methodpointer:=genzeronode(callparan); - p^.methodpointer^.location.loc:=LOC_REGISTER; - p^.methodpointer^.location.register:=R_ESI; - { make a reference } - new(r); - reset_reference(r^); - r^.offset:=p^.symtable^.datasize; - r^.base:=procinfo.framepointer; - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,r,R_ESI))); - end; - - { push self } - if assigned(p^.symtable) and - ((p^.symtable^.symtabletype=objectsymtable) or - (p^.symtable^.symtabletype=withsymtable)) then - begin - if assigned(p^.methodpointer) then - begin - { - if p^.methodpointer^.resulttype=classrefdef then - begin - two possibilities: - 1. constructor - 2. class method - - end - else } - begin - case p^.methodpointer^.treetype of - typen: - begin - { direct call to inherited method } - if (p^.procdefinition^.options and poabstractmethod)<>0 then - begin - Message(cg_e_cant_call_abstract_method); - goto dont_call; - end; - { generate no virtual call } - no_virtual_call:=true; - - if (p^.symtableprocentry^.properties and sp_static)<>0 then - begin - { well lets put the VMT address directly into ESI } - { it is kind of dirty but that is the simplest } - { way to accept virtual static functions (PM) } - loadesi:=true; - exprasmlist^.concat(new(pai386,op_csymbol_reg(A_MOV,S_L, - newcsymbol(pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname,0),R_ESI))); - maybe_concat_external(pobjectdef(p^.methodpointer^.resulttype)^.owner, - pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname); - exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_ESI))); - end - else - { this is a member call, so ESI isn't modfied } - loadesi:=false; - if not(is_con_or_destructor and - pobjectdef(p^.methodpointer^.resulttype)^.isclass and - assigned(aktprocsym) and - ((aktprocsym^.definition^.options and - (poconstructor or podestructor))<>0)) then - exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_ESI))); - { if an inherited con- or destructor should be } - { called in a con- or destructor then a warning } - { will be made } - { con- and destructors need a pointer to the vmt } - if is_con_or_destructor and - not(pobjectdef(p^.methodpointer^.resulttype)^.isclass) and - assigned(aktprocsym) then - begin - if not ((aktprocsym^.definition^.options - and (poconstructor or podestructor))<>0) then - - Message(cg_w_member_cd_call_from_method); - end; - if is_con_or_destructor then - push_int(0) - end; - hnewn: - begin - { extended syntax of new } - { ESI must be zero } - exprasmlist^.concat(new(pai386,op_reg_reg(A_XOR,S_L,R_ESI,R_ESI))); - exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_ESI))); - { insert the vmt } - exprasmlist^.concat(new(pai386,op_csymbol(A_PUSH,S_L, - newcsymbol(pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname,0)))); - maybe_concat_external(pobjectdef(p^.methodpointer^.resulttype)^.owner, - pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname); - extended_new:=true; - end; - hdisposen: - begin - secondpass(p^.methodpointer); - - { destructor with extended syntax called from dispose } - { hdisposen always deliver LOC_REFERENCE } - exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L, - newreference(p^.methodpointer^.location.reference),R_ESI))); - del_reference(p^.methodpointer^.location.reference); - exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_ESI))); - exprasmlist^.concat(new(pai386,op_csymbol(A_PUSH,S_L, - newcsymbol(pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname,0)))); - maybe_concat_external(pobjectdef(p^.methodpointer^.resulttype)^.owner, - pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname); - end; - else - begin - { call to an instance member } - if (p^.symtable^.symtabletype<>withsymtable) then - begin - secondpass(p^.methodpointer); - case p^.methodpointer^.location.loc of - LOC_REGISTER: - begin - ungetregister32(p^.methodpointer^.location.register); - emit_reg_reg(A_MOV,S_L,p^.methodpointer^.location.register,R_ESI); - end; - else - begin - if (p^.methodpointer^.resulttype^.deftype=objectdef) and - pobjectdef(p^.methodpointer^.resulttype)^.isclass then - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, - newreference(p^.methodpointer^.location.reference),R_ESI))) - else - exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L, - newreference(p^.methodpointer^.location.reference),R_ESI))); - del_reference(p^.methodpointer^.location.reference); - end; - end; - end; - { when calling a class method, we have - to load ESI with the VMT ! - But that's wrong, if we call a class method via self - } - if ((p^.procdefinition^.options and poclassmethod)<>0) - and not(p^.methodpointer^.treetype=selfn) then - begin - { class method needs current VMT } - new(r); - reset_reference(r^); - r^.base:=R_ESI; - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,r,R_ESI))); - end; - - { direct call to class constructor, don't allocate memory } - if is_con_or_destructor and (p^.methodpointer^.resulttype^.deftype=objectdef) and - (pobjectdef(p^.methodpointer^.resulttype)^.isclass) then - exprasmlist^.concat(new(pai386,op_const(A_PUSH,S_L,0))) - else - exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_ESI))); - if is_con_or_destructor then - begin - { classes don't get a VMT pointer pushed } - if (p^.methodpointer^.resulttype^.deftype=objectdef) and - not(pobjectdef(p^.methodpointer^.resulttype)^.isclass) then - begin - if ((p^.procdefinition^.options and poconstructor)<>0) then - begin - { it's no bad idea, to insert the VMT } - exprasmlist^.concat(new(pai386,op_csymbol(A_PUSH,S_L, - newcsymbol(pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname, - 0)))); - maybe_concat_external(pobjectdef(p^.methodpointer^.resulttype)^.owner, - pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname); - end - { destructors haven't to dispose the instance, if this is } - { a direct call } - else - push_int(0); - end; - end; - end; - end; - end; - end - else - begin - if ((p^.procdefinition^.options and poclassmethod)<>0) and - not( - assigned(aktprocsym) and - ((aktprocsym^.definition^.options and poclassmethod)<>0) - ) then - begin - { class method needs current VMT } - new(r); - reset_reference(r^); - r^.base:=R_ESI; - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,r,R_ESI))); - end - else - begin - { member call, ESI isn't modified } - loadesi:=false; - end; - exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_ESI))); - { but a con- or destructor here would probably almost } - { always be placed wrong } - if is_con_or_destructor then - begin - Message(cg_w_member_cd_call_from_method); - push_int(0); - end; - end; - end; - - { push base pointer ?} - if (lexlevel>1) and assigned(pprocdef(p^.procdefinition)^.parast) and - ((p^.procdefinition^.parast^.symtablelevel)>2) then - begin - { if we call a nested function in a method, we must } - { push also SELF! } - { THAT'S NOT TRUE, we have to load ESI via frame pointer } - { access } - { - begin - loadesi:=false; - exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_ESI))); - end; - } - if lexlevel=(p^.procdefinition^.parast^.symtablelevel) then - begin - new(r); - reset_reference(r^); - r^.offset:=procinfo.framepointer_offset; - r^.base:=procinfo.framepointer; - exprasmlist^.concat(new(pai386,op_ref(A_PUSH,S_L,r))) - end - { this is only true if the difference is one !! - but it cannot be more !! } - else if (lexlevel=p^.procdefinition^.parast^.symtablelevel-1) then - begin - exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,procinfo.framepointer))) - end - else if (lexlevel>p^.procdefinition^.parast^.symtablelevel) then - begin - hregister:=getregister32; - new(r); - reset_reference(r^); - r^.offset:=procinfo.framepointer_offset; - r^.base:=procinfo.framepointer; - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,r,hregister))); - for i:=(p^.procdefinition^.parast^.symtablelevel) to lexlevel-1 do - begin - new(r); - reset_reference(r^); - {we should get the correct frame_pointer_offset at each level - how can we do this !!! } - r^.offset:=procinfo.framepointer_offset; - r^.base:=hregister; - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,r,hregister))); - end; - exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,hregister))); - ungetregister32(hregister); - end - else - internalerror(25000); - end; - - { exported methods should be never called direct. - Why? Bp7 Allows it (PFV) - - if (p^.procdefinition^.options and poexports)<>0 then - Message(cg_e_dont_call_exported_direct); } - - if (not inlined) and ((pushedparasize mod 4)<>0) then - begin - corr^.op1:=pointer(4-(pushedparasize mod 4)); - must_pop:=true; - pop_size:=4-(pushedparasize mod 4); - end - else - begin - exprasmlist^.remove(corr); - must_pop:=false; - pop_size:=0; - end; - - if ((p^.procdefinition^.options and povirtualmethod)<>0) and - not(no_virtual_call) then - begin - { static functions contain the vmt_address in ESI } - { also class methods } - if assigned(aktprocsym) then - begin - if ((aktprocsym^.properties and sp_static)<>0) or - ((aktprocsym^.definition^.options and poclassmethod)<>0) or - ((p^.procdefinition^.options and postaticmethod)<>0) or - ((p^.procdefinition^.options and poconstructor)<>0) or - { ESI is loaded earlier } - ((p^.procdefinition^.options and poclassmethod)<>0)then - begin - new(r); - reset_reference(r^); - r^.base:=R_ESI; - end - else - begin - new(r); - reset_reference(r^); - r^.base:=R_ESI; - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,r,R_EDI))); - new(r); - reset_reference(r^); - r^.base:=R_EDI; - end; - end - else - { aktprocsym should be assigned, also in main program } - internalerror(12345); - { - begin - new(r); - reset_reference(r^); - r^.base:=R_ESI; - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,r,R_EDI))); - new(r); - reset_reference(r^); - r^.base:=R_EDI; - end; - } - if p^.procdefinition^.extnumber=-1 then - internalerror($Da); - r^.offset:=p^.procdefinition^.extnumber*4+12; - if (cs_rangechecking in aktswitches) then - begin - exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,r^.base))); - emitcall('CHECK_OBJECT',true); - end; - exprasmlist^.concat(new(pai386,op_ref(A_CALL,S_NO,r))); - end - else if not inlined then - emitcall(p^.procdefinition^.mangledname, - (p^.symtableproc^.symtabletype=unitsymtable) or - ((p^.symtableproc^.symtabletype=objectsymtable) and - (pobjectdef(p^.symtableproc^.defowner)^.owner^.symtabletype=unitsymtable))) - else { inlined proc } - { inlined code is in inlinecode } - begin - secondpass(inlinecode); - { set poinline again } - p^.procdefinition^.options:=p^.procdefinition^.options or poinline; - { free the args } - if inlinecode^.para_size>0 then - ungetpersistanttemp(inlinecode^.para_offset, - inlinecode^.para_size); - end; - if (not inlined) and ((p^.procdefinition^.options and poclearstack)<>0) then - begin - { consider the alignment with the rest (PM) } - pushedparasize:=pushedparasize+pop_size; - must_pop:=false; - if pushedparasize=4 then - { better than an add on all processors } - exprasmlist^.concat(new(pai386,op_reg(A_POP,S_L,R_EDI))) - { the pentium has two pipes and pop reg is pairable } - { but the registers must be different! } - else if (pushedparasize=8) and - not(cs_littlesize in aktswitches) and - (aktoptprocessor=pentium) and - (procinfo._class=nil) then - begin - exprasmlist^.concat(new(pai386,op_reg(A_POP,S_L,R_EDI))); - exprasmlist^.concat(new(pai386,op_reg(A_POP,S_L,R_ESI))); - end - else exprasmlist^.concat(new(pai386,op_const_reg(A_ADD,S_L,pushedparasize,R_ESP))); - end; - end - else - begin - if (pushedparasize mod 4)<>0 then - begin - corr^.op1:=pointer(4-(pushedparasize mod 4)); - must_pop:=true; - pop_size:=4-(pushedparasize mod 4); - end - else - begin - exprasmlist^.remove(corr); - must_pop:=false; - pop_size:=0; - end; - secondpass(p^.right); - { method pointer ? } - if (p^.procdefinition^.options and pomethodpointer)<>0 then - begin - { method pointer can't be in a register } - inc(p^.right^.location.reference.offset,4); - { push self pointer } - exprasmlist^.concat(new(pai386,op_ref(A_PUSH,S_L,newreference(p^.right^.location.reference)))); - del_reference(p^.right^.location.reference); - dec(p^.right^.location.reference.offset,4); - end; - case p^.right^.location.loc of - LOC_REGISTER,LOC_CREGISTER: - begin - exprasmlist^.concat(new(pai386,op_reg(A_CALL,S_NO,p^.right^.location.register))); - ungetregister32(p^.right^.location.register); - end - else - exprasmlist^.concat(new(pai386,op_ref(A_CALL,S_NO,newreference(p^.right^.location.reference)))); - del_reference(p^.right^.location.reference); - end; - - - end; - dont_call: - pushedparasize:=oldpushedparasize; - unused:=unusedregisters; - - { handle function results } - { structured results are easy to handle.... } - { needed also when result_no_used !! } - if (p^.resulttype<>pdef(voiddef)) and ret_in_param(p^.resulttype) then - begin - p^.location.loc:=LOC_MEM; - stringdispose(p^.location.reference.symbol); - p^.location.reference:=funcretref; - end; - if (p^.resulttype<>pdef(voiddef)) and p^.return_value_used then - begin - { a contructor could be a function with boolean result } - if (p^.right=nil) and - ((p^.procdefinition^.options and poconstructor)<>0) and - { quick'n'dirty check if it is a class or an object } - (p^.resulttype^.deftype=orddef) then - begin - p^.location.loc:=LOC_FLAGS; - p^.location.resflags:=F_NE; - if extended_new then - begin -{$ifdef test_dest_loc} - if dest_loc_known and (dest_loc_tree=p) then - mov_reg_to_dest(p,S_L,R_EAX) - else -{$endif test_dest_loc} - begin - hregister:=getregister32; - emit_reg_reg(A_MOV,S_L,R_EAX,hregister); - p^.location.register:=hregister; - end; - end; - end - { structed results are easy to handle.... } - else if ret_in_param(p^.resulttype) then - begin - {p^.location.loc:=LOC_MEM; - stringdispose(p^.location.reference.symbol); - p^.location.reference:=funcretref; - already done above (PM) } - end - else - begin - if (p^.resulttype^.deftype=orddef) then - begin - p^.location.loc:=LOC_REGISTER; - case porddef(p^.resulttype)^.typ of - s32bit,u32bit,bool32bit : - begin -{$ifdef test_dest_loc} - if dest_loc_known and (dest_loc_tree=p) then - mov_reg_to_dest(p,S_L,R_EAX) - else -{$endif test_dest_loc} - begin - hregister:=getregister32; - emit_reg_reg(A_MOV,S_L,R_EAX,hregister); - p^.location.register:=hregister; - end; - end; - uchar,u8bit,bool8bit,s8bit : - begin -{$ifdef test_dest_loc} - if dest_loc_known and (dest_loc_tree=p) then - mov_reg_to_dest(p,S_B,R_AL) - else -{$endif test_dest_loc} - begin - hregister:=getregister32; - emit_reg_reg(A_MOV,S_B,R_AL,reg32toreg8(hregister)); - p^.location.register:=reg32toreg8(hregister); - end; - end; - s16bit,u16bit,bool16bit : - begin -{$ifdef test_dest_loc} - if dest_loc_known and (dest_loc_tree=p) then - mov_reg_to_dest(p,S_W,R_AX) - else -{$endif test_dest_loc} - begin - hregister:=getregister32; - emit_reg_reg(A_MOV,S_W,R_AX,reg32toreg16(hregister)); - p^.location.register:=reg32toreg16(hregister); - end; - end; - else internalerror(7); - end - - end - else if (p^.resulttype^.deftype=floatdef) then - case pfloatdef(p^.resulttype)^.typ of - f32bit : begin - p^.location.loc:=LOC_REGISTER; -{$ifdef test_dest_loc} - if dest_loc_known and (dest_loc_tree=p) then - mov_reg_to_dest(p,S_L,R_EAX) - else -{$endif test_dest_loc} - begin - hregister:=getregister32; - emit_reg_reg(A_MOV,S_L,R_EAX,hregister); - p^.location.register:=hregister; - end; - end; - else - p^.location.loc:=LOC_FPU; - end - else - begin - p^.location.loc:=LOC_REGISTER; -{$ifdef test_dest_loc} - if dest_loc_known and (dest_loc_tree=p) then - mov_reg_to_dest(p,S_L,R_EAX) - else -{$endif test_dest_loc} - begin - hregister:=getregister32; - emit_reg_reg(A_MOV,S_L,R_EAX,hregister); - p^.location.register:=hregister; - end; - end; - end; - end; - - { perhaps i/o check ? } - if iolabel<>nil then - begin - exprasmlist^.concat(new(pai386,op_csymbol(A_PUSH,S_L,newcsymbol(lab2str(iolabel),0)))); - { this was wrong, probably an error due to diff3 - emitcall(p^.procdefinition^.mangledname);} - emitcall('IOCHECK',true); - end; - { this should be optimized (PM) } - if must_pop then - exprasmlist^.concat(new(pai386,op_const_reg(A_ADD,S_L,pop_size,R_ESP))); - { restore registers } - popusedregisters(pushed); - - { at last, restore instance pointer (SELF) } - if loadesi then - maybe_loadesi; - pp:=params; - while assigned(pp) do - begin - if assigned(pp^.left) then - if (pp^.left^.location.loc=LOC_REFERENCE) or - (pp^.left^.location.loc=LOC_MEM) then - ungetiftemp(pp^.left^.location.reference); - pp:=pp^.right; - end; - - disposetree(params); - - - { from now on the result can be freed normally } - if inlined and ret_in_param(p^.resulttype) then - persistanttemptonormal(funcretref.offset); - - { if return value is not used } - if (not p^.return_value_used) and (p^.resulttype<>pdef(voiddef)) then - begin - if p^.location.loc in [LOC_MEM,LOC_REFERENCE] then - { release unused temp } - ungetiftemp(p^.location.reference) - else if p^.location.loc=LOC_FPU then - { release FPU stack } - exprasmlist^.concat(new(pai386,op_none(A_FDECSTP,S_NO))); - end; - end; - - { reverts the parameter list } - var nb_para : integer; - - function reversparameter(p : ptree) : ptree; - - var - hp1,hp2 : ptree; - - begin - hp1:=nil; - nb_para := 0; - while assigned(p) do - begin - { pull out } - hp2:=p; - p:=p^.right; - inc(nb_para); - { pull in } - hp2^.right:=hp1; - hp1:=hp2; - end; - reversparameter:=hp1; - end; - - procedure secondinline(var p : ptree); - const in2size:array[in_inc_byte..in_dec_dword] of Topsize= - (S_B,S_W,S_L,S_B,S_W,S_L); - in2instr:array[in_inc_byte..in_dec_dword] of Tasmop= - (A_INC,A_INC,A_INC,A_DEC,A_DEC,A_DEC); - ad2instr:array[in_inc_byte..in_dec_dword] of Tasmop= - (A_ADD,A_ADD,A_ADD,A_SUB,A_SUB,A_SUB); - { tfloattype = (f32bit,s32real,s64real,s80real,s64bit); } - float_name: array[tfloattype] of string[8]= - ('FIXED','SINGLE','REAL','EXTENDED','COMP','FIXED16'); - var - aktfile : treference; - ft : tfiletype; - opsize : topsize; - asmop : tasmop; - pushed : tpushed; - - { produces code for READ(LN) and WRITE(LN) } - - procedure handlereadwrite(doread,callwriteln : boolean); - - procedure loadstream; - const - io:array[0..1] of string[7]=('_OUTPUT','_INPUT'); - var - r : preference; - begin - new(r); - reset_reference(r^); - r^.symbol:=stringdup('U_'+upper(target_info.system_unit)+io[byte(doread)]); -{ if not (cs_compilesystem in aktswitches) then } - concat_external(r^.symbol^,EXT_NEAR); - exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L,r,R_EDI))) - end; - - var - node,hp : ptree; - typedtyp,pararesult : pdef; - doflush,has_length : boolean; - dummycoll : tdefcoll; - iolabel : plabel; - npara : longint; - - begin - { I/O check } - if cs_iocheck in aktswitches then - begin - getlabel(iolabel); - emitl(A_LABEL,iolabel); - end - else iolabel:=nil; - { no automatic call from flush } - doflush:=false; - { for write of real with the length specified } - has_length:=false; - hp:=nil; - { reserve temporary pointer to data variable } - aktfile.symbol:=nil; - gettempofsizereference(4,aktfile); - { first state text data } - ft:=ft_text; - { and state a parameter ? } - if p^.left=nil then - begin - { state screen address} - doflush:=true; - { the following instructions are for "writeln;" } - loadstream; - { save @Dateivarible in temporary variable } - exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L,R_EDI,newreference(aktfile)))); - end - else - begin - { revers paramters } - node:=reversparameter(p^.left); - - p^.left := node; - npara := nb_para; - { calculate data variable } - { is first parameter a file type ? } - if node^.left^.resulttype^.deftype=filedef then - begin - ft:=pfiledef(node^.left^.resulttype)^.filetype; - if ft=ft_typed then - typedtyp:=pfiledef(node^.left^.resulttype)^.typed_as; - secondpass(node^.left); - if codegenerror then - exit; - - { save reference in temporary variables } { reference in tempor„re Variable retten } - if node^.left^.location.loc<>LOC_REFERENCE then - begin - Message(cg_e_illegal_expression); - exit; - end; - - exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L,newreference(node^.left^.location.reference),R_EDI))); - - { skip to the next parameter } - node:=node^.right; - end - else - begin - { if we write to stdout/in then flush after the write(ln) } - doflush:=true; - loadstream; - end; - - { save @Dateivarible in temporary variable } - exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L,R_EDI,newreference(aktfile)))); - if doread then - { parameter by READ gives call by reference } - dummycoll.paratyp:=vs_var - { an WRITE Call by "Const" } - else dummycoll.paratyp:=vs_const; - - { because of secondcallparan, which otherwise attaches } - if ft=ft_typed then - begin - { this is to avoid copy of simple const parameters } - dummycoll.data:=new(pformaldef,init); - end - else - { I think, this isn't a good solution (FK) } - dummycoll.data:=nil; - - while assigned(node) do - begin - pushusedregisters(pushed,$ff); - hp:=node; - node:=node^.right; - hp^.right:=nil; - if hp^.is_colon_para then - Message(parser_e_illegal_colon_qualifier); - if ft=ft_typed then - never_copy_const_param:=true; - secondcallparan(hp,@dummycoll,false - ,false,0 - ); - if ft=ft_typed then - never_copy_const_param:=false; - hp^.right:=node; - if codegenerror then - exit; - - emit_push_mem(aktfile); - if (ft=ft_typed) then - begin - { OK let's try this } - { first we must only allow the right type } - { we have to call blockread or blockwrite } - { but the real problem is that } - { reset and rewrite should have set } - { the type size } - { as recordsize for that file !!!! } - { how can we make that } - { I think that is only possible by adding } - { reset and rewrite to the inline list a call } - { allways read only one record by element } - push_int(typedtyp^.size); - if doread then - emitcall('TYPED_READ',true) - else - emitcall('TYPED_WRITE',true) - {!!!!!!!} - end - else - begin - { save current position } - pararesult:=hp^.left^.resulttype; - { handle possible field width } - { of course only for write(ln) } - if not doread then - begin - { handle total width parameter } - if assigned(node) and node^.is_colon_para then - begin - hp:=node; - node:=node^.right; - hp^.right:=nil; - secondcallparan(hp,@dummycoll,false - ,false,0 - ); - hp^.right:=node; - if codegenerror then - exit; - has_length:=true; - end - else - if pararesult^.deftype<>floatdef then - push_int(0) - else - push_int(-32767); - { a second colon para for a float ? } - if assigned(node) and node^.is_colon_para then - begin - hp:=node; - node:=node^.right; - hp^.right:=nil; - secondcallparan(hp,@dummycoll,false - ,false,0 - ); - hp^.right:=node; - if pararesult^.deftype<>floatdef then - Message(parser_e_illegal_colon_qualifier); - if codegenerror then - exit; - end - else - begin - if pararesult^.deftype=floatdef then - push_int(-1); - end - end; - case pararesult^.deftype of - stringdef: - begin - if doread then - emitcall('READ_TEXT_STRING',true) - else - begin - emitcall('WRITE_TEXT_STRING',true); - {ungetiftemp(hp^.left^.location.reference);} - end; - end; - pointerdef : begin - if is_equal(ppointerdef(pararesult)^.definition,cchardef) then - begin - if doread then - emitcall('READ_TEXT_PCHAR_AS_POINTER',true) - else - emitcall('WRITE_TEXT_PCHAR_AS_POINTER',true); - end - else - Message(parser_e_illegal_parameter_list); - end; - arraydef : begin - if (parraydef(pararesult)^.lowrange=0) - and is_equal(parraydef(pararesult)^.definition,cchardef) then - begin - if doread then - emitcall('READ_TEXT_PCHAR_AS_ARRAY',true) - else - emitcall('WRITE_TEXT_PCHAR_AS_ARRAY',true); - end - else - Message(parser_e_illegal_parameter_list); - end; - - floatdef: - begin - if doread then - emitcall('READ_TEXT_'+float_name[pfloatdef(pararesult)^.typ],true) - else - emitcall('WRITE_TEXT_'+float_name[pfloatdef(pararesult)^.typ],true); - end; - orddef : begin - case porddef(pararesult)^.typ of - u8bit : if doread then - emitcall('READ_TEXT_BYTE',true); - s8bit : if doread then - emitcall('READ_TEXT_SHORTINT',true); - u16bit : if doread then - emitcall('READ_TEXT_WORD',true); - s16bit : if doread then - emitcall('READ_TEXT_INTEGER',true); - s32bit : if doread then - emitcall('READ_TEXT_LONGINT',true) - else - emitcall('WRITE_TEXT_LONGINT',true); - u32bit : if doread then - emitcall('READ_TEXT_CARDINAL',true) - else - emitcall('WRITE_TEXT_CARDINAL',true); - uchar : if doread then - emitcall('READ_TEXT_CHAR',true) - else - emitcall('WRITE_TEXT_CHAR',true); - bool8bit, - bool16bit, - bool32bit : if doread then - { emitcall('READ_TEXT_BOOLEAN',true) } - Message(parser_e_illegal_parameter_list) - else - emitcall('WRITE_TEXT_BOOLEAN',true); - else Message(parser_e_illegal_parameter_list); - end; - end; - else Message(parser_e_illegal_parameter_list); - end; - end; - { load ESI in methods again } - popusedregisters(pushed); - maybe_loadesi; - end; - end; - if callwriteln then - begin - pushusedregisters(pushed,$ff); - emit_push_mem(aktfile); - { pushexceptlabel; } - if ft<>ft_text then - Message(parser_e_illegal_parameter_list) ; - emitcall('WRITELN_TEXT',true); - popusedregisters(pushed); - maybe_loadesi; - end; - if doflush and not(doread) then - begin - pushusedregisters(pushed,$ff); - { pushexceptlabel; } - emitcall('FLUSH_STDOUT',true); - popusedregisters(pushed); - maybe_loadesi; - end; - if iolabel<>nil then - begin - { registers are saved in the procedure } - exprasmlist^.concat(new(pai386,op_csymbol(A_PUSH,S_L,newcsymbol(lab2str(iolabel),0)))); - emitcall('IOCHECK',true); - end; - ungetiftemp(aktfile); - if assigned(p^.left) then - begin - p^.left:=reversparameter(p^.left); - if npara<>nb_para then - Message(cg_f_internal_error_in_secondinline); - hp:=p^.left; - while assigned(hp) do - begin - if assigned(hp^.left) then - if (hp^.left^.location.loc=LOC_REFERENCE) or - (hp^.left^.location.loc=LOC_MEM) then - ungetiftemp(hp^.left^.location.reference); - hp:=hp^.right; - end; - end; - end; - - procedure handle_str; - - var - hp,node : ptree; - dummycoll : tdefcoll; - is_real,has_length : boolean; - - begin - pushusedregisters(pushed,$ff); - node:=p^.left; - is_real:=false; - has_length:=false; - while assigned(node^.right) do node:=node^.right; - { if a real parameter somewhere then call REALSTR } - if (node^.left^.resulttype^.deftype=floatdef) then - is_real:=true; - - node:=p^.left; - { we have at least two args } - { with at max 2 colon_para in between } - - { first arg longint or float } - hp:=node; - node:=node^.right; - hp^.right:=nil; - dummycoll.data:=hp^.resulttype; - { string arg } - - dummycoll.paratyp:=vs_var; - secondcallparan(hp,@dummycoll,false - ,false,0 - ); - if codegenerror then - exit; - - dummycoll.paratyp:=vs_const; - { second arg } - hp:=node; - node:=node^.right; - hp^.right:=nil; - { frac para } - if hp^.is_colon_para and assigned(node) and - node^.is_colon_para then - begin - dummycoll.data:=hp^.resulttype; - secondcallparan(hp,@dummycoll,false - ,false,0 - ); - if codegenerror then - exit; - hp:=node; - node:=node^.right; - hp^.right:=nil; - has_length:=true; - end - else - if is_real then - push_int(-1); - - { third arg, length only if is_real } - if hp^.is_colon_para then - begin - dummycoll.data:=hp^.resulttype; - secondcallparan(hp,@dummycoll,false - ,false,0 - ); - if codegenerror then - exit; - hp:=node; - node:=node^.right; - hp^.right:=nil; - end - else - if is_real then - push_int(-32767) - else - push_int(-1); - - { last arg longint or real } - secondcallparan(hp,@dummycoll,false - ,false,0 - ); - if codegenerror then - exit; - - if is_real then - emitcall('STR_'+float_name[pfloatdef(hp^.resulttype)^.typ],true) - else if porddef(hp^.resulttype)^.typ=u32bit then - emitcall('STR_CARDINAL',true) - else - emitcall('STR_LONGINT',true); - popusedregisters(pushed); - end; - - var - r : preference; - l : longint; - ispushed : boolean; - hregister : tregister; - - begin - case p^.inlinenumber of - in_lo_word, - in_hi_word : - begin - secondpass(p^.left); - p^.location.loc:=LOC_REGISTER; - if p^.left^.location.loc<>LOC_REGISTER then - begin - if p^.left^.location.loc=LOC_CREGISTER then - begin - p^.location.register:=reg32toreg16(getregister32); - emit_reg_reg(A_MOV,S_W,p^.left^.location.register, - p^.location.register); - end - else - begin - del_reference(p^.left^.location.reference); - p^.location.register:=reg32toreg16(getregister32); - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_W,newreference(p^.left^.location.reference), - p^.location.register))); - end; - end - else p^.location.register:=p^.left^.location.register; - if p^.inlinenumber=in_hi_word then - exprasmlist^.concat(new(pai386,op_const_reg(A_SHR,S_W,8,p^.location.register))); - p^.location.register:=reg16toreg8(p^.location.register); - end; - in_high_x : - begin - if is_open_array(p^.left^.resulttype) then - begin - secondpass(p^.left); - del_reference(p^.left^.location.reference); - p^.location.register:=getregister32; - new(r); - reset_reference(r^); - r^.base:=highframepointer; - r^.offset:=highoffset+4; - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, - r,p^.location.register))); - end - end; - in_sizeof_x, - in_typeof_x : - begin - { for both cases load vmt } - if p^.left^.treetype=typen then - begin - p^.location.register:=getregister32; - exprasmlist^.concat(new(pai386,op_csymbol_reg(A_MOV, - S_L,newcsymbol(pobjectdef(p^.left^.resulttype)^.vmt_mangledname,0), - p^.location.register))); - end - else - begin - secondpass(p^.left); - del_reference(p^.left^.location.reference); - p^.location.loc:=LOC_REGISTER; - p^.location.register:=getregister32; - { load VMT pointer } - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, - newreference(p^.left^.location.reference), - p^.location.register))); - end; - { in sizeof load size } - if p^.inlinenumber=in_sizeof_x then - begin - new(r); - reset_reference(r^); - r^.base:=p^.location.register; - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,r, - p^.location.register))); - end; - end; - in_lo_long, - in_hi_long : - begin - secondpass(p^.left); - p^.location.loc:=LOC_REGISTER; - if p^.left^.location.loc<>LOC_REGISTER then - begin - if p^.left^.location.loc=LOC_CREGISTER then - begin - p^.location.register:=getregister32; - emit_reg_reg(A_MOV,S_L,p^.left^.location.register, - p^.location.register); - end - else - begin - del_reference(p^.left^.location.reference); - p^.location.register:=getregister32; - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(p^.left^.location.reference), - p^.location.register))); - end; - end - else p^.location.register:=p^.left^.location.register; - if p^.inlinenumber=in_hi_long then - exprasmlist^.concat(new(pai386,op_const_reg(A_SHR,S_L,16,p^.location.register))); - p^.location.register:=reg32toreg16(p^.location.register); - end; -{***CHARBUG} -{We can now comment them out, as they are handled as typecast. - Saves an incredible amount of 8 bytes code. - I'am not lucky about this, because it's _not_ a type cast (FK) } -{ in_ord_char, - in_chr_byte,} -{***} - in_length_string : - begin - secondpass(p^.left); - set_location(p^.location,p^.left^.location); - { length in ansi strings is at offset -8 } -{$ifdef UseAnsiString} - if is_ansistring(p^.left^.resulttype) then - dec(p^.location.reference.offset,8); -{$endif UseAnsiString} - end; - in_pred_x, - in_succ_x: - begin - secondpass(p^.left); - if p^.inlinenumber=in_pred_x then - asmop:=A_DEC - else - asmop:=A_INC; - case p^.resulttype^.size of - 4 : opsize:=S_L; - 2 : opsize:=S_W; - 1 : opsize:=S_B; - else - internalerror(10080); - end; - p^.location.loc:=LOC_REGISTER; - if p^.left^.location.loc<>LOC_REGISTER then - begin - p^.location.register:=getregister32; - if (p^.resulttype^.size=2) then - p^.location.register:=reg32toreg16(p^.location.register); - if (p^.resulttype^.size=1) then - p^.location.register:=reg32toreg8(p^.location.register); - if p^.left^.location.loc=LOC_CREGISTER then - emit_reg_reg(A_MOV,opsize,p^.left^.location.register, - p^.location.register) - else - if p^.left^.location.loc=LOC_FLAGS then - exprasmlist^.concat(new(pai386,op_reg(flag_2_set[p^.left^.location.resflags],S_B, - p^.location.register))) - else - begin - del_reference(p^.left^.location.reference); - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,opsize,newreference(p^.left^.location.reference), - p^.location.register))); - end; - end - else p^.location.register:=p^.left^.location.register; - exprasmlist^.concat(new(pai386,op_reg(asmop,opsize, - p^.location.register))) - { here we should insert bounds check ? } - { and direct call to bounds will crash the program } - { if we are at the limit } - { we could also simply say that pred(first)=first and succ(last)=last } - { could this be usefull I don't think so (PM) - emitoverflowcheck;} - end; - in_inc_byte..in_dec_dword: - begin - secondpass(p^.left); - if cs_check_overflow in aktswitches then - begin - { SINCE THE CARRY FLAG IS NEVER SET BY DEC/INC, we must use } - { ADD and SUB to check for overflow for unsigned operations. } - exprasmlist^.concat(new(pai386,op_const_ref(ad2instr[p^.inlinenumber], - in2size[p^.inlinenumber],1,newreference(p^.left^.location.reference)))); - emitoverflowcheck(p^.left); - end - else - exprasmlist^.concat(new(pai386,op_ref(in2instr[p^.inlinenumber], - in2size[p^.inlinenumber],newreference(p^.left^.location.reference)))); - end; - in_assigned_x : - begin - secondpass(p^.left^.left); - p^.location.loc:=LOC_FLAGS; - if (p^.left^.left^.location.loc=LOC_REGISTER) or - (p^.left^.left^.location.loc=LOC_CREGISTER) then - begin - exprasmlist^.concat(new(pai386,op_reg_reg(A_OR,S_L, - p^.left^.left^.location.register, - p^.left^.left^.location.register))); - ungetregister32(p^.left^.left^.location.register); - end - else - begin - exprasmlist^.concat(new(pai386,op_const_ref(A_CMP,S_L,0, - newreference(p^.left^.left^.location.reference)))); - del_reference(p^.left^.left^.location.reference); - end; - p^.location.resflags:=F_NE; - end; - in_reset_typedfile,in_rewrite_typedfile : - begin - pushusedregisters(pushed,$ff); - exprasmlist^.concat(new(pai386,op_const(A_PUSH,S_L,pfiledef(p^.left^.resulttype)^.typed_as^.size))); - secondload(p^.left); - emitpushreferenceaddr(p^.left^.location.reference); - if p^.inlinenumber=in_reset_typedfile then - emitcall('RESET_TYPED',true) - else - emitcall('REWRITE_TYPED',true); - popusedregisters(pushed); - end; - in_write_x : - handlereadwrite(false,false); - in_writeln_x : - handlereadwrite(false,true); - in_read_x : - handlereadwrite(true,false); - in_readln_x : - begin - handlereadwrite(true,false); - pushusedregisters(pushed,$ff); - emit_push_mem(aktfile); - { pushexceptlabel; } - if ft<>ft_text then - Message(parser_e_illegal_parameter_list); - emitcall('READLN_TEXT',true); - popusedregisters(pushed); - maybe_loadesi; - end; - in_str_x_string : - begin - handle_str; - maybe_loadesi; - end; - in_include_x_y, - in_exclude_x_y: - begin - secondpass(p^.left^.left); - if p^.left^.right^.left^.treetype=ordconstn then - begin - { calculate bit position } - l:=1 shl (p^.left^.right^.left^.value mod 32); - - { determine operator } - if p^.inlinenumber=in_include_x_y then - asmop:=A_OR - else - begin - asmop:=A_AND; - l:=not(l); - end; - if (p^.left^.left^.location.loc=LOC_REFERENCE) then - begin - inc(p^.left^.left^.location.reference.offset,(p^.left^.right^.left^.value div 32)*4); - exprasmlist^.concat(new(pai386,op_const_ref(asmop,S_L, - l,newreference(p^.left^.left^.location.reference)))); - del_reference(p^.left^.left^.location.reference); - end - else - { LOC_CREGISTER } - exprasmlist^.concat(new(pai386,op_const_reg(asmop,S_L, - l,p^.left^.left^.location.register))); - end - else - begin - { generate code for the element to set } - ispushed:=maybe_push(p^.left^.right^.left^.registers32,p^.left^.left); - secondpass(p^.left^.right^.left); - if ispushed then - restore(p^.left^.left); - { determine asm operator } - if p^.inlinenumber=in_include_x_y then - asmop:=A_BTS - else - asmop:=A_BTR; - if psetdef(p^.left^.resulttype)^.settype=smallset then - begin - if p^.left^.right^.left^.location.loc in - [LOC_CREGISTER,LOC_REGISTER] then - hregister:=p^.left^.right^.left^.location.register - else - begin - hregister:=R_EDI; - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, - newreference(p^.left^.right^.left^.location.reference), - R_EDI))); - end; - if (p^.left^.left^.location.loc=LOC_REFERENCE) then - exprasmlist^.concat(new(pai386,op_reg_ref(asmop,S_L,R_EDI, - newreference(p^.left^.right^.left^.location.reference)))) - else - exprasmlist^.concat(new(pai386,op_reg_reg(asmop,S_L,R_EDI, - p^.left^.right^.left^.location.register))); - end - else - begin - end; - end; - end; - else internalerror(9); - end; - end; - - procedure secondsubscriptn(var p : ptree); - - var - hr : tregister; - - begin - secondpass(p^.left); - - if codegenerror then - exit; - { classes must be dereferenced implicit } - if (p^.left^.resulttype^.deftype=objectdef) and - pobjectdef(p^.left^.resulttype)^.isclass then - begin - clear_reference(p^.location.reference); - case p^.left^.location.loc of - LOC_REGISTER: - p^.location.reference.base:=p^.left^.location.register; - LOC_CREGISTER: - begin - { ... and reserve one for the pointer } - hr:=getregister32; - emit_reg_reg(A_MOV,S_L,p^.left^.location.register,hr); - p^.location.reference.base:=hr; - end; - else - begin - { free register } - del_reference(p^.left^.location.reference); - - { ... and reserve one for the pointer } - hr:=getregister32; - exprasmlist^.concat(new(pai386,op_ref_reg( - A_MOV,S_L,newreference(p^.left^.location.reference), - hr))); - p^.location.reference.base:=hr; - end; - end; - end - else - set_location(p^.location,p^.left^.location); - - inc(p^.location.reference.offset,p^.vs^.address); - end; - - procedure secondselfn(var p : ptree); - - begin - clear_reference(p^.location.reference); - if (p^.resulttype^.deftype=classrefdef) or - ((p^.resulttype^.deftype=objectdef) - and pobjectdef(p^.resulttype)^.isclass - ) then - p^.location.register:=R_ESI - else - p^.location.reference.base:=R_ESI; - end; - - procedure secondhdisposen(var p : ptree); - - begin - secondpass(p^.left); - - if codegenerror then - exit; - clear_reference(p^.location.reference); - case p^.left^.location.loc of - LOC_REGISTER, - LOC_CREGISTER: - begin - p^.location.reference.index:=getregister32; - exprasmlist^.concat(new(pai386,op_reg_reg(A_MOV,S_L, - p^.left^.location.register, - p^.location.reference.index))); - end; - LOC_MEM,LOC_REFERENCE : - begin - del_reference(p^.left^.location.reference); - p^.location.reference.index:=getregister32; - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(p^.left^.location.reference), - p^.location.reference.index))); - end; - end; - end; - - procedure secondhnewn(var p : ptree); - - begin - end; - - procedure secondnewn(var p : ptree); - - begin - secondpass(p^.left); - - if codegenerror then - exit; - - p^.location.register:=p^.left^.location.register; - end; - - procedure secondsimplenewdispose(var p : ptree); - - var - pushed : tpushed; - begin - secondpass(p^.left); - if codegenerror then - exit; - - pushusedregisters(pushed,$ff); - { determines the size of the mem block } - push_int(ppointerdef(p^.left^.resulttype)^.definition^.size); - - { push pointer adress } - case p^.left^.location.loc of - LOC_CREGISTER : exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L, - p^.left^.location.register))); - LOC_REFERENCE : emitpushreferenceaddr(p^.left^.location.reference); - - end; - - { call the mem handling procedures } - case p^.treetype of - simpledisposen: - emitcall('FREEMEM',true); - simplenewn: - emitcall('GETMEM',true); - end; - - popusedregisters(pushed); - { may be load ESI } - maybe_loadesi; - end; - - { copies p a set element on the stack } - - procedure pushsetelement(var p : ptree); - - var - hr : tregister; - - begin - { copy the element on the stack, slightly complicated } - case p^.location.loc of - LOC_REGISTER, - LOC_CREGISTER : begin - hr:=p^.location.register; - case hr of - R_EAX,R_EBX,R_ECX,R_EDX,R_EDI,R_ESI,R_ESP : - begin - ungetregister32(hr); - exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_W,reg32toreg16(hr)))); - end; - R_AX,R_BX,R_CX,R_DX,R_DI,R_SI,R_SP : - begin - ungetregister32(reg16toreg32(hr)); - exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_W,hr))); - end; - R_AL,R_BL,R_CL,R_DL : - begin - ungetregister32(reg8toreg32(hr)); - exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_W,reg8toreg16(hr)))); - end; - end; - end; - else - begin - exprasmlist^.concat(new(pai386,op_ref(A_PUSH,S_W,newreference(p^.location.reference)))); - del_reference(p^.location.reference); - end; - end; - end; - - procedure secondsetcons(var p : ptree); - - var - l : plabel; - i : longint; - hp : ptree; - href,sref : treference; -{$ifdef TestSmallSet} - smallsetvalue : longint; - hr,hr2 : tregister; -{$endif TestSmallSet} - - begin - { this should be reimplemented for smallsets } - { differently (PM) } - { produce constant part } -{$ifdef TestSmallSet} - if psetdef(p^.resulttype)^.settype=smallset then - begin - smallsetvalue:=(p^.constset^[3]*256)+p^.constset^[2]; - smallsetvalue:=(smallsetvalue*256+p^.constset^[1])*256+p^.constset^[0]; - {consts^.concat(new(pai_const,init_32bit(smallsetvalue)));} - hr:=getregister32; - exprasmlist^.concat(new(pai386,op_const_reg(A_MOV,S_L, - smallsetvalue,hr))); - hp:=p^.left; - if assigned(hp) then - begin - while assigned(hp) do - begin - secondpass(hp^.left); - if codegenerror then - exit; - case hp^.left^.location.loc of - LOC_MEM,LOC_REFERENCE : - begin - hr2:=getregister32; - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, - newreference(hp^.left^.location.reference),hr2))); - exprasmlist^.concat(new(pai386,op_reg_reg(A_BTS,S_NO, - hr2,hr))); - ungetregister32(hr2); - end; - LOC_REGISTER,LOC_CREGISTER : - exprasmlist^.concat(new(pai386,op_reg_reg(A_BTS,S_NO, - hp^.left^.location.register,hr))); - else - internalerror(10567); - end; - hp:=hp^.right; - end; - end; - p^.location.loc:=LOC_REGISTER; - p^.location.register:=hr; - end - else -{$endif TestSmallSet} - begin - href.symbol := Nil; - clear_reference(href); - getlabel(l); - stringdispose(p^.location.reference.symbol); - href.symbol:=stringdup(constlabel2str(l,constseta)); - concat_constlabel(l,constseta); - for i:=0 to 31 do - consts^.concat(new(pai_const,init_8bit(p^.constset^[i]))); - hp:=p^.left; - if assigned(hp) then - begin - sref.symbol:=nil; - gettempofsizereference(32,sref); - concatcopy(href,sref,32,false); - while assigned(hp) do - begin - secondpass(hp^.left); - if codegenerror then - exit; - - pushsetelement(hp^.left); - emitpushreferenceaddr(sref); - { register is save in subroutine } - emitcall('SET_SET_BYTE',true); - hp:=hp^.right; - end; - p^.location.reference:=sref; - end - else p^.location.reference:=href; - end; - end; - - { could be built into secondadd but it } - { should be easy to read } - procedure secondin(var p : ptree); - - - type Tsetpart=record - range:boolean; {Part is a range.} - start,stop:byte; {Start/stop when range; Stop=element - when an element.} - end; - - var - pushed,ranges : boolean; - hr,pleftreg : tregister; - opsize : topsize; - setparts:array[1..8] of Tsetpart; - i,numparts:byte; - href,href2:Treference; - l,l2 : plabel; - - - function analizeset(Aset:Pconstset):boolean; - - var compares,maxcompares:word; - i:byte; - - type byteset=set of byte; - - begin - analizeset:=false; - ranges:=false; - numparts:=0; - compares:=0; - {Lots of comparisions take a lot of time, so do not allow - too much comparisions. 8 comparisions are, however, still - smalller than emitting the set.} - maxcompares:=5; - if cs_littlesize in aktswitches then - maxcompares:=8; - for i:=0 to 255 do - if i in byteset(Aset^) then - begin - if (numparts=0) or - (i<>setparts[numparts].stop+1) then - begin - {Set element is a separate element.} - inc(compares); - if compares>maxcompares then - exit; - inc(numparts); - setparts[numparts].range:=false; - setparts[numparts].stop:=i; - end - else - {Set element is part of a range.} - if not setparts[numparts].range then - begin - {Transform an element into a range.} - setparts[numparts].range:=true; - setparts[numparts].start:= - setparts[numparts].stop; - setparts[numparts].stop:=i; - inc(compares); - if compares>maxcompares then - exit; - end - else - begin - {Extend a range.} - setparts[numparts].stop:=i; - {A range of two elements can better - be checked as two separate ones. - When extending a range, our range - becomes larger than two elements.} - ranges:=true; - end; - end; - analizeset:=true; - end; - - begin - if psetdef(p^.right^.resulttype)^.settype=smallset then - begin - if p^.left^.treetype=ordconstn then - begin - { only compulsory } - secondpass(p^.left); - secondpass(p^.right); - if codegenerror then - exit; - p^.location.resflags:=F_NE; - case p^.right^.location.loc of - LOC_REGISTER,LOC_CREGISTER: - begin - exprasmlist^.concat(new(pai386,op_const_reg( - A_TEST,S_L,1 shl (p^.left^.value and 31), - p^.right^.location.register))); - ungetregister32(p^.right^.location.register); - end - else - begin - exprasmlist^.concat(new(pai386,op_const_ref(A_TEST,S_L,1 shl (p^.left^.value and 31), - newreference(p^.right^.location.reference)))); - del_reference(p^.right^.location.reference); - end; - end; - end - else - begin - { calculate both operators } - { the complex one first } - firstcomplex(p); - secondpass(p^.left); - { are too few registers free? } - pushed:=maybe_push(p^.right^.registers32,p^.left); - secondpass(p^.right); - if pushed then - restore(p^.left); - { of course not commutative } - if p^.swaped then - swaptree(p); - case p^.left^.location.loc of - LOC_REGISTER, - LOC_CREGISTER: - begin - hr:=p^.left^.location.register; - case p^.left^.location.register of - R_AX,R_BX,R_CX,R_DX,R_DI,R_SI,R_SP : - begin - hr:=reg16toreg32(p^.left^.location.register); - ungetregister32(hr); - exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVZX,S_WL, - p^.left^.location.register,hr))); - end; - R_AL,R_BL,R_CL,R_DL : - begin - hr:=reg8toreg32(p^.left^.location.register); - ungetregister32(hr); - exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVZX,S_BL, - p^.left^.location.register,hr))); - end; - end; - end; - else - begin - { the set element isn't never samller than a byte } - { and because it's a small set we need only 5 bits } - { but 8 bits are eaiser to load } - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVZX,S_BL, - newreference(p^.left^.location.reference),R_EDI))); - hr:=R_EDI; - del_reference(p^.left^.location.reference); - end; - end; - case p^.right^.location.loc of - LOC_REGISTER, - LOC_CREGISTER: - exprasmlist^.concat(new(pai386,op_reg_reg(A_BT,S_L,hr, - p^.right^.location.register))); - else - begin - exprasmlist^.concat(new(pai386,op_reg_ref(A_BT,S_L,hr, - newreference(p^.right^.location.reference)))); - del_reference(p^.right^.location.reference); - end; - end; - p^.location.loc:=LOC_FLAGS; - p^.location.resflags:=F_C; - end; - end - else - begin - if p^.left^.treetype=ordconstn then - begin - { only compulsory } - secondpass(p^.left); - secondpass(p^.right); - if codegenerror then - exit; - p^.location.resflags:=F_NE; - inc(p^.right^.location.reference.offset,p^.left^.value shr 3); - exprasmlist^.concat(new(pai386,op_const_ref(A_TEST,S_B,1 shl (p^.left^.value and 7), - newreference(p^.right^.location.reference)))); - del_reference(p^.right^.location.reference); - end - else - begin - if (p^.right^.treetype=setconstrn) and - analizeset(p^.right^.constset) then - begin - {It gives us advantage to check for the set elements - separately instead of using the SET_IN_BYTE procedure. - To do: Build in support for LOC_JUMP.} - secondpass(p^.left); - {We won't do a second pass on p^.right, because - this will emit the constant set.} - {If register is used, use only lower 8 bits} - if p^.left^.location.loc in [LOC_REGISTER,LOC_CREGISTER] then - begin - pleftreg:=p^.left^.location.register; - if pleftreg in [R_AL..R_DH] then - begin - exprasmlist^.concat(new(pai386,op_const_reg( - A_AND,S_B,255,pleftreg))); - opsize:=S_B; - end - else - begin - exprasmlist^.concat(new(pai386,op_const_reg( - A_AND,S_L,255,pleftreg))); - if pleftreg in [R_EAX..R_EDI] then - opsize:=S_L - else - opsize:=S_W; - end; - end; - {Get a label to jump to the end.} - p^.location.loc:=LOC_FLAGS; - {It's better to use the zero flag when there are - no ranges.} - if ranges then - p^.location.resflags:=F_C - else - p^.location.resflags:=F_E; - href.symbol := nil; - clear_reference(href); - getlabel(l); - href.symbol:=stringdup(lab2str(l)); - for i:=1 to numparts do - if setparts[i].range then - begin - {Check if left is in a range.} - {Get a label to jump over the check.} - href2.symbol := nil; - clear_reference(href2); - getlabel(l2); - href.symbol:=stringdup(lab2str(l2)); - if setparts[i].start=setparts[i].stop-1 then - begin - case p^.left^.location.loc of - LOC_REGISTER, - LOC_CREGISTER : - exprasmlist^.concat(new(pai386,op_const_reg(A_CMP,opsize, - setparts[i].start,pleftreg))); - else - exprasmlist^.concat(new(pai386,op_const_ref(A_CMP,S_B, - setparts[i].start,newreference(p^.left^.location.reference)))); - end; - {Result should be in carry flag when ranges are used.} - if ranges then - exprasmlist^.concat(new(pai386,op_none(A_STC,S_NO))); - {If found, jump to end.} - emitl(A_JE,l); - case p^.left^.location.loc of - LOC_REGISTER, - LOC_CREGISTER: - exprasmlist^.concat(new(pai386,op_const_reg(A_CMP,opsize, - setparts[i].stop,pleftreg))); - else - exprasmlist^.concat(new(pai386,op_const_ref(A_CMP,S_B, - setparts[i].stop,newreference(p^.left^.location.reference)))); - end; - {Result should be in carry flag when ranges are used.} - if ranges then - exprasmlist^.concat(new(pai386,op_none(A_STC,S_NO))); - {If found, jump to end.} - emitl(A_JE,l); - end - else - begin - if setparts[i].start<>0 then - begin - { We only check for the lower bound if it is > 0, because - set elements lower than 0 do nt exist.} - case p^.left^.location.loc of - LOC_REGISTER, - LOC_CREGISTER : - exprasmlist^.concat(new(pai386,op_const_reg(A_CMP,opsize, - setparts[i].start,pleftreg))); - else - exprasmlist^.concat(new(pai386,op_const_ref(A_CMP,S_B, - setparts[i].start,newreference(p^.left^.location.reference)))); - end; - {If lower, jump to next check.} - emitl(A_JB,l2); - end; - { We only check for the high bound if it is < 255, because - set elements higher than 255 do nt exist, the its always true, - so only a JMP is generated } - if setparts[i].stop<>255 then - begin - case p^.left^.location.loc of - LOC_REGISTER, - LOC_CREGISTER : - exprasmlist^.concat(new(pai386,op_const_reg(A_CMP,opsize, - setparts[i].stop+1,pleftreg))); - else - exprasmlist^.concat(new(pai386,op_const_ref(A_CMP,S_B, - setparts[i].stop+1,newreference(p^.left^.location.reference)))); - end; - {If higher, element is in set.} - emitl(A_JB,l); - end - else - begin - exprasmlist^.concat(new(pai386,op_none(A_STC,S_NO))); - emitl(A_JMP,l); - end; - end; - {Emit the jump over label.} - exprasmlist^.concat(new(pai_label,init(l2))); - end - else - begin - {Emit code to check if left is an element.} - case p^.left^.location.loc of - LOC_REGISTER, - LOC_CREGISTER: - exprasmlist^.concat(new(pai386,op_const_reg(A_CMP,opsize, - setparts[i].stop,pleftreg))); - else - exprasmlist^.concat(new(pai386,op_const_ref(A_CMP,S_B, - setparts[i].stop,newreference(p^.left^.location.reference)))); - end; - {Result should be in carry flag when ranges are used.} - if ranges then - exprasmlist^.concat(new(pai386,op_none(A_STC,S_NO))); - {If found, jump to end.} - emitl(A_JE,l); - end; - if ranges then - exprasmlist^.concat(new(pai386,op_none(A_CLC,S_NO))); - {To compensate for not doing a second pass.} - stringdispose(p^.right^.location.reference.symbol); - {Now place the end label.} - exprasmlist^.concat(new(pai_label,init(l))); - case p^.left^.location.loc of - LOC_REGISTER, - LOC_CREGISTER: - ungetregister32(pleftreg); - else - del_reference(p^.left^.location.reference); - end; - end - else - begin - { calculate both operators } - { the complex one first } - firstcomplex(p); - secondpass(p^.left); - { are too few registers free? } - pushed:=maybe_push(p^.right^.registers32,p); - secondpass(p^.right); - if pushed then restore(p); - { of course not commutative } - if p^.swaped then - swaptree(p); - pushsetelement(p^.left); - emitpushreferenceaddr(p^.right^.location.reference); - del_reference(p^.right^.location.reference); - { registers need not be save. that happens in SET_IN_BYTE } - { (EDI is changed) } - emitcall('SET_IN_BYTE',true); - { ungetiftemp(p^.right^.location.reference); } - p^.location.loc:=LOC_FLAGS; - p^.location.resflags:=F_C; - end; - end; - end; - end; -{***} procedure secondstatement(var p : ptree); var hp : ptree; - begin hp:=p; while assigned(hp) do - begin - { assignments could be distance optimized } - if assigned(hp^.right) then - begin - cleartempgen; - secondpass(hp^.right); - end; - hp:=hp^.left; - end; + begin + if assigned(hp^.right) then + begin + cleartempgen; + secondpass(hp^.right); + end; + hp:=hp^.left; + end; end; procedure secondblockn(var p : ptree); - begin - { do second pass on left node } - if assigned(p^.left) then - secondpass(p^.left); - end; - - - - procedure second_while_repeatn(var p : ptree); - - var - l1,l2,l3,oldclabel,oldblabel : plabel; - otlabel,oflabel : plabel; - - begin - getlabel(l1); - getlabel(l2); - { arrange continue and breaklabels: } - oldclabel:=aktcontinuelabel; - oldblabel:=aktbreaklabel; - if p^.treetype=repeatn then - begin - emitl(A_LABEL,l1); - aktcontinuelabel:=l1; - aktbreaklabel:=l2; - cleartempgen; - if assigned(p^.right) then - secondpass(p^.right); - - otlabel:=truelabel; - oflabel:=falselabel; - truelabel:=l2; - falselabel:=l1; - cleartempgen; - secondpass(p^.left); - maketojumpbool(p^.left); - emitl(A_LABEL,l2); - truelabel:=otlabel; - falselabel:=oflabel; - end - else - begin - { handling code at the end as it is much more efficient } - emitl(A_JMP,l2); - - emitl(A_LABEL,l1); - cleartempgen; - - getlabel(l3); - aktcontinuelabel:=l2; - aktbreaklabel:=l3; - - if assigned(p^.right) then - secondpass(p^.right); - - emitl(A_LABEL,l2); - otlabel:=truelabel; - oflabel:=falselabel; - truelabel:=l1; - falselabel:=l3; - cleartempgen; - secondpass(p^.left); - maketojumpbool(p^.left); - - emitl(A_LABEL,l3); - truelabel:=otlabel; - falselabel:=oflabel; - end; - aktcontinuelabel:=oldclabel; - aktbreaklabel:=oldblabel; - end; - - procedure secondifn(var p : ptree); - - var - hl,otlabel,oflabel : plabel; - - begin - otlabel:=truelabel; - oflabel:=falselabel; - getlabel(truelabel); - getlabel(falselabel); - cleartempgen; - secondpass(p^.left); - maketojumpbool(p^.left); - if assigned(p^.right) then - begin - emitl(A_LABEL,truelabel); - cleartempgen; - secondpass(p^.right); - end; - if assigned(p^.t1) then - begin - if assigned(p^.right) then - begin - getlabel(hl); - emitl(A_JMP,hl); - end; - emitl(A_LABEL,falselabel); - cleartempgen; - secondpass(p^.t1); - if assigned(p^.right) then - emitl(A_LABEL,hl); - end - else - emitl(A_LABEL,falselabel); - if not(assigned(p^.right)) then - emitl(A_LABEL,truelabel); - truelabel:=otlabel; - falselabel:=oflabel; - end; - - procedure secondbreakn(var p : ptree); - - begin - if aktbreaklabel<>nil then - emitl(A_JMP,aktbreaklabel) - else - Message(cg_e_break_not_allowed); - end; - - procedure secondcontinuen(var p : ptree); - - begin - if aktcontinuelabel<>nil then - emitl(A_JMP,aktcontinuelabel) - else - Message(cg_e_continue_not_allowed); - end; - - procedure secondfor(var p : ptree); - - var - l3,oldclabel,oldblabel : plabel; - omitfirstcomp,temptovalue : boolean; - hs : byte; - temp1 : treference; - hop : tasmop; - cmpreg,cmp32 : tregister; - opsize : topsize; - count_var_is_signed : boolean; - - begin - oldclabel:=aktcontinuelabel; - oldblabel:=aktbreaklabel; - getlabel(aktcontinuelabel); - getlabel(aktbreaklabel); - getlabel(l3); - - { could we spare the first comparison ? } - omitfirstcomp:=false; - if p^.right^.treetype=ordconstn then - if p^.left^.right^.treetype=ordconstn then - omitfirstcomp:=(p^.backward and (p^.left^.right^.value>=p^.right^.value)) - or (not(p^.backward) and (p^.left^.right^.value<=p^.right^.value)); - - { only calculate reference } - cleartempgen; - secondpass(p^.t2); - if not(simple_loadn) then - Message(cg_e_illegal_count_var); - - { produce start assignment } - cleartempgen; - secondpass(p^.left); - count_var_is_signed:=is_signed(porddef(p^.t2^.resulttype)); - hs:=p^.t2^.resulttype^.size; - cmp32:=getregister32; - case hs of - 1 : begin - opsize:=S_B; - cmpreg:=reg32toreg8(cmp32); - end; - 2 : begin - opsize:=S_W; - cmpreg:=reg32toreg16(cmp32); - end; - 4 : begin - opsize:=S_L; - cmpreg:=cmp32; - end; - end; - cleartempgen; - secondpass(p^.right); - { calculate pointer value and check if changeable and if so } - { load into temporary variable } - if p^.right^.treetype<>ordconstn then - begin - temp1.symbol:=nil; - gettempofsizereference(hs,temp1); - temptovalue:=true; - if (p^.right^.location.loc=LOC_REGISTER) or - (p^.right^.location.loc=LOC_CREGISTER) then - begin - exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,opsize,p^.right^.location.register, - newreference(temp1)))); - end - else - concatcopy(p^.right^.location.reference,temp1,hs,false); - end - else temptovalue:=false; - - if temptovalue then - begin - if p^.t2^.location.loc=LOC_CREGISTER then - begin - exprasmlist^.concat(new(pai386,op_ref_reg(A_CMP,opsize,newreference(temp1), - p^.t2^.location.register))); - end - else - begin - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,opsize,newreference(p^.t2^.location.reference), - cmpreg))); - exprasmlist^.concat(new(pai386,op_ref_reg(A_CMP,opsize,newreference(temp1), - cmpreg))); - end; - end - else - begin - if not(omitfirstcomp) then - begin - if p^.t2^.location.loc=LOC_CREGISTER then - exprasmlist^.concat(new(pai386,op_const_reg(A_CMP,opsize,p^.right^.value, - p^.t2^.location.register))) - else - exprasmlist^.concat(new(pai386,op_const_ref(A_CMP,opsize,p^.right^.value, - newreference(p^.t2^.location.reference)))); - end; - end; - if p^.backward then - if count_var_is_signed then - hop:=A_JL - else hop:=A_JB - else - if count_var_is_signed then - hop:=A_JG - else hop:=A_JA; - - if not(omitfirstcomp) or temptovalue then - emitl(hop,aktbreaklabel); - - emitl(A_LABEL,l3); - - { help register must not be in instruction block } - cleartempgen; - if assigned(p^.t1) then - secondpass(p^.t1); - - emitl(A_LABEL,aktcontinuelabel); - - { makes no problems there } - cleartempgen; - - { demand help register again } - cmp32:=getregister32; - case hs of - 1 : begin - opsize:=S_B; - cmpreg:=reg32toreg8(cmp32); - end; - 2 : begin - opsize:=S_W; - cmpreg:=reg32toreg16(cmp32); - end; - 4 : opsize:=S_L; - end; - - { produce comparison and the corresponding } - { jump } - if temptovalue then - begin - if p^.t2^.location.loc=LOC_CREGISTER then - begin - exprasmlist^.concat(new(pai386,op_ref_reg(A_CMP,opsize,newreference(temp1), - p^.t2^.location.register))); - end - else - begin - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,opsize,newreference(p^.t2^.location.reference), - cmpreg))); - exprasmlist^.concat(new(pai386,op_ref_reg(A_CMP,opsize,newreference(temp1), - cmpreg))); - end; - end - else - begin - if p^.t2^.location.loc=LOC_CREGISTER then - exprasmlist^.concat(new(pai386,op_const_reg(A_CMP,opsize,p^.right^.value, - p^.t2^.location.register))) - else - exprasmlist^.concat(new(pai386,op_const_ref(A_CMP,opsize,p^.right^.value, - newreference(p^.t2^.location.reference)))); - end; - if p^.backward then - if count_var_is_signed then - hop:=A_JLE - else - hop :=A_JBE - else - if count_var_is_signed then - hop:=A_JGE - else - hop:=A_JAE; - emitl(hop,aktbreaklabel); - { according to count direction DEC or INC... } - { must be after the test because of 0to 255 for bytes !! } - if p^.backward then - hop:=A_DEC - else hop:=A_INC; - - if p^.t2^.location.loc=LOC_CREGISTER then - exprasmlist^.concat(new(pai386,op_reg(hop,opsize,p^.t2^.location.register))) - else - exprasmlist^.concat(new(pai386,op_ref(hop,opsize,newreference(p^.t2^.location.reference)))); - emitl(A_JMP,l3); - - { this is the break label: } - emitl(A_LABEL,aktbreaklabel); - ungetregister32(cmp32); - - if temptovalue then - ungetiftemp(temp1); - - aktcontinuelabel:=oldclabel; - aktbreaklabel:=oldblabel; - end; - -{ var - hs : string; } - - procedure secondexitn(var p : ptree); - - var - is_mem : boolean; - {op : tasmop; - s : topsize;} - otlabel,oflabel : plabel; - - label - do_jmp; - - begin - if assigned(p^.left) then - begin - otlabel:=truelabel; - oflabel:=falselabel; - getlabel(truelabel); - getlabel(falselabel); - secondpass(p^.left); - case p^.left^.location.loc of - LOC_FPU : goto do_jmp; - LOC_MEM,LOC_REFERENCE : is_mem:=true; - LOC_CREGISTER, - LOC_REGISTER : is_mem:=false; - LOC_FLAGS : begin - exprasmlist^.concat(new(pai386,op_reg(flag_2_set[p^.right^.location.resflags],S_B,R_AL))); - goto do_jmp; - end; - LOC_JUMP : begin - emitl(A_LABEL,truelabel); - exprasmlist^.concat(new(pai386,op_const_reg(A_MOV,S_B,1,R_AL))); - emitl(A_JMP,aktexit2label); - exprasmlist^.concat(new(pai386,op_reg_reg(A_XOR,S_B,R_AL,R_AL))); - goto do_jmp; - end; - else internalerror(2001); - end; - if (procinfo.retdef^.deftype=orddef) then - begin - case porddef(procinfo.retdef)^.typ of - s32bit,u32bit,bool32bit : if is_mem then - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, - newreference(p^.left^.location.reference),R_EAX))) - else - emit_reg_reg(A_MOV,S_L,p^.left^.location.register,R_EAX); - u8bit,s8bit,uchar,bool8bit : if is_mem then - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_B, - newreference(p^.left^.location.reference),R_AL))) - else - emit_reg_reg(A_MOV,S_B,p^.left^.location.register,R_AL); - s16bit,u16bit,bool16bit : if is_mem then - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_W, - newreference(p^.left^.location.reference),R_AX))) - else - emit_reg_reg(A_MOV,S_W,p^.left^.location.register,R_AX); - end; - end - else - if (procinfo.retdef^.deftype in [pointerdef,enumdef,procvardef]) then - begin - if is_mem then - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, - newreference(p^.left^.location.reference),R_EAX))) - else - exprasmlist^.concat(new(pai386,op_reg_reg(A_MOV,S_L, - p^.left^.location.register,R_EAX))); - end - else - if (procinfo.retdef^.deftype=floatdef) then - begin - if pfloatdef(procinfo.retdef)^.typ=f32bit then - begin - if is_mem then - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, - newreference(p^.left^.location.reference),R_EAX))) - else - emit_reg_reg(A_MOV,S_L,p^.left^.location.register,R_EAX); - end - else - if is_mem then - floatload(pfloatdef(procinfo.retdef)^.typ,p^.left^.location.reference); - end; -do_jmp: - truelabel:=otlabel; - falselabel:=oflabel; - emitl(A_JMP,aktexit2label); - end - else - begin - emitl(A_JMP,aktexitlabel); - end; - end; - - procedure secondgoto(var p : ptree); - - begin - emitl(A_JMP,p^.labelnr); - end; - - procedure secondlabel(var p : ptree); - - begin - emitl(A_LABEL,p^.labelnr); - cleartempgen; + { do second pass on left node } + if assigned(p^.left) then secondpass(p^.left); end; + procedure secondasm(var p : ptree); - begin exprasmlist^.concatlist(p^.p_asm); if not p^.object_preserved then maybe_loadesi; end; - procedure secondcase(var p : ptree); - - var - with_sign : boolean; - opsize : topsize; - jmp_gt,jmp_le,jmp_lee : tasmop; - hp : ptree; - { register with case expression } - hregister : tregister; - endlabel,elselabel : plabel; - - { true, if we can omit the range check of the jump table } - jumptable_no_range : boolean; - { where to put the jump table } - jumpsegment : paasmoutput; - - procedure gentreejmp(p : pcaserecord); - - var - lesslabel,greaterlabel : plabel; - - begin - emitl(A_LABEL,p^._at); - { calculate labels for left and right } - if (p^.less=nil) then - lesslabel:=elselabel - else - lesslabel:=p^.less^._at; - if (p^.greater=nil) then - greaterlabel:=elselabel - else - greaterlabel:=p^.greater^._at; - { calculate labels for left and right } - { no range label: } - if p^._low=p^._high then - begin - exprasmlist^.concat(new(pai386,op_const_reg(A_CMP,opsize,p^._low,hregister))); - if greaterlabel=lesslabel then - begin - emitl(A_JNE,lesslabel); - end - else - begin - emitl(jmp_le,lesslabel); - emitl(jmp_gt,greaterlabel); - end; - emitl(A_JMP,p^.statement); - end - else - begin - exprasmlist^.concat(new(pai386,op_const_reg(A_CMP,opsize,p^._low,hregister))); - emitl(jmp_le,lesslabel); - exprasmlist^.concat(new(pai386,op_const_reg(A_CMP,opsize,p^._high,hregister))); - emitl(jmp_gt,greaterlabel); - emitl(A_JMP,p^.statement); - end; - if assigned(p^.less) then - gentreejmp(p^.less); - if assigned(p^.greater) then - gentreejmp(p^.greater); - end; - - procedure genlinearlist(hp : pcaserecord); - - var - first : boolean; - last : longint; - {helplabel : longint;} - - procedure genitem(t : pcaserecord); - - begin - if assigned(t^.less) then - genitem(t^.less); - if t^._low=t^._high then - begin - if t^._low-last=1 then - exprasmlist^.concat(new(pai386,op_reg(A_DEC,opsize,hregister))) - else if t^._low-last=0 then - exprasmlist^.concat(new(pai386,op_reg_reg(A_OR,opsize,hregister,hregister))) - else - exprasmlist^.concat(new(pai386,op_const_reg(A_SUB,opsize,t^._low-last,hregister))); - last:=t^._low; - - emitl(A_JZ,t^.statement); - end - else - begin - { it begins with the smallest label, if the value } - { is even smaller then jump immediately to the } - { ELSE-label } - if first then - begin - if t^._low-1=1 then - exprasmlist^.concat(new(pai386,op_reg(A_DEC,opsize, - hregister))) - else if t^._low-1=0 then - exprasmlist^.concat(new(pai386,op_reg_reg(A_OR,opsize, - hregister,hregister))) - else - exprasmlist^.concat(new(pai386,op_const_reg(A_SUB,opsize, - t^._low-1,hregister))); - { work around: if the lower range=0 and we - do the subtraction we have to take care - of the sign! - } - if t^._low=0 then - emitl(A_JLE,elselabel) - else - emitl(jmp_lee,elselabel); - end - { if there is no unused label between the last and the } - { present label then the lower limit can be checked } - { immediately. else check the range in between: } - else if (t^._low-last>1)then - begin - if t^._low-last-1=1 then - exprasmlist^.concat(new(pai386,op_reg(A_DEC,opsize,hregister))) - else - exprasmlist^.concat(new(pai386,op_const_reg(A_SUB,opsize,t^._low-last-1,hregister))); - emitl(jmp_lee,elselabel); - end; - exprasmlist^.concat(new(pai386,op_const_reg(A_SUB,opsize,t^._high-t^._low+1,hregister))); - emitl(jmp_lee,t^.statement); - - last:=t^._high; - end; - first:=false; - if assigned(t^.greater) then - genitem(t^.greater); - end; - - var - hr : tregister; - - begin - { case register is modified by the list evalution } - if (p^.left^.location.loc=LOC_CREGISTER) then - begin - hr:=getregister32; - case opsize of - S_B : hregister:=reg32toreg8(hr); - S_W : hregister:=reg32toreg16(hr); - S_L : hregister:=hr; - end; - end; - last:=0; - first:=true; - genitem(hp); - emitl(A_JMP,elselabel); - end; - - procedure genjumptable(hp : pcaserecord;min_,max_ : longint); - - var - table : plabel; - last : longint; - hr : preference; - - procedure genitem(t : pcaserecord); - - var - i : longint; - - begin - if assigned(t^.less) then - genitem(t^.less); - { fill possible hole } - for i:=last+1 to t^._low-1 do - jumpsegment^.concat(new(pai_const,init_symbol(strpnew(lab2str - (elselabel))))); - for i:=t^._low to t^._high do - jumpsegment^.concat(new(pai_const,init_symbol(strpnew(lab2str - (t^.statement))))); - last:=t^._high; - if assigned(t^.greater) then - genitem(t^.greater); - end; - - begin - if not(jumptable_no_range) then - begin - exprasmlist^.concat(new(pai386,op_const_reg(A_CMP,opsize,min_,hregister))); - { case expr less than min_ => goto elselabel } - emitl(jmp_le,elselabel); - exprasmlist^.concat(new(pai386,op_const_reg(A_CMP,opsize,max_,hregister))); - emitl(jmp_gt,elselabel); - end; - getlabel(table); - { extend with sign } - if opsize=S_W then - begin - exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVZX,S_WL,hregister, - reg16toreg32(hregister)))); - hregister:=reg16toreg32(hregister); - end - else if opsize=S_B then - begin - exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVZX,S_BL,hregister, - reg8toreg32(hregister)))); - hregister:=reg8toreg32(hregister); - end; - new(hr); - reset_reference(hr^); - hr^.symbol:=stringdup(lab2str(table)); - hr^.offset:=(-min_)*4; - hr^.index:=hregister; - hr^.scalefactor:=4; - exprasmlist^.concat(new(pai386,op_ref(A_JMP,S_NO,hr))); - { !!!!! generate tables - if not(cs_littlesize in aktswitches^ ) then - jumpsegment^.concat(new(pai386,op_const(A_ALIGN,S_NO,4))); - } - jumpsegment^.concat(new(pai_label,init(table))); - last:=min_; - genitem(hp); - { !!!!!!! - if not(cs_littlesize in aktswitches^ ) then - exprasmlist^.concat(new(pai386,op_const(A_ALIGN,S_NO,4))); - } - end; - - var - lv,hv,min_label,max_label,labels : longint; - max_linear_list : longint; - - begin - getlabel(endlabel); - getlabel(elselabel); - if (cs_smartlink in aktswitches) then - jumpsegment:=procinfo.aktlocaldata - else - jumpsegment:=datasegment; - with_sign:=is_signed(p^.left^.resulttype); - if with_sign then - begin - jmp_gt:=A_JG; - jmp_le:=A_JL; - jmp_lee:=A_JLE; - end - else - begin - jmp_gt:=A_JA; - jmp_le:=A_JB; - jmp_lee:=A_JBE; - end; - cleartempgen; - secondpass(p^.left); - { determines the size of the operand } - { determines the size of the operand } - opsize:=bytes2Sxx[p^.left^.resulttype^.size]; - { copy the case expression to a register } - { copy the case expression to a register } - case p^.left^.location.loc of - LOC_REGISTER, - LOC_CREGISTER: - hregister:=p^.left^.location.register; - LOC_MEM,LOC_REFERENCE : begin - del_reference(p^.left^.location.reference); - hregister:=getregister32; - case opsize of - S_B : hregister:=reg32toreg8(hregister); - S_W : hregister:=reg32toreg16(hregister); - end; - exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,opsize,newreference( - p^.left^.location.reference),hregister))); - end; - else internalerror(2002); - end; - { now generate the jumps } - if cs_optimize in aktswitches then - begin - { procedures are empirically passed on } - { consumption can also be calculated } - { but does it pay on the different } - { processors? } - { moreover can the size only be appro- } - { ximated as it is not known if rel8, } - { rel16 or rel32 jumps are used } - min_label:=case_get_min(p^.nodes); - max_label:=case_get_max(p^.nodes); - labels:=case_count_labels(p^.nodes); - { can we omit the range check of the jump table } - getrange(p^.left^.resulttype,lv,hv); - jumptable_no_range:=(lv=min_label) and (hv=max_label); - - { optimize for size ? } - if cs_littlesize in aktswitches then - begin - if (labels<=2) or ((max_label-min_label)>3*labels) then - { a linear list is always smaller than a jump tree } - genlinearlist(p^.nodes) - else - { if the labels less or more a continuum then } - genjumptable(p^.nodes,min_label,max_label); - end - else - begin - if jumptable_no_range then - max_linear_list:=4 - else - max_linear_list:=2; - { a jump table crashes the pipeline! } - if aktoptprocessor=i486 then - inc(max_linear_list,3); - if aktoptprocessor=pentium then - inc(max_linear_list,6); - if aktoptprocessor>=pentiumpro then - inc(max_linear_list,9); - - if (labels<=max_linear_list) then - genlinearlist(p^.nodes) - else - begin - if ((max_label-min_label)>4*labels) then - begin - if labels>16 then - gentreejmp(p^.nodes) - else - genlinearlist(p^.nodes); - end - else - genjumptable(p^.nodes,min_label,max_label); - end; - end; - end - else - { it's always not bad } - genlinearlist(p^.nodes); - - { now generate the instructions } - hp:=p^.right; - while assigned(hp) do - begin - cleartempgen; - secondpass(hp^.right); - emitl(A_JMP,endlabel); - hp:=hp^.left; - end; - emitl(A_LABEL,elselabel); - { ...and the else block } - if assigned(p^.elseblock) then - begin - cleartempgen; - secondpass(p^.elseblock); - end; - emitl(A_LABEL,endlabel); - end; - - { generates the code for a raise statement } - procedure secondraise(var p : ptree); - - var - a : plabel; - - begin - if assigned(p^.left) then - begin - { generate the address } - if assigned(p^.right) then - begin - secondpass(p^.right); - if codegenerror then - exit; - end - else - begin - getlabel(a); - emitl(A_LABEL,a); - exprasmlist^.concat(new(pai386, - op_csymbol(A_PUSH,S_L,newcsymbol(lab2str(a),0)))); - end; - secondpass(p^.left); - if codegenerror then - exit; - - case p^.left^.location.loc of - LOC_MEM,LOC_REFERENCE : emitpushreferenceaddr(p^.left^.location.reference); - LOC_CREGISTER,LOC_REGISTER : exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L, - p^.left^.location.register))); - else Message(sym_e_type_mismatch); - end; - emitcall('DO_RAISE',true); - end - else - emitcall('DO_RERAISE',true); - end; - - procedure secondtryexcept(var p : ptree); - - begin - end; - - procedure secondtryfinally(var p : ptree); - - begin - end; - - procedure secondfail(var p : ptree); - - var hp : preference; - - begin - {if procinfo.exceptions then - aktproccode.concat(gennasmrec(CALL,S_NO,'HELP_DESTRUCTOR_E')) - else } - { we should know if the constructor is called with a new or not, - how can we do that ??? - exprasmlist^.concat(new(pai386,op_csymbol(A_CALL,S_NO,newcsymbol('HELP_DESTRUCTOR',0)))); - } - exprasmlist^.concat(new(pai386,op_reg_reg(A_XOR,S_L,R_ESI,R_ESI))); - { also reset to zero in the stack } - new(hp); - reset_reference(hp^); - hp^.offset:=procinfo.ESI_offset; - hp^.base:=procinfo.framepointer; - exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L,R_ESI,hp))); - exprasmlist^.concat(new(pai_labeled,init(A_JMP,quickexitlabel))); - end; - - procedure secondwith(var p : ptree); - - var - ref : treference; - symtable : psymtable; - i : longint; - - begin - if assigned(p^.left) then - begin - secondpass(p^.left); - ref.symbol:=nil; - gettempofsizereference(4,ref); - exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L, - newreference(p^.left^.location.reference),R_EDI))); - exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L, - R_EDI,newreference(ref)))); - del_reference(p^.left^.location.reference); - { the offset relative to (%ebp) is only needed here! } - symtable:=p^.withsymtable; - for i:=1 to p^.tablecount do - begin - symtable^.datasize:=ref.offset; - symtable:=symtable^.next; - end; - - { p^.right can be optimize out !!! } - if p^.right<>nil then - secondpass(p^.right); - { clear some stuff } - ungetiftemp(ref); - end; - end; - - { implementation not complete yet } - - var addr_correction : longint; - - procedure correct_address(p : psym); - - begin - if p^.typ=varsym then - begin - inc(pvarsym(p)^.address,addr_correction); -{$ifdef extdebug} - Comment(V_debug,pvarsym(p)^.name+' is at offset -' - +tostr(pvarsym(p)^.address)); - exprasmlist^.concat(new(pai_asm_comment,init( - strpnew(pvarsym(p)^.name+' is at offset -' - +tostr(pvarsym(p)^.address))))); -{$endif extdebug} - end; - end; - - procedure secondprocinline(var p : ptree); - - var st : psymtable; - oldprocsym : pprocsym; - para_size : longint; - oldprocinfo : tprocinfo; - old_make_const_global : boolean; - { just dummies for genentrycode } - nostackframe,make_global : boolean; - proc_names : tstringcontainer; - inlineentrycode,inlineexitcode : paasmoutput; - oldexitlabel,oldexit2label,oldquickexitlabel:Plabel; - begin - oldexitlabel:=aktexitlabel; - oldexit2label:=aktexit2label; - oldquickexitlabel:=quickexitlabel; - getlabel(aktexitlabel); - getlabel(aktexit2label); - oldprocsym:=aktprocsym; - oldprocinfo:=procinfo; - { set the return value } - procinfo.retdef:=p^.inlineprocdef^.retdef; - procinfo.retoffset:=p^.retoffset; - { arg space has been filled by the parent secondcall } - st:=p^.inlineprocdef^.localst; - { set it to the same lexical level } - st^.symtablelevel:= - oldprocsym^.definition^.localst^.symtablelevel; - old_make_const_global:=make_const_global; - make_const_global:=true; - if st^.datasize>0 then - st^.call_offset:=gettempofsizepersistant(st^.datasize); -{$ifdef extdebug} - Comment(V_debug,'local symtable is at offset ' - +tostr(st^.call_offset)); - exprasmlist^.concat(new(pai_asm_comment,init( - strpnew('local symtable is at offset ' - +tostr(st^.call_offset))))); -{$endif extdebug} - addr_correction:=-st^.call_offset-st^.datasize; - st^.foreach(correct_address); -{$ifdef extdebug} - exprasmlist^.concat(new(pai_asm_comment,init('Start of inlined proc'))); -{$endif extdebug} - { takes care of local data initialization } - inlineentrycode:=new(paasmoutput,init); - inlineexitcode:=new(paasmoutput,init); - proc_names.init; - para_size:=p^.para_size; - make_global:=false; { to avoid warning } - genentrycode(inlineentrycode,proc_names,make_global, - 0,para_size,nostackframe,true); - exprasmlist^.concatlist(inlineentrycode); - secondpass(p^.left); - genexitcode(inlineexitcode,0,false,true); - exprasmlist^.concatlist(inlineexitcode); -{$ifdef extdebug} - exprasmlist^.concat(new(pai_asm_comment,init('End of inlined proc'))); -{$endif extdebug} - {we can free the local data now } - if st^.datasize>0 then - ungetpersistanttemp(st^.call_offset,st^.datasize); - { set the real address again } - addr_correction:=-addr_correction; - st^.foreach(correct_address); - aktprocsym:=oldprocsym; - aktexitlabel:=oldexitlabel; - aktexit2label:=oldexit2label; - quickexitlabel:=oldquickexitlabel; - make_const_global:=old_make_const_global; - procinfo:=oldprocinfo; - end; - procedure secondpass(var p : ptree); - const - procedures : array[ttreetyp] of secondpassproc = - (secondadd,secondadd,secondadd,secondmoddiv,secondadd, - secondmoddiv,secondassignment,secondload,secondnothing, - secondadd,secondadd,secondadd,secondadd, - secondadd,secondadd,secondin,secondadd, - secondadd,secondshlshr,secondshlshr,secondadd, - secondadd,secondsubscriptn,secondderef,secondaddr, + procedures : array[ttreetyp] of secondpassproc = + (secondadd,secondadd,secondadd,secondmoddiv,secondadd, + secondmoddiv,secondassignment,secondload,secondnothing, + secondadd,secondadd,secondadd,secondadd, + secondadd,secondadd,secondin,secondadd, + secondadd,secondshlshr,secondshlshr,secondadd, + secondadd,secondsubscriptn,secondderef,secondaddr, seconddoubleaddr, secondordconst,secondtypeconv,secondcalln,secondnothing, secondrealconst,secondfixconst,secondumminus, @@ -4813,8 +257,8 @@ do_jmp: current_module^.current_inputfile^.line_no:=oldnr; end; - function do_secondpass(var p : ptree) : boolean; + function do_secondpass(var p : ptree) : boolean; begin codegenerror:=false; if not(p^.error) then @@ -4822,6 +266,8 @@ do_jmp: do_secondpass:=codegenerror; end; + + var regvars : array[1..maxvarregs] of pvarsym; regvars_para : array[1..maxvarregs] of boolean; @@ -4930,7 +376,7 @@ do_jmp: } if assigned(aktprocsym) then begin - if (aktprocsym^.definition^.options and + if (aktprocsym^.definition^.options and poconstructor+podestructor{+poinline}+pointerrupt=0) and ((procinfo.flags and pi_do_call)=0) and (lexlevel>1) then begin @@ -5070,7 +516,10 @@ do_jmp: end. { $Log$ - Revision 1.35 1998-06-05 16:13:32 pierre + Revision 1.36 1998-06-05 17:49:54 peter + * cleanup of cgai386 + + Revision 1.35 1998/06/05 16:13:32 pierre * fix for real and string consts inside inlined procs Revision 1.34 1998/06/05 14:37:27 pierre diff --git a/compiler/cws.txt b/compiler/cws.txt index a5768243cc..14f2dd0262 100644 --- a/compiler/cws.txt +++ b/compiler/cws.txt @@ -16,27 +16,26 @@ Location of the codegenerator functions The names are given for the i386, for the m68k rename the 386 to 68k cg386con - Constant generation - - secondordconst - - secondrealconst - - secondstringconst - - secondfixconst - - secondsetconst - - secondniln - + - secondordconst + - secondrealconst + - secondstringconst + - secondfixconst + - secondsetconst + - secondniln cg386mat - Mathematic functions - - secondmoddiv - - secondshlshr - - secondumminus - - secondnot + - secondmoddiv + - secondshlshr + - secondumminus + - secondnot cg386cnv - Type conversion functions - - secondtypeconv - + - secondtypeconv + - secondis + - secondas cg386add - Add/concat functions - - secondadd - + - secondadd cg386mem - Memory functions - secondvecn @@ -50,9 +49,6 @@ cg386mem - Memory functions - secondloadvmt - secondsubscriptn - secondderef - - secondis - - secondas - cg386flw - Flow functions - secondifn @@ -73,7 +69,6 @@ cg386ld - Load/Store functions - secondassignment - secondfuncret - cg386set - Set functions - secondcase - secondin @@ -87,7 +82,6 @@ cg386cal - Call/inline functions cgi386 - Main secondpass handling - secondnothing - seconderror - - secondasm, - - secondblockn, - - secondstatement, - \ No newline at end of file + - secondasm + - secondblockn + - secondstatement