{ $Id$ Copyright (c) 1993-98 by Florian Klaempfl Generate m68k assembler for nodes that influence the flow 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 cg68kflw; interface uses tree; procedure second_while_repeatn(var p : ptree); procedure secondifn(var p : ptree); procedure secondfor(var p : ptree); procedure secondexitn(var p : ptree); procedure secondbreakn(var p : ptree); procedure secondcontinuen(var p : ptree); procedure secondgoto(var p : ptree); procedure secondlabel(var p : ptree); procedure secondraise(var p : ptree); procedure secondtryexcept(var p : ptree); procedure secondtryfinally(var p : ptree); procedure secondon(var p : ptree); procedure secondfail(var p : ptree); implementation uses globtype,systems, cobjects,verbose,globals, symtable,aasm,types, hcodegen,temp_gen,pass_2, m68k,cga68k,tgen68k; {***************************************************************************** Second_While_RepeatN *****************************************************************************} 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 { //// NOT a small set //// } 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; freelabel(l1); freelabel(l2); aktcontinuelabel:=oldclabel; aktbreaklabel:=oldblabel; end; {***************************************************************************** SecondIfN *****************************************************************************} 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); freelabel(truelabel); freelabel(falselabel); truelabel:=otlabel; falselabel:=oflabel; end; {***************************************************************************** SecondFor *****************************************************************************} procedure secondfor(var p : ptree); var l1,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 CGMessage(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; cmpreg:=cmp32; case hs of 1 : begin opsize:=S_B; end; 2 : begin opsize:=S_W; end; 4 : begin opsize:=S_L; 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(pai68k,op_reg_ref(A_MOVE,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(pai68k,op_ref_reg(A_CMP,opsize,newreference(temp1), p^.t2^.location.register))); end else begin exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,opsize,newreference(p^.t2^.location.reference), cmpreg))); exprasmlist^.concat(new(pai68k,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(pai68k,op_const_reg(A_CMP,opsize,p^.right^.value, p^.t2^.location.register))) else exprasmlist^.concat(new(pai68k,op_const_ref(A_CMP,opsize,p^.right^.value, newreference(p^.t2^.location.reference)))); end; end; if p^.backward then begin if count_var_is_signed then hop:=A_BLT else hop:=A_BCS; end else if count_var_is_signed then hop:=A_BGT else hop:=A_BHI; 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; end; 2 : begin opsize:=S_W; 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(pai68k,op_ref_reg(A_CMP,opsize,newreference(temp1), p^.t2^.location.register))); end else begin exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,opsize,newreference(p^.t2^.location.reference), cmpreg))); exprasmlist^.concat(new(pai68k,op_ref_reg(A_CMP,opsize,newreference(temp1), cmpreg))); end; end else begin if p^.t2^.location.loc=LOC_CREGISTER then exprasmlist^.concat(new(pai68k,op_const_reg(A_CMP,opsize,p^.right^.value, p^.t2^.location.register))) else exprasmlist^.concat(new(pai68k,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_BLE else hop :=A_BLS else if count_var_is_signed then hop:=A_BGE else hop:=A_BCC; 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_SUB else hop:=A_ADD; if p^.t2^.location.loc=LOC_CREGISTER then exprasmlist^.concat(new(pai68k,op_const_reg(hop,opsize,1,p^.t2^.location.register))) else exprasmlist^.concat(new(pai68k,op_const_ref(hop,opsize,1,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); freelabel(aktcontinuelabel); freelabel(aktbreaklabel); freelabel(l3); aktcontinuelabel:=oldclabel; aktbreaklabel:=oldblabel; end; {***************************************************************************** SecondExitN *****************************************************************************} 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(pai68k,op_reg(flag_2_set[p^.right^.location.resflags],S_B,R_D0))); exprasmlist^.concat(new(pai68k,op_reg(A_NEG, S_B, R_D0))); goto do_jmp; end; LOC_JUMP : begin emitl(A_LABEL,truelabel); exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_B,1,R_D0))); emitl(A_JMP,aktexit2label); exprasmlist^.concat(new(pai68k,op_reg(A_CLR,S_B,R_D0))); goto do_jmp; end; else internalerror(2001); end; case procinfo.retdef^.deftype of orddef, enumdef : begin case procinfo.retdef^.size of 4 : if is_mem then exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L, newreference(p^.left^.location.reference),R_D0))) else emit_reg_reg(A_MOVE,S_L,p^.left^.location.register,R_D0); 2 : if is_mem then exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_W, newreference(p^.left^.location.reference),R_D0))) else emit_reg_reg(A_MOVE,S_W,p^.left^.location.register,R_D0); 1 : if is_mem then exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_B, newreference(p^.left^.location.reference),R_D0))) else emit_reg_reg(A_MOVE,S_B,p^.left^.location.register,R_D0); end; end; pointerdef, procvardef : begin if is_mem then exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L, newreference(p^.left^.location.reference),R_D0))) else exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,p^.left^.location.register,R_D0))); end; floatdef : begin { floating point return values .... } { single are returned in d0 } if (pfloatdef(procinfo.retdef)^.typ=f32bit) or (pfloatdef(procinfo.retdef)^.typ=s32real) then begin if is_mem then exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L, newreference(p^.left^.location.reference),R_D0))) else begin if pfloatdef(procinfo.retdef)^.typ=f32bit then emit_reg_reg(A_MOVE,S_L,p^.left^.location.register,R_D0) else begin { single values are in the floating point registers } if cs_fp_emulation in aktmoduleswitches then emit_reg_reg(A_MOVE,S_L,p^.left^.location.fpureg,R_D0) else exprasmlist^.concat(new(pai68k,op_reg_reg(A_FMOVE,S_FS, p^.left^.location.fpureg,R_D0))); end; end; end else Begin { this is only possible in real non emulation mode } { LOC_MEM,LOC_REFERENCE } if is_mem then begin exprasmlist^.concat(new(pai68k,op_ref_reg(A_FMOVE, getfloatsize(pfloatdef(procinfo.retdef)^.typ), newreference(p^.left^.location.reference),R_FP0))); end else { LOC_FPU } begin { convert from extended to correct type } { when storing } exprasmlist^.concat(new(pai68k,op_reg_reg(A_FMOVE, getfloatsize(pfloatdef(procinfo.retdef)^.typ),p^.left^.location.fpureg,R_FP0))); end; end; end; end; do_jmp: freelabel(truelabel); freelabel(falselabel); truelabel:=otlabel; falselabel:=oflabel; emitl(A_JMP,aktexit2label); end else begin emitl(A_JMP,aktexitlabel); end; end; {***************************************************************************** SecondBreakN *****************************************************************************} procedure secondbreakn(var p : ptree); begin if aktbreaklabel<>nil then emitl(A_JMP,aktbreaklabel) else CGMessage(cg_e_break_not_allowed); end; {***************************************************************************** SecondContinueN *****************************************************************************} procedure secondcontinuen(var p : ptree); begin if aktcontinuelabel<>nil then emitl(A_JMP,aktcontinuelabel) else CGMessage(cg_e_continue_not_allowed); end; {***************************************************************************** SecondGoto *****************************************************************************} procedure secondgoto(var p : ptree); begin emitl(A_JMP,p^.labelnr); end; {***************************************************************************** SecondLabel *****************************************************************************} procedure secondlabel(var p : ptree); begin emitl(A_LABEL,p^.labelnr); cleartempgen; secondpass(p^.left); end; {***************************************************************************** SecondRaise *****************************************************************************} { 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(pai68k, op_csymbol_reg(A_MOVE,S_L,newcsymbol(lab2str(a),0),R_SPPUSH))); end; secondpass(p^.left); if codegenerror then exit; case p^.left^.location.loc of LOC_MEM,LOC_REFERENCE : emitpushreferenceaddr(exprasmlist,p^.left^.location.reference); LOC_CREGISTER,LOC_REGISTER : exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L, p^.left^.location.register,R_SPPUSH))); else CGMessage(type_e_mismatch); end; emitcall('FPC_RAISEEXCEPTION',true); end else emitcall('FPC_RERAISE',true); end; {***************************************************************************** SecondTryExcept *****************************************************************************} var endexceptlabel : plabel; procedure secondtryexcept(var p : ptree); var exceptlabel,doexceptlabel,oldendexceptlabel, lastonlabel : plabel; begin InternalError(3431243); (* { this can be called recursivly } oldendexceptlabel:=endexceptlabel; { we modify EAX } usedinproc:=usedinproc or ($80 shr byte(R_EAX)); getlabel(exceptlabel); getlabel(doexceptlabel); getlabel(endexceptlabel); getlabel(lastonlabel); push_int (1); { push type of exceptionframe } emitcall('FPC_PUSHEXCEPTADDR',true); exprasmlist^.concat(new(pai386, op_reg(A_PUSH,S_L,R_EAX))); emitcall('FPC_SETJMP',true); exprasmlist^.concat(new(pai386, op_reg(A_PUSH,S_L,R_EAX))); exprasmlist^.concat(new(pai386, op_reg_reg(A_TEST,S_L,R_EAX,R_EAX))); emitl(A_JNE,exceptlabel); { try code } secondpass(p^.left); if codegenerror then exit; emitl(A_LABEL,exceptlabel); exprasmlist^.concat(new(pai386, op_reg(A_POP,S_L,R_EAX))); exprasmlist^.concat(new(pai386, op_reg_reg(A_TEST,S_L,R_EAX,R_EAX))); emitl(A_JNE,doexceptlabel); emitcall('FPC_POPADDRSTACK',true); emitl(A_JMP,endexceptlabel); emitl(A_LABEL,doexceptlabel); if assigned(p^.right) then secondpass(p^.right); emitl(A_LABEL,lastonlabel); { default handling } if assigned(p^.t1) then begin { FPC_CATCHES must be called with 'default handler' flag (=-1) } push_int (-1); emitcall('FPC_CATCHES',true); secondpass(p^.t1); end else emitcall('FPC_RERAISE',true); emitl(A_LABEL,endexceptlabel); endexceptlabel:=oldendexceptlabel; *) end; {***************************************************************************** SecondOn *****************************************************************************} procedure secondon(var p : ptree); var nextonlabel,myendexceptlabel : plabel; ref : treference; begin { !!!!!!!!!!!!!!! } (* getlabel(nextonlabel); { push the vmt } exprasmlist^.concat(new(pai386,op_csymbol(A_PUSH,S_L, newcsymbol(p^.excepttype^.vmt_mangledname,0)))); maybe_concat_external(p^.excepttype^.owner, p^.excepttype^.vmt_mangledname); emitcall('FPC_CATCHES',true); exprasmlist^.concat(new(pai386, op_reg_reg(A_TEST,S_L,R_EAX,R_EAX))); emitl(A_JE,nextonlabel); ref.symbol:=nil; gettempofsizereference(4,ref); { what a hack ! } if assigned(p^.exceptsymtable) then pvarsym(p^.exceptsymtable^.root)^.address:=ref.offset; exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L, R_EAX,newreference(ref)))); if assigned(p^.right) then secondpass(p^.right); { clear some stuff } ungetiftemp(ref); emitl(A_JMP,endexceptlabel); emitl(A_LABEL,nextonlabel); { next on node } if assigned(p^.left) then secondpass(p^.left); *) end; {***************************************************************************** SecondTryFinally *****************************************************************************} procedure secondtryfinally(var p : ptree); var finallylabel,noreraiselabel,endfinallylabel : plabel; begin (* { we modify EAX } usedinproc:=usedinproc or ($80 shr byte(R_EAX)); getlabel(finallylabel); getlabel(noreraiselabel); getlabel(endfinallylabel); push_int(1); { Type of stack-frame must be pushed} emitcall('FPC_PUSHEXCEPTADDR',true); exprasmlist^.concat(new(pai386, op_reg(A_PUSH,S_L,R_EAX))); emitcall('FPC_SETJMP',true); exprasmlist^.concat(new(pai386, op_reg(A_PUSH,S_L,R_EAX))); exprasmlist^.concat(new(pai386, op_reg_reg(A_TEST,S_L,R_EAX,R_EAX))); emitl(A_JNE,finallylabel); { try code } secondpass(p^.left); if codegenerror then exit; emitl(A_LABEL,finallylabel); { finally code } secondpass(p^.right); if codegenerror then exit; exprasmlist^.concat(new(pai386, op_reg(A_POP,S_L,R_EAX))); exprasmlist^.concat(new(pai386, op_reg_reg(A_TEST,S_L,R_EAX,R_EAX))); emitl(A_JE,noreraiselabel); emitcall('FPC_RERAISE',true); emitl(A_LABEL,noreraiselabel); emitcall('FPC_POPADDRSTACK',true); emitl(A_LABEL,endfinallylabel); *) end; {***************************************************************************** SecondFail *****************************************************************************} procedure secondfail(var p : ptree); var hp : preference; begin exprasmlist^.concat(new(pai68k,op_reg(A_CLR,S_L,R_A5))); { also reset to zero in the stack } new(hp); reset_reference(hp^); hp^.offset:=procinfo.ESI_offset; hp^.base:=procinfo.framepointer; exprasmlist^.concat(new(pai68k,op_reg_ref(A_MOVE,S_L,R_A5,hp))); exprasmlist^.concat(new(pai_labeled,init(A_JMP,quickexitlabel))); end; end. { $Log$ Revision 1.8 1998-12-11 00:03:02 peter + globtype,tokens,version unit splitted from globals Revision 1.7 1998/10/14 11:28:19 florian * emitpushreferenceaddress gets now the asmlist as parameter * m68k version compiles with -duseansistrings Revision 1.6 1998/10/13 16:50:07 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.5 1998/09/17 09:42:24 peter + pass_2 for cg386 * Message() -> CGMessage() for pass_1/pass_2 Revision 1.4 1998/09/14 10:43:58 peter * all internal RTL functions start with FPC_ Revision 1.3 1998/09/04 08:41:47 peter * updated some error messages Revision 1.2 1998/09/01 12:48:01 peter * use pdef^.size instead of orddef^.typ Revision 1.1 1998/09/01 09:07:09 peter * m68k fixes, splitted cg68k like cgi386 }