{ $Id$ Copyright (c) 1993-98 by Florian Klaempfl Generate i386 inline nodes This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. **************************************************************************** } unit cg386inl; interface uses tree; procedure secondinline(var p : ptree); implementation uses globtype,systems, cobjects,verbose,globals,files, symconst,symtable,aasm,types, hcodegen,temp_gen,pass_1,pass_2, cpubase,cpuasm, cgai386,tgeni386,cg386cal; {***************************************************************************** Helpers *****************************************************************************} { 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; {***************************************************************************** SecondInLine *****************************************************************************} procedure StoreDirectFuncResult(var dest:ptree); var hp : ptree; hdef : porddef; hreg : tregister; hregister : tregister; oldregisterdef : boolean; begin { Get the accumulator first so it can't be used in the dest } hregister:=getexplicitregister32(accumulator); { process dest } SecondPass(dest); if Codegenerror then exit; { store the value } Case dest^.resulttype^.deftype of floatdef: floatstore(PFloatDef(dest^.resulttype)^.typ,dest^.location.reference); orddef: begin if porddef(dest^.resulttype)^.typ in [u64bit,s64bit] then begin emit_movq_reg_loc(R_EDX,R_EAX,dest^.location); end else begin Case dest^.resulttype^.size of 1 : hreg:=regtoreg8(hregister); 2 : hreg:=regtoreg16(hregister); 4 : hreg:=hregister; End; emit_mov_reg_loc(hreg,dest^.location); If (cs_check_range in aktlocalswitches) and {no need to rangecheck longints or cardinals on 32bit processors} not((porddef(dest^.resulttype)^.typ = s32bit) and (porddef(dest^.resulttype)^.low = $80000000) and (porddef(dest^.resulttype)^.high = $7fffffff)) and not((porddef(dest^.resulttype)^.typ = u32bit) and (porddef(dest^.resulttype)^.low = 0) and (porddef(dest^.resulttype)^.high = $ffffffff)) then Begin {do not register this temporary def} OldRegisterDef := RegisterDef; RegisterDef := False; hdef:=nil; Case PordDef(dest^.resulttype)^.typ of u8bit,u16bit,u32bit: begin new(hdef,init(u32bit,0,$ffffffff)); hreg:=hregister; end; s8bit,s16bit,s32bit: begin new(hdef,init(s32bit,$80000000,$7fffffff)); hreg:=hregister; end; end; { create a fake node } hp := genzeronode(nothingn); hp^.location.loc := LOC_REGISTER; hp^.location.register := hreg; if assigned(hdef) then hp^.resulttype:=hdef else hp^.resulttype:=dest^.resulttype; { emit the range check } emitrangecheck(hp,dest^.resulttype); hp^.right := nil; if assigned(hdef) then Dispose(hdef, Done); RegisterDef := OldRegisterDef; disposetree(hp); End; end; End; else internalerror(66766766); end; { free used registers } del_locref(dest^.location); ungetregister(hregister); end; procedure secondinline(var p : ptree); const {tfloattype = (s32real,s64real,s80real,s64bit,f16bit,f32bit);} { float_name: array[tfloattype] of string[8]= ('S32REAL','S64REAL','S80REAL','S64BIT','F16BIT','F32BIT'); } incdecop:array[in_inc_x..in_dec_x] of tasmop=(A_INC,A_DEC); addsubop:array[in_inc_x..in_dec_x] of tasmop=(A_ADD,A_SUB); var aktfile : treference; ft : tfiletype; opsize : topsize; op, asmop : tasmop; pushed : tpushed; {inc/dec} addconstant : boolean; addvalue : longint; procedure handlereadwrite(doread,doln : boolean); { produces code for READ(LN) and WRITE(LN) } procedure loadstream; const io:array[boolean] of string[7]=('_OUTPUT','_INPUT'); var r : preference; begin new(r); reset_reference(r^); r^.symbol:=newasmsymbol('U_'+upper(target_info.system_unit)+io[doread]); emit_ref_reg(A_LEA,S_L,r,R_EDI) end; const rdwrprefix:array[boolean] of string[15]=('FPC_WRITE_TEXT_','FPC_READ_TEXT_'); var node,hp : ptree; typedtyp, pararesult : pdef; orgfloattype : tfloattype; has_length : boolean; dummycoll : tdefcoll; iolabel : pasmlabel; npara : longint; begin { here we don't use register calling conventions } dummycoll.register:=R_NO; { I/O check } if (cs_check_io in aktlocalswitches) and not(po_iocheck in aktprocsym^.definition^.procoptions) then begin getlabel(iolabel); emitlab(iolabel); end else iolabel:=nil; { 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 { the following instructions are for "writeln;" } loadstream; { save @aktfile in temporary variable } emit_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 } if node^.left^.location.loc<>LOC_REFERENCE then begin CGMessage(cg_e_illegal_expression); exit; end; emit_ref_reg(A_LEA,S_L,newreference(node^.left^.location.reference),R_EDI); { skip to the next parameter } node:=node^.right; end else begin { load stdin/stdout stream } loadstream; end; { save @aktfile in temporary variable } emit_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 { this is to avoid copy of simple const parameters } {dummycoll.data:=new(pformaldef,init)} dummycoll.data:=cformaldef 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 CGMessage(parser_e_illegal_colon_qualifier); { when float is written then we need bestreal to be pushed convert here else we loose the old flaot type } if (not doread) and (ft<>ft_typed) and (hp^.left^.resulttype^.deftype=floatdef) then begin orgfloattype:=pfloatdef(hp^.left^.resulttype)^.typ; hp^.left:=gentypeconvnode(hp^.left,bestrealdef^); firstpass(hp^.left); end; { when read ord,floats are functions, so they need this parameter as their destination instead of being pushed } if doread and (ft<>ft_typed) and (hp^.resulttype^.deftype in [orddef,floatdef]) then begin end else begin if ft=ft_typed then never_copy_const_param:=true; { reset data type } dummycoll.data:=nil; { create temporary defs for high tree generation } if doread and (is_shortstring(hp^.resulttype)) then dummycoll.data:=openshortstringdef else if (is_chararray(hp^.resulttype)) then dummycoll.data:=openchararraydef; secondcallparan(hp,@dummycoll,false,false,false,0); if ft=ft_typed then never_copy_const_param:=false; end; 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('FPC_TYPED_READ') else emitcall('FPC_TYPED_WRITE'); 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,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,false,0); hp^.right:=node; if pararesult^.deftype<>floatdef then CGMessage(parser_e_illegal_colon_qualifier); if codegenerror then exit; end else begin if pararesult^.deftype=floatdef then push_int(-1); end; { push also the real type for floats } if pararesult^.deftype=floatdef then push_int(ord(orgfloattype)); end; case pararesult^.deftype of stringdef : begin emitcall(rdwrprefix[doread]+pstringdef(pararesult)^.stringtypname); end; pointerdef : begin if is_pchar(pararesult) then emitcall(rdwrprefix[doread]+'PCHAR_AS_POINTER') end; arraydef : begin if is_chararray(pararesult) then emitcall(rdwrprefix[doread]+'PCHAR_AS_ARRAY') end; floatdef : begin emitcall(rdwrprefix[doread]+'FLOAT'); if pfloatdef(p^.resulttype)^.typ<>f32bit then inc(fpuvaroffset); if doread then StoreDirectFuncResult(hp^.left); end; orddef : begin case porddef(pararesult)^.typ of s8bit,s16bit,s32bit : emitcall(rdwrprefix[doread]+'SINT'); u8bit,u16bit,u32bit : emitcall(rdwrprefix[doread]+'UINT'); uchar : emitcall(rdwrprefix[doread]+'CHAR'); s64bit : emitcall(rdwrprefix[doread]+'INT64'); u64bit : emitcall(rdwrprefix[doread]+'QWORD'); bool8bit, bool16bit, bool32bit : emitcall(rdwrprefix[doread]+'BOOLEAN'); end; if doread then StoreDirectFuncResult(hp^.left); end; end; end; { load ESI in methods again } popusedregisters(pushed); maybe_loadesi; end; end; { Insert end of writing for textfiles } if ft=ft_text then begin pushusedregisters(pushed,$ff); emit_push_mem(aktfile); if doread then begin if doln then emitcall('FPC_READLN_END') else emitcall('FPC_READ_END'); end else begin if doln then emitcall('FPC_WRITELN_END') else emitcall('FPC_WRITE_END'); end; popusedregisters(pushed); maybe_loadesi; end; { Insert IOCheck if set } if assigned(iolabel) then begin { registers are saved in the procedure } emit_sym(A_PUSH,S_L,iolabel); emitcall('FPC_IOCHECK'); end; { Freeup all used temps } ungetiftemp(aktfile); if assigned(p^.left) then begin p^.left:=reversparameter(p^.left); if npara<>nb_para then CGMessage(cg_f_internal_error_in_secondinline); hp:=p^.left; while assigned(hp) do begin if assigned(hp^.left) then if (hp^.left^.location.loc in [LOC_MEM,LOC_REFERENCE]) 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; realtype : tfloattype; procedureprefix : string; begin dummycoll.register:=R_NO; 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 begin is_real:=true; realtype:=pfloatdef(node^.left^.resulttype)^.typ; end; node:=p^.left; { we have at least two args } { with at max 2 colon_para in between } { string arg } hp:=node; node:=node^.right; hp^.right:=nil; dummycoll.paratyp:=vs_var; if is_shortstring(hp^.resulttype) then dummycoll.data:=openshortstringdef else dummycoll.data:=hp^.resulttype; procedureprefix:='FPC_'+pstringdef(hp^.resulttype)^.stringtypname+'_'; secondcallparan(hp,@dummycoll,false,false,false,0); if codegenerror then exit; dummycoll.paratyp:=vs_const; disposetree(p^.left); p^.left:=nil; { second arg } hp:=node; node:=node^.right; hp^.right:=nil; { if real push real type } if is_real then push_int(ord(realtype)); { 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,false,0 ); if codegenerror then exit; disposetree(hp); 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,false,0 ); if codegenerror then exit; disposetree(hp); hp:=node; node:=node^.right; hp^.right:=nil; end else if is_real then push_int(-32767) else push_int(-1); { Convert float to bestreal } if is_real then begin hp^.left:=gentypeconvnode(hp^.left,bestrealdef^); firstpass(hp^.left); end; { last arg longint or real } secondcallparan(hp,@dummycoll,false ,false,false,0 ); if codegenerror then exit; if is_real then emitcall(procedureprefix+'FLOAT') else case porddef(hp^.resulttype)^.typ of u32bit: emitcall(procedureprefix+'CARDINAL'); u64bit: emitcall(procedureprefix+'QWORD'); s64bit: emitcall(procedureprefix+'INT64'); else emitcall(procedureprefix+'LONGINT'); end; disposetree(hp); popusedregisters(pushed); end; Procedure Handle_Val; var hp,node, code_para, dest_para : ptree; hreg,hreg2: TRegister; hdef: POrdDef; procedureprefix : string; hr, hr2: TReference; dummycoll : tdefcoll; has_code, has_32bit_code, oldregisterdef: boolean; r : preference; begin dummycoll.register:=R_NO; node:=p^.left; hp:=node; node:=node^.right; hp^.right:=nil; {if we have 3 parameters, we have a code parameter} has_code := Assigned(node^.right); has_32bit_code := false; reset_reference(hr); hreg := R_NO; If has_code then Begin {code is an orddef, that's checked in tcinl} code_para := hp; hp := node; node := node^.right; hp^.right := nil; has_32bit_code := (porddef(code_para^.left^.resulttype)^.typ in [u32bit,s32bit]); End; {hp = destination now, save for later use} dest_para := hp; {if EAX is already in use, it's a register variable. Since we don't need another register besides EAX, release the one we got} If hreg <> R_EAX Then ungetregister32(hreg); {load and push the address of the destination} dummycoll.paratyp:=vs_var; dummycoll.data:=dest_para^.resulttype; secondcallparan(dest_para,@dummycoll,false,false,false,0); if codegenerror then exit; {save the regvars} pushusedregisters(pushed,$ff); {now that we've already pushed the addres of dest_para^.left on the stack, we can put the real parameters on the stack} If has_32bit_code Then Begin dummycoll.paratyp:=vs_var; dummycoll.data:=code_para^.resulttype; secondcallparan(code_para,@dummycoll,false,false,false,0); if codegenerror then exit; Disposetree(code_para); End Else Begin {only 32bit code parameter is supported, so fake one} GetTempOfSizeReference(4,hr); emitpushreferenceaddr(hr); End; {node = first parameter = string} dummycoll.paratyp:=vs_const; dummycoll.data:=node^.resulttype; secondcallparan(node,@dummycoll,false,false,false,0); if codegenerror then exit; Case dest_para^.resulttype^.deftype of floatdef: begin procedureprefix := 'FPC_VAL_REAL_'; if pfloatdef(p^.resulttype)^.typ<>f32bit then inc(fpuvaroffset); end; orddef: if is_64bitint(dest_para^.resulttype) then begin if is_signed(dest_para^.resulttype) then procedureprefix := 'FPC_VAL_INT64_' else procedureprefix := 'FPC_VAL_QWORD_'; end else begin if is_signed(dest_para^.resulttype) then begin {if we are converting to a signed number, we have to include the size of the destination, so the Val function can extend the sign of the result to allow proper range checking} emit_const(A_PUSH,S_L,dest_para^.resulttype^.size); procedureprefix := 'FPC_VAL_SINT_' end else procedureprefix := 'FPC_VAL_UINT_'; end; End; emitcall(procedureprefix+pstringdef(node^.resulttype)^.stringtypname); { before disposing node we need to ungettemp !! PM } if node^.left^.location.loc in [LOC_REFERENCE,LOC_MEM] then ungetiftemp(node^.left^.location.reference); disposetree(node); p^.left := nil; {reload esi in case the dest_para/code_para is a class variable or so} maybe_loadesi; If (dest_para^.resulttype^.deftype = orddef) Then Begin {store the result in a safe place, because EAX may be used by a register variable} hreg := getexplicitregister32(R_EAX); emit_reg_reg(A_MOV,S_L,R_EAX,hreg); if is_64bitint(dest_para^.resulttype) then begin hreg2:=getexplicitregister32(R_EDX); emit_reg_reg(A_MOV,S_L,R_EDX,hreg2); end; {as of now, hreg now holds the location of the result, if it was integer} End; { restore the register vars} popusedregisters(pushed); If has_code and Not(has_32bit_code) Then {only 16bit code is possible} Begin {load the address of the code parameter} secondpass(code_para^.left); {move the code to its destination} emit_ref_reg(A_MOV,S_L,NewReference(hr),R_EDI); emit_mov_reg_loc(R_DI,code_para^.left^.location); Disposetree(code_para); End; {restore the address of the result} emit_reg(A_POP,S_L,R_EDI); {set up hr2 to a refernce with EDI as base register} reset_reference(hr2); hr2.base := R_EDI; {save the function result in the destination variable} Case dest_para^.left^.resulttype^.deftype of floatdef: floatstore(PFloatDef(dest_para^.left^.resulttype)^.typ, hr2); orddef: Case PordDef(dest_para^.left^.resulttype)^.typ of u8bit,s8bit: emit_reg_ref(A_MOV, S_B, RegToReg8(hreg),newreference(hr2)); u16bit,s16bit: emit_reg_ref(A_MOV, S_W, RegToReg16(hreg),newreference(hr2)); u32bit,s32bit: emit_reg_ref(A_MOV, S_L, hreg,newreference(hr2)); u64bit,s64bit: begin emit_reg_ref(A_MOV, S_L, hreg,newreference(hr2)); r:=newreference(hr2); inc(r^.offset,4); emit_reg_ref(A_MOV, S_L, hreg2,r); end; End; End; If (cs_check_range in aktlocalswitches) and (dest_para^.left^.resulttype^.deftype = orddef) and (not(is_64bitint(dest_para^.left^.resulttype))) and {the following has to be changed to 64bit checking, once Val returns 64 bit values (unless a special Val function is created for that)} {no need to rangecheck longints or cardinals on 32bit processors} not((porddef(dest_para^.left^.resulttype)^.typ = s32bit) and (porddef(dest_para^.left^.resulttype)^.low = $80000000) and (porddef(dest_para^.left^.resulttype)^.high = $7fffffff)) and not((porddef(dest_para^.left^.resulttype)^.typ = u32bit) and (porddef(dest_para^.left^.resulttype)^.low = 0) and (porddef(dest_para^.left^.resulttype)^.high = $ffffffff)) then Begin hp := getcopy(dest_para^.left); hp^.location.loc := LOC_REGISTER; hp^.location.register := hreg; {do not register this temporary def} OldRegisterDef := RegisterDef; RegisterDef := False; Case PordDef(dest_para^.left^.resulttype)^.typ of u8bit,u16bit,u32bit: new(hdef,init(u32bit,0,$ffffffff)); s8bit,s16bit,s32bit: new(hdef,init(s32bit,$80000000,$7fffffff)); end; hp^.resulttype := hdef; emitrangecheck(hp,dest_para^.left^.resulttype); hp^.right := nil; Dispose(hp^.resulttype, Done); RegisterDef := OldRegisterDef; disposetree(hp); End; {dest_para^.right is already nil} disposetree(dest_para); UnGetIfTemp(hr); end; var r : preference; hp : ptree; l : longint; ispushed : boolean; hregister : tregister; otlabel,oflabel : pasmlabel; oldpushedparasize : longint; begin { save & reset pushedparasize } oldpushedparasize:=pushedparasize; pushedparasize:=0; case p^.inlinenumber of in_assert_x_y: begin otlabel:=truelabel; oflabel:=falselabel; getlabel(truelabel); getlabel(falselabel); secondpass(p^.left^.left); if cs_do_assertion in aktlocalswitches then begin maketojumpbool(p^.left^.left); emitlab(falselabel); { erroraddr } emit_reg(A_PUSH,S_L,R_EBP); { lineno } emit_const(A_PUSH,S_L,aktfilepos.line); { filename string } hp:=genstringconstnode(current_module^.sourcefiles^.get_file_name(aktfilepos.fileindex)); secondpass(hp); if codegenerror then exit; emitpushreferenceaddr(hp^.location.reference); disposetree(hp); { push msg } secondpass(p^.left^.right^.left); emitpushreferenceaddr(p^.left^.right^.left^.location.reference); { call } emitcall('FPC_ASSERT'); emitlab(truelabel); end; freelabel(truelabel); freelabel(falselabel); truelabel:=otlabel; falselabel:=oflabel; end; 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); emit_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 emit_const_reg(A_SHR,S_W,8,p^.location.register); p^.location.register:=reg16toreg8(p^.location.register); end; in_sizeof_x, in_typeof_x : begin { for both cases load vmt } if p^.left^.treetype=typen then begin p^.location.register:=getregister32; emit_sym_ofs_reg(A_MOV, S_L,newasmsymbol(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 } inc(p^.left^.location.reference.offset, pobjectdef(p^.left^.resulttype)^.vmt_offset); emit_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; emit_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; emit_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 emit_const_reg(A_SHR,S_L,16,p^.location.register); p^.location.register:=reg32toreg16(p^.location.register); end; in_lo_qword, in_hi_qword: begin secondpass(p^.left); p^.location.loc:=LOC_REGISTER; case p^.left^.location.loc of LOC_CREGISTER: begin p^.location.register:=getregister32; if p^.inlinenumber=in_hi_qword then emit_reg_reg(A_MOV,S_L,p^.left^.location.registerhigh, p^.location.register) else emit_reg_reg(A_MOV,S_L,p^.left^.location.registerlow, p^.location.register) end; LOC_MEM,LOC_REFERENCE: begin del_reference(p^.left^.location.reference); p^.location.register:=getregister32; r:=newreference(p^.left^.location.reference); if p^.inlinenumber=in_hi_qword then inc(r^.offset,4); emit_ref_reg(A_MOV,S_L, r,p^.location.register); end; LOC_REGISTER: begin if p^.inlinenumber=in_hi_qword then begin p^.location.register:=p^.left^.location.registerhigh; ungetregister32(p^.left^.location.registerlow); end else begin p^.location.register:=p^.left^.location.registerlow; ungetregister32(p^.left^.location.registerhigh); end; end; end; end; in_length_string : begin secondpass(p^.left); set_location(p^.location,p^.left^.location); { length in ansi strings is at offset -8 } if is_ansistring(p^.left^.resulttype) then dec(p^.location.reference.offset,8) { char is always 1, so make it a constant value } else if is_char(p^.left^.resulttype) then begin clear_location(p^.location); p^.location.loc:=LOC_MEM; p^.location.reference.is_immediate:=true; p^.location.reference.offset:=1; end; end; in_pred_x, in_succ_x: begin secondpass(p^.left); if not (cs_check_overflow in aktlocalswitches) then if p^.inlinenumber=in_pred_x then asmop:=A_DEC else asmop:=A_INC else if p^.inlinenumber=in_pred_x then asmop:=A_SUB else asmop:=A_ADD; 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 emit_flag2reg(p^.left^.location.resflags,p^.location.register) else begin del_reference(p^.left^.location.reference); emit_ref_reg(A_MOV,opsize,newreference(p^.left^.location.reference), p^.location.register); end; end else p^.location.register:=p^.left^.location.register; if not (cs_check_overflow in aktlocalswitches) then emit_reg(asmop,opsize, p^.location.register) else emit_const_reg(asmop,opsize,1, p^.location.register); emitoverflowcheck(p); emitrangecheck(p,p^.resulttype); end; in_dec_x, in_inc_x : begin { set defaults } addvalue:=1; addconstant:=true; { load first parameter, must be a reference } secondpass(p^.left^.left); case p^.left^.left^.resulttype^.deftype of orddef, enumdef : begin case p^.left^.left^.resulttype^.size of 1 : opsize:=S_B; 2 : opsize:=S_W; 4 : opsize:=S_L; end; end; pointerdef : begin opsize:=S_L; if porddef(ppointerdef(p^.left^.left^.resulttype)^.definition)=voiddef then addvalue:=1 else addvalue:=ppointerdef(p^.left^.left^.resulttype)^.definition^.size; end; else internalerror(10081); end; { second argument specified?, must be a s32bit in register } if assigned(p^.left^.right) then begin secondpass(p^.left^.right^.left); { when constant, just multiply the addvalue } if is_constintnode(p^.left^.right^.left) then addvalue:=addvalue*get_ordinal_value(p^.left^.right^.left) else begin case p^.left^.right^.left^.location.loc of LOC_REGISTER, LOC_CREGISTER : hregister:=p^.left^.right^.left^.location.register; LOC_MEM, LOC_REFERENCE : begin del_reference(p^.left^.right^.left^.location.reference); hregister:=getregister32; emit_ref_reg(A_MOV,S_L, newreference(p^.left^.right^.left^.location.reference),hregister); end; else internalerror(10082); end; { insert multiply with addvalue if its >1 } if addvalue>1 then emit_const_reg(A_IMUL,opsize, addvalue,hregister); addconstant:=false; end; end; { write the add instruction } if addconstant then begin if (addvalue=1) and not(cs_check_overflow in aktlocalswitches) then begin if p^.left^.left^.location.loc=LOC_CREGISTER then emit_reg(incdecop[p^.inlinenumber],opsize, p^.left^.left^.location.register) else emit_ref(incdecop[p^.inlinenumber],opsize, newreference(p^.left^.left^.location.reference)) end else begin if p^.left^.left^.location.loc=LOC_CREGISTER then emit_const_reg(addsubop[p^.inlinenumber],opsize, addvalue,p^.left^.left^.location.register) else emit_const_ref(addsubop[p^.inlinenumber],opsize, addvalue,newreference(p^.left^.left^.location.reference)); end end else begin { BUG HERE : detected with nasm : hregister is allways 32 bit it should be converted to 16 or 8 bit depending on op_size PM } { still not perfect : if hregister is already a 16 bit reg ?? PM } { makeregXX is the solution (FK) } case opsize of S_B : hregister:=makereg8(hregister); S_W : hregister:=makereg16(hregister); end; if p^.left^.left^.location.loc=LOC_CREGISTER then emit_reg_reg(addsubop[p^.inlinenumber],opsize, hregister,p^.left^.left^.location.register) else emit_reg_ref(addsubop[p^.inlinenumber],opsize, hregister,newreference(p^.left^.left^.location.reference)); case opsize of S_B : hregister:=reg8toreg32(hregister); S_W : hregister:=reg16toreg32(hregister); end; ungetregister32(hregister); end; emitoverflowcheck(p^.left^.left); emitrangecheck(p^.left^.left,p^.left^.left^.resulttype); end; in_assigned_x : begin secondpass(p^.left^.left); p^.location.loc:=LOC_FLAGS; if (p^.left^.left^.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then begin emit_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 emit_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); emit_const(A_PUSH,S_L,pfiledef(p^.left^.resulttype)^.typed_as^.size); secondpass(p^.left); emitpushreferenceaddr(p^.left^.location.reference); if p^.inlinenumber=in_reset_typedfile then emitcall('FPC_RESET_TYPED') else emitcall('FPC_REWRITE_TYPED'); popusedregisters(pushed); end; in_write_x : handlereadwrite(false,false); in_writeln_x : handlereadwrite(false,true); in_read_x : handlereadwrite(true,false); in_readln_x : handlereadwrite(true,true); in_str_x_string : begin handle_str; maybe_loadesi; end; in_val_x : Begin handle_val; 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); emit_const_ref(asmop,S_L, l,newreference(p^.left^.left^.location.reference)); del_reference(p^.left^.left^.location.reference); end else { LOC_CREGISTER } emit_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,false); secondpass(p^.left^.right^.left); if ispushed then restore(p^.left^.left,false); { 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; opsize:=def2def_opsize(p^.left^.right^.left^.resulttype,u32bitdef); if opsize in [S_B,S_W,S_L] then op:=A_MOV else op:=A_MOVZX; emit_ref_reg(op,opsize, newreference(p^.left^.right^.left^.location.reference),R_EDI); end; if (p^.left^.left^.location.loc=LOC_REFERENCE) then emit_reg_ref(asmop,S_L,hregister, newreference(p^.left^.left^.location.reference)) else emit_reg_reg(asmop,S_L,hregister, p^.left^.left^.location.register); end else begin pushsetelement(p^.left^.right^.left); { normset is allways a ref } emitpushreferenceaddr(p^.left^.left^.location.reference); if p^.inlinenumber=in_include_x_y then emitcall('FPC_SET_SET_BYTE') else emitcall('FPC_SET_UNSET_BYTE'); {CGMessage(cg_e_include_not_implemented);} end; end; end; {$ifdef SUPPORT_MMX} in_mmx_pcmpeqb..in_mmx_pcmpgtw: begin if p^.left^.location.loc=LOC_REGISTER then begin {!!!!!!!} end else if p^.left^.left^.location.loc=LOC_REGISTER then begin {!!!!!!!} end else begin {!!!!!!!} end; end; {$endif SUPPORT_MMX} else internalerror(9); end; { reset pushedparasize } pushedparasize:=oldpushedparasize; end; end. { $Log$ Revision 1.69 1999-08-28 15:34:16 florian * bug 519 fixed Revision 1.68 1999/08/19 13:08:47 pierre * emit_??? used Revision 1.67 1999/08/10 13:21:08 pierre * fpuvaroffset not increased for f32bit float type Revision 1.66 1999/08/10 12:47:53 pierre * fpuvaroffset problems solved Revision 1.65 1999/08/04 00:22:47 florian * renamed i386asm and i386base to cpuasm and cpubase Revision 1.64 1999/08/03 22:02:42 peter * moved bitmask constants to sets * some other type/const renamings Revision 1.63 1999/07/23 16:05:18 peter * alignment is now saved in the symtable * C alignment added for records * PPU version increased to solve .12 <-> .13 probs Revision 1.62 1999/07/05 20:13:10 peter * removed temp defines Revision 1.61 1999/07/03 14:14:27 florian + start of val(int64/qword) * longbool, wordbool constants weren't written, fixed Revision 1.60 1999/07/01 15:49:09 florian * int64/qword type release + lo/hi for int64/qword Revision 1.59 1999/06/21 16:33:27 jonas * fixed include() with smallsets Revision 1.58 1999/06/11 11:44:56 peter *** empty log message *** Revision 1.57 1999/06/02 10:11:43 florian * make cycle fixed i.e. compilation with 0.99.10 * some fixes for qword * start of register calling conventions Revision 1.56 1999/05/31 12:43:32 peter * fixed register allocation for storefuncresult Revision 1.55 1999/05/27 19:44:13 peter * removed oldasm * plabel -> pasmlabel * -a switches to source writing automaticly * assembler readers OOPed * asmsymbol automaticly external * jumptables and other label fixes for asm readers Revision 1.54 1999/05/23 19:55:11 florian * qword/int64 multiplication fixed + qword/int64 subtraction Revision 1.53 1999/05/23 18:42:01 florian * better error recovering in typed constants * some problems with arrays of const fixed, some problems due my previous - the location type of array constructor is now LOC_MEM - the pushing of high fixed - parameter copying fixed - zero temp. allocation removed * small problem in the assembler writers fixed: ref to nil wasn't written correctly Revision 1.52 1999/05/21 13:54:50 peter * NEWLAB for label as symbol Revision 1.51 1999/05/18 21:58:27 florian * fixed some bugs related to temp. ansistrings and functions results which return records/objects/arrays which need init/final. Revision 1.50 1999/05/17 21:57:03 florian * new temporary ansistring handling Revision 1.49 1999/05/12 15:46:26 pierre * handle_str disposetree was badly placed Revision 1.48 1999/05/12 00:19:42 peter * removed R_DEFAULT_SEG * uniform float names Revision 1.47 1999/05/06 09:05:13 peter * generic write_float and str_float * fixed constant float conversions Revision 1.46 1999/05/05 16:18:20 jonas * changes to handle_val so register vars are pushed/poped only once Revision 1.45 1999/05/01 13:24:08 peter * merged nasm compiler * old asm moved to oldasm/ Revision 1.44 1999/04/26 18:28:13 peter * better read/write array Revision 1.43 1999/04/19 09:45:48 pierre + cdecl or stdcall push all args with longint size * tempansi stuff cleaned up Revision 1.42 1999/04/14 09:11:59 peter * fixed include Revision 1.41 1999/04/08 23:59:49 pierre * temp string for val code freed Revision 1.40 1999/04/08 15:57:46 peter + subrange checking for readln() Revision 1.39 1999/04/07 15:31:16 pierre * all formaldefs are now a sinlge definition cformaldef (this was necessary for double_checksum) + small part of double_checksum code Revision 1.38 1999/04/05 11:07:26 jonas * fixed some typos in the constants of the range checking for Val Revision 1.37 1999/04/01 22:07:51 peter * universal string names (ansistr instead of stransi) for val/str Revision 1.36 1999/04/01 06:21:04 jonas * added initialization for has_32bit_code (caused problems with Val statement without code parameter) Revision 1.35 1999/03/31 20:30:49 michael * fixed typo: odlval to oldval Revision 1.34 1999/03/31 17:13:09 jonas * bugfix for -Ox with internal val code * internal val code now requires less free registers * internal val code no longer needs a temp var for range checking Revision 1.33 1999/03/26 00:24:15 peter * last para changed to long for easier pushing with 4 byte aligns Revision 1.32 1999/03/26 00:05:26 peter * released valintern + deffile is now removed when compiling is finished * ^( compiles now correct + static directive * shrd fixed Revision 1.31 1999/03/24 23:16:49 peter * fixed bugs 212,222,225,227,229,231,233 Revision 1.30 1999/03/16 17:52:56 jonas * changes for internal Val code (do a "make cycle OPT=-dvalintern" to test) * in cgi386inl: also range checking for subrange types (compile with "-dreadrangecheck") * in cgai386: also small fixes to emitrangecheck Revision 1.29 1999/02/25 21:02:27 peter * ag386bin updates + coff writer Revision 1.28 1999/02/22 02:15:11 peter * updates for ag386bin Revision 1.27 1999/02/17 14:21:40 pierre * unused local removed Revision 1.26 1999/02/15 11:40:21 pierre * pred/succ with overflow check must use ADD DEC !! Revision 1.25 1999/02/05 10:56:19 florian * in some cases a writeln of temp. ansistrings cause a memory leak, fixed Revision 1.24 1999/01/21 22:10:39 peter * fixed array of const * generic platform independent high() support Revision 1.23 1999/01/06 12:23:29 florian * str(...) for ansi/long and widestrings fixed Revision 1.22 1998/12/11 23:36:07 florian + again more stuff for int64/qword: - comparision operators - code generation for: str, read(ln), write(ln) Revision 1.21 1998/12/11 00:02:50 peter + globtype,tokens,version unit splitted from globals Revision 1.20 1998/11/27 14:50:32 peter + open strings, $P switch support Revision 1.19 1998/11/26 13:10:40 peter * new int - int conversion -dNEWCNV * some function renamings Revision 1.18 1998/11/24 17:04:27 peter * fixed length(char) when char is a variable Revision 1.17 1998/11/05 12:02:33 peter * released useansistring * removed -Sv, its now available in fpc modes Revision 1.16 1998/10/22 17:11:13 pierre + terminated the include exclude implementation for i386 * enums inside records fixed Revision 1.15 1998/10/21 15:12:50 pierre * bug fix for IOCHECK inside a procedure with iocheck modifier * removed the GPF for unexistant overloading (firstcall was called with procedinition=nil !) * changed typen to what Florian proposed gentypenode(p : pdef) sets the typenodetype field and resulttype is only set if inside bt_type block ! Revision 1.14 1998/10/20 08:06:40 pierre * several memory corruptions due to double freemem solved => never use p^.loc.location:=p^.left^.loc.location; + finally I added now by default that ra386dir translates global and unit symbols + added a first field in tsymtable and a nextsym field in tsym (this allows to obtain ordered type info for records and objects in gdb !) Revision 1.13 1998/10/13 16:50:02 pierre * undid some changes of Peter that made the compiler wrong for m68k (I had to reinsert some ifdefs) * removed several memory leaks under m68k * removed the meory leaks for assembler readers * cross compiling shoud work again better ( crosscompiling sysamiga works but as68k still complain about some code !) Revision 1.12 1998/10/08 17:17:12 pierre * current_module old scanner tagged as invalid if unit is recompiled + added ppheap for better info on tracegetmem of heaptrc (adds line column and file index) * several memory leaks removed ith help of heaptrc !! Revision 1.11 1998/10/05 21:33:15 peter * fixed 161,165,166,167,168 Revision 1.10 1998/10/05 12:32:44 peter + assert() support Revision 1.8 1998/10/02 10:35:09 peter * support for inc(pointer,value) which now increases with value instead of 0*value :) Revision 1.7 1998/09/21 08:45:07 pierre + added vmt_offset in tobjectdef.write for fututre use (first steps to have objects without vmt if no virtual !!) + added fpu_used field for tabstractprocdef : sets this level to 2 if the functions return with value in FPU (is then set to correct value at parsing of implementation) THIS MIGHT refuse some code with FPU expression too complex that were accepted before and even in some cases that don't overflow in fact ( like if f : float; is a forward that finally in implementation only uses one fpu register !!) Nevertheless I think that it will improve security on FPU operations !! * most other changes only for UseBrowser code (added symtable references for record and objects) local switch for refs to args and local of each function (static symtable still missing) UseBrowser still not stable and probably broken by the definition hash array !! Revision 1.6 1998/09/20 12:26:37 peter * merged fixes Revision 1.5 1998/09/17 09:42:15 peter + pass_2 for cg386 * Message() -> CGMessage() for pass_1/pass_2 Revision 1.4 1998/09/14 10:43:49 peter * all internal RTL functions start with FPC_ Revision 1.3.2.1 1998/09/20 12:20:07 peter * Fixed stack not on 4 byte boundary when doing a call Revision 1.3 1998/09/05 23:03:57 florian * some fixes to get -Or work: - inc/dec didn't take care of CREGISTER - register calculcation of inc/dec was wrong - var/const parameters get now assigned 32 bit register, but const parameters only if they are passed by reference ! Revision 1.2 1998/09/04 08:41:40 peter * updated some error CGMessages Revision 1.1 1998/08/31 12:22:14 peter * secondinline moved to cg386inl Revision 1.19 1998/08/31 08:52:03 peter * fixed error 10 with succ() and pref() Revision 1.18 1998/08/20 21:36:38 peter * fixed 'with object do' bug Revision 1.17 1998/08/19 16:07:36 jonas * changed optimizer switches + cleanup of DestroyRefs in daopt386.pas Revision 1.16 1998/08/18 09:24:36 pierre * small warning position bug fixed * support_mmx switches splitting was missing * rhide error and warning output corrected Revision 1.15 1998/08/13 11:00:09 peter * fixed procedure<>procedure construct Revision 1.14 1998/08/11 14:05:33 peter * fixed sizeof(array of char) Revision 1.13 1998/08/10 14:49:45 peter + localswitches, moduleswitches, globalswitches splitting Revision 1.12 1998/07/30 13:30:31 florian * final implemenation of exception support, maybe it needs some fixes :) Revision 1.11 1998/07/24 22:16:52 florian * internal error 10 together with array access fixed. I hope that's the final fix. Revision 1.10 1998/07/18 22:54:23 florian * some ansi/wide/longstring support fixed: o parameter passing o returning as result from functions Revision 1.9 1998/07/07 17:40:37 peter * packrecords 4 works * word aligning of parameters Revision 1.8 1998/07/06 15:51:15 michael Added length checking for string reading Revision 1.7 1998/07/06 14:19:51 michael + Added calls for reading/writing ansistrings Revision 1.6 1998/07/01 15:28:48 peter + better writeln/readln handling, now 100% like tp7 Revision 1.5 1998/06/25 14:04:17 peter + internal inc/dec Revision 1.4 1998/06/25 08:48:06 florian * first version of rtti support Revision 1.3 1998/06/09 16:01:33 pierre + added procedure directive parsing for procvars (accepted are popstack cdecl and pascal) + added C vars with the following syntax var C calias 'true_c_name';(can be followed by external) reason is that you must add the Cprefix which is target dependent Revision 1.2 1998/06/08 13:13:29 pierre + temporary variables now in temp_gen.pas unit because it is processor independent * mppc68k.bat modified to undefine i386 and support_mmx (which are defaults for i386) Revision 1.1 1998/06/05 17:44:10 peter * splitted cgi386 }