X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FnativeGen%2FMachCode.lhs;h=12d4dbe452fc45929faba62ef55077a18b577c9a;hb=4070b105490709e2fbc40ef926853fc93595b7a6;hp=820b5aeb367bae7457357df16d260c7be5c8e8d5;hpb=e0e07f52be0e7518bbd5eea1e3b374b3e09c910c;p=ghc-hetmet.git diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs index 820b5ae..12d4dbe 100644 --- a/ghc/compiler/nativeGen/MachCode.lhs +++ b/ghc/compiler/nativeGen/MachCode.lhs @@ -9,45 +9,61 @@ 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 +module MachCode ( stmt2Instrs, InstrBlock ) where #include "HsVersions.h" #include "nativeGen/NCG.h" import MachMisc -- may differ per-platform import MachRegs - +import OrdList ( OrdList, nilOL, isNilOL, unitOL, appOL, toOL, + snocOL, consOL, concatOL ) import AbsCSyn ( MagicId ) import AbsCUtils ( magicIdPrimRep ) import CallConv ( CallConv ) import CLabel ( isAsmTemp, CLabel, pprCLabel_asm ) import Maybes ( maybeToBool, expectJust ) -import OrdList -- quite a bit of it import PrimRep ( isFloatingRep, PrimRep(..) ) import PrimOp ( PrimOp(..) ) import CallConv ( cCallConv ) -import Stix ( getUniqLabelNCG, StixTree(..), +import Stix ( getNatLabelNCG, StixTree(..), StixReg(..), CodeSegment(..), - pprStixTrees, ppStixReg - ) -import UniqSupply ( returnUs, thenUs, mapUs, mapAndUnzipUs, - mapAccumLUs, UniqSM + pprStixTrees, ppStixReg, + NatM, thenNat, returnNat, mapNat, mapAndUnzipNat, + getDeltaNat, setDeltaNat ) import Outputable + +\end{code} + +@InstrBlock@s are the insn sequences generated by the insn selectors. +They are really trees of insns to facilitate fast appending, where a +left-to-right traversal (pre-order?) yields the insns in the correct +order. + +\begin{code} + +type InstrBlock = OrdList Instr + +infixr 3 `bind` +x `bind` f = f x + \end{code} Code extractor for an entire stix tree---stix statement level. \begin{code} -stmt2Instrs :: StixTree {- a stix statement -} -> UniqSM InstrBlock +stmt2Instrs :: StixTree {- a stix statement -} -> NatM InstrBlock stmt2Instrs stmt = case stmt of - StComment s -> returnInstr (COMMENT s) - StSegment seg -> returnInstr (SEGMENT seg) + StComment s -> returnNat (unitOL (COMMENT s)) + StSegment seg -> returnNat (unitOL (SEGMENT seg)) - StFunBegin lab -> returnInstr (IF_ARCH_alpha(FUNBEGIN lab,LABEL lab)) - StFunEnd lab -> IF_ARCH_alpha(returnInstr (FUNEND lab),returnUs id) - StLabel lab -> returnInstr (LABEL lab) + StFunBegin lab -> returnNat (unitOL (IF_ARCH_alpha(FUNBEGIN lab, + LABEL lab))) + StFunEnd lab -> IF_ARCH_alpha(returnNat (unitOL (FUNEND lab)), + returnNat nilOL) + StLabel lab -> returnNat (unitOL (LABEL lab)) StJump arg -> genJump arg StCondJump lab arg -> genCondJump lab arg @@ -61,27 +77,28 @@ stmt2Instrs stmt = case stmt of -- When falling through on the Alpha, we still have to load pv -- with the address of the next routine, so that it can load gp. -> IF_ARCH_alpha(returnInstr (LDA pv (AddrImm (ImmCLbl lbl))) - ,returnUs id) + ,returnNat nilOL) StData kind args - -> mapAndUnzipUs getData args `thenUs` \ (codes, imms) -> - returnUs (\xs -> mkSeqList (asmInstr (DATA (primRepToSize kind) imms)) - (foldr (.) id codes xs)) + -> mapAndUnzipNat getData args `thenNat` \ (codes, imms) -> + returnNat (DATA (primRepToSize kind) imms + `consOL` concatOL codes) where - getData :: StixTree -> UniqSM (InstrBlock, Imm) + getData :: StixTree -> NatM (InstrBlock, Imm) - getData (StInt i) = returnUs (id, ImmInteger i) - getData (StDouble d) = returnUs (id, ImmDouble d) - getData (StLitLbl s) = returnUs (id, ImmLab s) - getData (StCLbl l) = returnUs (id, ImmCLbl l) + getData (StInt i) = returnNat (nilOL, ImmInteger i) + getData (StDouble d) = returnNat (nilOL, ImmDouble d) + getData (StLitLbl s) = returnNat (nilOL, ImmLab s) + getData (StCLbl l) = returnNat (nilOL, ImmCLbl l) getData (StString s) = - getUniqLabelNCG `thenUs` \ lbl -> - returnUs (mkSeqInstrs [LABEL lbl, - ASCII True (_UNPK_ s)], - ImmCLbl lbl) + getNatLabelNCG `thenNat` \ lbl -> + returnNat (toOL [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))) + returnNat (nilOL, + ImmIndex lbl (fromInteger (off * sizeOf rep))) \end{code} %************************************************************************ @@ -91,38 +108,6 @@ stmt2Instrs stmt = case stmt of %************************************************************************ \begin{code} -type InstrList = OrdList Instr -type InstrBlock = InstrList -> InstrList - -asmVoid :: InstrList -asmVoid = mkEmptyList - -asmInstr :: Instr -> InstrList -asmInstr i = mkUnitList i - -asmSeq :: [Instr] -> InstrList -asmSeq is = foldr (mkSeqList . asmInstr) asmVoid is - -asmParThen :: [InstrList] -> InstrBlock -asmParThen others code = mkSeqList (foldr mkParList mkEmptyList others) code - -returnInstr :: Instr -> UniqSM InstrBlock -returnInstr instr = returnUs (\xs -> mkSeqList (asmInstr instr) xs) - -returnInstrs :: [Instr] -> UniqSM InstrBlock -returnInstrs instrs = returnUs (\xs -> mkSeqList (asmSeq instrs) xs) - -returnSeq :: InstrBlock -> [Instr] -> UniqSM InstrBlock -returnSeq code instrs = returnUs (\xs -> code (mkSeqList (asmSeq instrs) xs)) - -mkSeqInstr :: Instr -> InstrBlock -mkSeqInstr instr code = mkSeqList (asmInstr instr) code - -mkSeqInstrs :: [Instr] -> InstrBlock -mkSeqInstrs instrs code = mkSeqList (asmSeq instrs) code -\end{code} - -\begin{code} mangleIndexTree :: StixTree -> StixTree mangleIndexTree (StIndex pk base (StInt i)) @@ -184,6 +169,9 @@ registerCode (Any _ code) reg = code reg registerCodeF (Fixed _ _ code) = code registerCodeF (Any _ _) = pprPanic "registerCodeF" empty +registerCodeA (Any _ code) = code +registerCodeA (Fixed _ _ _) = pprPanic "registerCodeA" empty + registerName :: Register -> Reg -> Reg registerName (Fixed _ reg _) _ = reg registerName (Any _ _) reg = reg @@ -195,41 +183,49 @@ registerRep :: Register -> PrimRep registerRep (Fixed pk _ _) = pk registerRep (Any pk _) = pk -isFixed, isFloat :: Register -> Bool +{-# INLINE registerCode #-} +{-# INLINE registerCodeF #-} +{-# INLINE registerName #-} +{-# INLINE registerNameF #-} +{-# INLINE registerRep #-} +{-# INLINE isFixed #-} +{-# INLINE isAny #-} + +isFixed, isAny :: Register -> Bool isFixed (Fixed _ _ _) = True isFixed (Any _ _) = False -isFloat = not . isFixed +isAny = not . isFixed \end{code} Generate code to get a subtree into a @Register@: \begin{code} -getRegister :: StixTree -> UniqSM Register +getRegister :: StixTree -> NatM Register getRegister (StReg (StixMagicId stgreg)) = case (magicIdRegMaybe stgreg) of - Just reg -> returnUs (Fixed (magicIdPrimRep stgreg) reg id) + Just reg -> returnNat (Fixed (magicIdPrimRep stgreg) reg nilOL) -- cannae be Nothing getRegister (StReg (StixTemp u pk)) - = returnUs (Fixed pk (UnmappedReg u pk) id) + = returnNat (Fixed pk (UnmappedReg u pk) nilOL) getRegister tree@(StIndex _ _ _) = getRegister (mangleIndexTree tree) getRegister (StCall fn cconv kind args) - = genCCall fn cconv kind args `thenUs` \ call -> - returnUs (Fixed kind reg call) + = genCCall fn cconv kind args `thenNat` \ call -> + returnNat (Fixed kind reg call) where reg = if isFloatingRep kind then IF_ARCH_alpha( f0, IF_ARCH_i386( fake0, IF_ARCH_sparc( f0,))) else IF_ARCH_alpha( v0, IF_ARCH_i386( eax, IF_ARCH_sparc( o0,))) getRegister (StString s) - = getUniqLabelNCG `thenUs` \ lbl -> + = getNatLabelNCG `thenNat` \ lbl -> let imm_lbl = ImmCLbl lbl - code dst = mkSeqInstrs [ + code dst = toOL [ SEGMENT DataSegment, LABEL lbl, ASCII True (_UNPK_ s), @@ -246,7 +242,7 @@ getRegister (StString s) #endif ] in - returnUs (Any PtrRep code) + returnNat (Any PtrRep code) @@ -255,8 +251,8 @@ getRegister (StString s) #if alpha_TARGET_ARCH getRegister (StDouble d) - = getUniqLabelNCG `thenUs` \ lbl -> - getNewRegNCG PtrRep `thenUs` \ tmp -> + = getNatLabelNCG `thenNat` \ lbl -> + getNewRegNCG PtrRep `thenNat` \ tmp -> let code dst = mkSeqInstrs [ SEGMENT DataSegment, LABEL lbl, @@ -265,7 +261,7 @@ getRegister (StDouble d) LDA tmp (AddrImm (ImmCLbl lbl)), LD TF dst (AddrReg tmp)] in - returnUs (Any DoubleRep code) + returnNat (Any DoubleRep code) getRegister (StPrim primop [x]) -- unary PrimOps = case primop of @@ -401,17 +397,17 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps any kind leave the result in a floating point register, so we need to wrangle an integer register out of things. -} - int_NE_code :: StixTree -> StixTree -> UniqSM Register + int_NE_code :: StixTree -> StixTree -> NatM Register int_NE_code x y - = trivialCode (CMP EQQ) x y `thenUs` \ register -> - getNewRegNCG IntRep `thenUs` \ tmp -> + = trivialCode (CMP EQQ) x y `thenNat` \ register -> + getNewRegNCG IntRep `thenNat` \ tmp -> let code = registerCode register tmp src = registerName register tmp code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst) in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) {- ------------------------------------------------------------ Comments for int_NE_code also apply to cmpF_code @@ -420,12 +416,12 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps :: (Reg -> Reg -> Reg -> Instr) -> Cond -> StixTree -> StixTree - -> UniqSM Register + -> NatM Register cmpF_code instr cond x y - = trivialFCode pr instr x y `thenUs` \ register -> - getNewRegNCG DoubleRep `thenUs` \ tmp -> - getUniqLabelNCG `thenUs` \ lbl -> + = trivialFCode pr instr x y `thenNat` \ register -> + getNewRegNCG DoubleRep `thenNat` \ tmp -> + getNatLabelNCG `thenNat` \ lbl -> let code = registerCode register tmp result = registerName register tmp @@ -436,32 +432,32 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps OR zeroh (RIReg zeroh) dst, LABEL lbl] in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) where pr = panic "trivialU?FCode: does not use PrimRep on Alpha" ------------------------------------------------------------ getRegister (StInd pk mem) - = getAmode mem `thenUs` \ amode -> + = getAmode mem `thenNat` \ amode -> let code = amodeCode amode src = amodeAddr amode size = primRepToSize pk code__2 dst = code . mkSeqInstr (LD size dst src) in - returnUs (Any pk code__2) + returnNat (Any pk code__2) getRegister (StInt i) | fits8Bits i = let code dst = mkSeqInstr (OR zeroh (RIImm src) dst) in - returnUs (Any IntRep code) + returnNat (Any IntRep code) | otherwise = let code dst = mkSeqInstr (LDI Q dst src) in - returnUs (Any IntRep code) + returnNat (Any IntRep code) where src = ImmInt (fromInteger i) @@ -470,7 +466,7 @@ getRegister leaf = let code dst = mkSeqInstr (LDA dst (AddrImm imm__2)) in - returnUs (Any PtrRep code) + returnNat (Any PtrRep code) where imm = maybeImm leaf imm__2 = case imm of Just x -> x @@ -480,8 +476,20 @@ getRegister leaf #if i386_TARGET_ARCH getRegister (StDouble d) - = getUniqLabelNCG `thenUs` \ lbl -> - let code dst = mkSeqInstrs [ + + | d == 0.0 + = let code dst = unitOL (GLDZ dst) + in trace "nativeGen: GLDZ" + (returnNat (Any DoubleRep code)) + + | d == 1.0 + = let code dst = unitOL (GLD1 dst) + in trace "nativeGen: GLD1" + returnNat (Any DoubleRep code) + + | otherwise + = getNatLabelNCG `thenNat` \ lbl -> + let code dst = toOL [ SEGMENT DataSegment, LABEL lbl, DATA DF [ImmDouble d], @@ -489,13 +497,18 @@ getRegister (StDouble d) GLD DF (ImmAddr (ImmCLbl lbl) 0) dst ] in - returnUs (Any DoubleRep code) + returnNat (Any DoubleRep code) --- incorrectly assumes that %esp doesn't move (as does spilling); ToDo: fix +-- Calculate the offset for (i+1) words above the _initial_ +-- %esp value by first determining the current offset of it. getRegister (StScratchWord i) | i >= 0 && i < 6 - = let code dst = mkSeqInstr (LEA L (OpAddr (spRel (i+1))) (OpReg dst)) - in returnUs (Any PtrRep code) + = getDeltaNat `thenNat` \ current_stack_offset -> + let j = i+1 - (current_stack_offset `div` 4) + code dst + = unitOL (LEA L (OpAddr (spRel (j+1))) (OpReg dst)) + in + returnNat (Any PtrRep code) getRegister (StPrim primop [x]) -- unary PrimOps = case primop of @@ -541,10 +554,6 @@ getRegister (StPrim primop [x]) -- unary PrimOps FloatExpOp -> (True, SLIT("exp")) FloatLogOp -> (True, SLIT("log")) - --FloatSinOp -> (True, SLIT("sin")) - --FloatCosOp -> (True, SLIT("cos")) - --FloatTanOp -> (True, SLIT("tan")) - FloatAsinOp -> (True, SLIT("asin")) FloatAcosOp -> (True, SLIT("acos")) FloatAtanOp -> (True, SLIT("atan")) @@ -556,10 +565,6 @@ getRegister (StPrim primop [x]) -- unary PrimOps DoubleExpOp -> (False, SLIT("exp")) DoubleLogOp -> (False, SLIT("log")) - --DoubleSinOp -> (False, SLIT("sin")) - --DoubleCosOp -> (False, SLIT("cos")) - --DoubleTanOp -> (False, SLIT("tan")) - DoubleAsinOp -> (False, SLIT("asin")) DoubleAcosOp -> (False, SLIT("acos")) DoubleAtanOp -> (False, SLIT("atan")) @@ -661,25 +666,25 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps shift_code :: (Imm -> Operand -> Instr) -> StixTree -> StixTree - -> UniqSM Register + -> NatM 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` \ regx -> + = getRegister x `thenNat` \ regx -> let mkcode dst - = if isFloat regx - then registerCode regx dst `bind` \ code_x -> - code_x . - mkSeqInstr (instr imm__2 (OpReg dst)) + = if isAny regx + then registerCodeA regx dst `bind` \ code_x -> + code_x `snocOL` + instr imm__2 (OpReg dst) else registerCodeF regx `bind` \ code_x -> registerNameF regx `bind` \ r_x -> - code_x . - mkSeqInstr (MOV L (OpReg r_x) (OpReg dst)) . - mkSeqInstr (instr imm__2 (OpReg dst)) + code_x `snocOL` + MOV L (OpReg r_x) (OpReg dst) `snocOL` + instr imm__2 (OpReg dst) in - returnUs (Any IntRep mkcode) + returnNat (Any IntRep mkcode) where imm = maybeImm y imm__2 = case imm of Just x -> x @@ -689,17 +694,17 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps -- use it here to do non-immediate shifts. No big deal -- -- they are only very rare, and we can use an equivalent -- test-and-jump sequence which doesn't use ECX. - -- DO NOT USE REPLACE THIS CODE WITH THE "OBVIOUS" shl/shr/sar CODE, + -- DO NOT REPLACE THIS CODE WITH THE "OBVIOUS" shl/shr/sar CODE, -- SINCE IT WILL CAUSE SERIOUS PROBLEMS WITH THE SPILLER shift_code instr x y{-amount-} - = getRegister x `thenUs` \ register1 -> - getRegister y `thenUs` \ register2 -> - getUniqLabelNCG `thenUs` \ lbl_test3 -> - getUniqLabelNCG `thenUs` \ lbl_test2 -> - getUniqLabelNCG `thenUs` \ lbl_test1 -> - getUniqLabelNCG `thenUs` \ lbl_test0 -> - getUniqLabelNCG `thenUs` \ lbl_after -> - getNewRegNCG IntRep `thenUs` \ tmp -> + = getRegister x `thenNat` \ register1 -> + getRegister y `thenNat` \ register2 -> + getNatLabelNCG `thenNat` \ lbl_test3 -> + getNatLabelNCG `thenNat` \ lbl_test2 -> + getNatLabelNCG `thenNat` \ lbl_test1 -> + getNatLabelNCG `thenNat` \ lbl_test0 -> + getNatLabelNCG `thenNat` \ lbl_after -> + getNewRegNCG IntRep `thenNat` \ tmp -> let code__2 dst = let src_val = registerName register1 dst code_val = registerCode register1 dst @@ -708,11 +713,11 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps r_dst = OpReg dst r_tmp = OpReg tmp in - code_amt . - mkSeqInstr (MOV L (OpReg src_amt) r_tmp) . - code_val . - mkSeqInstr (MOV L (OpReg src_val) r_dst) . - mkSeqInstrs [ + code_amt `snocOL` + MOV L (OpReg src_amt) r_tmp `appOL` + code_val `snocOL` + MOV L (OpReg src_val) r_dst `appOL` + toOL [ COMMENT (_PK_ "begin shift sequence"), MOV L (OpReg src_val) r_dst, MOV L (OpReg src_amt) r_tmp, @@ -745,59 +750,43 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps COMMENT (_PK_ "end shift sequence") ] in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) -------------------- - add_code :: Size -> StixTree -> StixTree -> UniqSM Register + add_code :: Size -> StixTree -> StixTree -> NatM Register add_code sz x (StInt y) - = getRegister x `thenUs` \ register -> - getNewRegNCG IntRep `thenUs` \ tmp -> + = getRegister x `thenNat` \ register -> + getNewRegNCG IntRep `thenNat` \ tmp -> let code = registerCode register tmp src1 = registerName register tmp src2 = ImmInt (fromInteger y) code__2 dst - = code . - mkSeqInstr (LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2)) - (OpReg dst)) + = code `snocOL` + LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2)) + (OpReg dst) in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) - add_code sz x y - = getRegister x `thenUs` \ register1 -> - getRegister y `thenUs` \ register2 -> - getNewRegNCG IntRep `thenUs` \ tmp1 -> - getNewRegNCG IntRep `thenUs` \ tmp2 -> - let - code1 = registerCode register1 tmp1 asmVoid - src1 = registerName register1 tmp1 - code2 = registerCode register2 tmp2 asmVoid - src2 = registerName register2 tmp2 - code__2 dst - = asmParThen [code1, code2] . - mkSeqInstr (LEA sz (OpAddr (AddrBaseIndex (Just src1) (Just (src2,1)) - (ImmInt 0))) - (OpReg dst)) - in - returnUs (Any IntRep code__2) + add_code sz x y = trivialCode (ADD sz) (Just (ADD sz)) x y -------------------- - sub_code :: Size -> StixTree -> StixTree -> UniqSM Register + sub_code :: Size -> StixTree -> StixTree -> NatM Register sub_code sz x (StInt y) - = getRegister x `thenUs` \ register -> - getNewRegNCG IntRep `thenUs` \ tmp -> + = getRegister x `thenNat` \ register -> + getNewRegNCG IntRep `thenNat` \ tmp -> let code = registerCode register tmp src1 = registerName register tmp src2 = ImmInt (-(fromInteger y)) code__2 dst - = code . - mkSeqInstr (LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2)) - (OpReg dst)) + = code `snocOL` + LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2)) + (OpReg dst) in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) sub_code sz x y = trivialCode (SUB sz) Nothing x y @@ -806,106 +795,68 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps :: Size -> StixTree -> StixTree -> Bool -- True => division, False => remainder operation - -> UniqSM Register + -> NatM Register -- x must go into eax, edx must be a sign-extension of eax, and y -- should go in some other register (or memory), so that we get - -- edx:eax / reg -> eax (remainder in edx) Currently we chose to - -- put y in memory (if it is not there already) - - -- quot_code needs further checking in the Rules-of-the-Game(x86) audit - quot_code sz x (StInd pk mem) is_division - = getRegister x `thenUs` \ register1 -> - getNewRegNCG IntRep `thenUs` \ tmp1 -> - getAmode mem `thenUs` \ amode -> - let - code1 = registerCode register1 tmp1 asmVoid - src1 = registerName register1 tmp1 - code2 = amodeCode amode asmVoid - src2 = amodeAddr amode - code__2 = asmParThen [code1, code2] . - mkSeqInstrs [MOV L (OpReg src1) (OpReg eax), - CLTD, - IDIV sz (OpAddr src2)] - in - returnUs (Fixed IntRep (if is_division then eax else edx) code__2) - - quot_code sz x (StInt i) is_division - = getRegister x `thenUs` \ register1 -> - getNewRegNCG IntRep `thenUs` \ tmp1 -> - let - code1 = registerCode register1 tmp1 asmVoid - src1 = registerName register1 tmp1 - src2 = ImmInt (fromInteger i) - code__2 = asmParThen [code1] . - mkSeqInstrs [-- we put src2 in (ebx) - MOV L (OpImm src2) - (OpAddr (AddrBaseIndex (Just ebx) Nothing - (ImmInt OFFSET_R1))), - MOV L (OpReg src1) (OpReg eax), - CLTD, - IDIV sz (OpAddr (AddrBaseIndex (Just ebx) Nothing - (ImmInt OFFSET_R1))) - ] - in - returnUs (Fixed IntRep (if is_division then eax else edx) code__2) + -- edx:eax / reg -> eax (remainder in edx). Currently we choose + -- to put y on the C stack, since that avoids tying up yet another + -- precious register. quot_code sz x y is_division - = getRegister x `thenUs` \ register1 -> - getNewRegNCG IntRep `thenUs` \ tmp1 -> - getRegister y `thenUs` \ register2 -> - getNewRegNCG IntRep `thenUs` \ tmp2 -> + = getRegister x `thenNat` \ register1 -> + getRegister y `thenNat` \ register2 -> + getNewRegNCG IntRep `thenNat` \ tmp -> + getDeltaNat `thenNat` \ delta -> let - code1 = registerCode register1 tmp1 asmVoid - src1 = registerName register1 tmp1 - code2 = registerCode register2 tmp2 asmVoid - src2 = registerName register2 tmp2 - code__2 = asmParThen [code1, code2] . - if src2 == ecx || src2 == esi - then mkSeqInstrs [ - MOV L (OpReg src1) (OpReg eax), - CLTD, - IDIV sz (OpReg src2) - ] - else mkSeqInstrs [ -- we put src2 in (ebx) - MOV L (OpReg src2) - (OpAddr (AddrBaseIndex (Just ebx) Nothing - (ImmInt OFFSET_R1))), - MOV L (OpReg src1) (OpReg eax), - CLTD, - IDIV sz (OpAddr (AddrBaseIndex (Just ebx) Nothing - (ImmInt OFFSET_R1))) - ] + code1 = registerCode register1 tmp + src1 = registerName register1 tmp + code2 = registerCode register2 tmp + src2 = registerName register2 tmp + code__2 = code2 `snocOL` -- src2 := y + PUSH L (OpReg src2) `snocOL` -- -4(%esp) := y + DELTA (delta-4) `appOL` + code1 `snocOL` -- src1 := x + MOV L (OpReg src1) (OpReg eax) `snocOL` -- eax := x + CLTD `snocOL` + IDIV sz (OpAddr (spRel 0)) `snocOL` + ADD L (OpImm (ImmInt 4)) (OpReg esp) `snocOL` + DELTA delta in - returnUs (Fixed IntRep (if is_division then eax else edx) code__2) + returnNat (Fixed IntRep (if is_division then eax else edx) code__2) ----------------------- getRegister (StInd pk mem) - = getAmode mem `thenUs` \ amode -> + = getAmode mem `thenNat` \ amode -> let code = amodeCode amode src = amodeAddr amode size = primRepToSize pk - code__2 dst = code . - if pk == DoubleRep || pk == FloatRep - then mkSeqInstr (GLD size src dst) - else mkSeqInstr (MOV size (OpAddr src) (OpReg dst)) + code__2 dst = code `snocOL` + if pk == DoubleRep || pk == FloatRep + then GLD size src dst + else case size of + L -> MOV L (OpAddr src) (OpReg dst) + B -> MOVZxL B (OpAddr src) (OpReg dst) in - returnUs (Any pk code__2) + returnNat (Any pk code__2) getRegister (StInt i) = let src = ImmInt (fromInteger i) - code dst = mkSeqInstr (MOV L (OpImm src) (OpReg dst)) + code dst + | i == 0 + = unitOL (XOR L (OpReg dst) (OpReg dst)) + | otherwise + = unitOL (MOV L (OpImm src) (OpReg dst)) in - returnUs (Any IntRep code) + returnNat (Any IntRep code) getRegister leaf | maybeToBool imm - = let - code dst = mkSeqInstr (MOV L (OpImm imm__2) (OpReg dst)) + = let code dst = unitOL (MOV L (OpImm imm__2) (OpReg dst)) in - returnUs (Any PtrRep code) + returnNat (Any PtrRep code) | otherwise = pprPanic "getRegister(x86)" (pprStixTrees [leaf]) where @@ -917,8 +868,8 @@ getRegister leaf #if sparc_TARGET_ARCH getRegister (StDouble d) - = getUniqLabelNCG `thenUs` \ lbl -> - getNewRegNCG PtrRep `thenUs` \ tmp -> + = getNatLabelNCG `thenNat` \ lbl -> + getNewRegNCG PtrRep `thenNat` \ tmp -> let code dst = mkSeqInstrs [ SEGMENT DataSegment, LABEL lbl, @@ -927,7 +878,7 @@ getRegister (StDouble d) SETHI (HI (ImmCLbl lbl)) tmp, LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst] in - returnUs (Any DoubleRep code) + returnNat (Any DoubleRep code) getRegister (StPrim primop [x]) -- unary PrimOps = case primop of @@ -1072,14 +1023,14 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps imul_div fn x y = getRegister (StCall fn cCallConv IntRep [x, y]) getRegister (StInd pk mem) - = getAmode mem `thenUs` \ amode -> + = getAmode mem `thenNat` \ amode -> let code = amodeCode amode src = amodeAddr amode size = primRepToSize pk code__2 dst = code . mkSeqInstr (LD size src dst) in - returnUs (Any pk code__2) + returnNat (Any pk code__2) getRegister (StInt i) | fits13Bits i @@ -1087,7 +1038,7 @@ getRegister (StInt i) src = ImmInt (fromInteger i) code dst = mkSeqInstr (OR False g0 (RIImm src) dst) in - returnUs (Any IntRep code) + returnNat (Any IntRep code) getRegister leaf | maybeToBool imm @@ -1096,7 +1047,7 @@ getRegister leaf SETHI (HI imm__2) dst, OR False dst (RIImm (LO imm__2)) dst] in - returnUs (Any PtrRep code) + returnNat (Any PtrRep code) where imm = maybeImm leaf imm__2 = case imm of Just x -> x @@ -1121,119 +1072,125 @@ amodeCode (Amode _ code) = code Now, given a tree (the argument to an StInd) that references memory, produce a suitable addressing mode. +A Rule of the Game (tm) for Amodes: use of the addr bit must +immediately follow use of the code part, since the code part puts +values in registers which the addr then refers to. So you can't put +anything in between, lest it overwrite some of those registers. If +you need to do some other computation between the code part and use of +the addr bit, first store the effective address from the amode in a +temporary, then do the other computation, and then use the temporary: + + code + LEA amode, tmp + ... other computation ... + ... (tmp) ... + \begin{code} -getAmode :: StixTree -> UniqSM Amode +getAmode :: StixTree -> NatM Amode getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree) #if alpha_TARGET_ARCH getAmode (StPrim IntSubOp [x, StInt i]) - = getNewRegNCG PtrRep `thenUs` \ tmp -> - getRegister x `thenUs` \ register -> + = getNewRegNCG PtrRep `thenNat` \ tmp -> + getRegister x `thenNat` \ register -> let code = registerCode register tmp reg = registerName register tmp off = ImmInt (-(fromInteger i)) in - returnUs (Amode (AddrRegImm reg off) code) + returnNat (Amode (AddrRegImm reg off) code) getAmode (StPrim IntAddOp [x, StInt i]) - = getNewRegNCG PtrRep `thenUs` \ tmp -> - getRegister x `thenUs` \ register -> + = getNewRegNCG PtrRep `thenNat` \ tmp -> + getRegister x `thenNat` \ register -> let code = registerCode register tmp reg = registerName register tmp off = ImmInt (fromInteger i) in - returnUs (Amode (AddrRegImm reg off) code) + returnNat (Amode (AddrRegImm reg off) code) getAmode leaf | maybeToBool imm - = returnUs (Amode (AddrImm imm__2) id) + = returnNat (Amode (AddrImm imm__2) id) where imm = maybeImm leaf imm__2 = case imm of Just x -> x getAmode other - = getNewRegNCG PtrRep `thenUs` \ tmp -> - getRegister other `thenUs` \ register -> + = getNewRegNCG PtrRep `thenNat` \ tmp -> + getRegister other `thenNat` \ register -> let code = registerCode register tmp reg = registerName register tmp in - returnUs (Amode (AddrReg reg) code) + returnNat (Amode (AddrReg reg) code) #endif {- alpha_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if i386_TARGET_ARCH getAmode (StPrim IntSubOp [x, StInt i]) - = getNewRegNCG PtrRep `thenUs` \ tmp -> - getRegister x `thenUs` \ register -> + = getNewRegNCG PtrRep `thenNat` \ tmp -> + getRegister x `thenNat` \ register -> let code = registerCode register tmp reg = registerName register tmp off = ImmInt (-(fromInteger i)) in - returnUs (Amode (AddrBaseIndex (Just reg) Nothing off) code) + returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code) getAmode (StPrim IntAddOp [x, StInt i]) | maybeToBool imm - = let - code = mkSeqInstrs [] - in - returnUs (Amode (ImmAddr imm__2 (fromInteger i)) code) + = returnNat (Amode (ImmAddr imm__2 (fromInteger i)) nilOL) where imm = maybeImm x imm__2 = case imm of Just x -> x getAmode (StPrim IntAddOp [x, StInt i]) - = getNewRegNCG PtrRep `thenUs` \ tmp -> - getRegister x `thenUs` \ register -> + = getNewRegNCG PtrRep `thenNat` \ tmp -> + getRegister x `thenNat` \ register -> let code = registerCode register tmp reg = registerName register tmp off = ImmInt (fromInteger i) in - returnUs (Amode (AddrBaseIndex (Just reg) Nothing off) code) + returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code) getAmode (StPrim IntAddOp [x, StPrim SllOp [y, StInt shift]]) | shift == 0 || shift == 1 || shift == 2 || shift == 3 - = getNewRegNCG PtrRep `thenUs` \ tmp1 -> - getNewRegNCG IntRep `thenUs` \ tmp2 -> - getRegister x `thenUs` \ register1 -> - getRegister y `thenUs` \ register2 -> + = getNewRegNCG PtrRep `thenNat` \ tmp1 -> + getNewRegNCG IntRep `thenNat` \ tmp2 -> + getRegister x `thenNat` \ register1 -> + getRegister y `thenNat` \ register2 -> let - code1 = registerCode register1 tmp1 asmVoid + code1 = registerCode register1 tmp1 reg1 = registerName register1 tmp1 - code2 = registerCode register2 tmp2 asmVoid + code2 = registerCode register2 tmp2 reg2 = registerName register2 tmp2 - code__2 = asmParThen [code1, code2] + code__2 = code1 `appOL` code2 base = case shift of 0 -> 1 ; 1 -> 2; 2 -> 4; 3 -> 8 in - returnUs (Amode (AddrBaseIndex (Just reg1) (Just (reg2,base)) (ImmInt 0)) - code__2) + returnNat (Amode (AddrBaseIndex (Just reg1) (Just (reg2,base)) (ImmInt 0)) + code__2) getAmode leaf | maybeToBool imm - = let - code = mkSeqInstrs [] - in - returnUs (Amode (ImmAddr imm__2 0) code) + = returnNat (Amode (ImmAddr imm__2 0) nilOL) where imm = maybeImm leaf imm__2 = case imm of Just x -> x getAmode other - = getNewRegNCG PtrRep `thenUs` \ tmp -> - getRegister other `thenUs` \ register -> + = getNewRegNCG PtrRep `thenNat` \ tmp -> + getRegister other `thenNat` \ register -> let code = registerCode register tmp reg = registerName register tmp - off = Nothing in - returnUs (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code) + returnNat (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code) #endif {- i386_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -1241,61 +1198,61 @@ getAmode other getAmode (StPrim IntSubOp [x, StInt i]) | fits13Bits (-i) - = getNewRegNCG PtrRep `thenUs` \ tmp -> - getRegister x `thenUs` \ register -> + = getNewRegNCG PtrRep `thenNat` \ tmp -> + getRegister x `thenNat` \ register -> let code = registerCode register tmp reg = registerName register tmp off = ImmInt (-(fromInteger i)) in - returnUs (Amode (AddrRegImm reg off) code) + returnNat (Amode (AddrRegImm reg off) code) getAmode (StPrim IntAddOp [x, StInt i]) | fits13Bits i - = getNewRegNCG PtrRep `thenUs` \ tmp -> - getRegister x `thenUs` \ register -> + = getNewRegNCG PtrRep `thenNat` \ tmp -> + getRegister x `thenNat` \ register -> let code = registerCode register tmp reg = registerName register tmp off = ImmInt (fromInteger i) in - returnUs (Amode (AddrRegImm reg off) code) + returnNat (Amode (AddrRegImm reg off) code) getAmode (StPrim IntAddOp [x, y]) - = getNewRegNCG PtrRep `thenUs` \ tmp1 -> - getNewRegNCG IntRep `thenUs` \ tmp2 -> - getRegister x `thenUs` \ register1 -> - getRegister y `thenUs` \ register2 -> + = getNewRegNCG PtrRep `thenNat` \ tmp1 -> + getNewRegNCG IntRep `thenNat` \ tmp2 -> + getRegister x `thenNat` \ register1 -> + getRegister y `thenNat` \ register2 -> let - code1 = registerCode register1 tmp1 asmVoid + code1 = registerCode register1 tmp1 [] reg1 = registerName register1 tmp1 - code2 = registerCode register2 tmp2 asmVoid + code2 = registerCode register2 tmp2 [] reg2 = registerName register2 tmp2 - code__2 = asmParThen [code1, code2] + code__2 = asmSeqThen [code1, code2] in - returnUs (Amode (AddrRegReg reg1 reg2) code__2) + returnNat (Amode (AddrRegReg reg1 reg2) code__2) getAmode leaf | maybeToBool imm - = getNewRegNCG PtrRep `thenUs` \ tmp -> + = getNewRegNCG PtrRep `thenNat` \ tmp -> let code = mkSeqInstr (SETHI (HI imm__2) tmp) in - returnUs (Amode (AddrRegImm tmp (LO imm__2)) code) + returnNat (Amode (AddrRegImm tmp (LO imm__2)) code) where imm = maybeImm leaf imm__2 = case imm of Just x -> x getAmode other - = getNewRegNCG PtrRep `thenUs` \ tmp -> - getRegister other `thenUs` \ register -> + = getNewRegNCG PtrRep `thenNat` \ tmp -> + getRegister other `thenNat` \ register -> let code = registerCode register tmp reg = registerName register tmp off = ImmInt 0 in - returnUs (Amode (AddrRegImm reg off) code) + returnNat (Amode (AddrRegImm reg off) code) #endif {- sparc_TARGET_ARCH -} \end{code} @@ -1318,7 +1275,7 @@ condCode (CondCode _ _ code) = code Set up a condition code for a conditional branch. \begin{code} -getCondCode :: StixTree -> UniqSM CondCode +getCondCode :: StixTree -> NatM CondCode #if alpha_TARGET_ARCH getCondCode = panic "MachCode.getCondCode: not on Alphas" @@ -1331,46 +1288,46 @@ getCondCode = panic "MachCode.getCondCode: not on Alphas" getCondCode (StPrim primop [x, y]) = case primop of CharGtOp -> condIntCode GTT x y - CharGeOp -> condIntCode GE x y + CharGeOp -> condIntCode GE x y CharEqOp -> condIntCode EQQ x y - CharNeOp -> condIntCode NE x y + CharNeOp -> condIntCode NE x y CharLtOp -> condIntCode LTT x y - CharLeOp -> condIntCode LE x y + CharLeOp -> condIntCode LE x y IntGtOp -> condIntCode GTT x y - IntGeOp -> condIntCode GE x y + IntGeOp -> condIntCode GE x y IntEqOp -> condIntCode EQQ x y - IntNeOp -> condIntCode NE x y + IntNeOp -> condIntCode NE x y IntLtOp -> condIntCode LTT x y - IntLeOp -> condIntCode LE x y + IntLeOp -> condIntCode LE x y - WordGtOp -> condIntCode GU x y - WordGeOp -> condIntCode GEU x y + WordGtOp -> condIntCode GU x y + WordGeOp -> condIntCode GEU x y WordEqOp -> condIntCode EQQ x y - WordNeOp -> condIntCode NE x y - WordLtOp -> condIntCode LU x y - WordLeOp -> condIntCode LEU x y + WordNeOp -> condIntCode NE x y + WordLtOp -> condIntCode LU x y + WordLeOp -> condIntCode LEU x y - AddrGtOp -> condIntCode GU x y - AddrGeOp -> condIntCode GEU x y + AddrGtOp -> condIntCode GU x y + AddrGeOp -> condIntCode GEU x y AddrEqOp -> condIntCode EQQ x y - AddrNeOp -> condIntCode NE x y - AddrLtOp -> condIntCode LU x y - AddrLeOp -> condIntCode LEU x y + AddrNeOp -> condIntCode NE x y + AddrLtOp -> condIntCode LU x y + AddrLeOp -> condIntCode LEU x y FloatGtOp -> condFltCode GTT x y - FloatGeOp -> condFltCode GE x y + FloatGeOp -> condFltCode GE x y FloatEqOp -> condFltCode EQQ x y - FloatNeOp -> condFltCode NE x y + FloatNeOp -> condFltCode NE x y FloatLtOp -> condFltCode LTT x y - FloatLeOp -> condFltCode LE x y + FloatLeOp -> condFltCode LE x y DoubleGtOp -> condFltCode GTT x y - DoubleGeOp -> condFltCode GE x y + DoubleGeOp -> condFltCode GE x y DoubleEqOp -> condFltCode EQQ x y - DoubleNeOp -> condFltCode NE x y + DoubleNeOp -> condFltCode NE x y DoubleLtOp -> condFltCode LTT x y - DoubleLeOp -> condFltCode LE x y + DoubleLeOp -> condFltCode LE x y #endif {- i386_TARGET_ARCH || sparc_TARGET_ARCH -} \end{code} @@ -1381,7 +1338,7 @@ getCondCode (StPrim primop [x, y]) passed back up the tree. \begin{code} -condIntCode, condFltCode :: Cond -> StixTree -> StixTree -> UniqSM CondCode +condIntCode, condFltCode :: Cond -> StixTree -> StixTree -> NatM CondCode #if alpha_TARGET_ARCH condIntCode = panic "MachCode.condIntCode: not on Alphas" @@ -1391,99 +1348,130 @@ condFltCode = panic "MachCode.condFltCode: not on Alphas" -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if i386_TARGET_ARCH --- some condIntCode clauses look pretty dodgy to me -condIntCode cond (StInd _ x) y +-- memory vs immediate +condIntCode cond (StInd pk x) y | maybeToBool imm - = getAmode x `thenUs` \ amode -> + = getAmode x `thenNat` \ amode -> let - code1 = amodeCode amode asmVoid - y__2 = amodeAddr amode - code__2 = asmParThen [code1] . - mkSeqInstr (CMP L (OpImm imm__2) (OpAddr y__2)) + code1 = amodeCode amode + x__2 = amodeAddr amode + sz = primRepToSize pk + code__2 = code1 `snocOL` + CMP sz (OpImm imm__2) (OpAddr x__2) in - returnUs (CondCode False cond code__2) + returnNat (CondCode False cond code__2) where imm = maybeImm y imm__2 = case imm of Just x -> x +-- anything vs zero condIntCode cond x (StInt 0) - = getRegister x `thenUs` \ register1 -> - getNewRegNCG IntRep `thenUs` \ tmp1 -> + = getRegister x `thenNat` \ register1 -> + getNewRegNCG IntRep `thenNat` \ tmp1 -> let - code1 = registerCode register1 tmp1 asmVoid + code1 = registerCode register1 tmp1 src1 = registerName register1 tmp1 - code__2 = asmParThen [code1] . - mkSeqInstr (TEST L (OpReg src1) (OpReg src1)) + code__2 = code1 `snocOL` + TEST L (OpReg src1) (OpReg src1) in - returnUs (CondCode False cond code__2) + returnNat (CondCode False cond code__2) +-- anything vs immediate condIntCode cond x y | maybeToBool imm - = getRegister x `thenUs` \ register1 -> - getNewRegNCG IntRep `thenUs` \ tmp1 -> + = getRegister x `thenNat` \ register1 -> + getNewRegNCG IntRep `thenNat` \ tmp1 -> let - code1 = registerCode register1 tmp1 asmVoid + code1 = registerCode register1 tmp1 src1 = registerName register1 tmp1 - code__2 = asmParThen [code1] . - mkSeqInstr (CMP L (OpImm imm__2) (OpReg src1)) + code__2 = code1 `snocOL` + CMP L (OpImm imm__2) (OpReg src1) in - returnUs (CondCode False cond code__2) + returnNat (CondCode False cond code__2) where imm = maybeImm y imm__2 = case imm of Just x -> x -condIntCode cond (StInd _ x) y - = getAmode x `thenUs` \ amode -> - getRegister y `thenUs` \ register2 -> - getNewRegNCG IntRep `thenUs` \ tmp2 -> - let - code1 = amodeCode amode asmVoid - src1 = amodeAddr amode - code2 = registerCode register2 tmp2 asmVoid - src2 = registerName register2 tmp2 - code__2 = asmParThen [code1, code2] . - mkSeqInstr (CMP L (OpReg src2) (OpAddr src1)) - in - returnUs (CondCode False cond code__2) - -condIntCode cond y (StInd _ x) - = getAmode x `thenUs` \ amode -> - getRegister y `thenUs` \ register2 -> - getNewRegNCG IntRep `thenUs` \ tmp2 -> - let - code1 = amodeCode amode asmVoid - src1 = amodeAddr amode - code2 = registerCode register2 tmp2 asmVoid - src2 = registerName register2 tmp2 - code__2 = asmParThen [code1, code2] . - mkSeqInstr (CMP L (OpAddr src1) (OpReg src2)) - in - returnUs (CondCode False cond code__2) - +-- memory vs anything +condIntCode cond (StInd pk x) y + = getAmode x `thenNat` \ amode_x -> + getRegister y `thenNat` \ reg_y -> + getNewRegNCG IntRep `thenNat` \ tmp -> + let + c_x = amodeCode amode_x + am_x = amodeAddr amode_x + c_y = registerCode reg_y tmp + r_y = registerName reg_y tmp + sz = primRepToSize pk + + -- optimisation: if there's no code for x, just an amode, + -- use whatever reg y winds up in. Assumes that c_y doesn't + -- clobber any regs in the amode am_x, which I'm not sure is + -- justified. The otherwise clause makes the same assumption. + code__2 | isNilOL c_x + = c_y `snocOL` + CMP sz (OpReg r_y) (OpAddr am_x) + + | otherwise + = c_y `snocOL` + MOV L (OpReg r_y) (OpReg tmp) `appOL` + c_x `snocOL` + CMP sz (OpReg tmp) (OpAddr am_x) + in + returnNat (CondCode False cond code__2) + +-- anything vs memory +-- +condIntCode cond y (StInd pk x) + = getAmode x `thenNat` \ amode_x -> + getRegister y `thenNat` \ reg_y -> + getNewRegNCG IntRep `thenNat` \ tmp -> + let + c_x = amodeCode amode_x + am_x = amodeAddr amode_x + c_y = registerCode reg_y tmp + r_y = registerName reg_y tmp + sz = primRepToSize pk + -- same optimisation and nagging doubts as previous clause + code__2 | isNilOL c_x + = c_y `snocOL` + CMP sz (OpAddr am_x) (OpReg r_y) + + | otherwise + = c_y `snocOL` + MOV L (OpReg r_y) (OpReg tmp) `appOL` + c_x `snocOL` + CMP sz (OpAddr am_x) (OpReg tmp) + in + returnNat (CondCode False cond code__2) + +-- anything vs anything condIntCode cond x y - = getRegister x `thenUs` \ register1 -> - getRegister y `thenUs` \ register2 -> - getNewRegNCG IntRep `thenUs` \ tmp1 -> - getNewRegNCG IntRep `thenUs` \ tmp2 -> + = getRegister x `thenNat` \ register1 -> + getRegister y `thenNat` \ register2 -> + getNewRegNCG IntRep `thenNat` \ tmp1 -> + getNewRegNCG IntRep `thenNat` \ tmp2 -> let - code1 = registerCode register1 tmp1 asmVoid + code1 = registerCode register1 tmp1 src1 = registerName register1 tmp1 - code2 = registerCode register2 tmp2 asmVoid + code2 = registerCode register2 tmp2 src2 = registerName register2 tmp2 - code__2 = asmParThen [code1, code2] . - mkSeqInstr (CMP L (OpReg src2) (OpReg src1)) + code__2 = code1 `snocOL` + MOV L (OpReg src1) (OpReg tmp1) `appOL` + code2 `snocOL` + CMP L (OpReg src2) (OpReg tmp1) in - returnUs (CondCode False cond code__2) + returnNat (CondCode False cond code__2) ----------- condFltCode cond x y - = getRegister x `thenUs` \ register1 -> - getRegister y `thenUs` \ register2 -> + = getRegister x `thenNat` \ register1 -> + getRegister y `thenNat` \ register2 -> getNewRegNCG (registerRep register1) - `thenUs` \ tmp1 -> + `thenNat` \ tmp1 -> getNewRegNCG (registerRep register2) - `thenUs` \ tmp2 -> - getNewRegNCG DoubleRep `thenUs` \ tmp -> + `thenNat` \ tmp2 -> + getNewRegNCG DoubleRep `thenNat` \ tmp -> let pk1 = registerRep register1 code1 = registerCode register1 tmp1 @@ -1493,21 +1481,29 @@ condFltCode cond x y code2 = registerCode register2 tmp2 src2 = registerName register2 tmp2 - code__2 = asmParThen [code1 asmVoid, code2 asmVoid] . - mkSeqInstr (GCMP (primRepToSize pk1) src1 src2) + code__2 | isAny register1 + = code1 `appOL` -- result in tmp1 + code2 `snocOL` + GCMP (primRepToSize pk1) tmp1 src2 + + | otherwise + = code1 `snocOL` + GMOV src1 tmp1 `appOL` + code2 `snocOL` + GCMP (primRepToSize pk1) tmp1 src2 {- On the 486, the flags set by FP compare are the unsigned ones! (This looks like a HACK to me. WDP 96/03) -} fix_FP_cond :: Cond -> Cond - fix_FP_cond GE = GEU + fix_FP_cond GE = GEU fix_FP_cond GTT = GU fix_FP_cond LTT = LU - fix_FP_cond LE = LEU - fix_FP_cond any = any + fix_FP_cond LE = LEU + fix_FP_cond any = any in - returnUs (CondCode True (fix_FP_cond cond) code__2) + returnNat (CondCode True (fix_FP_cond cond) code__2) @@ -1517,40 +1513,40 @@ condFltCode cond x y condIntCode cond x (StInt y) | fits13Bits y - = getRegister x `thenUs` \ register -> - getNewRegNCG IntRep `thenUs` \ tmp -> + = getRegister x `thenNat` \ register -> + getNewRegNCG IntRep `thenNat` \ tmp -> let code = registerCode register tmp src1 = registerName register tmp src2 = ImmInt (fromInteger y) code__2 = code . mkSeqInstr (SUB False True src1 (RIImm src2) g0) in - returnUs (CondCode False cond code__2) + returnNat (CondCode False cond code__2) condIntCode cond x y - = getRegister x `thenUs` \ register1 -> - getRegister y `thenUs` \ register2 -> - getNewRegNCG IntRep `thenUs` \ tmp1 -> - getNewRegNCG IntRep `thenUs` \ tmp2 -> + = getRegister x `thenNat` \ register1 -> + getRegister y `thenNat` \ register2 -> + getNewRegNCG IntRep `thenNat` \ tmp1 -> + getNewRegNCG IntRep `thenNat` \ tmp2 -> let - code1 = registerCode register1 tmp1 asmVoid + code1 = registerCode register1 tmp1 [] src1 = registerName register1 tmp1 - code2 = registerCode register2 tmp2 asmVoid + code2 = registerCode register2 tmp2 [] src2 = registerName register2 tmp2 - code__2 = asmParThen [code1, code2] . + code__2 = asmSeqThen [code1, code2] . mkSeqInstr (SUB False True src1 (RIReg src2) g0) in - returnUs (CondCode False cond code__2) + returnNat (CondCode False cond code__2) ----------- condFltCode cond x y - = getRegister x `thenUs` \ register1 -> - getRegister y `thenUs` \ register2 -> + = getRegister x `thenNat` \ register1 -> + getRegister y `thenNat` \ register2 -> getNewRegNCG (registerRep register1) - `thenUs` \ tmp1 -> + `thenNat` \ tmp1 -> getNewRegNCG (registerRep register2) - `thenUs` \ tmp2 -> - getNewRegNCG DoubleRep `thenUs` \ tmp -> + `thenNat` \ tmp2 -> + getNewRegNCG DoubleRep `thenNat` \ tmp -> let promote x = asmInstr (FxTOy F DF x tmp) @@ -1564,16 +1560,16 @@ condFltCode cond x y code__2 = if pk1 == pk2 then - asmParThen [code1 asmVoid, code2 asmVoid] . + asmSeqThen [code1 [], code2 []] . mkSeqInstr (FCMP True (primRepToSize pk1) src1 src2) else if pk1 == FloatRep then - asmParThen [code1 (promote src1), code2 asmVoid] . + asmSeqThen [code1 (promote src1), code2 []] . mkSeqInstr (FCMP True DF tmp src2) else - asmParThen [code1 asmVoid, code2 (promote src2)] . + asmSeqThen [code1 [], code2 (promote src2)] . mkSeqInstr (FCMP True DF src1 tmp) in - returnUs (CondCode True cond code__2) + returnNat (CondCode True cond code__2) #endif {- sparc_TARGET_ARCH -} \end{code} @@ -1594,27 +1590,27 @@ hand side is forced into a fixed register (e.g. the result of a call). \begin{code} assignIntCode, assignFltCode - :: PrimRep -> StixTree -> StixTree -> UniqSM InstrBlock + :: PrimRep -> StixTree -> StixTree -> NatM InstrBlock #if alpha_TARGET_ARCH assignIntCode pk (StInd _ dst) src - = getNewRegNCG IntRep `thenUs` \ tmp -> - getAmode dst `thenUs` \ amode -> - getRegister src `thenUs` \ register -> + = getNewRegNCG IntRep `thenNat` \ tmp -> + getAmode dst `thenNat` \ amode -> + getRegister src `thenNat` \ register -> let - code1 = amodeCode amode asmVoid + code1 = amodeCode amode [] dst__2 = amodeAddr amode - code2 = registerCode register tmp asmVoid + code2 = registerCode register tmp [] src__2 = registerName register tmp sz = primRepToSize pk - code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2) + code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2) in - returnUs code__2 + returnNat code__2 assignIntCode pk dst src - = getRegister dst `thenUs` \ register1 -> - getRegister src `thenUs` \ register2 -> + = getRegister dst `thenNat` \ register1 -> + getRegister src `thenNat` \ register2 -> let dst__2 = registerName register1 zeroh code = registerCode register2 dst__2 @@ -1623,97 +1619,123 @@ assignIntCode pk dst src then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2) else code in - returnUs code__2 + returnNat code__2 #endif {- alpha_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if i386_TARGET_ARCH --- looks dodgy to me -assignIntCode pk dd@(StInd _ dst) src - = getAmode dst `thenUs` \ amode -> - get_op_RI src `thenUs` \ (codesrc, opsrc) -> - let - code1 = amodeCode amode asmVoid - dst__2 = amodeAddr amode - code__2 = asmParThen [code1, codesrc asmVoid] . - mkSeqInstr (MOV (primRepToSize pk) opsrc (OpAddr dst__2)) - in - returnUs code__2 +-- Destination of an assignment can only be reg or mem. +-- This is the mem case. +assignIntCode pk (StInd _ dst) src + = getAmode dst `thenNat` \ amode -> + get_op_RI src `thenNat` \ (codesrc, opsrc) -> + getNewRegNCG PtrRep `thenNat` \ tmp -> + let + -- In general, if the address computation for dst may require + -- some insns preceding the addressing mode itself. So there's + -- no guarantee that the code for dst and the code for src won't + -- write the same register. This means either the address or + -- the value needs to be copied into a temporary. We detect the + -- common case where the amode has no code, and elide the copy. + codea = amodeCode amode + dst__a = amodeAddr amode + + code | isNilOL codea + = codesrc `snocOL` + MOV (primRepToSize pk) opsrc (OpAddr dst__a) + | otherwise + + = codea `snocOL` + LEA L (OpAddr dst__a) (OpReg tmp) `appOL` + codesrc `snocOL` + MOV (primRepToSize pk) opsrc + (OpAddr (AddrBaseIndex (Just tmp) Nothing (ImmInt 0))) + in + returnNat code where get_op_RI :: StixTree - -> UniqSM (InstrBlock,Operand) -- code, operator + -> NatM (InstrBlock,Operand) -- code, operator get_op_RI op | maybeToBool imm - = returnUs (asmParThen [], OpImm imm_op) + = returnNat (nilOL, OpImm imm_op) where imm = maybeImm op imm_op = case imm of Just x -> x get_op_RI op - = getRegister op `thenUs` \ register -> + = getRegister op `thenNat` \ register -> getNewRegNCG (registerRep register) - `thenUs` \ tmp -> - let - code = registerCode register tmp + `thenNat` \ tmp -> + let code = registerCode register tmp reg = registerName register tmp in - returnUs (code, OpReg reg) + returnNat (code, OpReg reg) +-- Assign; dst is a reg, rhs is mem assignIntCode pk dst (StInd pks src) - = getNewRegNCG IntRep `thenUs` \ tmp -> - getAmode src `thenUs` \ amode -> - getRegister dst `thenUs` \ register -> - let - code1 = amodeCode amode asmVoid - src__2 = amodeAddr amode - code2 = registerCode register tmp asmVoid - dst__2 = registerName register tmp - szs = primRepToSize pks - code__2 = asmParThen [code1, code2] . - case szs of - L -> mkSeqInstr (MOV L (OpAddr src__2) (OpReg dst__2)) - B -> mkSeqInstr (MOVZxL B (OpAddr src__2) (OpReg dst__2)) - in - returnUs code__2 - -assignIntCode pk dst src - = getRegister dst `thenUs` \ register1 -> - getRegister src `thenUs` \ register2 -> - getNewRegNCG IntRep `thenUs` \ tmp -> + = getNewRegNCG PtrRep `thenNat` \ tmp -> + getAmode src `thenNat` \ amode -> + getRegister dst `thenNat` \ reg_dst -> let - dst__2 = registerName register1 tmp - code = registerCode register2 dst__2 - src__2 = registerName register2 dst__2 - code__2 = if isFixed register2 && dst__2 /= src__2 - then code . mkSeqInstr (MOV L (OpReg src__2) (OpReg dst__2)) - else code + c_addr = amodeCode amode + am_addr = amodeAddr amode + + c_dst = registerCode reg_dst tmp -- should be empty + r_dst = registerName reg_dst tmp + szs = primRepToSize pks + opc = case szs of L -> MOV L ; B -> MOVZxL B + + code | isNilOL c_dst + = c_addr `snocOL` + opc (OpAddr am_addr) (OpReg r_dst) + | otherwise + = pprPanic "assignIntCode(x86): bad dst(2)" empty in - returnUs code__2 + returnNat code + +-- dst is a reg, but src could be anything +assignIntCode pk dst src + = getRegister dst `thenNat` \ registerd -> + getRegister src `thenNat` \ registers -> + getNewRegNCG IntRep `thenNat` \ tmp -> + let + r_dst = registerName registerd tmp + c_dst = registerCode registerd tmp -- should be empty + r_src = registerName registers r_dst + c_src = registerCode registers r_dst + + code | isNilOL c_dst + = c_src `snocOL` + MOV L (OpReg r_src) (OpReg r_dst) + | otherwise + = pprPanic "assignIntCode(x86): bad dst(3)" empty + in + returnNat code #endif {- i386_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if sparc_TARGET_ARCH assignIntCode pk (StInd _ dst) src - = getNewRegNCG IntRep `thenUs` \ tmp -> - getAmode dst `thenUs` \ amode -> - getRegister src `thenUs` \ register -> + = getNewRegNCG IntRep `thenNat` \ tmp -> + getAmode dst `thenNat` \ amode -> + getRegister src `thenNat` \ register -> let - code1 = amodeCode amode asmVoid + code1 = amodeCode amode [] dst__2 = amodeAddr amode - code2 = registerCode register tmp asmVoid + code2 = registerCode register tmp [] src__2 = registerName register tmp sz = primRepToSize pk - code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2) + code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2) in - returnUs code__2 + returnNat code__2 assignIntCode pk dst src - = getRegister dst `thenUs` \ register1 -> - getRegister src `thenUs` \ register2 -> + = getRegister dst `thenNat` \ register1 -> + getRegister src `thenNat` \ register2 -> let dst__2 = registerName register1 g0 code = registerCode register2 dst__2 @@ -1722,7 +1744,7 @@ assignIntCode pk dst src then code . mkSeqInstr (OR False g0 (RIReg src__2) dst__2) else code in - returnUs code__2 + returnNat code__2 #endif {- sparc_TARGET_ARCH -} \end{code} @@ -1734,22 +1756,22 @@ Floating-point assignments: #if alpha_TARGET_ARCH assignFltCode pk (StInd _ dst) src - = getNewRegNCG pk `thenUs` \ tmp -> - getAmode dst `thenUs` \ amode -> - getRegister src `thenUs` \ register -> + = getNewRegNCG pk `thenNat` \ tmp -> + getAmode dst `thenNat` \ amode -> + getRegister src `thenNat` \ register -> let - code1 = amodeCode amode asmVoid + code1 = amodeCode amode [] dst__2 = amodeAddr amode - code2 = registerCode register tmp asmVoid + code2 = registerCode register tmp [] src__2 = registerName register tmp sz = primRepToSize pk - code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2) + code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2) in - returnUs code__2 + returnNat code__2 assignFltCode pk dst src - = getRegister dst `thenUs` \ register1 -> - getRegister src `thenUs` \ register2 -> + = getRegister dst `thenNat` \ register1 -> + getRegister src `thenNat` \ register2 -> let dst__2 = registerName register1 zeroh code = registerCode register2 dst__2 @@ -1758,106 +1780,95 @@ assignFltCode pk dst src then code . mkSeqInstr (FMOV src__2 dst__2) else code in - returnUs code__2 + returnNat code__2 #endif {- alpha_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if i386_TARGET_ARCH -assignFltCode pk (StInd pk_dst dst) (StInd pk_src src) - = getNewRegNCG IntRep `thenUs` \ tmp -> - getAmode src `thenUs` \ amodesrc -> - getAmode dst `thenUs` \ amodedst -> - let - codesrc1 = amodeCode amodesrc asmVoid - addrsrc1 = amodeAddr amodesrc - codedst1 = amodeCode amodedst asmVoid - addrdst1 = amodeAddr amodedst - addrsrc2 = case (addrOffset addrsrc1 4) of Just x -> x - addrdst2 = case (addrOffset addrdst1 4) of Just x -> x - - code__2 = asmParThen [codesrc1, codedst1] . - mkSeqInstrs ([MOV L (OpAddr addrsrc1) (OpReg tmp), - MOV L (OpReg tmp) (OpAddr addrdst1)] - ++ - if pk == DoubleRep - then [MOV L (OpAddr addrsrc2) (OpReg tmp), - MOV L (OpReg tmp) (OpAddr addrdst2)] - else []) - in - returnUs code__2 - -assignFltCode pk (StInd _ dst) src - = getNewRegNCG pk `thenUs` \ tmp -> - getAmode dst `thenUs` \ amode -> - getRegister src `thenUs` \ register -> +-- dst is memory +assignFltCode pk (StInd pk_dst addr) src + | pk /= pk_dst + = pprPanic "assignFltCode(x86): src/ind sz mismatch" empty + | otherwise + = getRegister src `thenNat` \ reg_src -> + getRegister addr `thenNat` \ reg_addr -> + getNewRegNCG pk `thenNat` \ tmp_src -> + getNewRegNCG PtrRep `thenNat` \ tmp_addr -> + let r_src = registerName reg_src tmp_src + c_src = registerCode reg_src tmp_src + r_addr = registerName reg_addr tmp_addr + c_addr = registerCode reg_addr tmp_addr + sz = primRepToSize pk + + code = c_src `appOL` + -- no need to preserve r_src across the addr computation, + -- since r_src must be a float reg + -- whilst r_addr is an int reg + c_addr `snocOL` + GST sz r_src + (AddrBaseIndex (Just r_addr) Nothing (ImmInt 0)) + in + returnNat code + +-- dst must be a (FP) register +assignFltCode pk dst src + = getRegister dst `thenNat` \ reg_dst -> + getRegister src `thenNat` \ reg_src -> + getNewRegNCG pk `thenNat` \ tmp -> let - sz = primRepToSize pk - dst__2 = amodeAddr amode - - code1 = amodeCode amode asmVoid - code2 = registerCode register tmp asmVoid + r_dst = registerName reg_dst tmp + c_dst = registerCode reg_dst tmp -- should be empty - src__2 = registerName register tmp + r_src = registerName reg_src r_dst + c_src = registerCode reg_src r_dst - code__2 = asmParThen [code1, code2] . - mkSeqInstr (GST sz src__2 dst__2) + code | isNilOL c_dst + = if isFixed reg_src + then c_src `snocOL` GMOV r_src r_dst + else c_src + | otherwise + = pprPanic "assignFltCode(x86): lhs is not mem or reg" + empty in - returnUs code__2 + returnNat code -assignFltCode pk dst src - = getRegister dst `thenUs` \ register1 -> - getRegister src `thenUs` \ register2 -> - getNewRegNCG pk `thenUs` \ tmp -> - let - -- the register which is dst - dst__2 = registerName register1 tmp - -- the register into which src is computed, preferably dst__2 - src__2 = registerName register2 dst__2 - -- code to compute src into src__2 - code = registerCode register2 dst__2 - - code__2 = if isFixed register2 - then code . mkSeqInstr (GMOV src__2 dst__2) - else code - in - returnUs code__2 #endif {- i386_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if sparc_TARGET_ARCH assignFltCode pk (StInd _ dst) src - = getNewRegNCG pk `thenUs` \ tmp1 -> - getAmode dst `thenUs` \ amode -> - getRegister src `thenUs` \ register -> + = getNewRegNCG pk `thenNat` \ tmp1 -> + getAmode dst `thenNat` \ amode -> + getRegister src `thenNat` \ register -> let sz = primRepToSize pk dst__2 = amodeAddr amode - code1 = amodeCode amode asmVoid - code2 = registerCode register tmp1 asmVoid + code1 = amodeCode amode [] + code2 = registerCode register tmp1 [] src__2 = registerName register tmp1 pk__2 = registerRep register sz__2 = primRepToSize pk__2 - code__2 = asmParThen [code1, code2] . + code__2 = asmSeqThen [code1, code2] ++ if pk == pk__2 then mkSeqInstr (ST sz src__2 dst__2) else mkSeqInstrs [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2] in - returnUs code__2 + returnNat code__2 assignFltCode pk dst src - = getRegister dst `thenUs` \ register1 -> - getRegister src `thenUs` \ register2 -> + = getRegister dst `thenNat` \ register1 -> + getRegister src `thenNat` \ register2 -> let pk__2 = registerRep register2 sz__2 = primRepToSize pk__2 in - getNewRegNCG pk__2 `thenUs` \ tmp -> + getNewRegNCG pk__2 `thenNat` \ tmp -> let sz = primRepToSize pk dst__2 = registerName register1 g0 -- must be Fixed @@ -1877,7 +1888,7 @@ assignFltCode pk dst src else code in - returnUs code__2 + returnNat code__2 #endif {- sparc_TARGET_ARCH -} \end{code} @@ -1897,7 +1908,7 @@ branch instruction. Other CLabels are assumed to be far away. register allocator. \begin{code} -genJump :: StixTree{-the branch target-} -> UniqSM InstrBlock +genJump :: StixTree{-the branch target-} -> NatM InstrBlock #if alpha_TARGET_ARCH @@ -1908,8 +1919,8 @@ genJump (StCLbl lbl) target = ImmCLbl lbl genJump tree - = getRegister tree `thenUs` \ register -> - getNewRegNCG PtrRep `thenUs` \ tmp -> + = getRegister tree `thenNat` \ register -> + getNewRegNCG PtrRep `thenNat` \ tmp -> let dst = registerName register pv code = registerCode register pv @@ -1918,40 +1929,32 @@ genJump tree if isFixed register then returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0] else - returnUs (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0)) + returnNat (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0)) #endif {- alpha_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if i386_TARGET_ARCH -{- -genJump (StCLbl lbl) - | isAsmTemp lbl = returnInstrs [JXX ALWAYS lbl] - | otherwise = returnInstrs [JMP (OpImm target)] - where - target = ImmCLbl lbl --} - genJump (StInd pk mem) - = getAmode mem `thenUs` \ amode -> + = getAmode mem `thenNat` \ amode -> let code = amodeCode amode target = amodeAddr amode in - returnSeq code [JMP (OpAddr target)] + returnNat (code `snocOL` JMP (OpAddr target)) genJump tree | maybeToBool imm - = returnInstr (JMP (OpImm target)) + = returnNat (unitOL (JMP (OpImm target))) | otherwise - = getRegister tree `thenUs` \ register -> - getNewRegNCG PtrRep `thenUs` \ tmp -> + = getRegister tree `thenNat` \ register -> + getNewRegNCG PtrRep `thenNat` \ tmp -> let code = registerCode register tmp target = registerName register tmp in - returnSeq code [JMP (OpReg target)] + returnNat (code `snocOL` JMP (OpReg target)) where imm = maybeImm tree target = case imm of Just x -> x @@ -1967,8 +1970,8 @@ genJump (StCLbl lbl) target = ImmCLbl lbl genJump tree - = getRegister tree `thenUs` \ register -> - getNewRegNCG PtrRep `thenUs` \ tmp -> + = getRegister tree `thenNat` \ register -> + getNewRegNCG PtrRep `thenNat` \ tmp -> let code = registerCode register tmp target = registerName register tmp @@ -2007,14 +2010,14 @@ allocator. genCondJump :: CLabel -- the branch target -> StixTree -- the condition on which to branch - -> UniqSM InstrBlock + -> NatM InstrBlock #if alpha_TARGET_ARCH genCondJump lbl (StPrim op [x, StInt 0]) - = getRegister x `thenUs` \ register -> + = getRegister x `thenNat` \ register -> getNewRegNCG (registerRep register) - `thenUs` \ tmp -> + `thenNat` \ tmp -> let code = registerCode register tmp value = registerName register tmp @@ -2049,16 +2052,16 @@ genCondJump lbl (StPrim op [x, StInt 0]) cmpOp AddrLeOp = EQQ genCondJump lbl (StPrim op [x, StDouble 0.0]) - = getRegister x `thenUs` \ register -> + = getRegister x `thenNat` \ register -> getNewRegNCG (registerRep register) - `thenUs` \ tmp -> + `thenNat` \ tmp -> let code = registerCode register tmp value = registerName register tmp pk = registerRep register target = ImmCLbl lbl in - returnUs (code . mkSeqInstr (BF (cmpOp op) value target)) + returnNat (code . mkSeqInstr (BF (cmpOp op) value target)) where cmpOp FloatGtOp = GTT cmpOp FloatGeOp = GE @@ -2075,14 +2078,14 @@ genCondJump lbl (StPrim op [x, StDouble 0.0]) genCondJump lbl (StPrim op [x, y]) | fltCmpOp op - = trivialFCode pr instr x y `thenUs` \ register -> - getNewRegNCG DoubleRep `thenUs` \ tmp -> + = trivialFCode pr instr x y `thenNat` \ register -> + getNewRegNCG DoubleRep `thenNat` \ tmp -> let code = registerCode register tmp result = registerName register tmp target = ImmCLbl lbl in - returnUs (code . mkSeqInstr (BF cond result target)) + returnNat (code . mkSeqInstr (BF cond result target)) where pr = panic "trivialU?FCode: does not use PrimRep on Alpha" @@ -2115,14 +2118,14 @@ genCondJump lbl (StPrim op [x, y]) DoubleLeOp -> (FCMP TF LE, NE) genCondJump lbl (StPrim op [x, y]) - = trivialCode instr x y `thenUs` \ register -> - getNewRegNCG IntRep `thenUs` \ tmp -> + = trivialCode instr x y `thenNat` \ register -> + getNewRegNCG IntRep `thenNat` \ tmp -> let code = registerCode register tmp result = registerName register tmp target = ImmCLbl lbl in - returnUs (code . mkSeqInstr (BI cond result target)) + returnNat (code . mkSeqInstr (BI cond result target)) where (instr, cond) = case op of CharGtOp -> (CMP LE, EQQ) @@ -2155,20 +2158,20 @@ genCondJump lbl (StPrim op [x, y]) #if i386_TARGET_ARCH genCondJump lbl bool - = getCondCode bool `thenUs` \ condition -> + = getCondCode bool `thenNat` \ condition -> let code = condCode condition cond = condName condition target = ImmCLbl lbl in - returnSeq code [JXX cond lbl] + returnNat (code `snocOL` JXX cond lbl) #endif {- i386_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if sparc_TARGET_ARCH genCondJump lbl bool - = getCondCode bool `thenUs` \ condition -> + = getCondCode bool `thenNat` \ condition -> let code = condCode condition cond = condName condition @@ -2203,16 +2206,16 @@ genCCall -> CallConv -> PrimRep -- type of the result -> [StixTree] -- arguments (of mixed type) - -> UniqSM InstrBlock + -> NatM InstrBlock #if alpha_TARGET_ARCH genCCall fn cconv kind args - = mapAccumLUs get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args - `thenUs` \ ((unused,_), argCode) -> + = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args + `thenNat` \ ((unused,_), argCode) -> let nRegs = length allArgRegs - length unused - code = asmParThen (map ($ asmVoid) argCode) + code = asmSeqThen (map ($ []) argCode) in returnSeq code [ LDA pv (AddrImm (ImmLab (ptext fn))), @@ -2229,24 +2232,24 @@ genCCall fn cconv kind args registers to be assigned for this call and the next stack offset to use for overflowing arguments. This way, @get_Arg@ can be applied to all of a call's arguments using - @mapAccumLUs@. + @mapAccumLNat@. -} get_arg :: ([(Reg,Reg)], Int) -- Argument registers and stack offset (accumulator) -> StixTree -- Current argument - -> UniqSM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code + -> NatM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code -- We have to use up all of our argument registers first... get_arg ((iDst,fDst):dsts, offset) arg - = getRegister arg `thenUs` \ register -> + = getRegister arg `thenNat` \ register -> let reg = if isFloatingRep pk then fDst else iDst code = registerCode register reg src = registerName register reg pk = registerRep register in - returnUs ( + returnNat ( if isFloatingRep pk then ((dsts, offset), if isFixed register then code . mkSeqInstr (FMOV src fDst) @@ -2260,16 +2263,16 @@ genCCall fn cconv kind args -- stack... get_arg ([], offset) arg - = getRegister arg `thenUs` \ register -> + = getRegister arg `thenNat` \ register -> getNewRegNCG (registerRep register) - `thenUs` \ tmp -> + `thenNat` \ tmp -> let code = registerCode register tmp src = registerName register tmp pk = registerRep register sz = primRepToSize pk in - returnUs (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset))) + returnNat (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset))) #endif {- alpha_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -2277,24 +2280,31 @@ genCCall fn cconv kind args 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")))))] + = let call = toOL [ + MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax), + CALL (ImmLit (ptext (if underscorePrefix + then (SLIT ("_PerformGC_wrapper")) + else (SLIT ("PerformGC_wrapper"))))) + ] in - returnInstrs call + returnNat call genCCall fn cconv kind args - = get_call_args args `thenUs` \ (tot_arg_size, argCode) -> - let - code2 = asmParThen (map ($ asmVoid) argCode) - call = [SUB L (OpImm (ImmInt tot_arg_size)) (OpReg esp), - CALL fn__2 , - ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp) + = mapNat get_call_arg + (reverse args) `thenNat` \ sizes_n_codes -> + getDeltaNat `thenNat` \ delta -> + let (sizes, codes) = unzip sizes_n_codes + tot_arg_size = sum sizes + code2 = concatOL codes + call = toOL [ + CALL fn__2, + ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp), + DELTA (delta + tot_arg_size) ] in - returnSeq code2 call + setDeltaNat (delta + tot_arg_size) `thenNat` \ _ -> + returnNat (code2 `appOL` call) where -- function names that begin with '.' are assumed to be special @@ -2310,70 +2320,56 @@ genCCall fn cconv kind args arg_size _ = 4 ------------ - -- do get_call_arg on each arg, threading the total arg size along - -- process the args right-to-left - get_call_args :: [StixTree] -> UniqSM (Int, [InstrBlock]) - get_call_args args - = f 0 args - where - f curr_sz [] - = returnUs (curr_sz, []) - f curr_sz (arg:args) - = f curr_sz args `thenUs` \ (new_sz, iblocks) -> - get_call_arg arg new_sz `thenUs` \ (new_sz2, iblock) -> - returnUs (new_sz2, iblock:iblocks) - - - ------------ get_call_arg :: StixTree{-current argument-} - -> Int{-running total of arg sizes seen so far-} - -> UniqSM (Int, InstrBlock) -- updated tot argsz, code - - get_call_arg arg old_sz - = get_op arg `thenUs` \ (code, reg, sz) -> - let new_sz = old_sz + arg_size sz - in if (case sz of DF -> True; F -> True; _ -> False) - then returnUs (new_sz, - code . - mkSeqInstr (GST DF reg - (AddrBaseIndex (Just esp) - Nothing (ImmInt (- new_sz)))) - ) - else returnUs (new_sz, - code . - mkSeqInstr (MOV L (OpReg reg) - (OpAddr - (AddrBaseIndex (Just esp) - Nothing (ImmInt (- new_sz))))) - ) + -> NatM (Int, InstrBlock) -- argsz, code + + get_call_arg arg + = get_op arg `thenNat` \ (code, reg, sz) -> + getDeltaNat `thenNat` \ delta -> + arg_size sz `bind` \ size -> + setDeltaNat (delta-size) `thenNat` \ _ -> + if (case sz of DF -> True; F -> True; _ -> False) + then returnNat (size, + code `appOL` + toOL [SUB L (OpImm (ImmInt 8)) (OpReg esp), + DELTA (delta-size), + GST DF reg (AddrBaseIndex (Just esp) + Nothing + (ImmInt 0))] + ) + else returnNat (size, + code `snocOL` + PUSH L (OpReg reg) `snocOL` + DELTA (delta-size) + ) ------------ get_op :: StixTree - -> UniqSM (InstrBlock, Reg, Size) -- code, reg, size + -> NatM (InstrBlock, Reg, Size) -- code, reg, size get_op op - = getRegister op `thenUs` \ register -> + = getRegister op `thenNat` \ register -> getNewRegNCG (registerRep register) - `thenUs` \ tmp -> + `thenNat` \ tmp -> let code = registerCode register tmp reg = registerName register tmp pk = registerRep register sz = primRepToSize pk in - returnUs (code, reg, sz) + returnNat (code, reg, sz) #endif {- i386_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if sparc_TARGET_ARCH genCCall fn cconv kind args - = mapAccumLUs get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args - `thenUs` \ ((unused,_), argCode) -> + = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args + `thenNat` \ ((unused,_), argCode) -> let nRegs = length allArgRegs - length unused call = CALL fn__2 nRegs False - code = asmParThen (map ($ asmVoid) argCode) + code = asmSeqThen (map ($ []) argCode) in returnSeq code [call, NOP] where @@ -2400,21 +2396,21 @@ genCCall fn cconv kind args get_arg :: ([Reg],Int) -- Argument registers and stack offset (accumulator) -> StixTree -- Current argument - -> UniqSM (([Reg],Int), InstrBlock) -- Updated accumulator and code + -> NatM (([Reg],Int), InstrBlock) -- Updated accumulator and code -- We have to use up all of our argument registers first... get_arg (dst:dsts, offset) arg - = getRegister arg `thenUs` \ register -> + = getRegister arg `thenNat` \ register -> getNewRegNCG (registerRep register) - `thenUs` \ tmp -> + `thenNat` \ tmp -> let reg = if isFloatingRep pk then tmp else dst code = registerCode register reg src = registerName register reg pk = registerRep register in - returnUs (case pk of + returnNat (case pk of DoubleRep -> case dsts of [] -> (([], offset + 1), code . mkSeqInstrs [ @@ -2437,9 +2433,9 @@ genCCall fn cconv kind args -- stack... get_arg ([], offset) arg - = getRegister arg `thenUs` \ register -> + = getRegister arg `thenNat` \ register -> getNewRegNCG (registerRep register) - `thenUs` \ tmp -> + `thenNat` \ tmp -> let code = registerCode register tmp src = registerName register tmp @@ -2447,7 +2443,7 @@ genCCall fn cconv kind args sz = primRepToSize pk words = if pk == DoubleRep then 2 else 1 in - returnUs (([], offset + words), code . mkSeqInstr (ST sz src (spRel offset))) + returnNat (([], offset + words), code . mkSeqInstr (ST sz src (spRel offset))) #endif {- sparc_TARGET_ARCH -} \end{code} @@ -2471,7 +2467,7 @@ the right hand side of an assignment). register allocator. \begin{code} -condIntReg, condFltReg :: Cond -> StixTree -> StixTree -> UniqSM Register +condIntReg, condFltReg :: Cond -> StixTree -> StixTree -> NatM Register #if alpha_TARGET_ARCH condIntReg = panic "MachCode.condIntReg (not on Alpha)" @@ -2482,30 +2478,26 @@ condFltReg = panic "MachCode.condFltReg (not on Alpha)" #if i386_TARGET_ARCH condIntReg cond x y - = condIntCode cond x y `thenUs` \ condition -> - getNewRegNCG IntRep `thenUs` \ tmp -> - --getRegister dst `thenUs` \ register -> + = condIntCode cond x y `thenNat` \ condition -> + getNewRegNCG IntRep `thenNat` \ tmp -> let - --code2 = registerCode register tmp asmVoid - --dst__2 = registerName register tmp code = condCode condition cond = condName condition - -- ToDo: if dst is eax, ebx, ecx, or edx we would not need the move. - code__2 dst = code . mkSeqInstrs [ + code__2 dst = code `appOL` toOL [ SETCC cond (OpReg tmp), AND L (OpImm (ImmInt 1)) (OpReg tmp), MOV L (OpReg tmp) (OpReg dst)] in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) condFltReg cond x y - = getUniqLabelNCG `thenUs` \ lbl1 -> - getUniqLabelNCG `thenUs` \ lbl2 -> - condFltCode cond x y `thenUs` \ condition -> + = getNatLabelNCG `thenNat` \ lbl1 -> + getNatLabelNCG `thenNat` \ lbl2 -> + condFltCode cond x y `thenNat` \ condition -> let code = condCode condition cond = condName condition - code__2 dst = code . mkSeqInstrs [ + code__2 dst = code `appOL` toOL [ JXX cond lbl1, MOV L (OpImm (ImmInt 0)) (OpReg dst), JXX ALWAYS lbl2, @@ -2513,15 +2505,15 @@ condFltReg cond x y MOV L (OpImm (ImmInt 1)) (OpReg dst), LABEL lbl2] in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) #endif {- i386_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if sparc_TARGET_ARCH condIntReg EQQ x (StInt 0) - = getRegister x `thenUs` \ register -> - getNewRegNCG IntRep `thenUs` \ tmp -> + = getRegister x `thenNat` \ register -> + getNewRegNCG IntRep `thenNat` \ tmp -> let code = registerCode register tmp src = registerName register tmp @@ -2529,28 +2521,28 @@ condIntReg EQQ x (StInt 0) SUB False True g0 (RIReg src) g0, SUB True False g0 (RIImm (ImmInt (-1))) dst] in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) condIntReg EQQ x y - = getRegister x `thenUs` \ register1 -> - getRegister y `thenUs` \ register2 -> - getNewRegNCG IntRep `thenUs` \ tmp1 -> - getNewRegNCG IntRep `thenUs` \ tmp2 -> + = getRegister x `thenNat` \ register1 -> + getRegister y `thenNat` \ register2 -> + getNewRegNCG IntRep `thenNat` \ tmp1 -> + getNewRegNCG IntRep `thenNat` \ tmp2 -> let - code1 = registerCode register1 tmp1 asmVoid + code1 = registerCode register1 tmp1 [] src1 = registerName register1 tmp1 - code2 = registerCode register2 tmp2 asmVoid + code2 = registerCode register2 tmp2 [] src2 = registerName register2 tmp2 - code__2 dst = asmParThen [code1, code2] . mkSeqInstrs [ + code__2 dst = asmSeqThen [code1, code2] . mkSeqInstrs [ XOR False src1 (RIReg src2) dst, SUB False True g0 (RIReg dst) g0, SUB True False g0 (RIImm (ImmInt (-1))) dst] in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) condIntReg NE x (StInt 0) - = getRegister x `thenUs` \ register -> - getNewRegNCG IntRep `thenUs` \ tmp -> + = getRegister x `thenNat` \ register -> + getNewRegNCG IntRep `thenNat` \ tmp -> let code = registerCode register tmp src = registerName register tmp @@ -2558,29 +2550,29 @@ condIntReg NE x (StInt 0) SUB False True g0 (RIReg src) g0, ADD True False g0 (RIImm (ImmInt 0)) dst] in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) condIntReg NE x y - = getRegister x `thenUs` \ register1 -> - getRegister y `thenUs` \ register2 -> - getNewRegNCG IntRep `thenUs` \ tmp1 -> - getNewRegNCG IntRep `thenUs` \ tmp2 -> + = getRegister x `thenNat` \ register1 -> + getRegister y `thenNat` \ register2 -> + getNewRegNCG IntRep `thenNat` \ tmp1 -> + getNewRegNCG IntRep `thenNat` \ tmp2 -> let - code1 = registerCode register1 tmp1 asmVoid + code1 = registerCode register1 tmp1 [] src1 = registerName register1 tmp1 - code2 = registerCode register2 tmp2 asmVoid + code2 = registerCode register2 tmp2 [] src2 = registerName register2 tmp2 - code__2 dst = asmParThen [code1, code2] . mkSeqInstrs [ + code__2 dst = asmSeqThen [code1, code2] . mkSeqInstrs [ XOR False src1 (RIReg src2) dst, SUB False True g0 (RIReg dst) g0, ADD True False g0 (RIImm (ImmInt 0)) dst] in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) condIntReg cond x y - = getUniqLabelNCG `thenUs` \ lbl1 -> - getUniqLabelNCG `thenUs` \ lbl2 -> - condIntCode cond x y `thenUs` \ condition -> + = getNatLabelNCG `thenNat` \ lbl1 -> + getNatLabelNCG `thenNat` \ lbl2 -> + condIntCode cond x y `thenNat` \ condition -> let code = condCode condition cond = condName condition @@ -2592,12 +2584,12 @@ condIntReg cond x y OR False g0 (RIImm (ImmInt 1)) dst, LABEL lbl2] in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) condFltReg cond x y - = getUniqLabelNCG `thenUs` \ lbl1 -> - getUniqLabelNCG `thenUs` \ lbl2 -> - condFltCode cond x y `thenUs` \ condition -> + = getNatLabelNCG `thenNat` \ lbl1 -> + getNatLabelNCG `thenNat` \ lbl2 -> + condFltCode cond x y `thenNat` \ condition -> let code = condCode condition cond = condName condition @@ -2610,7 +2602,7 @@ condFltReg cond x y OR False g0 (RIImm (ImmInt 1)) dst, LABEL lbl2] in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) #endif {- sparc_TARGET_ARCH -} \end{code} @@ -2638,7 +2630,7 @@ trivialCode ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr) ,))) -> StixTree -> StixTree -- the two arguments - -> UniqSM Register + -> NatM Register trivialFCode :: PrimRep @@ -2647,7 +2639,7 @@ trivialFCode ,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr) ,))) -> StixTree -> StixTree -- the two arguments - -> UniqSM Register + -> NatM Register trivialUCode :: IF_ARCH_alpha((RI -> Reg -> Instr) @@ -2655,7 +2647,7 @@ trivialUCode ,IF_ARCH_sparc((RI -> Reg -> Instr) ,))) -> StixTree -- the one argument - -> UniqSM Register + -> NatM Register trivialUFCode :: PrimRep @@ -2664,54 +2656,54 @@ trivialUFCode ,IF_ARCH_sparc((Reg -> Reg -> Instr) ,))) -> StixTree -- the one argument - -> UniqSM Register + -> NatM Register #if alpha_TARGET_ARCH trivialCode instr x (StInt y) | fits8Bits y - = getRegister x `thenUs` \ register -> - getNewRegNCG IntRep `thenUs` \ tmp -> + = getRegister x `thenNat` \ register -> + getNewRegNCG IntRep `thenNat` \ tmp -> let code = registerCode register tmp src1 = registerName register tmp src2 = ImmInt (fromInteger y) code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst) in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) trivialCode instr x y - = getRegister x `thenUs` \ register1 -> - getRegister y `thenUs` \ register2 -> - getNewRegNCG IntRep `thenUs` \ tmp1 -> - getNewRegNCG IntRep `thenUs` \ tmp2 -> + = getRegister x `thenNat` \ register1 -> + getRegister y `thenNat` \ register2 -> + getNewRegNCG IntRep `thenNat` \ tmp1 -> + getNewRegNCG IntRep `thenNat` \ tmp2 -> let - code1 = registerCode register1 tmp1 asmVoid + code1 = registerCode register1 tmp1 [] src1 = registerName register1 tmp1 - code2 = registerCode register2 tmp2 asmVoid + code2 = registerCode register2 tmp2 [] src2 = registerName register2 tmp2 - code__2 dst = asmParThen [code1, code2] . + code__2 dst = asmSeqThen [code1, code2] . mkSeqInstr (instr src1 (RIReg src2) dst) in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) ------------ trivialUCode instr x - = getRegister x `thenUs` \ register -> - getNewRegNCG IntRep `thenUs` \ tmp -> + = getRegister x `thenNat` \ register -> + getNewRegNCG IntRep `thenNat` \ tmp -> let code = registerCode register tmp src = registerName register tmp code__2 dst = code . mkSeqInstr (instr (RIReg src) dst) in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) ------------ trivialFCode _ instr x y - = getRegister x `thenUs` \ register1 -> - getRegister y `thenUs` \ register2 -> - getNewRegNCG DoubleRep `thenUs` \ tmp1 -> - getNewRegNCG DoubleRep `thenUs` \ tmp2 -> + = getRegister x `thenNat` \ register1 -> + getRegister y `thenNat` \ register2 -> + getNewRegNCG DoubleRep `thenNat` \ tmp1 -> + getNewRegNCG DoubleRep `thenNat` \ tmp2 -> let code1 = registerCode register1 tmp1 src1 = registerName register1 tmp1 @@ -2719,20 +2711,20 @@ trivialFCode _ instr x y code2 = registerCode register2 tmp2 src2 = registerName register2 tmp2 - code__2 dst = asmParThen [code1 asmVoid, code2 asmVoid] . + code__2 dst = asmSeqThen [code1 [], code2 []] . mkSeqInstr (instr src1 src2 dst) in - returnUs (Any DoubleRep code__2) + returnNat (Any DoubleRep code__2) trivialUFCode _ instr x - = getRegister x `thenUs` \ register -> - getNewRegNCG DoubleRep `thenUs` \ tmp -> + = getRegister x `thenNat` \ register -> + getNewRegNCG DoubleRep `thenNat` \ tmp -> let code = registerCode register tmp src = registerName register tmp code__2 dst = code . mkSeqInstr (instr src dst) in - returnUs (Any DoubleRep code__2) + returnNat (Any DoubleRep code__2) #endif {- alpha_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -2741,7 +2733,7 @@ trivialUFCode _ instr x The Rules of the Game are: * You cannot assume anything about the destination register dst; - it may be anything, includind a fixed reg. + it may be anything, including a fixed reg. * You may compute an operand into a fixed reg, but you may not subsequently change the contents of that fixed reg. If you @@ -2758,98 +2750,95 @@ The Rules of the Game are: \begin{code} -infixr 3 `bind` -x `bind` f = f x - trivialCode instr maybe_revinstr a b | is_imm_b - = getRegister a `thenUs` \ rega -> + = getRegister a `thenNat` \ rega -> let mkcode dst - = if isFloat rega + = if isAny rega then registerCode rega dst `bind` \ code_a -> - code_a . - mkSeqInstr (instr (OpImm imm_b) (OpReg dst)) + code_a `snocOL` + instr (OpImm imm_b) (OpReg dst) else registerCodeF rega `bind` \ code_a -> registerNameF rega `bind` \ r_a -> - code_a . - mkSeqInstr (MOV L (OpReg r_a) (OpReg dst)) . - mkSeqInstr (instr (OpImm imm_b) (OpReg dst)) + code_a `snocOL` + MOV L (OpReg r_a) (OpReg dst) `snocOL` + instr (OpImm imm_b) (OpReg dst) in - returnUs (Any IntRep mkcode) + returnNat (Any IntRep mkcode) | is_imm_a - = getRegister b `thenUs` \ regb -> - getNewRegNCG IntRep `thenUs` \ tmp -> + = getRegister b `thenNat` \ regb -> + getNewRegNCG IntRep `thenNat` \ tmp -> let revinstr_avail = maybeToBool maybe_revinstr revinstr = case maybe_revinstr of Just ri -> ri mkcode dst | revinstr_avail - = if isFloat regb + = if isAny regb then registerCode regb dst `bind` \ code_b -> - code_b . - mkSeqInstr (revinstr (OpImm imm_a) (OpReg dst)) + code_b `snocOL` + revinstr (OpImm imm_a) (OpReg dst) else registerCodeF regb `bind` \ code_b -> registerNameF regb `bind` \ r_b -> - code_b . - mkSeqInstr (MOV L (OpReg r_b) (OpReg dst)) . - mkSeqInstr (revinstr (OpImm imm_a) (OpReg dst)) + code_b `snocOL` + MOV L (OpReg r_b) (OpReg dst) `snocOL` + revinstr (OpImm imm_a) (OpReg dst) | otherwise - = if isFloat regb + = if isAny regb then registerCode regb tmp `bind` \ code_b -> - code_b . - mkSeqInstr (MOV L (OpImm imm_a) (OpReg dst)) . - mkSeqInstr (instr (OpReg tmp) (OpReg dst)) + code_b `snocOL` + MOV L (OpImm imm_a) (OpReg dst) `snocOL` + instr (OpReg tmp) (OpReg dst) else registerCodeF regb `bind` \ code_b -> registerNameF regb `bind` \ r_b -> - code_b . - mkSeqInstr (MOV L (OpReg r_b) (OpReg tmp)) . - mkSeqInstr (MOV L (OpImm imm_a) (OpReg dst)) . - mkSeqInstr (instr (OpReg tmp) (OpReg dst)) + code_b `snocOL` + MOV L (OpReg r_b) (OpReg tmp) `snocOL` + MOV L (OpImm imm_a) (OpReg dst) `snocOL` + instr (OpReg tmp) (OpReg dst) in - returnUs (Any IntRep mkcode) + returnNat (Any IntRep mkcode) | otherwise - = getRegister a `thenUs` \ rega -> - getRegister b `thenUs` \ regb -> - getNewRegNCG IntRep `thenUs` \ tmp -> + = getRegister a `thenNat` \ rega -> + getRegister b `thenNat` \ regb -> + getNewRegNCG IntRep `thenNat` \ tmp -> let mkcode dst - = case (isFloat rega, isFloat regb) of + = case (isAny rega, isAny regb) of (True, True) -> registerCode regb tmp `bind` \ code_b -> registerCode rega dst `bind` \ code_a -> - code_b . - code_a . - mkSeqInstr (instr (OpReg tmp) (OpReg dst)) + code_b `appOL` + code_a `snocOL` + instr (OpReg tmp) (OpReg dst) (True, False) -> registerCode rega tmp `bind` \ code_a -> registerCodeF regb `bind` \ code_b -> registerNameF regb `bind` \ r_b -> - code_a . - code_b . - mkSeqInstr (instr (OpReg r_b) (OpReg tmp)) . - mkSeqInstr (MOV L (OpReg tmp) (OpReg dst)) + code_a `appOL` + code_b `snocOL` + instr (OpReg r_b) (OpReg tmp) `snocOL` + MOV L (OpReg tmp) (OpReg dst) (False, True) -> registerCode regb tmp `bind` \ code_b -> registerCodeF rega `bind` \ code_a -> registerNameF rega `bind` \ r_a -> - code_b . - code_a . - mkSeqInstr (MOV L (OpReg r_a) (OpReg dst)) . - mkSeqInstr (instr (OpReg tmp) (OpReg dst)) + code_b `appOL` + code_a `snocOL` + MOV L (OpReg r_a) (OpReg dst) `snocOL` + instr (OpReg tmp) (OpReg dst) (False, False) -> registerCodeF rega `bind` \ code_a -> registerNameF rega `bind` \ r_a -> registerCodeF regb `bind` \ code_b -> registerNameF regb `bind` \ r_b -> - code_a . - mkSeqInstr (MOV L (OpReg r_a) (OpReg tmp)) . - code_b . - mkSeqInstr (instr (OpReg r_b) (OpReg tmp)) . - mkSeqInstr (MOV L (OpReg tmp) (OpReg dst)) + code_a `snocOL` + MOV L (OpReg r_a) (OpReg tmp) `appOL` + code_b `snocOL` + instr (OpReg r_b) (OpReg tmp) `snocOL` + MOV L (OpReg tmp) (OpReg dst) in - returnUs (Any IntRep mkcode) + returnNat (Any IntRep mkcode) where maybe_imm_a = maybeImm a @@ -2863,24 +2852,24 @@ trivialCode instr maybe_revinstr a b ----------- trivialUCode instr x - = getRegister x `thenUs` \ register -> + = getRegister x `thenNat` \ register -> let code__2 dst = let code = registerCode register dst src = registerName register dst - in code . - if isFixed register && dst /= src - then mkSeqInstrs [MOV L (OpReg src) (OpReg dst), - instr (OpReg dst)] - else mkSeqInstr (instr (OpReg src)) + in code `appOL` + if isFixed register && dst /= src + then toOL [MOV L (OpReg src) (OpReg dst), + instr (OpReg dst)] + else unitOL (instr (OpReg src)) in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) ----------- trivialFCode pk instr x y - = getRegister x `thenUs` \ register1 -> - getRegister y `thenUs` \ register2 -> - getNewRegNCG DoubleRep `thenUs` \ tmp1 -> - getNewRegNCG DoubleRep `thenUs` \ tmp2 -> + = getRegister x `thenNat` \ register1 -> + getRegister y `thenNat` \ register2 -> + getNewRegNCG DoubleRep `thenNat` \ tmp1 -> + getNewRegNCG DoubleRep `thenNat` \ tmp2 -> let code1 = registerCode register1 tmp1 src1 = registerName register1 tmp1 @@ -2888,22 +2877,33 @@ trivialFCode pk instr x y code2 = registerCode register2 tmp2 src2 = registerName register2 tmp2 - code__2 dst = asmParThen [code1 asmVoid, code2 asmVoid] . - mkSeqInstr (instr (primRepToSize pk) src1 src2 dst) + code__2 dst + -- treat the common case specially: both operands in + -- non-fixed regs. + | isAny register1 && isAny register2 + = code1 `appOL` + code2 `snocOL` + instr (primRepToSize pk) src1 src2 dst + + -- be paranoid (and inefficient) + | otherwise + = code1 `snocOL` GMOV src1 tmp1 `appOL` + code2 `snocOL` + instr (primRepToSize pk) tmp1 src2 dst in - returnUs (Any DoubleRep code__2) + returnNat (Any DoubleRep code__2) ------------- trivialUFCode pk instr x - = getRegister x `thenUs` \ register -> - getNewRegNCG pk `thenUs` \ tmp -> + = getRegister x `thenNat` \ register -> + getNewRegNCG pk `thenNat` \ tmp -> let code = registerCode register tmp src = registerName register tmp - code__2 dst = code . mkSeqInstr (instr src dst) + code__2 dst = code `snocOL` instr src dst in - returnUs (Any pk code__2) + returnNat (Any pk code__2) #endif {- i386_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -2911,40 +2911,40 @@ trivialUFCode pk instr x trivialCode instr x (StInt y) | fits13Bits y - = getRegister x `thenUs` \ register -> - getNewRegNCG IntRep `thenUs` \ tmp -> + = getRegister x `thenNat` \ register -> + getNewRegNCG IntRep `thenNat` \ tmp -> let code = registerCode register tmp src1 = registerName register tmp src2 = ImmInt (fromInteger y) code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst) in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) trivialCode instr x y - = getRegister x `thenUs` \ register1 -> - getRegister y `thenUs` \ register2 -> - getNewRegNCG IntRep `thenUs` \ tmp1 -> - getNewRegNCG IntRep `thenUs` \ tmp2 -> + = getRegister x `thenNat` \ register1 -> + getRegister y `thenNat` \ register2 -> + getNewRegNCG IntRep `thenNat` \ tmp1 -> + getNewRegNCG IntRep `thenNat` \ tmp2 -> let - code1 = registerCode register1 tmp1 asmVoid + code1 = registerCode register1 tmp1 [] src1 = registerName register1 tmp1 - code2 = registerCode register2 tmp2 asmVoid + code2 = registerCode register2 tmp2 [] src2 = registerName register2 tmp2 - code__2 dst = asmParThen [code1, code2] . + code__2 dst = asmSeqThen [code1, code2] . mkSeqInstr (instr src1 (RIReg src2) dst) in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) ------------ trivialFCode pk instr x y - = getRegister x `thenUs` \ register1 -> - getRegister y `thenUs` \ register2 -> + = getRegister x `thenNat` \ register1 -> + getRegister y `thenNat` \ register2 -> getNewRegNCG (registerRep register1) - `thenUs` \ tmp1 -> + `thenNat` \ tmp1 -> getNewRegNCG (registerRep register2) - `thenUs` \ tmp2 -> - getNewRegNCG DoubleRep `thenUs` \ tmp -> + `thenNat` \ tmp2 -> + getNewRegNCG DoubleRep `thenNat` \ tmp -> let promote x = asmInstr (FxTOy F DF x tmp) @@ -2958,38 +2958,38 @@ trivialFCode pk instr x y code__2 dst = if pk1 == pk2 then - asmParThen [code1 asmVoid, code2 asmVoid] . + asmSeqThen [code1 [], code2 []] . mkSeqInstr (instr (primRepToSize pk) src1 src2 dst) else if pk1 == FloatRep then - asmParThen [code1 (promote src1), code2 asmVoid] . + asmSeqThen [code1 (promote src1), code2 []] . mkSeqInstr (instr DF tmp src2 dst) else - asmParThen [code1 asmVoid, code2 (promote src2)] . + asmSeqThen [code1 [], code2 (promote src2)] . mkSeqInstr (instr DF src1 tmp dst) in - returnUs (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2) + returnNat (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2) ------------ trivialUCode instr x - = getRegister x `thenUs` \ register -> - getNewRegNCG IntRep `thenUs` \ tmp -> + = getRegister x `thenNat` \ register -> + getNewRegNCG IntRep `thenNat` \ tmp -> let code = registerCode register tmp src = registerName register tmp code__2 dst = code . mkSeqInstr (instr (RIReg src) dst) in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) ------------- trivialUFCode pk instr x - = getRegister x `thenUs` \ register -> - getNewRegNCG pk `thenUs` \ tmp -> + = getRegister x `thenNat` \ register -> + getNewRegNCG pk `thenNat` \ tmp -> let code = registerCode register tmp src = registerName register tmp code__2 dst = code . mkSeqInstr (instr src dst) in - returnUs (Any pk code__2) + returnNat (Any pk code__2) #endif {- sparc_TARGET_ARCH -} \end{code} @@ -3009,15 +3009,15 @@ conversions. We have to store temporaries in memory to move between the integer and the floating point register sets. \begin{code} -coerceIntCode :: PrimRep -> StixTree -> UniqSM Register -coerceFltCode :: StixTree -> UniqSM Register +coerceIntCode :: PrimRep -> StixTree -> NatM Register +coerceFltCode :: StixTree -> NatM Register -coerceInt2FP :: PrimRep -> StixTree -> UniqSM Register -coerceFP2Int :: StixTree -> UniqSM Register +coerceInt2FP :: PrimRep -> StixTree -> NatM Register +coerceFP2Int :: StixTree -> NatM Register coerceIntCode pk x - = getRegister x `thenUs` \ register -> - returnUs ( + = getRegister x `thenNat` \ register -> + returnNat ( case register of Fixed _ reg code -> Fixed pk reg code Any _ code -> Any pk code @@ -3025,8 +3025,8 @@ coerceIntCode pk x ------------- coerceFltCode x - = getRegister x `thenUs` \ register -> - returnUs ( + = getRegister x `thenNat` \ register -> + returnNat ( case register of Fixed _ reg code -> Fixed DoubleRep reg code Any _ code -> Any DoubleRep code @@ -3037,8 +3037,8 @@ coerceFltCode x #if alpha_TARGET_ARCH coerceInt2FP _ x - = getRegister x `thenUs` \ register -> - getNewRegNCG IntRep `thenUs` \ reg -> + = getRegister x `thenNat` \ register -> + getNewRegNCG IntRep `thenNat` \ reg -> let code = registerCode register reg src = registerName register reg @@ -3048,12 +3048,12 @@ coerceInt2FP _ x LD TF dst (spRel 0), CVTxy Q TF dst dst] in - returnUs (Any DoubleRep code__2) + returnNat (Any DoubleRep code__2) ------------- coerceFP2Int x - = getRegister x `thenUs` \ register -> - getNewRegNCG DoubleRep `thenUs` \ tmp -> + = getRegister x `thenNat` \ register -> + getNewRegNCG DoubleRep `thenNat` \ tmp -> let code = registerCode register tmp src = registerName register tmp @@ -3063,46 +3063,44 @@ coerceFP2Int x ST TF tmp (spRel 0), LD Q dst (spRel 0)] in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) #endif {- alpha_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if i386_TARGET_ARCH coerceInt2FP pk x - = getRegister x `thenUs` \ register -> - getNewRegNCG IntRep `thenUs` \ reg -> + = getRegister x `thenNat` \ register -> + getNewRegNCG IntRep `thenNat` \ reg -> let code = registerCode register reg src = registerName register reg opc = case pk of FloatRep -> GITOF ; DoubleRep -> GITOD - code__2 dst = code . - mkSeqInstr (opc src dst) + code__2 dst = code `snocOL` opc src dst in - returnUs (Any pk code__2) + returnNat (Any pk code__2) ------------ coerceFP2Int x - = getRegister x `thenUs` \ register -> - getNewRegNCG DoubleRep `thenUs` \ tmp -> + = getRegister x `thenNat` \ register -> + getNewRegNCG DoubleRep `thenNat` \ tmp -> let code = registerCode register tmp src = registerName register tmp pk = registerRep register opc = case pk of FloatRep -> GFTOI ; DoubleRep -> GDTOI - code__2 dst = code . - mkSeqInstr (opc src dst) + code__2 dst = code `snocOL` opc src dst in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) #endif {- i386_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if sparc_TARGET_ARCH coerceInt2FP pk x - = getRegister x `thenUs` \ register -> - getNewRegNCG IntRep `thenUs` \ reg -> + = getRegister x `thenNat` \ register -> + getNewRegNCG IntRep `thenNat` \ reg -> let code = registerCode register reg src = registerName register reg @@ -3112,13 +3110,13 @@ coerceInt2FP pk x LD W (spRel (-2)) dst, FxTOy W (primRepToSize pk) dst dst] in - returnUs (Any pk code__2) + returnNat (Any pk code__2) ------------ coerceFP2Int x - = getRegister x `thenUs` \ register -> - getNewRegNCG IntRep `thenUs` \ reg -> - getNewRegNCG FloatRep `thenUs` \ tmp -> + = getRegister x `thenNat` \ register -> + getNewRegNCG IntRep `thenNat` \ reg -> + getNewRegNCG FloatRep `thenNat` \ tmp -> let code = registerCode register reg src = registerName register reg @@ -3129,7 +3127,7 @@ coerceFP2Int x ST W tmp (spRel (-2)), LD W (spRel (-2)) dst] in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) #endif {- sparc_TARGET_ARCH -} \end{code} @@ -3144,44 +3142,44 @@ Integer to character conversion. Where applicable, we try to do this in one step if the original object is in memory. \begin{code} -chrCode :: StixTree -> UniqSM Register +chrCode :: StixTree -> NatM Register #if alpha_TARGET_ARCH chrCode x - = getRegister x `thenUs` \ register -> - getNewRegNCG IntRep `thenUs` \ reg -> + = getRegister x `thenNat` \ register -> + getNewRegNCG IntRep `thenNat` \ reg -> let code = registerCode register reg src = registerName register reg code__2 dst = code . mkSeqInstr (ZAPNOT src (RIImm (ImmInt 1)) dst) in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) #endif {- alpha_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if i386_TARGET_ARCH chrCode x - = getRegister x `thenUs` \ register -> + = getRegister x `thenNat` \ register -> let code__2 dst = let code = registerCode register dst src = registerName register dst - in code . - if isFixed register && src /= dst - then mkSeqInstrs [MOV L (OpReg src) (OpReg dst), - AND L (OpImm (ImmInt 255)) (OpReg dst)] - else mkSeqInstr (AND L (OpImm (ImmInt 255)) (OpReg src)) + in code `appOL` + if isFixed register && src /= dst + then toOL [MOV L (OpReg src) (OpReg dst), + AND L (OpImm (ImmInt 255)) (OpReg dst)] + else unitOL (AND L (OpImm (ImmInt 255)) (OpReg src)) in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) #endif {- i386_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if sparc_TARGET_ARCH chrCode (StInd pk mem) - = getAmode mem `thenUs` \ amode -> + = getAmode mem `thenNat` \ amode -> let code = amodeCode amode src = amodeAddr amode @@ -3194,17 +3192,17 @@ chrCode (StInd pk mem) LD (primRepToSize pk) src dst, AND False dst (RIImm (ImmInt 255)) dst] in - returnUs (Any pk code__2) + returnNat (Any pk code__2) chrCode x - = getRegister x `thenUs` \ register -> - getNewRegNCG IntRep `thenUs` \ reg -> + = getRegister x `thenNat` \ register -> + getNewRegNCG IntRep `thenNat` \ reg -> let code = registerCode register reg src = registerName register reg code__2 dst = code . mkSeqInstr (AND False src (RIImm (ImmInt 255)) dst) in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) #endif {- sparc_TARGET_ARCH -} \end{code}