X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FnativeGen%2FMachCode.lhs;h=f54c759ee6e9ea117b95ea3cc54821dbc3c8fb07;hb=9df21db498fed4645fc624e692d70672a84432dc;hp=14c2b8a1b7e8db4f384a0bd5599b6194d89cef93;hpb=1c155370c423469078368289b4a30a35e354b492;p=ghc-hetmet.git diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs index 14c2b8a..f54c759 100644 --- a/ghc/compiler/nativeGen/MachCode.lhs +++ b/ghc/compiler/nativeGen/MachCode.lhs @@ -9,78 +9,132 @@ 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 AbsCSyn ( MagicId ) +import OrdList ( OrdList, nilOL, isNilOL, unitOL, appOL, toOL, + snocOL, consOL, concatOL ) import AbsCUtils ( magicIdPrimRep ) import CallConv ( CallConv ) -import CLabel ( isAsmTemp, CLabel ) +import CLabel ( isAsmTemp, CLabel, pprCLabel_asm, labelDynamic ) 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(..), - StixReg(..), CodeSegment(..) - ) -import UniqSupply ( returnUs, thenUs, mapUs, mapAndUnzipUs, - mapAccumLUs, UniqSM +import Stix ( getNatLabelNCG, StixTree(..), + StixReg(..), CodeSegment(..), + pprStixTree, ppStixReg, + NatM, thenNat, returnNat, mapNat, + mapAndUnzipNat, mapAccumLNat, + getDeltaNat, setDeltaNat ) import Outputable +import CmdLineOpts ( opt_Static ) + +infixr 3 `bind` + +\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 + +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) - 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) + StComment s -> returnNat (unitOL (COMMENT s)) + StSegment seg -> returnNat (unitOL (SEGMENT seg)) + + 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 - StCall fn cconv VoidRep args -> genCCall fn cconv VoidRep args + StJump arg -> genJump (derefDLL arg) + StCondJump lab arg -> genCondJump lab (derefDLL arg) + + -- A call returning void, ie one done for its side-effects + StCall fn cconv VoidRep args -> genCCall fn + cconv VoidRep (map derefDLL args) StAssign pk dst src - | isFloatingRep pk -> assignFltCode pk dst src - | otherwise -> assignIntCode pk dst src + | isFloatingRep pk -> assignFltCode pk (derefDLL dst) (derefDLL src) + | otherwise -> assignIntCode pk (derefDLL dst) (derefDLL src) StFallThrough lbl -- 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)) - (foldr1 (.) codes xs)) + -> mapAndUnzipNat getData args `thenNat` \ (codes, imms) -> + returnNat (DATA (primRepToSize kind) imms + `consOL` concatOL codes) where - getData :: StixTree -> UniqSM (InstrBlock, Imm) - - getData (StInt i) = returnUs (id, ImmInteger i) - getData (StDouble d) = returnUs (id, dblImmLit d) - getData (StLitLbl s) = returnUs (id, ImmLab s) - getData (StLitLit s) = returnUs (id, strImmLit (cvtLitLit (_UNPK_ s))) - getData (StCLbl l) = returnUs (id, ImmCLbl l) - getData (StString s) = - getUniqLabelNCG `thenUs` \ lbl -> - returnUs (mkSeqInstrs [LABEL lbl, - ASCII True (_UNPK_ s)], - ImmCLbl lbl) + getData :: StixTree -> NatM (InstrBlock, Imm) + + getData (StInt i) = returnNat (nilOL, ImmInteger i) + getData (StDouble d) = returnNat (nilOL, ImmDouble d) + getData (StFloat d) = returnNat (nilOL, ImmFloat d) + getData (StCLbl l) = returnNat (nilOL, ImmCLbl l) + getData (StString s) = + 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))) + +-- Walk a Stix tree, and insert dereferences to CLabels which are marked +-- as labelDynamic. stmt2Instrs calls derefDLL selectively, because +-- not all such CLabel occurrences need this dereferencing -- SRTs don't +-- for one. +derefDLL :: StixTree -> StixTree +derefDLL tree + | opt_Static -- short out the entire deal if not doing DLLs + = tree + | otherwise + = qq tree + where + qq t + = case t of + StCLbl lbl -> if labelDynamic lbl + then StInd PtrRep (StCLbl lbl) + else t + -- all the rest are boring + StIndex pk base offset -> StIndex pk (qq base) (qq offset) + StPrim pk args -> StPrim pk (map qq args) + StInd pk addr -> StInd pk (qq addr) + StCall who cc pk args -> StCall who cc pk (map qq args) + StInt _ -> t + StFloat _ -> t + StDouble _ -> t + StString _ -> t + StReg _ -> t + StScratchWord _ -> t + _ -> pprPanic "derefDLL: unhandled case" + (pprStixTree t) \end{code} %************************************************************************ @@ -90,38 +144,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)) @@ -129,41 +151,26 @@ mangleIndexTree (StIndex pk base (StInt i)) where off = StInt (i * sizeOf pk) -#ifndef i386_TARGET_ARCH mangleIndexTree (StIndex pk base off) - = StPrim IntAddOp [base, - case pk of - CharRep -> off - _ -> let - s = shift pk - in - ASSERT(toInteger s == expectJust "MachCode" (exactLog2 (sizeOf pk))) - StPrim SllOp [off, StInt s] - ] + = StPrim IntAddOp [ + base, + let s = shift pk + in ASSERT(toInteger s == expectJust "MachCode" (exactLog2 (sizeOf pk))) + if s == 0 then off else StPrim SllOp [off, StInt s] + ] where shift DoubleRep = 3::Integer + shift CharRep = 0::Integer shift _ = IF_ARCH_alpha(3,2) -#else --- Hmm..this is an attempt at fixing Adress amodes (i.e., *[disp](base,index,), --- that do include the size of the primitive kind we're addressing. When StIndex --- is expanded to actual code, the index (in units) is by the above code approp. --- shifted to get the no. of bytes. Since Address amodes do contain size info --- explicitly, we disable the shifting for x86s. -mangleIndexTree (StIndex pk base off) = StPrim IntAddOp [base, off] -#endif - \end{code} \begin{code} maybeImm :: StixTree -> Maybe Imm -maybeImm (StLitLbl s) = Just (ImmLab s) -maybeImm (StLitLit s) = Just (strImmLit (cvtLitLit (_UNPK_ s))) -maybeImm (StCLbl l) = Just (ImmCLbl l) - -maybeImm (StIndex rep (StCLbl l) (StInt off)) = - Just (ImmIndex l (fromInteger (off * sizeOf rep))) - +maybeImm (StCLbl l) + = Just (ImmCLbl l) +maybeImm (StIndex rep (StCLbl l) (StInt off)) + = Just (ImmIndex l (fromInteger (off * sizeOf rep))) maybeImm (StInt i) | i >= toInteger minInt && i <= toInteger maxInt = Just (ImmInt (fromInteger i)) @@ -193,47 +200,66 @@ registerCode :: Register -> Reg -> InstrBlock registerCode (Fixed _ _ code) reg = code 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 +registerName (Any _ _) reg = reg + +registerNameF (Fixed _ reg _) = reg +registerNameF (Any _ _) = pprPanic "registerNameF" empty registerRep :: Register -> PrimRep registerRep (Fixed pk _ _) = pk registerRep (Any pk _) = pk -isFixed :: 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 + +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) - -- cannae be Nothing + 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 (mkVReg 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( st0, IF_ARCH_sparc( f0,))) + 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), @@ -250,41 +276,17 @@ getRegister (StString s) #endif ] in - returnUs (Any PtrRep code) + returnNat (Any PtrRep code) -getRegister (StLitLit s) | _HEAD_ s == '"' && last xs == '"' - = getUniqLabelNCG `thenUs` \ lbl -> - let - imm_lbl = ImmCLbl lbl - code dst = mkSeqInstrs [ - SEGMENT DataSegment, - LABEL lbl, - ASCII False (init xs), - SEGMENT TextSegment, -#if alpha_TARGET_ARCH - LDA dst (AddrImm imm_lbl) -#endif -#if i386_TARGET_ARCH - MOV L (OpImm imm_lbl) (OpReg dst) -#endif -#if sparc_TARGET_ARCH - SETHI (HI imm_lbl) dst, - OR False dst (RIImm (LO imm_lbl)) dst -#endif - ] - in - returnUs (Any PtrRep code) - where - xs = _UNPK_ (_TAIL_ s) -- end of machine-"independent" bit; here we go on the rest... #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, @@ -293,7 +295,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 @@ -429,17 +431,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 @@ -448,12 +450,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 @@ -464,32 +466,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) @@ -498,7 +500,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 @@ -507,42 +509,74 @@ getRegister leaf -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if i386_TARGET_ARCH -getRegister (StDouble 0.0) - = let - code dst = mkSeqInstrs [FLDZ] +getRegister (StFloat f) + = getNatLabelNCG `thenNat` \ lbl -> + let code dst = toOL [ + SEGMENT DataSegment, + LABEL lbl, + DATA F [ImmFloat f], + SEGMENT TextSegment, + GLD F (ImmAddr (ImmCLbl lbl) 0) dst + ] in - returnUs (Any DoubleRep code) + returnNat (Any FloatRep code) -getRegister (StDouble 1.0) - = let - code dst = mkSeqInstrs [FLD1] - in - returnUs (Any DoubleRep code) getRegister (StDouble d) - = getUniqLabelNCG `thenUs` \ lbl -> - --getNewRegNCG PtrRep `thenUs` \ tmp -> - let code dst = mkSeqInstrs [ + + | d == 0.0 + = let code dst = unitOL (GLDZ dst) + in returnNat (Any DoubleRep code) + + | d == 1.0 + = let code dst = unitOL (GLD1 dst) + in returnNat (Any DoubleRep code) + + | otherwise + = getNatLabelNCG `thenNat` \ lbl -> + let code dst = toOL [ SEGMENT DataSegment, LABEL lbl, - DATA DF [dblImmLit d], + DATA DF [ImmDouble d], SEGMENT TextSegment, - FLD DF (OpImm (ImmCLbl lbl)) + GLD DF (ImmAddr (ImmCLbl lbl) 0) dst ] in - returnUs (Any DoubleRep code) + returnNat (Any DoubleRep code) + +-- 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 + = 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 IntNegOp -> trivialUCode (NEGI L) x - NotOp -> trivialUCode (NOT L) x - FloatNegOp -> trivialUFCode FloatRep FCHS x - FloatSqrtOp -> trivialUFCode FloatRep FSQRT x - DoubleNegOp -> trivialUFCode DoubleRep FCHS x + FloatNegOp -> trivialUFCode FloatRep (GNEG F) x + DoubleNegOp -> trivialUFCode DoubleRep (GNEG DF) x + + FloatSqrtOp -> trivialUFCode FloatRep (GSQRT F) x + DoubleSqrtOp -> trivialUFCode DoubleRep (GSQRT DF) x + + FloatSinOp -> trivialUFCode FloatRep (GSIN F) x + DoubleSinOp -> trivialUFCode DoubleRep (GSIN DF) x + + FloatCosOp -> trivialUFCode FloatRep (GCOS F) x + DoubleCosOp -> trivialUFCode DoubleRep (GCOS DF) x - DoubleSqrtOp -> trivialUFCode DoubleRep FSQRT x + FloatTanOp -> trivialUFCode FloatRep (GTAN F) x + DoubleTanOp -> trivialUFCode DoubleRep (GTAN DF) x + + Double2FloatOp -> trivialUFCode FloatRep GDTOF x + Float2DoubleOp -> trivialUFCode DoubleRep GFTOD x OrdOp -> coerceIntCode IntRep x ChrOp -> chrCode x @@ -552,14 +586,11 @@ getRegister (StPrim primop [x]) -- unary PrimOps Double2IntOp -> coerceFP2Int x Int2DoubleOp -> coerceInt2FP DoubleRep x - Double2FloatOp -> coerceFltCode x - Float2DoubleOp -> coerceFltCode x - other_op -> let - fixed_x = if is_float_op -- promote to double - then StPrim Float2DoubleOp [x] - else x + fixed_x = if is_float_op -- promote to double + then StPrim Float2DoubleOp [x] + else x in getRegister (StCall fn cCallConv DoubleRep [x]) where @@ -568,10 +599,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")) @@ -583,10 +610,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")) @@ -595,6 +618,10 @@ getRegister (StPrim primop [x]) -- unary PrimOps DoubleCoshOp -> (False, SLIT("cosh")) DoubleTanhOp -> (False, SLIT("tanh")) + other + -> pprPanic "getRegister(x86,unary primop)" + (pprStixTree (StPrim primop [x])) + getRegister (StPrim primop [x, y]) -- dyadic PrimOps = case primop of CharGtOp -> condIntReg GTT x y @@ -639,290 +666,244 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps DoubleLtOp -> condFltReg LTT x y DoubleLeOp -> condFltReg LE x y - IntAddOp -> {- ToDo: fix this, whatever it is (WDP 96/04)... - -- this should be optimised by the generic Opts, - -- I don't know why it is not (sometimes)! - case args of - [x, StInt 0] -> getRegister x - _ -> add_code L x y - -} - add_code L x y - + IntAddOp -> add_code L x y IntSubOp -> sub_code L x y IntQuotOp -> quot_code L x y True{-division-} IntRemOp -> quot_code L x y False{-remainder-} - IntMulOp -> trivialCode (IMUL L) x y {-True-} + IntMulOp -> let op = IMUL L in trivialCode op (Just op) x y - FloatAddOp -> trivialFCode FloatRep FADD FADD FADDP FADDP x y - FloatSubOp -> trivialFCode FloatRep FSUB FSUBR FSUBP FSUBRP x y - FloatMulOp -> trivialFCode FloatRep FMUL FMUL FMULP FMULP x y - FloatDivOp -> trivialFCode FloatRep FDIV FDIVR FDIVP FDIVRP x y + FloatAddOp -> trivialFCode FloatRep GADD x y + FloatSubOp -> trivialFCode FloatRep GSUB x y + FloatMulOp -> trivialFCode FloatRep GMUL x y + FloatDivOp -> trivialFCode FloatRep GDIV x y - DoubleAddOp -> trivialFCode DoubleRep FADD FADD FADDP FADDP x y - DoubleSubOp -> trivialFCode DoubleRep FSUB FSUBR FSUBP FSUBRP x y - DoubleMulOp -> trivialFCode DoubleRep FMUL FMUL FMULP FMULP x y - DoubleDivOp -> trivialFCode DoubleRep FDIV FDIVR FDIVP FDIVRP x y + DoubleAddOp -> trivialFCode DoubleRep GADD x y + DoubleSubOp -> trivialFCode DoubleRep GSUB x y + DoubleMulOp -> trivialFCode DoubleRep GMUL x y + DoubleDivOp -> trivialFCode DoubleRep GDIV x y - AndOp -> trivialCode (AND L) x y {-True-} - OrOp -> trivialCode (OR L) x y {-True-} - XorOp -> trivialCode (XOR L) x y {-True-} + AndOp -> let op = AND L in trivialCode op (Just op) x y + OrOp -> let op = OR L in trivialCode op (Just op) x y + XorOp -> let op = XOR L in trivialCode op (Just op) x y {- Shift ops on x86s have constraints on their source, it either has to be Imm, CL or 1 => trivialCode's is not restrictive enough (sigh.) -} - SllOp -> shift_code (SHL L) x y {-False-} - SrlOp -> shift_code (SHR L) x y {-False-} - - ISllOp -> shift_code (SHL L) x y {-False-} --was:panic "I386Gen:isll" - ISraOp -> shift_code (SAR L) x y {-False-} --was:panic "I386Gen:isra" - ISrlOp -> shift_code (SHR L) x y {-False-} --was:panic "I386Gen:isrl" - - FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [promote x, promote y]) + SllOp -> shift_code (SHL L) x y {-False-} + SrlOp -> shift_code (SHR L) x y {-False-} + ISllOp -> shift_code (SHL L) x y {-False-} + ISraOp -> shift_code (SAR L) x y {-False-} + ISrlOp -> shift_code (SHR L) x y {-False-} + + FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep + [promote x, promote y]) where promote x = StPrim Float2DoubleOp [x] - DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x, y]) + DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep + [x, y]) + other + -> pprPanic "getRegister(x86,dyadic primop)" + (pprStixTree (StPrim primop [x, y])) where - shift_code :: (Operand -> Operand -> Instr) + + -------------------- + 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` \ register -> - let - op_imm = OpImm imm__2 - code__2 dst = - let - code = registerCode register dst - src = registerName register dst - in - mkSeqInstr (COMMENT SLIT("shift_code")) . - code . - if isFixed register && src /= dst - then - mkSeqInstrs [MOV L (OpReg src) (OpReg dst), - instr op_imm (OpReg dst)] - else - mkSeqInstr (instr op_imm (OpReg src)) - in - returnUs (Any IntRep code__2) + = getRegister x `thenNat` \ regx -> + let mkcode 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 `snocOL` + MOV L (OpReg r_x) (OpReg dst) `snocOL` + instr imm__2 (OpReg dst) + in + returnNat (Any IntRep mkcode) where imm = maybeImm y imm__2 = case imm of Just x -> x {- Case2: shift length is complex (non-immediate) -} + -- Since ECX is always used as a spill temporary, we can't + -- 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 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 y `thenUs` \ register1 -> - getRegister x `thenUs` \ register2 -> --- getNewRegNCG IntRep `thenUs` \ dst -> - let - -- Note: we force the shift length to be loaded - -- into ECX, so that we can use CL when shifting. - -- (only register location we are allowed - -- to put shift amounts.) - -- - -- The shift instruction is fed ECX as src reg, - -- but we coerce this into CL when printing out. - src1 = registerName register1 ecx - code1 = if src1 /= ecx then -- if it is not in ecx already, force it! - registerCode register1 ecx . - mkSeqInstr (MOV L (OpReg src1) (OpReg ecx)) - else - registerCode register1 ecx - code__2 = - let - code2 = registerCode register2 eax - src2 = registerName register2 eax - in - code1 . code2 . - mkSeqInstr (instr (OpReg ecx) (OpReg eax)) + = 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 + src_amt = registerName register2 tmp + code_amt = registerCode register2 tmp + r_dst = OpReg dst + r_tmp = OpReg tmp + in + 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, + + BT L (ImmInt 4) r_tmp, + JXX GEU lbl_test3, + instr (ImmInt 16) r_dst, + + LABEL lbl_test3, + BT L (ImmInt 3) r_tmp, + JXX GEU lbl_test2, + instr (ImmInt 8) r_dst, + + LABEL lbl_test2, + BT L (ImmInt 2) r_tmp, + JXX GEU lbl_test1, + instr (ImmInt 4) r_dst, + + LABEL lbl_test1, + BT L (ImmInt 1) r_tmp, + JXX GEU lbl_test0, + instr (ImmInt 2) r_dst, + + LABEL lbl_test0, + BT L (ImmInt 0) r_tmp, + JXX GEU lbl_after, + instr (ImmInt 1) r_dst, + LABEL lbl_after, + + COMMENT (_PK_ "end shift sequence") + ] in - returnUs (Fixed IntRep eax 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__2 dst + = code `snocOL` + LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2)) + (OpReg dst) in - returnUs (Any IntRep code__2) -{- - add_code sz x (StInd _ mem) - = getRegister x `thenUs` \ register1 -> - --getNewRegNCG (registerRep register1) - -- `thenUs` \ tmp1 -> - getAmode mem `thenUs` \ amode -> - let - code2 = amodeCode amode - src2 = amodeAddr amode - - code__2 dst = let code1 = registerCode register1 dst - src1 = registerName register1 dst - in asmParThen [code2 asmVoid,code1 asmVoid] . - if isFixed register1 && src1 /= dst - then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst), - ADD sz (OpAddr src2) (OpReg dst)] - else - mkSeqInstrs [ADD sz (OpAddr src2) (OpReg src1)] - in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) - add_code sz (StInd _ mem) y - = getRegister y `thenUs` \ register2 -> - --getNewRegNCG (registerRep register2) - -- `thenUs` \ tmp2 -> - getAmode mem `thenUs` \ amode -> - let - code1 = amodeCode amode - src1 = amodeAddr amode - - code__2 dst = let code2 = registerCode register2 dst - src2 = registerName register2 dst - in asmParThen [code1 asmVoid,code2 asmVoid] . - if isFixed register2 && src2 /= dst - then mkSeqInstrs [MOV L (OpReg src2) (OpReg dst), - ADD sz (OpAddr src1) (OpReg dst)] - else - mkSeqInstrs [ADD sz (OpAddr src1) (OpReg src2)] - in - returnUs (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__2 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) x y {-False-} + sub_code sz x y = trivialCode (SUB sz) Nothing x y -------------------- quot_code :: 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 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 + src = amodeAddr amode size = primRepToSize pk - code__2 dst = code . - if pk == DoubleRep || pk == FloatRep - then mkSeqInstr (FLD {-DF-} size (OpAddr src)) - 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)" (pprStixTree leaf) where imm = maybeImm leaf imm__2 = case imm of Just x -> x @@ -931,47 +912,68 @@ getRegister leaf -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if sparc_TARGET_ARCH +getRegister (StFloat d) + = getNatLabelNCG `thenNat` \ lbl -> + getNewRegNCG PtrRep `thenNat` \ tmp -> + let code dst = toOL [ + SEGMENT DataSegment, + LABEL lbl, + DATA F [ImmFloat d], + SEGMENT TextSegment, + SETHI (HI (ImmCLbl lbl)) tmp, + LD F (AddrRegImm tmp (LO (ImmCLbl lbl))) dst] + in + returnNat (Any FloatRep code) + getRegister (StDouble d) - = getUniqLabelNCG `thenUs` \ lbl -> - getNewRegNCG PtrRep `thenUs` \ tmp -> - let code dst = mkSeqInstrs [ + = getNatLabelNCG `thenNat` \ lbl -> + getNewRegNCG PtrRep `thenNat` \ tmp -> + let code dst = toOL [ SEGMENT DataSegment, LABEL lbl, - DATA DF [dblImmLit d], + DATA DF [ImmDouble d], SEGMENT TextSegment, SETHI (HI (ImmCLbl lbl)) tmp, LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst] in - returnUs (Any DoubleRep code) + returnNat (Any DoubleRep code) + +-- The 6-word scratch area is immediately below the frame pointer. +-- Below that is the spill area. +getRegister (StScratchWord i) + | i >= 0 && i < 6 + = let j = i+1 + code dst = unitOL (fpRelEA j dst) + in + returnNat (Any PtrRep code) + getRegister (StPrim primop [x]) -- unary PrimOps = case primop of - IntNegOp -> trivialUCode (SUB False False g0) x - IntAbsOp -> absIntCode x - NotOp -> trivialUCode (XNOR False g0) x + IntNegOp -> trivialUCode (SUB False False g0) x + NotOp -> trivialUCode (XNOR False g0) x - FloatNegOp -> trivialUFCode FloatRep (FNEG F) x - - DoubleNegOp -> trivialUFCode DoubleRep (FNEG DF) x + FloatNegOp -> trivialUFCode FloatRep (FNEG F) x + DoubleNegOp -> trivialUFCode DoubleRep (FNEG DF) x Double2FloatOp -> trivialUFCode FloatRep (FxTOy DF F) x Float2DoubleOp -> trivialUFCode DoubleRep (FxTOy F DF) x - OrdOp -> coerceIntCode IntRep x - ChrOp -> chrCode x + OrdOp -> coerceIntCode IntRep x + ChrOp -> chrCode x - Float2IntOp -> coerceFP2Int x - Int2FloatOp -> coerceInt2FP FloatRep x - Double2IntOp -> coerceFP2Int x - Int2DoubleOp -> coerceInt2FP DoubleRep x + Float2IntOp -> coerceFP2Int x + Int2FloatOp -> coerceInt2FP FloatRep x + Double2IntOp -> coerceFP2Int x + Int2DoubleOp -> coerceInt2FP DoubleRep x other_op -> let - fixed_x = if is_float_op -- promote to double - then StPrim Float2DoubleOp [x] - else x + fixed_x = if is_float_op -- promote to double + then StPrim Float2DoubleOp [x] + else x in - getRegister (StCall fn cCallConv DoubleRep [x]) + getRegister (StCall fn cCallConv DoubleRep [fixed_x]) where (is_float_op, fn) = case primop of @@ -993,7 +995,7 @@ getRegister (StPrim primop [x]) -- unary PrimOps DoubleExpOp -> (False, SLIT("exp")) DoubleLogOp -> (False, SLIT("log")) - DoubleSqrtOp -> (True, SLIT("sqrt")) + DoubleSqrtOp -> (False, SLIT("sqrt")) DoubleSinOp -> (False, SLIT("sin")) DoubleCosOp -> (False, SLIT("cos")) @@ -1006,7 +1008,10 @@ getRegister (StPrim primop [x]) -- unary PrimOps DoubleSinhOp -> (False, SLIT("sinh")) DoubleCoshOp -> (False, SLIT("cosh")) DoubleTanhOp -> (False, SLIT("tanh")) - _ -> panic ("Monadic PrimOp not handled: " ++ show primop) + + other + -> pprPanic "getRegister(sparc,monadicprimop)" + (pprStixTree (StPrim primop [x])) getRegister (StPrim primop [x, y]) -- dyadic PrimOps = case primop of @@ -1080,39 +1085,47 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps ISraOp -> trivialCode SRA x y --was: panic "SparcGen:isra" ISrlOp -> trivialCode SRL x y --was: panic "SparcGen:isrl" - FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [promote x, promote y]) + FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep + [promote x, promote y]) where promote x = StPrim Float2DoubleOp [x] - DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x, y]) --- _ -> panic "Prim op " ++ (showPrimOp primop) ++ " not handled!" + DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep + [x, y]) + + other + -> pprPanic "getRegister(sparc,dyadic primop)" + (pprStixTree (StPrim primop [x, y])) + where 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) + code__2 dst = code `snocOL` LD size src dst in - returnUs (Any pk code__2) + returnNat (Any pk code__2) getRegister (StInt i) | fits13Bits i = let src = ImmInt (fromInteger i) - code dst = mkSeqInstr (OR False g0 (RIImm src) dst) + code dst = unitOL (OR False g0 (RIImm src) dst) in - returnUs (Any IntRep code) + returnNat (Any IntRep code) getRegister leaf | maybeToBool imm = let - code dst = mkSeqInstrs [ + code dst = toOL [ SETHI (HI imm__2) dst, OR False dst (RIImm (LO imm__2)) dst] in - returnUs (Any PtrRep code) + returnNat (Any PtrRep code) + | otherwise + = pprPanic "getRegister(sparc)" (pprStixTree leaf) where imm = maybeImm leaf imm__2 = case imm of Just x -> x @@ -1137,116 +1150,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, y]) - = getNewRegNCG PtrRep `thenUs` \ tmp1 -> - getNewRegNCG IntRep `thenUs` \ tmp2 -> - getRegister x `thenUs` \ register1 -> - getRegister y `thenUs` \ register2 -> +getAmode (StPrim IntAddOp [x, StPrim SllOp [y, StInt shift]]) + | shift == 0 || shift == 1 || shift == 2 || shift == 3 + = 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,4)) (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 -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -1254,61 +1276,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 = code1 `appOL` 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) + code = unitOL (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} @@ -1331,7 +1353,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" @@ -1344,46 +1366,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} @@ -1394,7 +1416,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" @@ -1404,146 +1426,164 @@ condFltCode = panic "MachCode.condFltCode: not on Alphas" -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if i386_TARGET_ARCH -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 (StDouble 0.0) - = getRegister x `thenUs` \ register1 -> - getNewRegNCG (registerRep register1) - `thenUs` \ tmp1 -> - let - pk1 = registerRep register1 - code1 = registerCode register1 tmp1 - src1 = registerName register1 tmp1 - - code__2 = asmParThen [code1 asmVoid] . - mkSeqInstrs [FTST, FSTP DF (OpReg st0), -- or FLDZ, FUCOMPP ? - FNSTSW, - --AND HB (OpImm (ImmInt 68)) (OpReg eax), - --XOR HB (OpImm (ImmInt 64)) (OpReg eax) - SAHF - ] - in - returnUs (CondCode True (fix_FP_cond 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 -> + `thenNat` \ tmp2 -> + getNewRegNCG DoubleRep `thenNat` \ tmp -> let pk1 = registerRep register1 code1 = registerCode register1 tmp1 src1 = registerName register1 tmp1 + pk2 = registerRep register2 code2 = registerCode register2 tmp2 src2 = registerName register2 tmp2 - code__2 = asmParThen [code2 asmVoid, code1 asmVoid] . - mkSeqInstrs [FUCOMPP, - FNSTSW, - --AND HB (OpImm (ImmInt 68)) (OpReg eax), - --XOR HB (OpImm (ImmInt 64)) (OpReg eax) - SAHF - ] - in - returnUs (CondCode True (fix_FP_cond cond) code__2) + 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 -{- 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 GE = GEU + fix_FP_cond GTT = GU + fix_FP_cond LTT = LU + fix_FP_cond LE = LEU + fix_FP_cond any = any + in + returnNat (CondCode True (fix_FP_cond cond) code__2) -fix_FP_cond :: Cond -> Cond -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 #endif {- i386_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -1551,42 +1591,42 @@ fix_FP_cond any = any 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) + code__2 = code `snocOL` 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] . - mkSeqInstr (SUB False True src1 (RIReg src2) g0) + code__2 = code1 `appOL` code2 `snocOL` + 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) + promote x = FxTOy F DF x tmp pk1 = registerRep register1 code1 = registerCode register1 tmp1 @@ -1598,16 +1638,16 @@ condFltCode cond x y code__2 = if pk1 == pk2 then - asmParThen [code1 asmVoid, code2 asmVoid] . - mkSeqInstr (FCMP True (primRepToSize pk1) src1 src2) + code1 `appOL` code2 `snocOL` + FCMP True (primRepToSize pk1) src1 src2 else if pk1 == FloatRep then - asmParThen [code1 (promote src1), code2 asmVoid] . - mkSeqInstr (FCMP True DF tmp src2) + code1 `snocOL` promote src1 `appOL` code2 `snocOL` + FCMP True DF tmp src2 else - asmParThen [code1 asmVoid, code2 (promote src2)] . - mkSeqInstr (FCMP True DF src1 tmp) + code1 `appOL` code2 `snocOL` promote src2 `snocOL` + FCMP True DF src1 tmp in - returnUs (CondCode True cond code__2) + returnNat (CondCode True cond code__2) #endif {- sparc_TARGET_ARCH -} \end{code} @@ -1628,27 +1668,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 @@ -1657,105 +1697,132 @@ 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 +-- Destination of an assignment can only be reg or mem. +-- This is the mem case. assignIntCode pk (StInd _ dst) src - = getAmode dst `thenUs` \ amode -> - get_op_RI src `thenUs` \ (codesrc, opsrc, sz) -> - let - code1 = amodeCode amode asmVoid - dst__2 = amodeAddr amode - code__2 = asmParThen [code1, codesrc asmVoid] . - mkSeqInstr (MOV sz opsrc (OpAddr dst__2)) - in - returnUs code__2 + = 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, Size) -- code, operator, size + -> NatM (InstrBlock,Operand) -- code, operator get_op_RI op | maybeToBool imm - = returnUs (asmParThen [], OpImm imm_op, L) + = 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 - pk = registerRep register - sz = primRepToSize pk in - returnUs (code, OpReg reg, sz) + returnNat (code, OpReg reg) -assignIntCode pk dst (StInd _ src) - = getNewRegNCG IntRep `thenUs` \ tmp -> - getAmode src `thenUs` \ amode -> - getRegister dst `thenUs` \ register -> +-- Assign; dst is a reg, rhs is mem +assignIntCode pk dst (StInd pks src) + = getNewRegNCG PtrRep `thenNat` \ tmp -> + getAmode src `thenNat` \ amode -> + getRegister dst `thenNat` \ reg_dst -> let - code1 = amodeCode amode asmVoid - src__2 = amodeAddr amode - code2 = registerCode register tmp asmVoid - dst__2 = registerName register tmp - sz = primRepToSize pk - code__2 = asmParThen [code1, code2] . - mkSeqInstr (MOV sz (OpAddr src__2) (OpReg dst__2)) + 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 `thenUs` \ register1 -> - getRegister src `thenUs` \ register2 -> - getNewRegNCG IntRep `thenUs` \ tmp -> - 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 - in - returnUs code__2 + = 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 = code1 `appOL` code2 `snocOL` 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 src__2 = registerName register2 dst__2 code__2 = if isFixed register2 - then code . mkSeqInstr (OR False g0 (RIReg src__2) dst__2) + then code `snocOL` OR False g0 (RIReg src__2) dst__2 else code in - returnUs code__2 + returnNat code__2 #endif {- sparc_TARGET_ARCH -} \end{code} @@ -1767,22 +1834,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 @@ -1791,107 +1858,94 @@ 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 -> - --getRegister src `thenUs` \ register -> - 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 -> - let - sz = primRepToSize pk - dst__2 = amodeAddr amode - - code1 = amodeCode amode asmVoid - code2 = registerCode register {-tmp-}st0 asmVoid - - --src__2= registerName register tmp - pk__2 = registerRep register - sz__2 = primRepToSize pk__2 - - code__2 = asmParThen [code1, code2] . - mkSeqInstr (FSTP sz (OpAddr dst__2)) - in - returnUs code__2 - +-- 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 `thenUs` \ register1 -> - getRegister src `thenUs` \ register2 -> - --getNewRegNCG (registerRep register2) - -- `thenUs` \ tmp -> + = getRegister dst `thenNat` \ reg_dst -> + getRegister src `thenNat` \ reg_src -> + getNewRegNCG pk `thenNat` \ tmp -> let - sz = primRepToSize pk - dst__2 = registerName register1 st0 --tmp + r_dst = registerName reg_dst tmp + c_dst = registerCode reg_dst tmp -- should be empty - code = registerCode register2 dst__2 - src__2 = registerName register2 dst__2 + r_src = registerName reg_src r_dst + c_src = registerCode reg_src r_dst - code__2 = code + 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 + #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] . - 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] + code__2 = code1 `appOL` code2 `appOL` + if pk == pk__2 + then unitOL (ST sz src__2 dst__2) + else toOL [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 @@ -1905,13 +1959,13 @@ assignFltCode pk dst src code__2 = if pk /= pk__2 then - code . mkSeqInstr (FxTOy sz__2 sz src__2 dst__2) + code `snocOL` FxTOy sz__2 sz src__2 dst__2 else if isFixed register2 then - code . mkSeqInstr (FMOV sz src__2 dst__2) + code `snocOL` FMOV sz src__2 dst__2 else code in - returnUs code__2 + returnNat code__2 #endif {- sparc_TARGET_ARCH -} \end{code} @@ -1931,7 +1985,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 @@ -1942,8 +1996,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 @@ -1952,40 +2006,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 @@ -1995,19 +2041,19 @@ genJump tree #if sparc_TARGET_ARCH genJump (StCLbl lbl) - | isAsmTemp lbl = returnInstrs [BI ALWAYS False target, NOP] - | otherwise = returnInstrs [CALL target 0 True, NOP] + | isAsmTemp lbl = returnNat (toOL [BI ALWAYS False target, NOP]) + | otherwise = returnNat (toOL [CALL target 0 True, NOP]) where 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 in - returnSeq code [JMP (AddrRegReg target g0), NOP] + returnNat (code `snocOL` JMP (AddrRegReg target g0) `snocOL` NOP) #endif {- sparc_TARGET_ARCH -} \end{code} @@ -2041,14 +2087,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 @@ -2083,16 +2129,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 @@ -2109,14 +2155,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" @@ -2149,14 +2195,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) @@ -2189,30 +2235,32 @@ 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 target = ImmCLbl lbl in - returnSeq code ( - if condFloat condition then - [NOP, BF cond False target, NOP] - else - [BI cond False target, NOP] + returnNat ( + code `appOL` + toOL ( + if condFloat condition + then [NOP, BF cond False target, NOP] + else [BI cond False target, NOP] + ) ) #endif {- sparc_TARGET_ARCH -} @@ -2237,16 +2285,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))), @@ -2263,24 +2311,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) @@ -2294,16 +2342,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 -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -2311,48 +2359,32 @@ 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 -{- OLD: - = getUniqLabelNCG `thenUs` \ lbl -> - let - call = [MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax), - MOV L (OpImm (ImmCLbl lbl)) - -- this is hardwired - (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt 104))), - JMP (OpImm (ImmLit (ptext (if underscorePrefix then (SLIT ("_PerformGC_wrapper")) else (SLIT ("PerformGC_wrapper")))))), - LABEL lbl] - in - returnInstrs call --} genCCall fn cconv kind args - = mapUs get_call_arg args `thenUs` \ argCode -> - let - nargs = length args - -{- OLD: Since there's no attempt at stealing %esp at the moment, - restoring %esp from MainRegTable.rCstkptr is not done. -- SOF 97/09 - (ditto for saving away old-esp in MainRegTable.Hp (!!) ) - code1 = asmParThen [asmSeq [ -- MOV L (OpReg esp) (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt 80))), - MOV L (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt 100))) (OpReg esp) - ] - ] --} - code2 = asmParThen (map ($ asmVoid) (reverse argCode)) - call = [CALL fn__2 , - -- pop args; all args word sized? - ADD L (OpImm (ImmInt (nargs * 4))) (OpReg esp) --, - - -- Don't restore %esp (see above) - -- MOV L (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt 80))) (OpReg esp) - ] - in - returnSeq (code2) call + = 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 + setDeltaNat (delta + tot_arg_size) `thenNat` \ _ -> + returnNat (code2 `appOL` call) + where -- function names that begin with '.' are assumed to be special -- internally generated names like '.mul,' which don't get an @@ -2360,57 +2392,76 @@ genCCall fn cconv kind args -- ToDo:needed (WDP 96/03) ??? fn__2 = case (_HEAD_ fn) of '.' -> ImmLit (ptext fn) - _ -> ImmLab (ptext fn) + _ -> ImmLab False (ptext fn) + + arg_size DF = 8 + arg_size F = 4 + arg_size _ = 4 ------------ - get_call_arg :: StixTree{-current argument-} -> UniqSM InstrBlock -- code + get_call_arg :: StixTree{-current argument-} + -> NatM (Int, InstrBlock) -- argsz, code get_call_arg arg - = get_op arg `thenUs` \ (code, op, sz) -> - returnUs (code . mkSeqInstr (PUSH sz op)) - + = 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 size)) (OpReg esp), + DELTA (delta-size), + GST sz 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,Operand, Size) -- code, operator, size - - get_op (StInt i) - = returnUs (asmParThen [], OpImm (ImmInt (fromInteger i)), L) - - get_op (StInd pk mem) - = getAmode mem `thenUs` \ amode -> - let - code = amodeCode amode --asmVoid - addr = amodeAddr amode - sz = primRepToSize pk - in - returnUs (code, OpAddr addr, sz) + -> 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, OpReg 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) - in - returnSeq code [call, NOP] + call = unitOL (CALL fn__2 nRegs False) + code = concatOL argCode + + -- 3 because in the worst case, %o0 .. %o5 will only use up 3 args + (move_sp_down, move_sp_up) + = let nn = length args - 3 + in if nn <= 0 + then (nilOL, nilOL) + else (unitOL (moveSp (-(2*nn))), unitOL (moveSp (2*nn))) + in + returnNat (move_sp_down `appOL` + code `appOL` + call `appOL` + unitOL NOP `appOL` + move_sp_up) where -- function names that begin with '.' are assumed to be special -- internally generated names like '.mul,' which don't get an @@ -2418,7 +2469,7 @@ genCCall fn cconv kind args -- ToDo:needed (WDP 96/03) ??? fn__2 = case (_HEAD_ fn) of '.' -> ImmLit (ptext fn) - _ -> ImmLab (ptext fn) + _ -> ImmLab False (ptext fn) ------------------------------------ {- Try to get a value into a specific register (or registers) for @@ -2431,50 +2482,68 @@ genCCall fn cconv kind args offset to use for overflowing arguments. This way, @get_arg@ can be applied to all of a call's arguments using @mapAccumL@. + + If we have to put args on the stack, move %o6==%sp down by + 8 x the number of args, to ensure there's enough space. -} 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 [ - -- conveniently put the second part in the right stack - -- location, and load the first part into %o5 - ST DF src (spRel (offset - 1)), - LD W (spRel (offset - 1)) dst]) - (dst__2:dsts__2) -> ((dsts__2, offset), code . mkSeqInstrs [ - ST DF src (spRel (-2)), - LD W (spRel (-2)) dst, - LD W (spRel (-1)) dst__2]) - FloatRep -> ((dsts, offset), code . mkSeqInstrs [ - ST F src (spRel (-2)), - LD W (spRel (-2)) dst]) - _ -> ((dsts, offset), if isFixed register then - code . mkSeqInstr (OR False g0 (RIReg src) dst) - else code)) - + [] -> ( ([], offset + 1), + code `snocOL` + -- put the second part in the right stack + -- and load the first part into %o5 + FMOV DF src f0 `snocOL` + ST F f0 (spRel offset) `snocOL` + LD W (spRel offset) dst `snocOL` + ST F (fPair f0) (spRel offset) + ) + (dst__2:dsts__2) + -> ( (dsts__2, offset), + code `snocOL` + FMOV DF src f0 `snocOL` + ST F f0 (spRel 16) `snocOL` + LD W (spRel 16) dst `snocOL` + ST F (fPair f0) (spRel 16) `snocOL` + LD W (spRel 16) dst__2 + ) + FloatRep + -> ( (dsts, offset), + code `snocOL` + ST F src (spRel 16) `snocOL` + LD W (spRel 16) dst + ) + _ -> ( (dsts, offset), + if isFixed register + then code `snocOL` OR False g0 (RIReg src) dst + else code + ) + ) -- Once we have run out of argument registers, we move to the -- 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 @@ -2482,7 +2551,8 @@ 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 `snocOL` ST sz src (spRel offset) ) #endif {- sparc_TARGET_ARCH -} \end{code} @@ -2506,7 +2576,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)" @@ -2517,30 +2587,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, @@ -2548,78 +2614,78 @@ 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 - code__2 dst = code . mkSeqInstrs [ + code__2 dst = code `appOL` toOL [ 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 = code1 `appOL` code2 `appOL` toOL [ 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 - code__2 dst = code . mkSeqInstrs [ + code__2 dst = code `appOL` toOL [ 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 = code1 `appOL` code2 `appOL` toOL [ 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 - code__2 dst = code . mkSeqInstrs [ + code__2 dst = code `appOL` toOL [ BI cond False (ImmCLbl lbl1), NOP, OR False g0 (RIImm (ImmInt 0)) dst, BI ALWAYS False (ImmCLbl lbl2), NOP, @@ -2627,16 +2693,16 @@ 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 - code__2 dst = code . mkSeqInstrs [ + code__2 dst = code `appOL` toOL [ NOP, BF cond False (ImmCLbl lbl1), NOP, OR False g0 (RIImm (ImmInt 0)) dst, @@ -2645,7 +2711,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} @@ -2668,25 +2734,21 @@ have handled the constant-folding. \begin{code} trivialCode :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr) - ,IF_ARCH_i386 ((Operand -> Operand -> Instr) + ,IF_ARCH_i386 ((Operand -> Operand -> Instr) + -> Maybe (Operand -> Operand -> Instr) ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr) ,))) -> StixTree -> StixTree -- the two arguments - -> UniqSM Register + -> NatM Register trivialFCode :: PrimRep -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr) ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr) - ,IF_ARCH_i386 ( - {-this bizarre type for i386 seems a little too weird (WDP 96/03)-} - (Size -> Operand -> Instr) - -> (Size -> Operand -> Instr) {-reversed instr-} - -> Instr {-pop-} - -> Instr {-reversed instr: pop-} + ,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr) ,))) -> StixTree -> StixTree -- the two arguments - -> UniqSM Register + -> NatM Register trivialUCode :: IF_ARCH_alpha((RI -> Reg -> Instr) @@ -2694,63 +2756,63 @@ trivialUCode ,IF_ARCH_sparc((RI -> Reg -> Instr) ,))) -> StixTree -- the one argument - -> UniqSM Register + -> NatM Register trivialUFCode :: PrimRep -> IF_ARCH_alpha((Reg -> Reg -> Instr) - ,IF_ARCH_i386 (Instr + ,IF_ARCH_i386 ((Reg -> Reg -> Instr) ,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 @@ -2758,214 +2820,199 @@ 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 -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if i386_TARGET_ARCH +\end{code} +The Rules of the Game are: -trivialCode instr x y - | maybeToBool imm - = getRegister x `thenUs` \ register1 -> - --getNewRegNCG IntRep `thenUs` \ tmp1 -> - let - code__2 dst = let code1 = registerCode register1 dst - src1 = registerName register1 dst - in code1 . - if isFixed register1 && src1 /= dst - then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst), - instr (OpImm imm__2) (OpReg dst)] - else - mkSeqInstrs [instr (OpImm imm__2) (OpReg src1)] - in - returnUs (Any IntRep code__2) - where - imm = maybeImm y - imm__2 = case imm of Just x -> x +* You cannot assume anything about the destination register dst; + 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 + want to do so, first copy the value either to a temporary + or into dst. You are free to modify dst even if it happens + to be a fixed reg -- that's not your problem. + +* You cannot assume that a fixed reg will stay live over an + arbitrary computation. The same applies to the dst reg. + +* Temporary regs obtained from getNewRegNCG are distinct from + each other and from all other regs, and stay live over + arbitrary computations. + +\begin{code} + +trivialCode instr maybe_revinstr a b + + | is_imm_b + = getRegister a `thenNat` \ rega -> + let mkcode dst + = if isAny rega + then registerCode rega dst `bind` \ code_a -> + code_a `snocOL` + instr (OpImm imm_b) (OpReg dst) + else registerCodeF rega `bind` \ code_a -> + registerNameF rega `bind` \ r_a -> + code_a `snocOL` + MOV L (OpReg r_a) (OpReg dst) `snocOL` + instr (OpImm imm_b) (OpReg dst) + in + returnNat (Any IntRep mkcode) + + | is_imm_a + = 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 isAny regb + then registerCode regb dst `bind` \ code_b -> + code_b `snocOL` + revinstr (OpImm imm_a) (OpReg dst) + else registerCodeF regb `bind` \ code_b -> + registerNameF regb `bind` \ r_b -> + code_b `snocOL` + MOV L (OpReg r_b) (OpReg dst) `snocOL` + revinstr (OpImm imm_a) (OpReg dst) + + | otherwise + = if isAny regb + then registerCode regb tmp `bind` \ code_b -> + 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 `snocOL` + MOV L (OpReg r_b) (OpReg tmp) `snocOL` + MOV L (OpImm imm_a) (OpReg dst) `snocOL` + instr (OpReg tmp) (OpReg dst) + in + returnNat (Any IntRep mkcode) + + | otherwise + = getRegister a `thenNat` \ rega -> + getRegister b `thenNat` \ regb -> + getNewRegNCG IntRep `thenNat` \ tmp -> + let mkcode dst + = case (isAny rega, isAny regb) of + (True, True) + -> registerCode regb tmp `bind` \ code_b -> + registerCode rega dst `bind` \ code_a -> + 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 `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 `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 `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 + returnNat (Any IntRep mkcode) + + where + maybe_imm_a = maybeImm a + is_imm_a = maybeToBool maybe_imm_a + imm_a = case maybe_imm_a of Just imm -> imm + + maybe_imm_b = maybeImm b + is_imm_b = maybeToBool maybe_imm_b + imm_b = case maybe_imm_b of Just imm -> imm -trivialCode instr x y - | maybeToBool imm - = getRegister y `thenUs` \ register1 -> - --getNewRegNCG IntRep `thenUs` \ tmp1 -> - let - code__2 dst = let code1 = registerCode register1 dst - src1 = registerName register1 dst - in code1 . - if isFixed register1 && src1 /= dst - then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst), - instr (OpImm imm__2) (OpReg dst)] - else - mkSeqInstr (instr (OpImm imm__2) (OpReg src1)) - in - returnUs (Any IntRep code__2) - where - imm = maybeImm x - imm__2 = case imm of Just x -> x -{- -trivialCode instr x (StInd pk mem) - = getRegister x `thenUs` \ register -> - --getNewRegNCG IntRep `thenUs` \ tmp -> - getAmode mem `thenUs` \ amode -> - let - code2 = amodeCode amode asmVoid - src2 = amodeAddr amode - code__2 dst = let code1 = registerCode register dst asmVoid - src1 = registerName register dst - in asmParThen [code1, code2] . - if isFixed register && src1 /= dst - then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst), - instr (OpAddr src2) (OpReg dst)] - else - mkSeqInstr (instr (OpAddr src2) (OpReg src1)) - in - returnUs (Any pk code__2) - -trivialCode instr (StInd pk mem) y - = getRegister y `thenUs` \ register -> - --getNewRegNCG IntRep `thenUs` \ tmp -> - getAmode mem `thenUs` \ amode -> - let - code2 = amodeCode amode asmVoid - src2 = amodeAddr amode - code__2 dst = let - code1 = registerCode register dst asmVoid - src1 = registerName register dst - in asmParThen [code1, code2] . - if isFixed register && src1 /= dst - then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst), - instr (OpAddr src2) (OpReg dst)] - else - mkSeqInstr (instr (OpAddr src2) (OpReg src1)) - in - returnUs (Any pk code__2) --} -trivialCode instr x y - = getRegister x `thenUs` \ register1 -> - getRegister y `thenUs` \ register2 -> - --getNewRegNCG IntRep `thenUs` \ tmp1 -> - getNewRegNCG IntRep `thenUs` \ tmp2 -> - let - code2 = registerCode register2 tmp2 asmVoid - src2 = registerName register2 tmp2 - code__2 dst = let - code1 = registerCode register1 dst asmVoid - src1 = registerName register1 dst - in asmParThen [code1, code2] . - if isFixed register1 && src1 /= dst - then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst), - instr (OpReg src2) (OpReg dst)] - else - mkSeqInstr (instr (OpReg src2) (OpReg src1)) - in - returnUs (Any IntRep code__2) ----------- trivialUCode instr x - = getRegister x `thenUs` \ register -> --- getNewRegNCG IntRep `thenUs` \ tmp -> + = getRegister x `thenNat` \ register -> let - code__2 dst = let - code = registerCode register dst + 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 _ instrr _ _ (StInd pk' mem) y - = getRegister y `thenUs` \ register2 -> - --getNewRegNCG (registerRep register2) - -- `thenUs` \ tmp2 -> - getAmode mem `thenUs` \ amode -> - let - code1 = amodeCode amode - src1 = amodeAddr amode - - code__2 dst = let - code2 = registerCode register2 dst - src2 = registerName register2 dst - in asmParThen [code1 asmVoid,code2 asmVoid] . - mkSeqInstrs [instrr (primRepToSize pk) (OpAddr src1)] - in - returnUs (Any pk code__2) - -trivialFCode pk instr _ _ _ x (StInd pk' mem) - = getRegister x `thenUs` \ register1 -> - --getNewRegNCG (registerRep register1) - -- `thenUs` \ tmp1 -> - getAmode mem `thenUs` \ amode -> +trivialFCode pk instr x y + = getRegister x `thenNat` \ register1 -> + getRegister y `thenNat` \ register2 -> + getNewRegNCG DoubleRep `thenNat` \ tmp1 -> + getNewRegNCG DoubleRep `thenNat` \ tmp2 -> let - code2 = amodeCode amode - src2 = amodeAddr amode + code1 = registerCode register1 tmp1 + src1 = registerName register1 tmp1 - code__2 dst = let - code1 = registerCode register1 dst - src1 = registerName register1 dst - in asmParThen [code2 asmVoid,code1 asmVoid] . - mkSeqInstrs [instr (primRepToSize pk) (OpAddr src2)] - in - returnUs (Any pk code__2) - -trivialFCode pk _ _ _ instrpr x y - = getRegister x `thenUs` \ register1 -> - getRegister y `thenUs` \ register2 -> - --getNewRegNCG (registerRep register1) - -- `thenUs` \ tmp1 -> - --getNewRegNCG (registerRep register2) - -- `thenUs` \ tmp2 -> - getNewRegNCG DoubleRep `thenUs` \ tmp -> - let - pk1 = registerRep register1 - code1 = registerCode register1 st0 --tmp1 - src1 = registerName register1 st0 --tmp1 + code2 = registerCode register2 tmp2 + src2 = registerName register2 tmp2 - pk2 = registerRep register2 + 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 - code__2 dst = let - code2 = registerCode register2 dst - src2 = registerName register2 dst - in asmParThen [code1 asmVoid, code2 asmVoid] . - mkSeqInstr instrpr + -- be paranoid (and inefficient) + | otherwise + = code1 `snocOL` GMOV src1 tmp1 `appOL` + code2 `snocOL` + instr (primRepToSize pk) tmp1 src2 dst in - returnUs (Any pk1 code__2) + returnNat (Any pk code__2) -------------- -trivialUFCode pk instr (StInd pk' mem) - = getAmode mem `thenUs` \ amode -> - let - code = amodeCode amode - src = amodeAddr amode - code__2 dst = code . mkSeqInstrs [FLD (primRepToSize pk) (OpAddr src), - instr] - in - returnUs (Any pk code__2) +------------- trivialUFCode pk instr x - = getRegister x `thenUs` \ register -> - --getNewRegNCG pk `thenUs` \ tmp -> + = getRegister x `thenNat` \ register -> + getNewRegNCG pk `thenNat` \ tmp -> let - code__2 dst = let - code = registerCode register dst - src = registerName register dst - in code . mkSeqInstrs [instr] + code = registerCode register tmp + src = registerName register tmp + code__2 dst = code `snocOL` instr src dst in - returnUs (Any pk code__2) + returnNat (Any pk code__2) #endif {- i386_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -2973,42 +3020,42 @@ 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) + code__2 dst = code `snocOL` 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] . - mkSeqInstr (instr src1 (RIReg src2) dst) + code__2 dst = code1 `appOL` code2 `snocOL` + 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) + promote x = FxTOy F DF x tmp pk1 = registerRep register1 code1 = registerCode register1 tmp1 @@ -3020,38 +3067,38 @@ trivialFCode pk instr x y code__2 dst = if pk1 == pk2 then - asmParThen [code1 asmVoid, code2 asmVoid] . - mkSeqInstr (instr (primRepToSize pk) src1 src2 dst) + code1 `appOL` code2 `snocOL` + instr (primRepToSize pk) src1 src2 dst else if pk1 == FloatRep then - asmParThen [code1 (promote src1), code2 asmVoid] . - mkSeqInstr (instr DF tmp src2 dst) + code1 `snocOL` promote src1 `appOL` code2 `snocOL` + instr DF tmp src2 dst else - asmParThen [code1 asmVoid, code2 (promote src2)] . - mkSeqInstr (instr DF src1 tmp dst) + code1 `appOL` code2 `snocOL` promote src2 `snocOL` + 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) + code__2 dst = code `snocOL` 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) + code__2 dst = code `snocOL` instr src dst in - returnUs (Any pk code__2) + returnNat (Any pk code__2) #endif {- sparc_TARGET_ARCH -} \end{code} @@ -3071,15 +3118,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 @@ -3087,8 +3134,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 @@ -3099,8 +3146,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 @@ -3110,12 +3157,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 @@ -3125,76 +3172,71 @@ 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 - - code__2 dst = code . mkSeqInstrs [ - -- to fix: should spill instead of using R1 - MOV L (OpReg src) (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1))), - FILD (primRepToSize pk) (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1)) dst] + opc = case pk of FloatRep -> GITOF ; DoubleRep -> GITOD + 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 - code__2 dst = code . mkSeqInstrs [ - FRNDINT, - FIST L (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1)), - MOV L (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1))) (OpReg dst)] + opc = case pk of FloatRep -> GFTOI ; DoubleRep -> GDTOI + 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 - code__2 dst = code . mkSeqInstrs [ + code__2 dst = code `appOL` toOL [ ST W src (spRel (-2)), 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 pk = registerRep register - code__2 dst = code . mkSeqInstrs [ + code__2 dst = code `appOL` toOL [ FxTOy (primRepToSize pk) W src tmp, 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} @@ -3209,134 +3251,67 @@ 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 -> - --getNewRegNCG IntRep `thenUs` \ reg -> + = 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 src_off = addrOffset src 3 src__2 = case src_off of Just x -> x code__2 dst = if maybeToBool src_off then - code . mkSeqInstr (LD BU src__2 dst) + code `snocOL` LD BU src__2 dst else - code . mkSeqInstrs [ - LD (primRepToSize pk) src dst, - AND False dst (RIImm (ImmInt 255)) dst] + code `snocOL` + LD (primRepToSize pk) src dst `snocOL` + 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 -> - 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) - -#endif {- sparc_TARGET_ARCH -} -\end{code} - -%************************************************************************ -%* * -\subsubsection{Absolute value on integers} -%* * -%************************************************************************ - -Absolute value on integers, mostly for gmp size check macros. Again, -the argument cannot be an StInt, because genericOpt already folded -constants. - -If applicable, do not fill the delay slots here; you will confuse the -register allocator. - -\begin{code} -absIntCode :: StixTree -> UniqSM Register - -#if alpha_TARGET_ARCH -absIntCode = panic "MachCode.absIntCode: not on Alphas" -#endif {- alpha_TARGET_ARCH -} - --- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -#if i386_TARGET_ARCH - -absIntCode x - = getRegister x `thenUs` \ register -> - --getNewRegNCG IntRep `thenUs` \ reg -> - getUniqLabelNCG `thenUs` \ lbl -> - 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), - TEST L (OpReg dst) (OpReg dst), - JXX GE lbl, - NEGI L (OpReg dst), - LABEL lbl] - else mkSeqInstrs [TEST L (OpReg src) (OpReg src), - JXX GE lbl, - NEGI L (OpReg src), - LABEL lbl] - in - returnUs (Any IntRep code__2) - -#endif {- i386_TARGET_ARCH -} --- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -#if sparc_TARGET_ARCH - -absIntCode x - = getRegister x `thenUs` \ register -> - getNewRegNCG IntRep `thenUs` \ reg -> - getUniqLabelNCG `thenUs` \ lbl -> + = getRegister x `thenNat` \ register -> + getNewRegNCG IntRep `thenNat` \ reg -> let code = registerCode register reg src = registerName register reg - code__2 dst = code . mkSeqInstrs [ - SUB False True g0 (RIReg src) dst, - BI GE False (ImmCLbl lbl), NOP, - OR False g0 (RIReg src) dst, - LABEL lbl] + code__2 dst = code `snocOL` AND False src (RIImm (ImmInt 255)) dst in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) #endif {- sparc_TARGET_ARCH -} \end{code} -