{ $Id$ Copyright (c) 1993-98 by Florian Klaempfl, Carl Eric Codere This unit generates 68000 (or better) assembler from the parse tree 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 cga68k; interface uses cobjects,tree,m68k,aasm,symtable; procedure emitl(op : tasmop;var l : plabel); procedure emit_reg_reg(i : tasmop;s : topsize;reg1,reg2 : tregister); procedure emitcall(const routine:string;add_to_externals : boolean); procedure emitloadord2reg(location:Tlocation;orddef:Porddef; destreg:Tregister;delloc:boolean); procedure emit_to_reg32(var hr:tregister); procedure loadsetelement(var p : ptree); { produces jumps to true respectively false labels using boolean expressions } procedure maketojumpbool(p : ptree); procedure emitoverflowcheck(p: ptree); procedure push_int(l : longint); function maybe_push(needed : byte;p : ptree) : boolean; procedure restore(p : ptree); procedure emit_push_mem(const ref : treference); procedure emitpushreferenceaddr(const ref : treference); procedure copystring(const dref,sref : treference;len : byte); procedure concatcopy(source,dest : treference;size : longint;delsource : boolean); { see implementation } procedure maybe_loada5; procedure emit_bounds_check(hp: treference; index: tregister); procedure loadstring(p:ptree); procedure floatload(t : tfloattype;const ref : treference; var location:tlocation); { return a float op_size from a floatb type } { also does some error checking for problems } function getfloatsize(t: tfloattype): topsize; procedure floatstore(t : tfloattype;var location:tlocation; const ref:treference); { procedure floatloadops(t : tfloattype;var op : tasmop;var s : topsize); procedure floatstoreops(t : tfloattype;var op : tasmop;var s : topsize); } procedure firstcomplex(p : ptree); { generate stackframe for interrupt procedures } procedure generate_interrupt_stackframe_entry; procedure generate_interrupt_stackframe_exit; { generate entry code for a procedure.} procedure genentrycode(list : paasmoutput;const proc_names:Tstringcontainer;make_global:boolean; stackframe:longint; var parasize:longint;var nostackframe:boolean; inlined : boolean); { generate the exit code for a procedure. } procedure genexitcode(list : paasmoutput;parasize:longint; nostackframe,inlined:boolean); {$ifdef test_dest_loc} const { used to avoid temporary assignments } dest_loc_known : boolean = false; in_dest_loc : boolean = false; dest_loc_tree : ptree = nil; var dest_loc : tlocation; procedure mov_reg_to_dest(p : ptree; s : topsize; reg : tregister); {$endif test_dest_loc} implementation uses systems,globals,verbose,files,types,pbase, tgen68k,hcodegen,temp_gen,ppu {$ifdef GDB} ,gdb {$endif} ; { procedure genconstadd(size : topsize;l : longint;const str : string); begin if l=0 then else if l=1 then exprasmlist^.concat(new(pai68k,op_A_INC,size,str) else if l=-1 then exprasmlist^.concat(new(pai68k,op_A_INC,size,str) else exprasmlist^.concat(new(pai68k,op_ADD,size,'$'+tostr(l)+','+str); end; } procedure copystring(const dref,sref : treference;len : byte); var pushed : tpushed; begin pushusedregisters(pushed,$ffff); { emitpushreferenceaddr(dref); } { emitpushreferenceaddr(sref); } { push_int(len); } { This speeds up from 116 cycles to 24 cycles on the 68000 } { when passing register parameters! } exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,newreference(dref),R_A1))); exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,newreference(sref),R_A0))); exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_L,len,R_D0))); emitcall('STRCOPY',true); maybe_loada5; popusedregisters(pushed); end; procedure loadstring(p:ptree); begin case p^.right^.resulttype^.deftype of stringdef : begin { load a string ... } { here two possible choices: } { if it is a char, then simply } { load 0 length string } if (p^.right^.treetype=stringconstn) and (p^.right^.values^='') then exprasmlist^.concat(new(pai68k,op_const_ref( A_MOVE,S_B,0,newreference(p^.left^.location.reference)))) else copystring(p^.left^.location.reference,p^.right^.location.reference, min(pstringdef(p^.right^.resulttype)^.len,pstringdef(p^.left^.resulttype)^.len)); end; orddef : begin if p^.right^.treetype=ordconstn then begin { offset 0: length of string } { offset 1: character } exprasmlist^.concat(new(pai68k,op_const_ref(A_MOVE,S_W,1*256+p^.right^.value, newreference(p^.left^.location.reference)))) end else begin { not so elegant (goes better with extra register } if (p^.right^.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then begin exprasmlist^.concat(new(pai68k,op_reg_reg( A_MOVE,S_B,p^.right^.location.register,R_D0))); ungetregister32(p^.right^.location.register); end else begin exprasmlist^.concat(new(pai68k,op_ref_reg( A_MOVE,S_B,newreference(p^.right^.location.reference),R_D0))); del_reference(p^.right^.location.reference); end; { alignment can cause problems } { add length of string to ref } exprasmlist^.concat(new(pai68k,op_const_ref(A_MOVE,S_B,1, newreference(p^.left^.location.reference)))); (* if abs(p^.left^.location.reference.offset) >= 1 then Begin *) { temporarily decrease offset } Inc(p^.left^.location.reference.offset); exprasmlist^.concat(new(pai68k,op_reg_ref(A_MOVE,S_B,R_D0, newreference(p^.left^.location.reference)))); Dec(p^.left^.location.reference.offset); { restore offset } (* end else Begin Comment(V_Debug,'SecondChar2String() internal error.'); internalerror(34); end; *) end; end; else Message(type_e_mismatch); end; end; procedure restore(p : ptree); var hregister : tregister; begin if (p^.location.loc=LOC_REGISTER) or (p^.location.loc=LOC_CREGISTER) then hregister:=getregister32 else hregister:=getaddressreg; exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_SPPULL,hregister))); if (p^.location.loc=LOC_REGISTER) or (p^.location.loc=LOC_CREGISTER) then begin p^.location.register:=hregister; end else begin reset_reference(p^.location.reference); p^.location.reference.base:=hregister; set_location(p^.left^.location,p^.location); end; end; function maybe_push(needed : byte;p : ptree) : boolean; var pushed : boolean; begin if (needed>usablereg32) or (needed > usableaddress) then begin if (p^.location.loc=LOC_REGISTER) or (p^.location.loc=LOC_CREGISTER) then begin pushed:=true; exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,p^.location.register,R_SPPUSH))); ungetregister32(p^.location.register); end else if ((p^.location.loc=LOC_MEM) or(p^.location.loc=LOC_REFERENCE)) and ((p^.location.reference.base<>R_NO) or (p^.location.reference.index<>R_NO)) then begin del_reference(p^.location.reference); exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,newreference(p^.location.reference), R_A0))); exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_A0,R_SPPUSH))); pushed:=true; end else pushed:=false; end else pushed:=false; maybe_push:=pushed; end; { emit out of range check for arrays and sets} procedure emit_bounds_check(hp: treference; index: tregister); { index = index of array to check } { memory of range check information for array } var hl : plabel; begin if (aktoptprocessor = MC68020) then begin exprasmlist^.concat(new(pai68k, op_ref_reg(A_CMP2,S_L,newreference(hp),index))); getlabel(hl); emitl(A_BCC, hl); exprasmlist^.concat(new(pai68k, op_const_reg(A_MOVE,S_L,201,R_D0))); emitcall('HALT_ERROR',true); emitl(A_LABEL, hl); end else begin exprasmlist^.concat(new(pai68k, op_ref_reg(A_LEA,S_L,newreference(hp), R_A1))); exprasmlist^.concat(new(pai68k, op_reg_reg(A_MOVE, S_L, index, R_D0))); emitcall('RE_BOUNDS_CHECK',true); end; end; procedure emit_to_reg32(var hr:tregister); begin (* case hr of R_AX..R_DI : begin hr:=reg16toreg32(hr); exprasmlist^.concat(new(pai386,op_const_reg(A_AND,S_L,$ffff,hr))); end; R_AL..R_DL : begin hr:=reg8toreg32(hr); exprasmlist^.concat(new(pai386,op_const_reg(A_AND,S_L,$ff,hr))); end; R_AH..R_DH : begin hr:=reg8toreg32(hr); exprasmlist^.concat(new(pai386,op_const_reg(A_AND,S_L,$ff00,hr))); end; end; *) end; function getfloatsize(t: tfloattype): topsize; begin case t of s32real: getfloatsize := S_FS; s64real: getfloatsize := S_FL; s80real: getfloatsize := S_FX; {$ifdef extdebug} else {else case } begin Comment(V_Debug,' getfloatsize() trying to get unknown size.'); internalerror(12); end; {$endif} end; end; procedure emitl(op : tasmop;var l : plabel); begin if op=A_LABEL then exprasmlist^.concat(new(pai_label,init(l))) else exprasmlist^.concat(new(pai_labeled,init(op,l))) end; procedure emit_reg_reg(i : tasmop;s : topsize;reg1,reg2 : tregister); begin if (reg1 <> reg2) or (i <> A_MOVE) then exprasmlist^.concat(new(pai68k,op_reg_reg(i,s,reg1,reg2))); end; procedure emitcall(const routine:string;add_to_externals : boolean); begin exprasmlist^.concat(new(pai68k,op_csymbol(A_JSR,S_NO,newcsymbol(routine,0)))); if add_to_externals and not (cs_compilesystem in aktmoduleswitches) then concat_external(routine,EXT_NEAR); end; procedure maketojumpbool(p : ptree); begin if p^.error then exit; if (p^.resulttype^.deftype=orddef) and (porddef(p^.resulttype)^.typ=bool8bit) then begin if is_constboolnode(p) then begin if p^.value<>0 then emitl(A_JMP,truelabel) else emitl(A_JMP,falselabel); end else begin case p^.location.loc of LOC_CREGISTER,LOC_REGISTER : begin exprasmlist^.concat(new(pai68k,op_reg(A_TST,S_B,p^.location.register))); ungetregister32(p^.location.register); emitl(A_BNE,truelabel); emitl(A_JMP,falselabel); end; LOC_MEM,LOC_REFERENCE : begin exprasmlist^.concat(new(pai68k,op_ref( A_TST,S_B,newreference(p^.location.reference)))); del_reference(p^.location.reference); emitl(A_BNE,truelabel); emitl(A_JMP,falselabel); end; LOC_FLAGS : begin emitl(flag_2_jmp[p^.location.resflags],truelabel); emitl(A_JMP,falselabel); end; end; end; end else Message(type_e_mismatch); end; procedure emitoverflowcheck(p: ptree); var hl : plabel; begin if cs_check_overflow in aktlocalswitches then begin getlabel(hl); if not ((p^.resulttype^.deftype=pointerdef) or ((p^.resulttype^.deftype=orddef) and (porddef(p^.resulttype)^.typ in [u16bit,u32bit,u8bit,uchar,bool8bit]))) then emitl(A_BVC,hl) else emitl(A_BCC,hl); emitcall('RE_OVERFLOW',true); emitl(A_LABEL,hl); end; end; procedure push_int(l : longint); begin if (l = 0) and (aktoptprocessor = MC68020) then begin exprasmlist^.concat(new(pai68k,op_reg(A_CLR,S_L,R_D6))); exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L, R_D6, R_SPPUSH))); end else if not(cs_littlesize in aktglobalswitches) and (l >= -128) and (l <= 127) then begin exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVEQ,S_L,l,R_D6))); exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_D6,R_SPPUSH))); end else exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_L,l,R_SPPUSH))); end; procedure emit_push_mem(const ref : treference); { Push a value on to the stack } begin if ref.isintvalue then push_int(ref.offset) else exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(ref),R_SPPUSH))); end; { USES REGISTER R_A1 } procedure emitpushreferenceaddr(const ref : treference); { Push a pointer to a value on the stack } begin if ref.isintvalue then push_int(ref.offset) else begin if (ref.base=R_NO) and (ref.index=R_NO) then exprasmlist^.concat(new(pai68k,op_ref(A_PEA,S_L, newreference(ref)))) else if (ref.base=R_NO) and (ref.index<>R_NO) and (ref.offset=0) and (ref.scalefactor=0) and (ref.symbol=nil) then exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L, ref.index,R_SPPUSH))) else if (ref.base<>R_NO) and (ref.index=R_NO) and (ref.offset=0) and (ref.symbol=nil) then exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,ref.base,R_SPPUSH))) else begin exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,newreference(ref),R_A1))); exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_A1,R_SPPUSH))); end; end; end; { This routine needs to be further checked to see if it works correctly } { because contrary to the intel version, all large set elements are read } { as 32-bit values, and then decomposed to find the correct byte. } { CHECKED : Depending on the result size, if reference, a load may be } { required on word, long or byte. } procedure loadsetelement(var p : ptree); var hr : tregister; opsize : topsize; begin { copy the element in the d0.b register, slightly complicated } case p^.location.loc of LOC_REGISTER, LOC_CREGISTER : begin hr:=p^.location.register; emit_reg_reg(A_MOVE,S_L,hr,R_D0); ungetregister32(hr); end; else begin { This is quite complicated, because of the endian on } { the m68k! } opsize:=S_NO; case integer(p^.resulttype^.savesize) of 1 : opsize:=S_B; 2 : opsize:=S_W; 4 : opsize:=S_L; else internalerror(19); end; exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,opsize, newreference(p^.location.reference),R_D0))); exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L, 255,R_D0))); { exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L, newreference(p^.location.reference),R_D0))); } { exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L, $ff,R_D0))); } del_reference(p^.location.reference); end; end; end; procedure generate_interrupt_stackframe_entry; begin { save the registers of an interrupt procedure } { .... also the segment registers } end; procedure generate_interrupt_stackframe_exit; begin { restore the registers of an interrupt procedure } end; procedure genentrycode(list : paasmoutput;const proc_names:Tstringcontainer;make_global:boolean; stackframe:longint; var parasize:longint;var nostackframe:boolean; inlined : boolean); {Generates the entry code for a procedure.} var hs:string; hp:Pused_unit; unitinits:taasmoutput; {$ifdef GDB} oldaktprocname : string; stab_function_name:Pai_stab_function_name; {$endif GDB} begin if (aktprocsym^.definition^.options and poproginit<>0) then begin {Init the stack checking.} if (cs_check_stack in aktlocalswitches) and (target_info.target=target_linux) then begin procinfo.aktentrycode^.insert(new(pai68k, op_csymbol(A_JSR,S_NO,newcsymbol('INIT_STACK_CHECK',0)))); end else { The main program has already allocated its stack - so we simply compare } { with a value of ZERO, and the comparison will directly check! } if (cs_check_stack in aktlocalswitches) then begin procinfo.aktentrycode^.insert(new(pai68k,op_csymbol(A_JSR,S_NO, newcsymbol('STACKCHECK',0)))); procinfo.aktentrycode^.insert(new(pai68k,op_const_reg(A_MOVE,S_L, 0,R_D0))); concat_external('STACKCHECK',EXT_NEAR); end; unitinits.init; {Call the unit init procedures.} hp:=pused_unit(usedunits.first); while assigned(hp) do begin { call the unit init code and make it external } if (hp^.u^.flags and uf_init)<>0 then begin unitinits.concat(new(pai68k,op_csymbol(A_JSR,S_NO,newcsymbol('INIT$$'+hp^.u^.modulename^,0)))); concat_external('INIT$$'+hp^.u^.modulename^,EXT_NEAR); end; hp:=pused_unit(hp^.next); end; procinfo.aktentrycode^.insertlist(@unitinits); unitinits.done; end; { a constructor needs a help procedure } if (aktprocsym^.definition^.options and poconstructor)<>0 then begin if procinfo._class^.isclass then begin procinfo.aktentrycode^.insert(new(pai_labeled,init(A_BEQ,quickexitlabel))); procinfo.aktentrycode^.insert(new(pai68k,op_csymbol(A_JSR,S_NO, newcsymbol('NEW_CLASS',0)))); concat_external('NEW_CLASS',EXT_NEAR); end else begin procinfo.aktentrycode^.insert(new(pai_labeled,init(A_BEQ,quickexitlabel))); procinfo.aktentrycode^.insert(new(pai68k,op_csymbol(A_JSR,S_NO, newcsymbol('HELP_CONSTRUCTOR',0)))); concat_external('HELP_CONSTRUCTOR',EXT_NEAR); end; end; { don't load ESI, does the caller } { omit stack frame ? } if procinfo.framepointer=stack_pointer then begin Message(cg_d_stackframe_omited); nostackframe:=true; if (aktprocsym^.definition^.options and (pounitinit or poproginit)<>0) then parasize:=0 else parasize:=aktprocsym^.definition^.parast^.datasize+procinfo.call_offset; end else begin if (aktprocsym^.definition^.options and (pounitinit or poproginit)<>0) then parasize:=0 else parasize:=aktprocsym^.definition^.parast^.datasize+procinfo.call_offset-8; nostackframe:=false; if stackframe<>0 then begin if cs_littlesize in aktglobalswitches then begin if (cs_check_stack in aktlocalswitches) and (target_info.target<>target_linux) then begin { If only not in main program, do we setup stack checking } if (aktprocsym^.definition^.options and poproginit=0) then Begin procinfo.aktentrycode^.insert(new(pai68k, op_csymbol(A_JSR,S_NO,newcsymbol('STACKCHECK',0)))); procinfo.aktentrycode^.insert(new(pai68k,op_const_reg(A_MOVE,S_L,stackframe,R_D0))); concat_external('STACKCHECK',EXT_NEAR); end; end; { to allocate stack space } { here we allocate space using link signed 16-bit version } { -ve offset to allocate stack space! } if (stackframe > -32767) and (stackframe < 32769) then procinfo.aktentrycode^.insert(new(pai68k,op_reg_const(A_LINK,S_W,R_A6,-stackframe))) else Message(cg_e_stacklimit_in_local_routine); end else begin { Not to complicate the code generator too much, and since some } { of the systems only support this format, the stackframe cannot } { exceed 32K in size. } if (stackframe > -32767) and (stackframe < 32769) then begin procinfo.aktentrycode^.insert(new(pai68k,op_const_reg(A_SUB,S_L,stackframe,R_SP))); { IF only NOT in main program do we check the stack normally } if (cs_check_stack in aktlocalswitches) and (aktprocsym^.definition^.options and poproginit=0) then begin procinfo.aktentrycode^.insert(new(pai68k, op_csymbol(A_JSR,S_NO,newcsymbol('STACKCHECK',0)))); procinfo.aktentrycode^.insert(new(pai68k,op_const_reg(A_MOVE,S_L, stackframe,R_D0))); concat_external('STACKCHECK',EXT_NEAR); end; procinfo.aktentrycode^.insert(new(pai68k,op_reg_reg(A_MOVE,S_L,R_SP,R_A6))); procinfo.aktentrycode^.insert(new(pai68k,op_reg_reg(A_MOVE,S_L,R_A6,R_SPPUSH))); end else Message(cg_e_stacklimit_in_local_routine); end; end {endif stackframe<>0 } else begin procinfo.aktentrycode^.insert(new(pai68k,op_reg_reg(A_MOVE,S_L,R_SP,R_A6))); procinfo.aktentrycode^.insert(new(pai68k,op_reg_reg(A_MOVE,S_L,R_A6,R_SPPUSH))); end; end; if (aktprocsym^.definition^.options and pointerrupt)<>0 then generate_interrupt_stackframe_entry; {proc_names.insert(aktprocsym^.definition^.mangledname);} if (aktprocsym^.definition^.owner^.symtabletype=globalsymtable) or ((procinfo._class<>nil) and (procinfo._class^.owner^. symtabletype=globalsymtable)) then make_global:=true; hs:=proc_names.get; {$IfDef GDB} if (cs_debuginfo in aktmoduleswitches) and target_os.use_function_relative_addresses then stab_function_name := new(pai_stab_function_name,init(strpnew(hs))); oldaktprocname:=aktprocsym^.name; {$EndIf GDB} while hs<>'' do begin if make_global then procinfo.aktentrycode^.insert(new(pai_symbol,init_global(hs))) else procinfo.aktentrycode^.insert(new(pai_symbol,init(hs))); {$ifdef GDB} if (cs_debuginfo in aktmoduleswitches) and target_os.use_function_relative_addresses then begin procinfo.aktentrycode^.insert(new(pai_stab_function_name,init(strpnew(hs)))); { This is not a nice solution to save the name, change it and restore when done } aktprocsym^.setname(hs); procinfo.aktentrycode^.insert(new(pai_stabs,init(aktprocsym^.stabstring))); end; {$endif GDB} hs:=proc_names.get; end; {$ifdef GDB} aktprocsym^.setname(oldaktprocname); if (cs_debuginfo in aktmoduleswitches) then begin if target_os.use_function_relative_addresses then procinfo.aktentrycode^.insert(stab_function_name); if make_global or ((procinfo.flags and pi_is_global) <> 0) then aktprocsym^.is_global := True; aktprocsym^.isstabwritten:=true; end; {$endif GDB} { Alignment required for Motorola } procinfo.aktentrycode^.insert(new(pai_align,init(2))); end; {Generate the exit code for a procedure.} procedure genexitcode(list : paasmoutput;parasize:longint; nostackframe,inlined:boolean); var hr:Preference; {This is for function results.} op:Tasmop; s:Topsize; begin { !!!! insert there automatic destructors } procinfo.aktexitcode^.insert(new(pai_label,init(aktexitlabel))); { call the destructor help procedure } if (aktprocsym^.definition^.options and podestructor)<>0 then begin if procinfo._class^.isclass then begin procinfo.aktexitcode^.insert(new(pai68k,op_csymbol(A_JSR,S_NO, newcsymbol('DISPOSE_CLASS',0)))); concat_external('DISPOSE_CLASS',EXT_NEAR); end else begin procinfo.aktexitcode^.insert(new(pai68k,op_csymbol(A_JSR,S_NO, newcsymbol('HELP_DESTRUCTOR',0)))); concat_external('HELP_DESTRUCTOR',EXT_NEAR); end; end; { call __EXIT for main program } { ????????? } if ((aktprocsym^.definition^.options and poproginit)<>0) and (target_info.target<>target_PalmOS) then begin procinfo.aktexitcode^.concat(new(pai68k,op_csymbol(A_JSR,S_NO,newcsymbol('__EXIT',0)))); externals^.concat(new(pai_external,init('__EXIT',EXT_NEAR))); end; { handle return value } if (aktprocsym^.definition^.options and poassembler)=0 then if (aktprocsym^.definition^.options and poconstructor)=0 then begin if procinfo.retdef<>pdef(voiddef) then begin if not procinfo.funcret_is_valid then Message(sym_w_function_result_not_set); new(hr); reset_reference(hr^); hr^.offset:=procinfo.retoffset; hr^.base:=procinfo.framepointer; if (procinfo.retdef^.deftype in [orddef,enumdef]) then begin case procinfo.retdef^.size of 4 : procinfo.aktexitcode^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,hr,R_D0))); 2 : procinfo.aktexitcode^.concat(new(pai68k,op_ref_reg(A_MOVE,S_W,hr,R_D0))); 1 : procinfo.aktexitcode^.concat(new(pai68k,op_ref_reg(A_MOVE,S_B,hr,R_D0))); end; end else if (procinfo.retdef^.deftype in [pointerdef,enumdef,procvardef]) or ((procinfo.retdef^.deftype=setdef) and (psetdef(procinfo.retdef)^.settype=smallset)) then procinfo.aktexitcode^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,hr,R_D0))) else if (procinfo.retdef^.deftype=floatdef) then begin if pfloatdef(procinfo.retdef)^.typ=f32bit then begin { Isnt this missing ? } procinfo.aktexitcode^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,hr,R_D0))); end else begin { how the return value is handled } { if single value, then return in d0, otherwise return in } { TRUE FPU register (does not apply in emulation mode) } if (pfloatdef(procinfo.retdef)^.typ = s32real) then begin procinfo.aktexitcode^.concat(new(pai68k,op_ref_reg(A_MOVE, S_L,hr,R_D0))) end else begin if cs_fp_emulation in aktmoduleswitches then procinfo.aktexitcode^.concat(new(pai68k,op_ref_reg(A_MOVE, S_L,hr,R_D0))) else procinfo.aktexitcode^.concat(new(pai68k,op_ref_reg(A_FMOVE, getfloatsize(pfloatdef(procinfo.retdef)^.typ),hr,R_FP0))); end; end; end else dispose(hr); end end else begin { successful constructor deletes the zero flag } { and returns self in accumulator } procinfo.aktexitcode^.concat(new(pai_label,init(quickexitlabel))); { eax must be set to zero if the allocation failed !!! } procinfo.aktexitcode^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_A5,R_D0))); { faster then OR on mc68000/mc68020 } procinfo.aktexitcode^.concat(new(pai68k,op_reg(A_TST,S_L,R_D0))); end; procinfo.aktexitcode^.concat(new(pai_label,init(aktexit2label))); if not(nostackframe) then procinfo.aktexitcode^.concat(new(pai68k,op_reg(A_UNLK,S_NO,R_A6))); { at last, the return is generated } if (aktprocsym^.definition^.options and pointerrupt)<>0 then generate_interrupt_stackframe_exit else if (parasize=0) or ((aktprocsym^.definition^.options and poclearstack)<>0) then {Routines with the poclearstack flag set use only a ret.} { also routines with parasize=0 } procinfo.aktexitcode^.concat(new(pai68k,op_none(A_RTS,S_NO))) else { return with immediate size possible here } { signed! } if (aktoptprocessor = MC68020) and (parasize < $7FFF) then procinfo.aktexitcode^.concat(new(pai68k,op_const( A_RTD,S_NO,parasize))) { manually restore the stack } else begin { We must pull the PC Counter from the stack, before } { restoring the stack pointer, otherwise the PC would } { point to nowhere! } { save the PC counter (pop it from the stack) } procinfo.aktexitcode^.concat(new(pai68k,op_reg_reg( A_MOVE,S_L,R_SPPULL,R_A0))); { can we do a quick addition ... } if (parasize > 0) and (parasize < 9) then procinfo.aktexitcode^.concat(new(pai68k,op_const_reg( A_ADD,S_L,parasize,R_SP))) else { nope ... } procinfo.aktexitcode^.concat(new(pai68k,op_const_reg( A_ADD,S_L,parasize,R_SP))); { endif } { restore the PC counter (push it on the stack) } procinfo.aktexitcode^.concat(new(pai68k,op_reg_reg( A_MOVE,S_L,R_A0,R_SPPUSH))); procinfo.aktexitcode^.concat(new(pai68k,op_none( A_RTS,S_NO))) end; {$ifdef GDB} if cs_debuginfo in aktmoduleswitches then begin aktprocsym^.concatstabto(procinfo.aktexitcode); if assigned(procinfo._class) then procinfo.aktexitcode^.concat(new(pai_stabs,init(strpnew( '"$t:v'+procinfo._class^.numberstring+'",'+ tostr(N_PSYM)+',0,0,'+tostr(procinfo.esi_offset))))); if (porddef(aktprocsym^.definition^.retdef) <> voiddef) then procinfo.aktexitcode^.concat(new(pai_stabs,init(strpnew( '"'+aktprocsym^.name+':X'+aktprocsym^.definition^.retdef^.numberstring+'",'+ tostr(N_PSYM)+',0,0,'+tostr(procinfo.retoffset))))); procinfo.aktexitcode^.concat(new(pai_stabn,init(strpnew('192,0,0,' +aktprocsym^.definition^.mangledname)))); procinfo.aktexitcode^.concat(new(pai_stabn,init(strpnew('224,0,0,' +lab2str(aktexit2label))))); end; {$endif GDB} end; { USES REGISTERS R_A0 AND R_A1 } { maximum size of copy is 65535 bytes } procedure concatcopy(source,dest : treference;size : longint;delsource : boolean); var ecxpushed : boolean; helpsize : longint; i : byte; reg8,reg32 : tregister; swap : boolean; hregister : tregister; iregister : tregister; jregister : tregister; hp1 : treference; hp2 : treference; hl : plabel; hl2: plabel; begin { this should never occur } if size > 65535 then internalerror(0); hregister := getregister32; if delsource then del_reference(source); { from 12 bytes movs is being used } if (size<=8) or (not(cs_littlesize in aktglobalswitches) and (size<=12)) then begin helpsize:=size div 4; { move a dword x times } for i:=1 to helpsize do begin exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(source),hregister))); exprasmlist^.concat(new(pai68k,op_reg_ref(A_MOVE,S_L,hregister,newreference(dest)))); inc(source.offset,4); inc(dest.offset,4); dec(size,4); end; { move a word } if size>1 then begin exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_W,newreference(source),hregister))); exprasmlist^.concat(new(pai68k,op_reg_ref(A_MOVE,S_W,hregister,newreference(dest)))); inc(source.offset,2); inc(dest.offset,2); dec(size,2); end; { move a single byte } if size>0 then begin exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_B,newreference(source),hregister))); exprasmlist^.concat(new(pai68k,op_reg_ref(A_MOVE,S_B,hregister,newreference(dest)))); end end else begin if (usableaddress > 1) then begin iregister := getaddressreg; jregister := getaddressreg; end else if (usableaddress = 1) then begin iregister := getaddressreg; jregister := R_A1; end else begin iregister := R_A0; jregister := R_A1; end; { reference for move (An)+,(An)+ } reset_reference(hp1); hp1.base := iregister; { source register } hp1.direction := dir_inc; reset_reference(hp2); hp2.base := jregister; hp2.direction := dir_inc; { iregister = source } { jregister = destination } exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,newreference(source),iregister))); exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,newreference(dest),jregister))); { double word move only on 68020+ machines } { because of possible alignment problems } { use fast loop mode } if (aktoptprocessor=MC68020) then begin helpsize := size - size mod 4; size := size mod 4; exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_L,helpsize div 4,hregister))); getlabel(hl2); emitl(A_BRA,hl2); getlabel(hl); emitl(A_LABEL,hl); exprasmlist^.concat(new(pai68k,op_ref_ref(A_MOVE,S_L,newreference(hp1),newreference(hp2)))); emitl(A_LABEL,hl2); exprasmlist^.concat(new(pai_labeled, init_reg(A_DBRA,hl,hregister))); if size > 1 then begin dec(size,2); exprasmlist^.concat(new(pai68k,op_ref_ref(A_MOVE,S_W,newreference(hp1), newreference(hp2)))); end; if size = 1 then exprasmlist^.concat(new(pai68k,op_ref_ref(A_MOVE,S_B,newreference(hp1), newreference(hp2)))); end else begin { Fast 68010 loop mode with no possible alignment problems } helpsize := size; exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_L,helpsize,hregister))); getlabel(hl2); emitl(A_BRA,hl2); getlabel(hl); emitl(A_LABEL,hl); exprasmlist^.concat(new(pai68k,op_ref_ref(A_MOVE,S_B,newreference(hp1),newreference(hp2)))); emitl(A_LABEL,hl2); exprasmlist^.concat(new(pai_labeled, init_reg(A_DBRA,hl,hregister))); end; { restore the registers that we have just used olny if they are used! } if jregister = R_A1 then hp2.base := R_NO; if iregister = R_A0 then hp1.base := R_NO; del_reference(hp1); del_reference(hp2); end; { loading SELF-reference again } maybe_loada5; if delsource then ungetiftemp(source); ungetregister32(hregister); end; procedure emitloadord2reg(location:Tlocation;orddef:Porddef; destreg:Tregister;delloc:boolean); {A lot smaller and less bug sensitive than the original unfolded loads.} var tai:pai68k; r:Preference; begin case location.loc of LOC_REGISTER,LOC_CREGISTER: begin case orddef^.typ of u8bit: begin exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_B,location.register,destreg))); exprasmlist^.concat(new(pai68k,op_const_reg(A_ANDI,S_L,$FF,destreg))); end; s8bit: begin exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_B,location.register,destreg))); if (aktoptprocessor <> MC68020) then begin { byte to word } exprasmlist^.concat(new(pai68k,op_reg(A_EXT,S_W,destreg))); { word to long } exprasmlist^.concat(new(pai68k,op_reg(A_EXT,S_L,destreg))); end else { 68020+ and later only } exprasmlist^.concat(new(pai68k,op_reg(A_EXTB,S_L,destreg))); end; u16bit: begin exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_W,location.register,destreg))); exprasmlist^.concat(new(pai68k,op_const_reg(A_ANDI,S_L,$FFFF,destreg))); end; s16bit: begin exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_W,location.register,destreg))); { word to long } exprasmlist^.concat(new(pai68k,op_reg(A_EXT,S_L,destreg))); end; u32bit: exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,location.register,destreg))); s32bit: exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,location.register,destreg))); end; if delloc then ungetregister(location.register); end; LOC_REFERENCE: begin r:=newreference(location.reference); case orddef^.typ of u8bit: begin exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_B,r,destreg))); exprasmlist^.concat(new(pai68k,op_const_reg(A_ANDI,S_L,$FF,destreg))); end; s8bit: begin exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_B,r,destreg))); if (aktoptprocessor <> MC68020) then begin { byte to word } exprasmlist^.concat(new(pai68k,op_reg(A_EXT,S_W,destreg))); { word to long } exprasmlist^.concat(new(pai68k,op_reg(A_EXT,S_L,destreg))); end else { 68020+ and later only } exprasmlist^.concat(new(pai68k,op_reg(A_EXTB,S_L,destreg))); end; u16bit: begin exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_W,r,destreg))); exprasmlist^.concat(new(pai68k,op_const_reg(A_ANDI,S_L,$ffff,destreg))); end; s16bit: begin exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_W,r,destreg))); { word to long } exprasmlist^.concat(new(pai68k,op_reg(A_EXT,S_L,destreg))); end; u32bit: exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,r,destreg))); s32bit: exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,r,destreg))); end; if delloc then del_reference(location.reference); end else internalerror(6); end; end; { if necessary A5 is reloaded after a call} procedure maybe_loada5; var hp : preference; p : pprocinfo; i : longint; begin if assigned(procinfo._class) then begin if lexlevel>2 then begin new(hp); reset_reference(hp^); hp^.offset:=procinfo.framepointer_offset; hp^.base:=procinfo.framepointer; exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,hp,R_A5))); p:=procinfo.parent; for i:=3 to lexlevel-1 do begin new(hp); reset_reference(hp^); hp^.offset:=p^.framepointer_offset; hp^.base:=R_A5; exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,hp,R_A5))); p:=p^.parent; end; new(hp); reset_reference(hp^); hp^.offset:=p^.ESI_offset; hp^.base:=R_A5; exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,hp,R_A5))); end else begin new(hp); reset_reference(hp^); hp^.offset:=procinfo.ESI_offset; hp^.base:=procinfo.framepointer; exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,hp,R_A5))); end; end; end; (***********************************************************************) (* PROCEDURE FLOATLOAD *) (* Description: This routine is to be called each time a location *) (* must be set to LOC_FPU and a value loaded into a FPU register. *) (* *) (* Remark: The routine sets up the register field of LOC_FPU correctly*) (***********************************************************************) procedure floatload(t : tfloattype;const ref : treference; var location:tlocation); var op : tasmop; s : topsize; begin { no emulation } case t of s32real : s := S_FS; s64real : s := S_FL; s80real : s := S_FX; else begin Message(cg_f_unknown_float_type); end; end; { end case } location.loc := LOC_FPU; if not ((cs_fp_emulation) in aktmoduleswitches) then begin location.fpureg := getfloatreg; exprasmlist^.concat(new(pai68k,op_ref_reg(A_FMOVE,s,newreference(ref),location.fpureg))) end else { handle emulation } begin if t = s32real then begin location.fpureg := getregister32; exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(ref),location.fpureg))) end else { other floating types are not supported in emulation mode } Message(sym_e_type_id_not_defined); end; end; { procedure floatstoreops(t : tfloattype;var op : tasmop;var s : topsize); begin case t of s32real : begin op:=A_FSTP; s:=S_FS; end; s64real : begin op:=A_FSTP; s:=S_FL; end; s80real : begin op:=A_FSTP; s:=S_FX; end; s64bit : begin op:=A_FISTP; s:=S_IQ; end; else internalerror(17); end; end; } { stores an FPU value to memory } { location:tlocation used to free up FPU register } { ref: destination of storage } procedure floatstore(t : tfloattype;var location:tlocation; const ref:treference); var op : tasmop; s : topsize; begin if location.loc <> LOC_FPU then InternalError(34); { no emulation } case t of s32real : s := S_FS; s64real : s := S_FL; s80real : s := S_FX; else begin Message(cg_f_unknown_float_type); end; end; { end case } if not ((cs_fp_emulation) in aktmoduleswitches) then begin { This permits the mixing of emulation and non-emulation routines } { only possible for REAL = SINGLE values } if not (location.fpureg in [R_FP0..R_FP7]) then Begin if s = S_FS then exprasmlist^.concat(new(pai68k,op_reg_ref(A_MOVE,S_L,location.fpureg,newreference(ref)))) else internalerror(255); end else exprasmlist^.concat(new(pai68k,op_reg_ref(A_FMOVE,s,location.fpureg,newreference(ref)))); ungetregister(location.fpureg); end else { handle emulation } begin if t = s32real then begin exprasmlist^.concat(new(pai68k,op_reg_ref(A_MOVE,S_L,location.fpureg,newreference(ref)))); ungetregister32(location.fpureg); end else { other floating types are not supported in emulation mode } Message(sym_e_type_id_not_defined); end; location.fpureg:=R_NO; { no register in LOC_FPU now } end; procedure firstcomplex(p : ptree); var hp : ptree; begin { always calculate boolean AND and OR from left to right } if ((p^.treetype=orn) or (p^.treetype=andn)) and (p^.left^.resulttype^.deftype=orddef) and (porddef(p^.left^.resulttype)^.typ=bool8bit) then p^.swaped:=false else if (p^.left^.registers32