X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FnativeGen%2FMachCode.lhs;h=22ae785d68b0b54451af24ac96632ef3aa9875e3;hb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;hp=96a148c3f7e5a5583285e3d7f50dd7ced5b8d8dd;hpb=6a7f4042bb71bc5eff550b7d6bdf79883997110c;p=ghc-hetmet.git diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs index 96a148c..22ae785 100644 --- a/ghc/compiler/nativeGen/MachCode.lhs +++ b/ghc/compiler/nativeGen/MachCode.lhs @@ -1,5 +1,5 @@ % -% (c) The AQUA Project, Glasgow University, 1996 +% (c) The AQUA Project, Glasgow University, 1996-1998 % \section[MachCode]{Generating machine code} @@ -9,43 +9,31 @@ This is a big module, but, if you pay attention to structure should not be too overwhelming. \begin{code} +module MachCode ( stmt2Instrs, asmVoid, InstrList ) where + #include "HsVersions.h" #include "nativeGen/NCG.h" -module MachCode ( stmt2Instrs, asmVoid, SYN_IE(InstrList) ) where - -IMP_Ubiq(){-uitious-} - import MachMisc -- may differ per-platform -#if __GLASGOW_HASKELL__ >= 202 -import MachRegs hiding (Addr(..)) -import qualified MachRegs (Addr(..)) -#define MachRegsAddr MachRegs.Addr -#define MachRegsAddrRegImm MachRegs.AddrRegImm -#define MachRegsAddrRegReg MachRegs.AddrRegReg -#else import MachRegs -#define MachRegsAddr Addr -#define MachRegsAddrRegImm AddrRegImm -#define MachRegsAddrRegReg AddrRegReg -#endif import AbsCSyn ( MagicId ) import AbsCUtils ( magicIdPrimRep ) +import CallConv ( CallConv ) import CLabel ( isAsmTemp, CLabel ) import Maybes ( maybeToBool, expectJust ) import OrdList -- quite a bit of it -import Outputable ( PprStyle(..) ) -import Pretty ( ptext, rational ) import PrimRep ( isFloatingRep, PrimRep(..) ) -import PrimOp ( PrimOp(..), showPrimOp ) +import PrimOp ( PrimOp(..) ) +import CallConv ( cCallConv ) import Stix ( getUniqLabelNCG, StixTree(..), StixReg(..), CodeSegment(..) ) import UniqSupply ( returnUs, thenUs, mapUs, mapAndUnzipUs, - mapAccumLUs, SYN_IE(UniqSM) + mapAccumLUs, UniqSM ) -import Util ( panic, assertPanic ) +import Outputable +import GlaExts (trace) --tmp \end{code} Code extractor for an entire stix tree---stix statement level. @@ -62,7 +50,7 @@ stmt2Instrs stmt = case stmt of StJump arg -> genJump arg StCondJump lab arg -> genCondJump lab arg - StCall fn VoidRep args -> genCCall fn VoidRep args + StCall fn cconv VoidRep args -> genCCall fn cconv VoidRep args StAssign pk dst src | isFloatingRep pk -> assignFltCode pk dst src @@ -91,6 +79,9 @@ stmt2Instrs stmt = case stmt of returnUs (mkSeqInstrs [LABEL lbl, ASCII True (_UNPK_ s)], ImmCLbl lbl) + -- the linker can handle simple arithmetic... + getData (StIndex rep (StCLbl lbl) (StInt off)) = + returnUs (id, ImmIndex lbl (fromInteger (off * sizeOf rep))) \end{code} %************************************************************************ @@ -139,6 +130,7 @@ mangleIndexTree (StIndex pk base (StInt i)) where off = StInt (i * sizeOf pk) +#ifndef i386_TARGET_ARCH mangleIndexTree (StIndex pk base off) = StPrim IntAddOp [base, case pk of @@ -152,6 +144,15 @@ mangleIndexTree (StIndex pk base off) where shift DoubleRep = 3::Integer shift _ = IF_ARCH_alpha(3,2) +#else +-- Hmm..this is an attempt at fixing Adress amodes (i.e., *[disp](base,index,), +-- that do include the size of the primitive kind we're addressing. When StIndex +-- is expanded to actual code, the index (in units) is by the above code approp. +-- shifted to get the no. of bytes. Since Address amodes do contain size info +-- explicitly, we disable the shifting for x86s. +mangleIndexTree (StIndex pk base off) = StPrim IntAddOp [base, off] +#endif + \end{code} \begin{code} @@ -161,6 +162,9 @@ maybeImm (StLitLbl s) = Just (ImmLab s) maybeImm (StLitLit s) = Just (strImmLit (cvtLitLit (_UNPK_ s))) maybeImm (StCLbl l) = Just (ImmCLbl l) +maybeImm (StIndex rep (StCLbl l) (StInt off)) = + Just (ImmIndex l (fromInteger (off * sizeOf rep))) + maybeImm (StInt i) | i >= toInteger minInt && i <= toInteger maxInt = Just (ImmInt (fromInteger i)) @@ -217,8 +221,8 @@ getRegister (StReg (StixTemp u pk)) getRegister tree@(StIndex _ _ _) = getRegister (mangleIndexTree tree) -getRegister (StCall fn kind args) - = genCCall fn kind args `thenUs` \ call -> +getRegister (StCall fn cconv kind args) + = genCCall fn cconv kind args `thenUs` \ call -> returnUs (Fixed kind reg call) where reg = if isFloatingRep kind @@ -313,7 +317,7 @@ getRegister (StPrim primop [x]) -- unary PrimOps Double2FloatOp -> coerceFltCode x Float2DoubleOp -> coerceFltCode x - other_op -> getRegister (StCall fn DoubleRep [x]) + other_op -> getRegister (StCall fn cconv DoubleRep [x]) where fn = case other_op of FloatExpOp -> SLIT("exp") @@ -393,6 +397,9 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps IntQuotOp -> trivialCode (DIV Q False) x y IntRemOp -> trivialCode (REM Q False) x y + WordQuotOp -> trivialCode (DIV Q True) x y + WordRemOp -> trivialCode (REM Q True) x y + FloatAddOp -> trivialFCode FloatRep (FADD TF) x y FloatSubOp -> trivialFCode FloatRep (FSUB TF) x y FloatMulOp -> trivialFCode FloatRep (FMUL TF) x y @@ -405,16 +412,16 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps AndOp -> trivialCode AND x y OrOp -> trivialCode OR x y + XorOp -> trivialCode XOR x y SllOp -> trivialCode SLL x y - SraOp -> trivialCode SRA x y SrlOp -> trivialCode SRL x y - ISllOp -> panic "AlphaGen:isll" - ISraOp -> panic "AlphaGen:isra" - ISrlOp -> panic "AlphaGen:isrl" + ISllOp -> trivialCode SLL x y -- was: panic "AlphaGen:isll" + ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra" + ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl" - FloatPowerOp -> getRegister (StCall SLIT("pow") DoubleRep [x,y]) - DoublePowerOp -> getRegister (StCall SLIT("pow") DoubleRep [x,y]) + FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x,y]) + DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x,y]) where {- ------------------------------------------------------------ Some bizarre special code for getting condition codes into @@ -502,8 +509,6 @@ getRegister leaf -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if i386_TARGET_ARCH -getRegister (StReg (StixTemp u pk)) = returnUs (Fixed pk (UnmappedReg u pk) id) - getRegister (StDouble 0.0) = let code dst = mkSeqInstrs [FLDZ] @@ -559,7 +564,7 @@ getRegister (StPrim primop [x]) -- unary PrimOps then StPrim Float2DoubleOp [x] else x in - getRegister (StCall fn DoubleRep [x]) + getRegister (StCall fn cCallConv DoubleRep [x]) where (is_float_op, fn) = case primop of @@ -663,18 +668,83 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps AndOp -> trivialCode (AND L) x y {-True-} OrOp -> trivialCode (OR L) x y {-True-} - SllOp -> trivialCode (SHL L) x y {-False-} - SraOp -> trivialCode (SAR L) x y {-False-} - SrlOp -> trivialCode (SHR L) x y {-False-} + XorOp -> trivialCode (XOR L) x y {-True-} + + {- Shift ops on x86s have constraints on their source, it + either has to be Imm, CL or 1 + => trivialCode's is not restrictive enough (sigh.) + -} + + SllOp -> shift_code (SHL L) x y {-False-} + SrlOp -> shift_code (SHR L) x y {-False-} - ISllOp -> panic "I386Gen:isll" - ISraOp -> panic "I386Gen:isra" - ISrlOp -> panic "I386Gen:isrl" + ISllOp -> shift_code (SHL L) x y {-False-} --was:panic "I386Gen:isll" + ISraOp -> shift_code (SAR L) x y {-False-} --was:panic "I386Gen:isra" + ISrlOp -> shift_code (SHR L) x y {-False-} --was:panic "I386Gen:isrl" - FloatPowerOp -> getRegister (StCall SLIT("pow") DoubleRep [promote x, promote y]) + FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [promote x, promote y]) where promote x = StPrim Float2DoubleOp [x] - DoublePowerOp -> getRegister (StCall SLIT("pow") DoubleRep [x, y]) + DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x, y]) where + shift_code :: (Operand -> Operand -> Instr) + -> StixTree + -> StixTree + -> UniqSM Register + {- Case1: shift length as immediate -} + -- Code is the same as the first eq. for trivialCode -- sigh. + shift_code instr x y{-amount-} + | maybeToBool imm + = getRegister x `thenUs` \ register -> + let + op_imm = OpImm imm__2 + code__2 dst = + let + code = registerCode register dst + src = registerName register dst + in + mkSeqInstr (COMMENT SLIT("shift_code")) . + code . + if isFixed register && src /= dst + then + mkSeqInstrs [MOV L (OpReg src) (OpReg dst), + instr op_imm (OpReg dst)] + else + mkSeqInstr (instr op_imm (OpReg src)) + in + returnUs (Any IntRep code__2) + where + imm = maybeImm y + imm__2 = case imm of Just x -> x + + {- Case2: shift length is complex (non-immediate) -} + shift_code instr x y{-amount-} + = getRegister y `thenUs` \ register1 -> + getRegister x `thenUs` \ register2 -> +-- getNewRegNCG IntRep `thenUs` \ dst -> + let + -- Note: we force the shift length to be loaded + -- into ECX, so that we can use CL when shifting. + -- (only register location we are allowed + -- to put shift amounts.) + -- + -- The shift instruction is fed ECX as src reg, + -- but we coerce this into CL when printing out. + src1 = registerName register1 ecx + code1 = if src1 /= ecx then -- if it is not in ecx already, force it! + registerCode register1 ecx . + mkSeqInstr (MOV L (OpReg src1) (OpReg ecx)) + else + registerCode register1 ecx + code__2 = + let + code2 = registerCode register2 eax + src2 = registerName register2 eax + in + code1 . code2 . + mkSeqInstr (instr (OpReg ecx) (OpReg eax)) + in + returnUs (Fixed IntRep eax code__2) + add_code :: Size -> StixTree -> StixTree -> UniqSM Register add_code sz x (StInt y) @@ -685,7 +755,7 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps src1 = registerName register tmp src2 = ImmInt (fromInteger y) code__2 dst = code . - mkSeqInstr (LEA sz (OpAddr (MachRegsAddr (Just src1) Nothing src2)) (OpReg dst)) + mkSeqInstr (LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2)) (OpReg dst)) in returnUs (Any IntRep code__2) @@ -698,7 +768,7 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps code2 = amodeCode amode src2 = amodeAddr amode - fixedname = registerName register1 eax +-- fixedname = registerName register1 eax code__2 dst = let code1 = registerCode register1 dst src1 = registerName register1 dst in asmParThen [code2 asmVoid,code1 asmVoid] . @@ -719,7 +789,7 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps code1 = amodeCode amode src1 = amodeAddr amode - fixedname = registerName register2 eax +-- fixedname = registerName register2 eax code__2 dst = let code2 = registerCode register2 dst src2 = registerName register2 dst in asmParThen [code1 asmVoid,code2 asmVoid] . @@ -742,7 +812,7 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps code2 = registerCode register2 tmp2 asmVoid src2 = registerName register2 tmp2 code__2 dst = asmParThen [code1, code2] . - mkSeqInstr (LEA sz (OpAddr (MachRegsAddr (Just src1) (Just (src2,1)) (ImmInt 0))) (OpReg dst)) + mkSeqInstr (LEA sz (OpAddr (AddrBaseIndex (Just src1) (Just (src2,1)) (ImmInt 0))) (OpReg dst)) in returnUs (Any IntRep code__2) @@ -757,7 +827,7 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps src1 = registerName register tmp src2 = ImmInt (-(fromInteger y)) code__2 dst = code . - mkSeqInstr (LEA sz (OpAddr (MachRegsAddr (Just src1) Nothing src2)) (OpReg dst)) + mkSeqInstr (LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2)) (OpReg dst)) in returnUs (Any IntRep code__2) @@ -800,10 +870,10 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps src2 = ImmInt (fromInteger i) code__2 = asmParThen [code1] . mkSeqInstrs [-- we put src2 in (ebx) - MOV L (OpImm src2) (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt OFFSET_R1))), + MOV L (OpImm src2) (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1))), MOV L (OpReg src1) (OpReg eax), CLTD, - IDIV sz (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt OFFSET_R1)))] + IDIV sz (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1)))] in returnUs (Fixed IntRep (if is_division then eax else edx) code__2) @@ -823,10 +893,10 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps CLTD, IDIV sz (OpReg src2)] else mkSeqInstrs [ -- we put src2 in (ebx) - MOV L (OpReg src2) (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt OFFSET_R1))), + MOV L (OpReg src2) (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1))), MOV L (OpReg src1) (OpReg eax), CLTD, - IDIV sz (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt OFFSET_R1)))] + IDIV sz (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1)))] in returnUs (Fixed IntRep (if is_division then eax else edx) code__2) ----------------------- @@ -875,7 +945,7 @@ getRegister (StDouble d) DATA DF [dblImmLit d], SEGMENT TextSegment, SETHI (HI (ImmCLbl lbl)) tmp, - LD DF (MachRegsAddrRegImm tmp (LO (ImmCLbl lbl))) dst] + LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst] in returnUs (Any DoubleRep code) @@ -906,7 +976,7 @@ getRegister (StPrim primop [x]) -- unary PrimOps then StPrim Float2DoubleOp [x] else x in - getRegister (StCall fn DoubleRep [x]) + getRegister (StCall fn cCallConv DoubleRep [x]) where (is_float_op, fn) = case primop of @@ -941,7 +1011,7 @@ getRegister (StPrim primop [x]) -- unary PrimOps DoubleSinhOp -> (False, SLIT("sinh")) DoubleCoshOp -> (False, SLIT("cosh")) DoubleTanhOp -> (False, SLIT("tanh")) - _ -> panic ("Monadic PrimOp not handled: " ++ showPrimOp PprDebug primop) + _ -> panic ("Monadic PrimOp not handled: " ++ show primop) getRegister (StPrim primop [x, y]) -- dyadic PrimOps = case primop of @@ -1006,20 +1076,21 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps DoubleDivOp -> trivialFCode DoubleRep FDIV x y AndOp -> trivialCode (AND False) x y - OrOp -> trivialCode (OR False) x y + OrOp -> trivialCode (OR False) x y + XorOp -> trivialCode (XOR False) x y SllOp -> trivialCode SLL x y - SraOp -> trivialCode SRA x y SrlOp -> trivialCode SRL x y - ISllOp -> panic "SparcGen:isll" - ISraOp -> panic "SparcGen:isra" - ISrlOp -> panic "SparcGen:isrl" + ISllOp -> trivialCode SLL x y --was: panic "SparcGen:isll" + ISraOp -> trivialCode SRA x y --was: panic "SparcGen:isra" + ISrlOp -> trivialCode SRL x y --was: panic "SparcGen:isrl" - FloatPowerOp -> getRegister (StCall SLIT("pow") DoubleRep [promote x, promote y]) + FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [promote x, promote y]) where promote x = StPrim Float2DoubleOp [x] - DoublePowerOp -> getRegister (StCall SLIT("pow") DoubleRep [x, y]) + DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x, y]) +-- _ -> panic "Prim op " ++ (showPrimOp primop) ++ " not handled!" where - imul_div fn x y = getRegister (StCall fn IntRep [x, y]) + imul_div fn x y = getRegister (StCall fn cCallConv IntRep [x, y]) getRegister (StInd pk mem) = getAmode mem `thenUs` \ amode -> @@ -1086,7 +1157,7 @@ getAmode (StPrim IntSubOp [x, StInt i]) reg = registerName register tmp off = ImmInt (-(fromInteger i)) in - returnUs (Amode (MachRegsAddrRegImm reg off) code) + returnUs (Amode (AddrRegImm reg off) code) getAmode (StPrim IntAddOp [x, StInt i]) = getNewRegNCG PtrRep `thenUs` \ tmp -> @@ -1096,7 +1167,7 @@ getAmode (StPrim IntAddOp [x, StInt i]) reg = registerName register tmp off = ImmInt (fromInteger i) in - returnUs (Amode (MachRegsAddrRegImm reg off) code) + returnUs (Amode (AddrRegImm reg off) code) getAmode leaf | maybeToBool imm @@ -1126,7 +1197,7 @@ getAmode (StPrim IntSubOp [x, StInt i]) reg = registerName register tmp off = ImmInt (-(fromInteger i)) in - returnUs (Amode (MachRegsAddr (Just reg) Nothing off) code) + returnUs (Amode (AddrBaseIndex (Just reg) Nothing off) code) getAmode (StPrim IntAddOp [x, StInt i]) | maybeToBool imm @@ -1146,7 +1217,7 @@ getAmode (StPrim IntAddOp [x, StInt i]) reg = registerName register tmp off = ImmInt (fromInteger i) in - returnUs (Amode (MachRegsAddr (Just reg) Nothing off) code) + returnUs (Amode (AddrBaseIndex (Just reg) Nothing off) code) getAmode (StPrim IntAddOp [x, y]) = getNewRegNCG PtrRep `thenUs` \ tmp1 -> @@ -1160,7 +1231,7 @@ getAmode (StPrim IntAddOp [x, y]) reg2 = registerName register2 tmp2 code__2 = asmParThen [code1, code2] in - returnUs (Amode (MachRegsAddr (Just reg1) (Just (reg2,4)) (ImmInt 0)) code__2) + returnUs (Amode (AddrBaseIndex (Just reg1) (Just (reg2,4)) (ImmInt 0)) code__2) getAmode leaf | maybeToBool imm @@ -1180,7 +1251,7 @@ getAmode other reg = registerName register tmp off = Nothing in - returnUs (Amode (MachRegsAddr (Just reg) Nothing (ImmInt 0)) code) + returnUs (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code) #endif {- i386_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -1195,7 +1266,7 @@ getAmode (StPrim IntSubOp [x, StInt i]) reg = registerName register tmp off = ImmInt (-(fromInteger i)) in - returnUs (Amode (MachRegsAddrRegImm reg off) code) + returnUs (Amode (AddrRegImm reg off) code) getAmode (StPrim IntAddOp [x, StInt i]) @@ -1207,7 +1278,7 @@ getAmode (StPrim IntAddOp [x, StInt i]) reg = registerName register tmp off = ImmInt (fromInteger i) in - returnUs (Amode (MachRegsAddrRegImm reg off) code) + returnUs (Amode (AddrRegImm reg off) code) getAmode (StPrim IntAddOp [x, y]) = getNewRegNCG PtrRep `thenUs` \ tmp1 -> @@ -1221,7 +1292,7 @@ getAmode (StPrim IntAddOp [x, y]) reg2 = registerName register2 tmp2 code__2 = asmParThen [code1, code2] in - returnUs (Amode (MachRegsAddrRegReg reg1 reg2) code__2) + returnUs (Amode (AddrRegReg reg1 reg2) code__2) getAmode leaf | maybeToBool imm @@ -1229,7 +1300,7 @@ getAmode leaf let code = mkSeqInstr (SETHI (HI imm__2) tmp) in - returnUs (Amode (MachRegsAddrRegImm tmp (LO imm__2)) code) + returnUs (Amode (AddrRegImm tmp (LO imm__2)) code) where imm = maybeImm leaf imm__2 = case imm of Just x -> x @@ -1242,7 +1313,7 @@ getAmode other reg = registerName register tmp off = ImmInt 0 in - returnUs (Amode (MachRegsAddrRegImm reg off) code) + returnUs (Amode (AddrRegImm reg off) code) #endif {- sparc_TARGET_ARCH -} \end{code} @@ -1776,7 +1847,8 @@ assignFltCode pk (StInd _ dst) src returnUs code__2 assignFltCode pk dst src - = getRegister dst `thenUs` \ register1 -> + = trace "assignFltCode: dodgy floating point instruction" $ + getRegister dst `thenUs` \ register1 -> getRegister src `thenUs` \ register2 -> --getNewRegNCG (registerRep register2) -- `thenUs` \ tmp -> @@ -1941,7 +2013,7 @@ genJump tree code = registerCode register tmp target = registerName register tmp in - returnSeq code [JMP (MachRegsAddrRegReg target g0), NOP] + returnSeq code [JMP (AddrRegReg target g0), NOP] #endif {- sparc_TARGET_ARCH -} \end{code} @@ -2168,13 +2240,14 @@ register allocator. \begin{code} genCCall :: FAST_STRING -- function to call + -> CallConv -> PrimRep -- type of the result -> [StixTree] -- arguments (of mixed type) -> UniqSM InstrBlock #if alpha_TARGET_ARCH -genCCall fn kind args +genCCall fn cconv kind args = mapAccumLUs get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args `thenUs` \ ((unused,_), argCode) -> let @@ -2242,34 +2315,50 @@ genCCall fn kind args -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if i386_TARGET_ARCH -genCCall fn kind [StInt i] +genCCall fn cconv kind [StInt i] | fn == SLIT ("PerformGC_wrapper") + = let + call = [MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax), + CALL (ImmLit (ptext (if underscorePrefix then (SLIT ("_PerformGC_wrapper")) else (SLIT ("PerformGC_wrapper")))))] + in + returnInstrs call + +{- OLD: = getUniqLabelNCG `thenUs` \ lbl -> let call = [MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax), MOV L (OpImm (ImmCLbl lbl)) -- this is hardwired - (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt 104))), + (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt 104))), JMP (OpImm (ImmLit (ptext (if underscorePrefix then (SLIT ("_PerformGC_wrapper")) else (SLIT ("PerformGC_wrapper")))))), LABEL lbl] in returnInstrs call +-} -genCCall fn kind args +genCCall fn cconv kind args = mapUs get_call_arg args `thenUs` \ argCode -> let nargs = length args - code1 = asmParThen [asmSeq [ -- MOV L (OpReg esp) (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt 80))), - MOV L (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt 100))) (OpReg esp) + +{- OLD: Since there's no attempt at stealing %esp at the moment, + restoring %esp from MainRegTable.rCstkptr is not done. -- SOF 97/09 + (ditto for saving away old-esp in MainRegTable.Hp (!!) ) + code1 = asmParThen [asmSeq [ -- MOV L (OpReg esp) (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt 80))), + MOV L (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt 100))) (OpReg esp) ] ] +-} code2 = asmParThen (map ($ asmVoid) (reverse argCode)) - call = [CALL fn__2 -- , - -- ADD L (OpImm (ImmInt (nargs * 4))) (OpReg esp), - -- MOV L (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt 80))) (OpReg esp) + call = [CALL fn__2 , + -- pop args; all args word sized? + ADD L (OpImm (ImmInt (nargs * 4))) (OpReg esp) --, + + -- Don't restore %esp (see above) + -- MOV L (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt 80))) (OpReg esp) ] in - returnSeq (code1 . code2) call + returnSeq (code2) call where -- function names that begin with '.' are assumed to be special -- internally generated names like '.mul,' which don't get an @@ -2319,7 +2408,7 @@ genCCall fn kind args -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if sparc_TARGET_ARCH -genCCall fn kind args +genCCall fn cconv kind args = mapAccumLUs get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args `thenUs` \ ((unused,_), argCode) -> let @@ -2699,7 +2788,7 @@ trivialCode instr x y = getRegister x `thenUs` \ register1 -> --getNewRegNCG IntRep `thenUs` \ tmp1 -> let - fixedname = registerName register1 eax +-- fixedname = registerName register1 eax code__2 dst = let code1 = registerCode register1 dst src1 = registerName register1 dst in code1 . @@ -2719,7 +2808,7 @@ trivialCode instr x y = getRegister y `thenUs` \ register1 -> --getNewRegNCG IntRep `thenUs` \ tmp1 -> let - fixedname = registerName register1 eax +-- fixedname = registerName register1 eax code__2 dst = let code1 = registerCode register1 dst src1 = registerName register1 dst in code1 . @@ -2739,7 +2828,7 @@ trivialCode instr x (StInd pk mem) --getNewRegNCG IntRep `thenUs` \ tmp -> getAmode mem `thenUs` \ amode -> let - fixedname = registerName register eax +-- fixedname = registerName register eax code2 = amodeCode amode asmVoid src2 = amodeAddr amode code__2 dst = let code1 = registerCode register dst asmVoid @@ -2758,7 +2847,7 @@ trivialCode instr (StInd pk mem) y --getNewRegNCG IntRep `thenUs` \ tmp -> getAmode mem `thenUs` \ amode -> let - fixedname = registerName register eax +-- fixedname = registerName register eax code2 = amodeCode amode asmVoid src2 = amodeAddr amode code__2 dst = let @@ -2779,7 +2868,7 @@ trivialCode instr x y --getNewRegNCG IntRep `thenUs` \ tmp1 -> getNewRegNCG IntRep `thenUs` \ tmp2 -> let - fixedname = registerName register1 eax +-- fixedname = registerName register1 eax code2 = registerCode register2 tmp2 asmVoid src2 = registerName register2 tmp2 code__2 dst = let @@ -3063,8 +3152,8 @@ coerceInt2FP pk x code__2 dst = code . mkSeqInstrs [ -- to fix: should spill instead of using R1 - MOV L (OpReg src) (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt OFFSET_R1))), - FILD (primRepToSize pk) (MachRegsAddr (Just ebx) Nothing (ImmInt OFFSET_R1)) dst] + MOV L (OpReg src) (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1))), + FILD (primRepToSize pk) (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1)) dst] in returnUs (Any pk code__2) @@ -3077,11 +3166,10 @@ coerceFP2Int x src = registerName register tmp pk = registerRep register - code__2 dst = let - in code . mkSeqInstrs [ + code__2 dst = code . mkSeqInstrs [ FRNDINT, - FIST L (MachRegsAddr (Just ebx) Nothing (ImmInt OFFSET_R1)), - MOV L (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt OFFSET_R1))) (OpReg dst)] + FIST L (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1)), + MOV L (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1))) (OpReg dst)] in returnUs (Any IntRep code__2) @@ -3155,7 +3243,7 @@ chrCode x = getRegister x `thenUs` \ register -> --getNewRegNCG IntRep `thenUs` \ reg -> let - fixedname = registerName register eax +-- fixedname = registerName register eax code__2 dst = let code = registerCode register dst src = registerName register dst