diff options
| -rw-r--r-- | ghc/compiler/nativeGen/AsmCodeGen.lhs | 148 | ||||
| -rw-r--r-- | ghc/compiler/nativeGen/AsmRegAlloc.lhs | 86 | ||||
| -rw-r--r-- | ghc/compiler/nativeGen/MachCode.lhs | 1734 | ||||
| -rw-r--r-- | ghc/compiler/nativeGen/MachMisc.lhs | 17 | ||||
| -rw-r--r-- | ghc/compiler/nativeGen/MachRegs.lhs | 11 | ||||
| -rw-r--r-- | ghc/compiler/nativeGen/NOTES | 41 | ||||
| -rw-r--r-- | ghc/compiler/nativeGen/PprMach.lhs | 54 | ||||
| -rw-r--r-- | ghc/compiler/nativeGen/RegAllocInfo.lhs | 263 | ||||
| -rw-r--r-- | ghc/compiler/nativeGen/Stix.lhs | 211 | ||||
| -rw-r--r-- | ghc/compiler/nativeGen/StixInteger.lhs | 1 | ||||
| -rw-r--r-- | ghc/compiler/nativeGen/StixMacro.lhs | 1 | ||||
| -rw-r--r-- | ghc/compiler/utils/OrdList.lhs | 92 | ||||
| -rw-r--r-- | ghc/includes/Constants.h | 4 |
13 files changed, 1462 insertions, 1201 deletions
diff --git a/ghc/compiler/nativeGen/AsmCodeGen.lhs b/ghc/compiler/nativeGen/AsmCodeGen.lhs index e3a16c3bdd..e82bc8ec3d 100644 --- a/ghc/compiler/nativeGen/AsmCodeGen.lhs +++ b/ghc/compiler/nativeGen/AsmCodeGen.lhs @@ -19,17 +19,20 @@ import PprMach import AbsCStixGen ( genCodeAbstractC ) import AbsCSyn ( AbstractC, MagicId ) import AsmRegAlloc ( runRegAllocate ) -import OrdList ( OrdList, flattenOrdList ) import PrimOp ( commutableOp, PrimOp(..) ) import RegAllocInfo ( mkMRegsState, MRegsState, findReservedRegs ) import Stix ( StixTree(..), StixReg(..), - pprStixTrees, CodeSegment(..) ) + pprStixTrees, ppStixTree, CodeSegment(..), + stixCountTempUses, stixSubst, + NatM, initNat, mapNat, + NatM_State, mkNatM_State, + uniqOfNatM_State, deltaOfNatM_State ) import PrimRep ( isFloatingRep, PrimRep(..) ) import UniqSupply ( returnUs, thenUs, mapUs, initUs, initUs_, UniqSM, UniqSupply ) -import UniqFM ( UniqFM, emptyUFM, addToUFM, lookupUFM ) import MachMisc ( IF_ARCH_i386(i386_insert_ffrees,) ) +import OrdList ( fromOL, concatOL ) import Outputable \end{code} @@ -85,11 +88,11 @@ So, here we go: nativeCodeGen :: AbstractC -> UniqSupply -> (SDoc, SDoc) nativeCodeGen absC us = let (stixRaw, us1) = initUs us (genCodeAbstractC absC) - stixOpt = map (map genericOpt) stixRaw + stixOpt = map genericOpt stixRaw insns = initUs_ us1 (codeGen stixOpt) debug_stix = vcat (map pprStixTrees stixOpt) in - trace "--------- native code generator ---------" + trace "nativeGen: begin" (debug_stix, insns) \end{code} @@ -108,25 +111,49 @@ codeGen stixFinal docs = map (vcat . map pprInstr) static_instrss -- for debugging only - docs_prealloc = map (vcat . map pprInstr . flattenOrdList) + docs_prealloc = map (vcat . map pprInstr . fromOL) dynamic_codes text_prealloc = vcat (intersperse (char ' ' $$ char ' ') docs_prealloc) in -- trace (showSDoc text_prealloc) ( returnUs (vcat (intersperse (char ' ' - $$ text "# ___stg_split_marker" + $$ ptext SLIT("# ___stg_split_marker") $$ char ' ') docs)) -- ) \end{code} -Top level code generator for a chunk of stix code: -\begin{code} -genMachCode :: [StixTree] -> UniqSM InstrList +Top level code generator for a chunk of stix code. For this part of +the computation, we switch from the UniqSM monad to the NatM monad. +The latter carries not only a Unique, but also an Int denoting the +current C stack pointer offset in the generated code; this is needed +for creating correct spill offsets on architectures which don't offer, +or for which it would be prohibitively expensive to employ, a frame +pointer register. Viz, x86. + +The offset is measured in bytes, and indicates the difference between +the current (simulated) C stack-ptr and the value it was at the +beginning of the block. For stacks which grow down, this value should +be either zero or negative. -genMachCode stmts - = mapUs stmt2Instrs stmts `thenUs` \ blocks -> - returnUs (foldr (.) id blocks asmVoid) +Switching between the two monads whilst carrying along the same Unique +supply breaks abstraction. Is that bad? + +\begin{code} +genMachCode :: [StixTree] -> UniqSM InstrBlock + +genMachCode stmts initial_us + = let initial_st = mkNatM_State initial_us 0 + (blocks, final_st) = initNat initial_st + (mapNat stmt2Instrs stmts) + instr_list = concatOL blocks + final_us = uniqOfNatM_State final_st + final_delta = deltaOfNatM_State final_st + in + if final_delta == 0 + then (instr_list, final_us) + else pprPanic "genMachCode: nonzero final delta" + (int final_delta) \end{code} The next bit does the code scheduling. The scheduler must also deal @@ -135,7 +162,7 @@ exposed via the OrdList, but more might occur, so further analysis might be needed. \begin{code} -scheduleMachCode :: [InstrList] -> [[Instr]] +scheduleMachCode :: [InstrBlock] -> [[Instr]] scheduleMachCode = map (runRegAllocate freeRegsState findReservedRegs) @@ -160,71 +187,95 @@ have introduced some new opportunities for constant-folding wrt address manipulations. \begin{code} -genericOpt :: StixTree -> StixTree +genericOpt :: [StixTree] -> [StixTree] +genericOpt = map stixConFold . stixPeep + + + +stixPeep :: [StixTree] -> [StixTree] + +-- This transformation assumes that the temp assigned to in t1 +-- is not assigned to in t2; for otherwise the target of the +-- second assignment would be substituted for, giving nonsense +-- code. As far as I can see, StixTemps are only ever assigned +-- to once. It would be nice to be sure! +stixPeep ( t1@(StAssign pka (StReg (StixTemp u pk)) rhs) + : t2 + : ts ) + | stixCountTempUses u t2 == 1 + && sum (map (stixCountTempUses u) ts) == 0 + = trace ("nativeGen: stixInline: " ++ showSDoc (ppStixTree rhs)) + (stixPeep (stixSubst u rhs t2 : ts)) + +stixPeep (t1:t2:ts) = t1 : stixPeep (t2:ts) +stixPeep [t1] = [t1] +stixPeep [] = [] \end{code} For most nodes, just optimize the children. \begin{code} -genericOpt (StInd pk addr) = StInd pk (genericOpt addr) +stixConFold :: StixTree -> StixTree -genericOpt (StAssign pk dst src) - = StAssign pk (genericOpt dst) (genericOpt src) +stixConFold (StInd pk addr) = StInd pk (stixConFold addr) -genericOpt (StJump addr) = StJump (genericOpt addr) +stixConFold (StAssign pk dst src) + = StAssign pk (stixConFold dst) (stixConFold src) -genericOpt (StCondJump addr test) - = StCondJump addr (genericOpt test) +stixConFold (StJump addr) = StJump (stixConFold addr) -genericOpt (StCall fn cconv pk args) - = StCall fn cconv pk (map genericOpt args) +stixConFold (StCondJump addr test) + = StCondJump addr (stixConFold test) + +stixConFold (StCall fn cconv pk args) + = StCall fn cconv pk (map stixConFold args) \end{code} Fold indices together when the types match: \begin{code} -genericOpt (StIndex pk (StIndex pk' base off) off') +stixConFold (StIndex pk (StIndex pk' base off) off') | pk == pk' - = StIndex pk (genericOpt base) - (genericOpt (StPrim IntAddOp [off, off'])) + = StIndex pk (stixConFold base) + (stixConFold (StPrim IntAddOp [off, off'])) -genericOpt (StIndex pk base off) - = StIndex pk (genericOpt base) (genericOpt off) +stixConFold (StIndex pk base off) + = StIndex pk (stixConFold base) (stixConFold off) \end{code} For PrimOps, we first optimize the children, and then we try our hand at some constant-folding. \begin{code} -genericOpt (StPrim op args) = primOpt op (map genericOpt args) +stixConFold (StPrim op args) = stixPrimFold op (map stixConFold args) \end{code} Replace register leaves with appropriate StixTrees for the given target. \begin{code} -genericOpt leaf@(StReg (StixMagicId id)) +stixConFold leaf@(StReg (StixMagicId id)) = case (stgReg id) of - Always tree -> genericOpt tree + Always tree -> stixConFold tree Save _ -> leaf -genericOpt other = other +stixConFold other = other \end{code} Now, try to constant-fold the PrimOps. The arguments have already been optimized and folded. \begin{code} -primOpt +stixPrimFold :: PrimOp -- The operation from an StPrim -> [StixTree] -- The optimized arguments -> StixTree -primOpt op arg@[StInt x] +stixPrimFold op arg@[StInt x] = case op of IntNegOp -> StInt (-x) _ -> StPrim op arg -primOpt op args@[StInt x, StInt y] +stixPrimFold op args@[StInt x, StInt y] = case op of CharGtOp -> StInt (if x > y then 1 else 0) CharGeOp -> StInt (if x >= y then 1 else 0) @@ -253,13 +304,13 @@ also assume that constants have been shifted to the right when possible. \begin{code} -primOpt op [x@(StInt _), y] | commutableOp op = primOpt op [y, x] +stixPrimFold op [x@(StInt _), y] | commutableOp op = stixPrimFold op [y, x] \end{code} We can often do something with constants of 0 and 1 ... \begin{code} -primOpt op args@[x, y@(StInt 0)] +stixPrimFold op args@[x, y@(StInt 0)] = case op of IntAddOp -> x IntSubOp -> x @@ -272,9 +323,15 @@ primOpt op args@[x, y@(StInt 0)] ISllOp -> x ISraOp -> x ISrlOp -> x + IntNeOp | is_comparison -> x _ -> StPrim op args + where + is_comparison + = case x of + StPrim opp [_, _] -> opp `elem` comparison_ops + _ -> False -primOpt op args@[x, y@(StInt 1)] +stixPrimFold op args@[x, y@(StInt 1)] = case op of IntMulOp -> x IntQuotOp -> x @@ -285,7 +342,7 @@ primOpt op args@[x, y@(StInt 1)] Now look for multiplication/division by powers of 2 (integers). \begin{code} -primOpt op args@[x, y@(StInt n)] +stixPrimFold op args@[x, y@(StInt n)] = case op of IntMulOp -> case exactLog2 n of Nothing -> StPrim op args @@ -299,5 +356,16 @@ primOpt op args@[x, y@(StInt n)] Anything else is just too hard. \begin{code} -primOpt op args = StPrim op args +stixPrimFold op args = StPrim op args \end{code} + +\begin{code} +comparison_ops + = [ CharGtOp , CharGeOp , CharEqOp , CharNeOp , CharLtOp , CharLeOp, + IntGtOp , IntGeOp , IntEqOp , IntNeOp , IntLtOp , IntLeOp, + WordGtOp , WordGeOp , WordEqOp , WordNeOp , WordLtOp , WordLeOp, + AddrGtOp , AddrGeOp , AddrEqOp , AddrNeOp , AddrLtOp , AddrLeOp, + FloatGtOp , FloatGeOp , FloatEqOp , FloatNeOp , FloatLtOp , FloatLeOp, + DoubleGtOp, DoubleGeOp, DoubleEqOp, DoubleNeOp, DoubleLtOp, DoubleLeOp + ] +\end{code}
\ No newline at end of file diff --git a/ghc/compiler/nativeGen/AsmRegAlloc.lhs b/ghc/compiler/nativeGen/AsmRegAlloc.lhs index 2412173988..53f1140ac0 100644 --- a/ghc/compiler/nativeGen/AsmRegAlloc.lhs +++ b/ghc/compiler/nativeGen/AsmRegAlloc.lhs @@ -8,20 +8,20 @@ module AsmRegAlloc ( runRegAllocate, runHairyRegAllocate ) where #include "HsVersions.h" -import MachCode ( InstrList ) -import MachMisc ( Instr ) +import MachCode ( InstrBlock ) +import MachMisc ( Instr(..) ) import PprMach ( pprUserReg ) -- debugging import MachRegs import RegAllocInfo -import FiniteMap ( emptyFM, addListToFM, delListFromFM, lookupFM, keysFM ) +import FiniteMap ( emptyFM, addListToFM, delListFromFM, + lookupFM, keysFM ) import Maybes ( maybeToBool ) -import OrdList ( mkEmptyList, mkUnitList, mkSeqList, mkParList, - flattenOrdList, OrdList - ) import Unique ( mkBuiltinUnique ) import Util ( mapAccumB ) +import OrdList ( unitOL, appOL, fromOL, concatOL ) import Outputable +import List ( mapAccumL ) \end{code} This is the generic register allocator. @@ -33,7 +33,7 @@ things the hard way. runRegAllocate :: MRegsState -> ([Instr] -> [[RegNo]]) - -> InstrList + -> InstrBlock -> [Instr] runRegAllocate regs find_reserve_regs instrs @@ -49,21 +49,21 @@ runRegAllocate regs find_reserve_regs instrs Nothing -> tryHairy resvs reserves = find_reserve_regs flatInstrs - flatInstrs = flattenOrdList instrs - simpleAlloc = simpleRegAlloc regs [] emptyFM flatInstrs + flatInstrs = fromOL instrs + simpleAlloc = simpleRegAlloc regs [] emptyFM flatInstrs hairyAlloc resvd = hairyRegAlloc regs resvd flatInstrs runHairyRegAllocate :: MRegsState -> [RegNo] - -> InstrList + -> InstrBlock -> Maybe [Instr] runHairyRegAllocate regs reserve_regs instrs = hairyRegAlloc regs reserve_regs flatInstrs where - flatInstrs = flattenOrdList instrs + flatInstrs = fromOL instrs \end{code} Here is the simple register allocator. Just dole out registers until @@ -157,8 +157,7 @@ hairyRegAlloc regs reserve_regs instrs = | null reserve_regs -> Nothing -- failed, but we have reserves, so attempt to do spilling | otherwise - -> let instrs_patched' = patchMem instrs' - instrs_patched = flattenOrdList instrs_patched' + -> let instrs_patched = patchMem instrs' in case mapAccumB (doRegAlloc []) (RH regs'' mloc1 emptyFM) noFuture instrs_patched of @@ -185,30 +184,47 @@ hairyRegAlloc regs reserve_regs instrs = toMappedReg (I# i) = MappedReg i \end{code} -Here we patch instructions that reference ``registers'' which are really in -memory somewhere (the mapping is under the control of the machine-specific -code generator). We place the appropriate load sequences before any instructions -that use memory registers as sources, and we place the appropriate spill sequences -after any instructions that use memory registers as destinations. The offending -instructions are rewritten with new dynamic registers, so we have to run register -allocation again after all of this is said and done. +Here we patch instructions that reference ``registers'' which are +really in memory somewhere (the mapping is under the control of the +machine-specific code generator). We place the appropriate load +sequences before any instructions that use memory registers as +sources, and we place the appropriate spill sequences after any +instructions that use memory registers as destinations. The offending +instructions are rewritten with new dynamic registers, so we have to +run register allocation again after all of this is said and done. + +On some architectures (x86, currently), we do without a frame-pointer, +and instead spill relative to the stack pointer (%esp on x86). +Because the stack pointer may move, the patcher needs to keep track of +the current stack pointer "delta". That's easy, because all it needs +to do is spot the DELTA bogus-insns which will have been inserted by +the relevant insn selector precisely so as to notify the spiller of +stack-pointer movement. The delta is passed to loadReg and spillReg, +since they generate the actual spill code. We expect the final delta +to be the same as the starting one (zero), reflecting the fact that +changes to the stack pointer should not extend beyond a basic block. \begin{code} -patchMem :: [Instr] -> InstrList +patchMem :: [Instr] -> [Instr] +patchMem cs + = let (final_stack_delta, css) = mapAccumL patchMem' 0 cs + in + if final_stack_delta == 0 + then concat css + else pprPanic "patchMem: non-zero final delta" + (int final_stack_delta) -patchMem cs = foldr (mkSeqList . patchMem') mkEmptyList cs +patchMem' :: Int -> Instr -> (Int, [Instr]) +patchMem' delta instr -patchMem' :: Instr -> InstrList + | null memSrcs && null memDsts + = (delta', [instr]) -patchMem' instr - | null memSrcs && null memDsts = mkUnitList instr - | otherwise = - mkSeqList - (foldr mkParList mkEmptyList loadSrcs) - (mkSeqList instr' - (foldr mkParList mkEmptyList spillDsts)) + | otherwise + = (delta', loadSrcs ++ [instr'] ++ spillDsts) + where + delta' = case instr of DELTA d -> d ; _ -> delta - where (RU srcs dsts) = regUsage instr memToDyn (MemoryReg i pk) = UnmappedReg (mkBuiltinUnique i) pk @@ -217,13 +233,13 @@ patchMem' instr memSrcs = [ r | r@(MemoryReg _ _) <- regSetToList srcs] memDsts = [ r | r@(MemoryReg _ _) <- regSetToList dsts] - loadSrcs = map load memSrcs + loadSrcs = map load memSrcs spillDsts = map spill memDsts - load mem = loadReg mem (memToDyn mem) - spill mem = spillReg (memToDyn mem) mem + load mem = loadReg delta mem (memToDyn mem) + spill mem = spillReg delta' (memToDyn mem) mem - instr' = mkUnitList (patchRegs instr memToDyn) + instr' = patchRegs instr memToDyn \end{code} \begin{code} diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs index 820b5aeb36..12d4dbe452 100644 --- a/ghc/compiler/nativeGen/MachCode.lhs +++ b/ghc/compiler/nativeGen/MachCode.lhs @@ -9,45 +9,61 @@ This is a big module, but, if you pay attention to structure should not be too overwhelming. \begin{code} -module MachCode ( stmt2Instrs, asmVoid, InstrList ) where +module MachCode ( stmt2Instrs, InstrBlock ) where #include "HsVersions.h" #include "nativeGen/NCG.h" import MachMisc -- may differ per-platform import MachRegs - +import OrdList ( OrdList, nilOL, isNilOL, unitOL, appOL, toOL, + snocOL, consOL, concatOL ) import AbsCSyn ( MagicId ) import AbsCUtils ( magicIdPrimRep ) import CallConv ( CallConv ) import CLabel ( isAsmTemp, CLabel, pprCLabel_asm ) import Maybes ( maybeToBool, expectJust ) -import OrdList -- quite a bit of it import PrimRep ( isFloatingRep, PrimRep(..) ) import PrimOp ( PrimOp(..) ) import CallConv ( cCallConv ) -import Stix ( getUniqLabelNCG, StixTree(..), +import Stix ( getNatLabelNCG, StixTree(..), StixReg(..), CodeSegment(..), - pprStixTrees, ppStixReg - ) -import UniqSupply ( returnUs, thenUs, mapUs, mapAndUnzipUs, - mapAccumLUs, UniqSM + pprStixTrees, ppStixReg, + NatM, thenNat, returnNat, mapNat, mapAndUnzipNat, + getDeltaNat, setDeltaNat ) import Outputable + +\end{code} + +@InstrBlock@s are the insn sequences generated by the insn selectors. +They are really trees of insns to facilitate fast appending, where a +left-to-right traversal (pre-order?) yields the insns in the correct +order. + +\begin{code} + +type InstrBlock = OrdList Instr + +infixr 3 `bind` +x `bind` f = f x + \end{code} Code extractor for an entire stix tree---stix statement level. \begin{code} -stmt2Instrs :: StixTree {- a stix statement -} -> UniqSM InstrBlock +stmt2Instrs :: StixTree {- a stix statement -} -> NatM InstrBlock stmt2Instrs stmt = case stmt of - StComment s -> returnInstr (COMMENT s) - StSegment seg -> returnInstr (SEGMENT seg) + StComment s -> returnNat (unitOL (COMMENT s)) + StSegment seg -> returnNat (unitOL (SEGMENT seg)) - StFunBegin lab -> returnInstr (IF_ARCH_alpha(FUNBEGIN lab,LABEL lab)) - StFunEnd lab -> IF_ARCH_alpha(returnInstr (FUNEND lab),returnUs id) - StLabel lab -> returnInstr (LABEL lab) + StFunBegin lab -> returnNat (unitOL (IF_ARCH_alpha(FUNBEGIN lab, + LABEL lab))) + StFunEnd lab -> IF_ARCH_alpha(returnNat (unitOL (FUNEND lab)), + returnNat nilOL) + StLabel lab -> returnNat (unitOL (LABEL lab)) StJump arg -> genJump arg StCondJump lab arg -> genCondJump lab arg @@ -61,27 +77,28 @@ stmt2Instrs stmt = case stmt of -- When falling through on the Alpha, we still have to load pv -- with the address of the next routine, so that it can load gp. -> IF_ARCH_alpha(returnInstr (LDA pv (AddrImm (ImmCLbl lbl))) - ,returnUs id) + ,returnNat nilOL) StData kind args - -> mapAndUnzipUs getData args `thenUs` \ (codes, imms) -> - returnUs (\xs -> mkSeqList (asmInstr (DATA (primRepToSize kind) imms)) - (foldr (.) id codes xs)) + -> mapAndUnzipNat getData args `thenNat` \ (codes, imms) -> + returnNat (DATA (primRepToSize kind) imms + `consOL` concatOL codes) where - getData :: StixTree -> UniqSM (InstrBlock, Imm) + getData :: StixTree -> NatM (InstrBlock, Imm) - getData (StInt i) = returnUs (id, ImmInteger i) - getData (StDouble d) = returnUs (id, ImmDouble d) - getData (StLitLbl s) = returnUs (id, ImmLab s) - getData (StCLbl l) = returnUs (id, ImmCLbl l) + getData (StInt i) = returnNat (nilOL, ImmInteger i) + getData (StDouble d) = returnNat (nilOL, ImmDouble d) + getData (StLitLbl s) = returnNat (nilOL, ImmLab s) + getData (StCLbl l) = returnNat (nilOL, ImmCLbl l) getData (StString s) = - getUniqLabelNCG `thenUs` \ lbl -> - returnUs (mkSeqInstrs [LABEL lbl, - ASCII True (_UNPK_ s)], - ImmCLbl lbl) + getNatLabelNCG `thenNat` \ lbl -> + returnNat (toOL [LABEL lbl, + ASCII True (_UNPK_ s)], + ImmCLbl lbl) -- the linker can handle simple arithmetic... getData (StIndex rep (StCLbl lbl) (StInt off)) = - returnUs (id, ImmIndex lbl (fromInteger (off * sizeOf rep))) + returnNat (nilOL, + ImmIndex lbl (fromInteger (off * sizeOf rep))) \end{code} %************************************************************************ @@ -91,38 +108,6 @@ stmt2Instrs stmt = case stmt of %************************************************************************ \begin{code} -type InstrList = OrdList Instr -type InstrBlock = InstrList -> InstrList - -asmVoid :: InstrList -asmVoid = mkEmptyList - -asmInstr :: Instr -> InstrList -asmInstr i = mkUnitList i - -asmSeq :: [Instr] -> InstrList -asmSeq is = foldr (mkSeqList . asmInstr) asmVoid is - -asmParThen :: [InstrList] -> InstrBlock -asmParThen others code = mkSeqList (foldr mkParList mkEmptyList others) code - -returnInstr :: Instr -> UniqSM InstrBlock -returnInstr instr = returnUs (\xs -> mkSeqList (asmInstr instr) xs) - -returnInstrs :: [Instr] -> UniqSM InstrBlock -returnInstrs instrs = returnUs (\xs -> mkSeqList (asmSeq instrs) xs) - -returnSeq :: InstrBlock -> [Instr] -> UniqSM InstrBlock -returnSeq code instrs = returnUs (\xs -> code (mkSeqList (asmSeq instrs) xs)) - -mkSeqInstr :: Instr -> InstrBlock -mkSeqInstr instr code = mkSeqList (asmInstr instr) code - -mkSeqInstrs :: [Instr] -> InstrBlock -mkSeqInstrs instrs code = mkSeqList (asmSeq instrs) code -\end{code} - -\begin{code} mangleIndexTree :: StixTree -> StixTree mangleIndexTree (StIndex pk base (StInt i)) @@ -184,6 +169,9 @@ registerCode (Any _ code) reg = code reg registerCodeF (Fixed _ _ code) = code registerCodeF (Any _ _) = pprPanic "registerCodeF" empty +registerCodeA (Any _ code) = code +registerCodeA (Fixed _ _ _) = pprPanic "registerCodeA" empty + registerName :: Register -> Reg -> Reg registerName (Fixed _ reg _) _ = reg registerName (Any _ _) reg = reg @@ -195,41 +183,49 @@ registerRep :: Register -> PrimRep registerRep (Fixed pk _ _) = pk registerRep (Any pk _) = pk -isFixed, isFloat :: Register -> Bool +{-# INLINE registerCode #-} +{-# INLINE registerCodeF #-} +{-# INLINE registerName #-} +{-# INLINE registerNameF #-} +{-# INLINE registerRep #-} +{-# INLINE isFixed #-} +{-# INLINE isAny #-} + +isFixed, isAny :: Register -> Bool isFixed (Fixed _ _ _) = True isFixed (Any _ _) = False -isFloat = not . isFixed +isAny = not . isFixed \end{code} Generate code to get a subtree into a @Register@: \begin{code} -getRegister :: StixTree -> UniqSM Register +getRegister :: StixTree -> NatM Register getRegister (StReg (StixMagicId stgreg)) = case (magicIdRegMaybe stgreg) of - Just reg -> returnUs (Fixed (magicIdPrimRep stgreg) reg id) + Just reg -> returnNat (Fixed (magicIdPrimRep stgreg) reg nilOL) -- cannae be Nothing getRegister (StReg (StixTemp u pk)) - = returnUs (Fixed pk (UnmappedReg u pk) id) + = returnNat (Fixed pk (UnmappedReg u pk) nilOL) getRegister tree@(StIndex _ _ _) = getRegister (mangleIndexTree tree) getRegister (StCall fn cconv kind args) - = genCCall fn cconv kind args `thenUs` \ call -> - returnUs (Fixed kind reg call) + = genCCall fn cconv kind args `thenNat` \ call -> + returnNat (Fixed kind reg call) where reg = if isFloatingRep kind then IF_ARCH_alpha( f0, IF_ARCH_i386( fake0, IF_ARCH_sparc( f0,))) else IF_ARCH_alpha( v0, IF_ARCH_i386( eax, IF_ARCH_sparc( o0,))) getRegister (StString s) - = getUniqLabelNCG `thenUs` \ lbl -> + = getNatLabelNCG `thenNat` \ lbl -> let imm_lbl = ImmCLbl lbl - code dst = mkSeqInstrs [ + code dst = toOL [ SEGMENT DataSegment, LABEL lbl, ASCII True (_UNPK_ s), @@ -246,7 +242,7 @@ getRegister (StString s) #endif ] in - returnUs (Any PtrRep code) + returnNat (Any PtrRep code) @@ -255,8 +251,8 @@ getRegister (StString s) #if alpha_TARGET_ARCH getRegister (StDouble d) - = getUniqLabelNCG `thenUs` \ lbl -> - getNewRegNCG PtrRep `thenUs` \ tmp -> + = getNatLabelNCG `thenNat` \ lbl -> + getNewRegNCG PtrRep `thenNat` \ tmp -> let code dst = mkSeqInstrs [ SEGMENT DataSegment, LABEL lbl, @@ -265,7 +261,7 @@ getRegister (StDouble d) LDA tmp (AddrImm (ImmCLbl lbl)), LD TF dst (AddrReg tmp)] in - returnUs (Any DoubleRep code) + returnNat (Any DoubleRep code) getRegister (StPrim primop [x]) -- unary PrimOps = case primop of @@ -401,17 +397,17 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps any kind leave the result in a floating point register, so we need to wrangle an integer register out of things. -} - int_NE_code :: StixTree -> StixTree -> UniqSM Register + int_NE_code :: StixTree -> StixTree -> NatM Register int_NE_code x y - = trivialCode (CMP EQQ) x y `thenUs` \ register -> - getNewRegNCG IntRep `thenUs` \ tmp -> + = trivialCode (CMP EQQ) x y `thenNat` \ register -> + getNewRegNCG IntRep `thenNat` \ tmp -> let code = registerCode register tmp src = registerName register tmp code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst) in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) {- ------------------------------------------------------------ Comments for int_NE_code also apply to cmpF_code @@ -420,12 +416,12 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps :: (Reg -> Reg -> Reg -> Instr) -> Cond -> StixTree -> StixTree - -> UniqSM Register + -> NatM Register cmpF_code instr cond x y - = trivialFCode pr instr x y `thenUs` \ register -> - getNewRegNCG DoubleRep `thenUs` \ tmp -> - getUniqLabelNCG `thenUs` \ lbl -> + = trivialFCode pr instr x y `thenNat` \ register -> + getNewRegNCG DoubleRep `thenNat` \ tmp -> + getNatLabelNCG `thenNat` \ lbl -> let code = registerCode register tmp result = registerName register tmp @@ -436,32 +432,32 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps OR zeroh (RIReg zeroh) dst, LABEL lbl] in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) where pr = panic "trivialU?FCode: does not use PrimRep on Alpha" ------------------------------------------------------------ getRegister (StInd pk mem) - = getAmode mem `thenUs` \ amode -> + = getAmode mem `thenNat` \ amode -> let code = amodeCode amode src = amodeAddr amode size = primRepToSize pk code__2 dst = code . mkSeqInstr (LD size dst src) in - returnUs (Any pk code__2) + returnNat (Any pk code__2) getRegister (StInt i) | fits8Bits i = let code dst = mkSeqInstr (OR zeroh (RIImm src) dst) in - returnUs (Any IntRep code) + returnNat (Any IntRep code) | otherwise = let code dst = mkSeqInstr (LDI Q dst src) in - returnUs (Any IntRep code) + returnNat (Any IntRep code) where src = ImmInt (fromInteger i) @@ -470,7 +466,7 @@ getRegister leaf = let code dst = mkSeqInstr (LDA dst (AddrImm imm__2)) in - returnUs (Any PtrRep code) + returnNat (Any PtrRep code) where imm = maybeImm leaf imm__2 = case imm of Just x -> x @@ -480,8 +476,20 @@ getRegister leaf #if i386_TARGET_ARCH getRegister (StDouble d) - = getUniqLabelNCG `thenUs` \ lbl -> - let code dst = mkSeqInstrs [ + + | d == 0.0 + = let code dst = unitOL (GLDZ dst) + in trace "nativeGen: GLDZ" + (returnNat (Any DoubleRep code)) + + | d == 1.0 + = let code dst = unitOL (GLD1 dst) + in trace "nativeGen: GLD1" + returnNat (Any DoubleRep code) + + | otherwise + = getNatLabelNCG `thenNat` \ lbl -> + let code dst = toOL [ SEGMENT DataSegment, LABEL lbl, DATA DF [ImmDouble d], @@ -489,13 +497,18 @@ getRegister (StDouble d) GLD DF (ImmAddr (ImmCLbl lbl) 0) dst ] in - returnUs (Any DoubleRep code) + returnNat (Any DoubleRep code) --- incorrectly assumes that %esp doesn't move (as does spilling); ToDo: fix +-- Calculate the offset for (i+1) words above the _initial_ +-- %esp value by first determining the current offset of it. getRegister (StScratchWord i) | i >= 0 && i < 6 - = let code dst = mkSeqInstr (LEA L (OpAddr (spRel (i+1))) (OpReg dst)) - in returnUs (Any PtrRep code) + = getDeltaNat `thenNat` \ current_stack_offset -> + let j = i+1 - (current_stack_offset `div` 4) + code dst + = unitOL (LEA L (OpAddr (spRel (j+1))) (OpReg dst)) + in + returnNat (Any PtrRep code) getRegister (StPrim primop [x]) -- unary PrimOps = case primop of @@ -541,10 +554,6 @@ getRegister (StPrim primop [x]) -- unary PrimOps FloatExpOp -> (True, SLIT("exp")) FloatLogOp -> (True, SLIT("log")) - --FloatSinOp -> (True, SLIT("sin")) - --FloatCosOp -> (True, SLIT("cos")) - --FloatTanOp -> (True, SLIT("tan")) - FloatAsinOp -> (True, SLIT("asin")) FloatAcosOp -> (True, SLIT("acos")) FloatAtanOp -> (True, SLIT("atan")) @@ -556,10 +565,6 @@ getRegister (StPrim primop [x]) -- unary PrimOps DoubleExpOp -> (False, SLIT("exp")) DoubleLogOp -> (False, SLIT("log")) - --DoubleSinOp -> (False, SLIT("sin")) - --DoubleCosOp -> (False, SLIT("cos")) - --DoubleTanOp -> (False, SLIT("tan")) - DoubleAsinOp -> (False, SLIT("asin")) DoubleAcosOp -> (False, SLIT("acos")) DoubleAtanOp -> (False, SLIT("atan")) @@ -661,25 +666,25 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps shift_code :: (Imm -> Operand -> Instr) -> StixTree -> StixTree - -> UniqSM Register + -> NatM Register {- Case1: shift length as immediate -} -- Code is the same as the first eq. for trivialCode -- sigh. shift_code instr x y{-amount-} | maybeToBool imm - = getRegister x `thenUs` \ regx -> + = getRegister x `thenNat` \ regx -> let mkcode dst - = if isFloat regx - then registerCode regx dst `bind` \ code_x -> - code_x . - mkSeqInstr (instr imm__2 (OpReg dst)) + = if isAny regx + then registerCodeA regx dst `bind` \ code_x -> + code_x `snocOL` + instr imm__2 (OpReg dst) else registerCodeF regx `bind` \ code_x -> registerNameF regx `bind` \ r_x -> - code_x . - mkSeqInstr (MOV L (OpReg r_x) (OpReg dst)) . - mkSeqInstr (instr imm__2 (OpReg dst)) + code_x `snocOL` + MOV L (OpReg r_x) (OpReg dst) `snocOL` + instr imm__2 (OpReg dst) in - returnUs (Any IntRep mkcode) + returnNat (Any IntRep mkcode) where imm = maybeImm y imm__2 = case imm of Just x -> x @@ -689,17 +694,17 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps -- use it here to do non-immediate shifts. No big deal -- -- they are only very rare, and we can use an equivalent -- test-and-jump sequence which doesn't use ECX. - -- DO NOT USE REPLACE THIS CODE WITH THE "OBVIOUS" shl/shr/sar CODE, + -- DO NOT REPLACE THIS CODE WITH THE "OBVIOUS" shl/shr/sar CODE, -- SINCE IT WILL CAUSE SERIOUS PROBLEMS WITH THE SPILLER shift_code instr x y{-amount-} - = getRegister x `thenUs` \ register1 -> - getRegister y `thenUs` \ register2 -> - getUniqLabelNCG `thenUs` \ lbl_test3 -> - getUniqLabelNCG `thenUs` \ lbl_test2 -> - getUniqLabelNCG `thenUs` \ lbl_test1 -> - getUniqLabelNCG `thenUs` \ lbl_test0 -> - getUniqLabelNCG `thenUs` \ lbl_after -> - getNewRegNCG IntRep `thenUs` \ tmp -> + = getRegister x `thenNat` \ register1 -> + getRegister y `thenNat` \ register2 -> + getNatLabelNCG `thenNat` \ lbl_test3 -> + getNatLabelNCG `thenNat` \ lbl_test2 -> + getNatLabelNCG `thenNat` \ lbl_test1 -> + getNatLabelNCG `thenNat` \ lbl_test0 -> + getNatLabelNCG `thenNat` \ lbl_after -> + getNewRegNCG IntRep `thenNat` \ tmp -> let code__2 dst = let src_val = registerName register1 dst code_val = registerCode register1 dst @@ -708,11 +713,11 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps r_dst = OpReg dst r_tmp = OpReg tmp in - code_amt . - mkSeqInstr (MOV L (OpReg src_amt) r_tmp) . - code_val . - mkSeqInstr (MOV L (OpReg src_val) r_dst) . - mkSeqInstrs [ + code_amt `snocOL` + MOV L (OpReg src_amt) r_tmp `appOL` + code_val `snocOL` + MOV L (OpReg src_val) r_dst `appOL` + toOL [ COMMENT (_PK_ "begin shift sequence"), MOV L (OpReg src_val) r_dst, MOV L (OpReg src_amt) r_tmp, @@ -745,59 +750,43 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps COMMENT (_PK_ "end shift sequence") ] in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) -------------------- - add_code :: Size -> StixTree -> StixTree -> UniqSM Register + add_code :: Size -> StixTree -> StixTree -> NatM Register add_code sz x (StInt y) - = getRegister x `thenUs` \ register -> - getNewRegNCG IntRep `thenUs` \ tmp -> + = getRegister x `thenNat` \ register -> + getNewRegNCG IntRep `thenNat` \ tmp -> let code = registerCode register tmp src1 = registerName register tmp src2 = ImmInt (fromInteger y) code__2 dst - = code . - mkSeqInstr (LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2)) - (OpReg dst)) + = code `snocOL` + LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2)) + (OpReg dst) in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) - add_code sz x y - = getRegister x `thenUs` \ register1 -> - getRegister y `thenUs` \ register2 -> - getNewRegNCG IntRep `thenUs` \ tmp1 -> - getNewRegNCG IntRep `thenUs` \ tmp2 -> - let - code1 = registerCode register1 tmp1 asmVoid - src1 = registerName register1 tmp1 - code2 = registerCode register2 tmp2 asmVoid - src2 = registerName register2 tmp2 - code__2 dst - = asmParThen [code1, code2] . - mkSeqInstr (LEA sz (OpAddr (AddrBaseIndex (Just src1) (Just (src2,1)) - (ImmInt 0))) - (OpReg dst)) - in - returnUs (Any IntRep code__2) + add_code sz x y = trivialCode (ADD sz) (Just (ADD sz)) x y -------------------- - sub_code :: Size -> StixTree -> StixTree -> UniqSM Register + sub_code :: Size -> StixTree -> StixTree -> NatM Register sub_code sz x (StInt y) - = getRegister x `thenUs` \ register -> - getNewRegNCG IntRep `thenUs` \ tmp -> + = getRegister x `thenNat` \ register -> + getNewRegNCG IntRep `thenNat` \ tmp -> let code = registerCode register tmp src1 = registerName register tmp src2 = ImmInt (-(fromInteger y)) code__2 dst - = code . - mkSeqInstr (LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2)) - (OpReg dst)) + = code `snocOL` + LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2)) + (OpReg dst) in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) sub_code sz x y = trivialCode (SUB sz) Nothing x y @@ -806,106 +795,68 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps :: Size -> StixTree -> StixTree -> Bool -- True => division, False => remainder operation - -> UniqSM Register + -> NatM Register -- x must go into eax, edx must be a sign-extension of eax, and y -- should go in some other register (or memory), so that we get - -- edx:eax / reg -> eax (remainder in edx) Currently we chose to - -- put y in memory (if it is not there already) - - -- quot_code needs further checking in the Rules-of-the-Game(x86) audit - quot_code sz x (StInd pk mem) is_division - = getRegister x `thenUs` \ register1 -> - getNewRegNCG IntRep `thenUs` \ tmp1 -> - getAmode mem `thenUs` \ amode -> - let - code1 = registerCode register1 tmp1 asmVoid - src1 = registerName register1 tmp1 - code2 = amodeCode amode asmVoid - src2 = amodeAddr amode - code__2 = asmParThen [code1, code2] . - mkSeqInstrs [MOV L (OpReg src1) (OpReg eax), - CLTD, - IDIV sz (OpAddr src2)] - in - returnUs (Fixed IntRep (if is_division then eax else edx) code__2) - - quot_code sz x (StInt i) is_division - = getRegister x `thenUs` \ register1 -> - getNewRegNCG IntRep `thenUs` \ tmp1 -> - let - code1 = registerCode register1 tmp1 asmVoid - src1 = registerName register1 tmp1 - src2 = ImmInt (fromInteger i) - code__2 = asmParThen [code1] . - mkSeqInstrs [-- we put src2 in (ebx) - MOV L (OpImm src2) - (OpAddr (AddrBaseIndex (Just ebx) Nothing - (ImmInt OFFSET_R1))), - MOV L (OpReg src1) (OpReg eax), - CLTD, - IDIV sz (OpAddr (AddrBaseIndex (Just ebx) Nothing - (ImmInt OFFSET_R1))) - ] - in - returnUs (Fixed IntRep (if is_division then eax else edx) code__2) + -- edx:eax / reg -> eax (remainder in edx). Currently we choose + -- to put y on the C stack, since that avoids tying up yet another + -- precious register. quot_code sz x y is_division - = getRegister x `thenUs` \ register1 -> - getNewRegNCG IntRep `thenUs` \ tmp1 -> - getRegister y `thenUs` \ register2 -> - getNewRegNCG IntRep `thenUs` \ tmp2 -> + = getRegister x `thenNat` \ register1 -> + getRegister y `thenNat` \ register2 -> + getNewRegNCG IntRep `thenNat` \ tmp -> + getDeltaNat `thenNat` \ delta -> let - code1 = registerCode register1 tmp1 asmVoid - src1 = registerName register1 tmp1 - code2 = registerCode register2 tmp2 asmVoid - src2 = registerName register2 tmp2 - code__2 = asmParThen [code1, code2] . - if src2 == ecx || src2 == esi - then mkSeqInstrs [ - MOV L (OpReg src1) (OpReg eax), - CLTD, - IDIV sz (OpReg src2) - ] - else mkSeqInstrs [ -- we put src2 in (ebx) - MOV L (OpReg src2) - (OpAddr (AddrBaseIndex (Just ebx) Nothing - (ImmInt OFFSET_R1))), - MOV L (OpReg src1) (OpReg eax), - CLTD, - IDIV sz (OpAddr (AddrBaseIndex (Just ebx) Nothing - (ImmInt OFFSET_R1))) - ] + code1 = registerCode register1 tmp + src1 = registerName register1 tmp + code2 = registerCode register2 tmp + src2 = registerName register2 tmp + code__2 = code2 `snocOL` -- src2 := y + PUSH L (OpReg src2) `snocOL` -- -4(%esp) := y + DELTA (delta-4) `appOL` + code1 `snocOL` -- src1 := x + MOV L (OpReg src1) (OpReg eax) `snocOL` -- eax := x + CLTD `snocOL` + IDIV sz (OpAddr (spRel 0)) `snocOL` + ADD L (OpImm (ImmInt 4)) (OpReg esp) `snocOL` + DELTA delta in - returnUs (Fixed IntRep (if is_division then eax else edx) code__2) + returnNat (Fixed IntRep (if is_division then eax else edx) code__2) ----------------------- getRegister (StInd pk mem) - = getAmode mem `thenUs` \ amode -> + = getAmode mem `thenNat` \ amode -> let code = amodeCode amode src = amodeAddr amode size = primRepToSize pk - code__2 dst = code . - if pk == DoubleRep || pk == FloatRep - then mkSeqInstr (GLD size src dst) - else mkSeqInstr (MOV size (OpAddr src) (OpReg dst)) + code__2 dst = code `snocOL` + if pk == DoubleRep || pk == FloatRep + then GLD size src dst + else case size of + L -> MOV L (OpAddr src) (OpReg dst) + B -> MOVZxL B (OpAddr src) (OpReg dst) in - returnUs (Any pk code__2) + returnNat (Any pk code__2) getRegister (StInt i) = let src = ImmInt (fromInteger i) - code dst = mkSeqInstr (MOV L (OpImm src) (OpReg dst)) + code dst + | i == 0 + = unitOL (XOR L (OpReg dst) (OpReg dst)) + | otherwise + = unitOL (MOV L (OpImm src) (OpReg dst)) in - returnUs (Any IntRep code) + returnNat (Any IntRep code) getRegister leaf | maybeToBool imm - = let - code dst = mkSeqInstr (MOV L (OpImm imm__2) (OpReg dst)) + = let code dst = unitOL (MOV L (OpImm imm__2) (OpReg dst)) in - returnUs (Any PtrRep code) + returnNat (Any PtrRep code) | otherwise = pprPanic "getRegister(x86)" (pprStixTrees [leaf]) where @@ -917,8 +868,8 @@ getRegister leaf #if sparc_TARGET_ARCH getRegister (StDouble d) - = getUniqLabelNCG `thenUs` \ lbl -> - getNewRegNCG PtrRep `thenUs` \ tmp -> + = getNatLabelNCG `thenNat` \ lbl -> + getNewRegNCG PtrRep `thenNat` \ tmp -> let code dst = mkSeqInstrs [ SEGMENT DataSegment, LABEL lbl, @@ -927,7 +878,7 @@ getRegister (StDouble d) SETHI (HI (ImmCLbl lbl)) tmp, LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst] in - returnUs (Any DoubleRep code) + returnNat (Any DoubleRep code) getRegister (StPrim primop [x]) -- unary PrimOps = case primop of @@ -1072,14 +1023,14 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps imul_div fn x y = getRegister (StCall fn cCallConv IntRep [x, y]) getRegister (StInd pk mem) - = getAmode mem `thenUs` \ amode -> + = getAmode mem `thenNat` \ amode -> let code = amodeCode amode src = amodeAddr amode size = primRepToSize pk code__2 dst = code . mkSeqInstr (LD size src dst) in - returnUs (Any pk code__2) + returnNat (Any pk code__2) getRegister (StInt i) | fits13Bits i @@ -1087,7 +1038,7 @@ getRegister (StInt i) src = ImmInt (fromInteger i) code dst = mkSeqInstr (OR False g0 (RIImm src) dst) in - returnUs (Any IntRep code) + returnNat (Any IntRep code) getRegister leaf | maybeToBool imm @@ -1096,7 +1047,7 @@ getRegister leaf SETHI (HI imm__2) dst, OR False dst (RIImm (LO imm__2)) dst] in - returnUs (Any PtrRep code) + returnNat (Any PtrRep code) where imm = maybeImm leaf imm__2 = case imm of Just x -> x @@ -1121,119 +1072,125 @@ amodeCode (Amode _ code) = code Now, given a tree (the argument to an StInd) that references memory, produce a suitable addressing mode. +A Rule of the Game (tm) for Amodes: use of the addr bit must +immediately follow use of the code part, since the code part puts +values in registers which the addr then refers to. So you can't put +anything in between, lest it overwrite some of those registers. If +you need to do some other computation between the code part and use of +the addr bit, first store the effective address from the amode in a +temporary, then do the other computation, and then use the temporary: + + code + LEA amode, tmp + ... other computation ... + ... (tmp) ... + \begin{code} -getAmode :: StixTree -> UniqSM Amode +getAmode :: StixTree -> NatM Amode getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree) #if alpha_TARGET_ARCH getAmode (StPrim IntSubOp [x, StInt i]) - = getNewRegNCG PtrRep `thenUs` \ tmp -> - getRegister x `thenUs` \ register -> + = getNewRegNCG PtrRep `thenNat` \ tmp -> + getRegister x `thenNat` \ register -> let code = registerCode register tmp reg = registerName register tmp off = ImmInt (-(fromInteger i)) in - returnUs (Amode (AddrRegImm reg off) code) + returnNat (Amode (AddrRegImm reg off) code) getAmode (StPrim IntAddOp [x, StInt i]) - = getNewRegNCG PtrRep `thenUs` \ tmp -> - getRegister x `thenUs` \ register -> + = getNewRegNCG PtrRep `thenNat` \ tmp -> + getRegister x `thenNat` \ register -> let code = registerCode register tmp reg = registerName register tmp off = ImmInt (fromInteger i) in - returnUs (Amode (AddrRegImm reg off) code) + returnNat (Amode (AddrRegImm reg off) code) getAmode leaf | maybeToBool imm - = returnUs (Amode (AddrImm imm__2) id) + = returnNat (Amode (AddrImm imm__2) id) where imm = maybeImm leaf imm__2 = case imm of Just x -> x getAmode other - = getNewRegNCG PtrRep `thenUs` \ tmp -> - getRegister other `thenUs` \ register -> + = getNewRegNCG PtrRep `thenNat` \ tmp -> + getRegister other `thenNat` \ register -> let code = registerCode register tmp reg = registerName register tmp in - returnUs (Amode (AddrReg reg) code) + returnNat (Amode (AddrReg reg) code) #endif {- alpha_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if i386_TARGET_ARCH getAmode (StPrim IntSubOp [x, StInt i]) - = getNewRegNCG PtrRep `thenUs` \ tmp -> - getRegister x `thenUs` \ register -> + = getNewRegNCG PtrRep `thenNat` \ tmp -> + getRegister x `thenNat` \ register -> let code = registerCode register tmp reg = registerName register tmp off = ImmInt (-(fromInteger i)) in - returnUs (Amode (AddrBaseIndex (Just reg) Nothing off) code) + returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code) getAmode (StPrim IntAddOp [x, StInt i]) | maybeToBool imm - = let - code = mkSeqInstrs [] - in - returnUs (Amode (ImmAddr imm__2 (fromInteger i)) code) + = returnNat (Amode (ImmAddr imm__2 (fromInteger i)) nilOL) where imm = maybeImm x imm__2 = case imm of Just x -> x getAmode (StPrim IntAddOp [x, StInt i]) - = getNewRegNCG PtrRep `thenUs` \ tmp -> - getRegister x `thenUs` \ register -> + = getNewRegNCG PtrRep `thenNat` \ tmp -> + getRegister x `thenNat` \ register -> let code = registerCode register tmp reg = registerName register tmp off = ImmInt (fromInteger i) in - returnUs (Amode (AddrBaseIndex (Just reg) Nothing off) code) + returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code) getAmode (StPrim IntAddOp [x, StPrim SllOp [y, StInt shift]]) | shift == 0 || shift == 1 || shift == 2 || shift == 3 - = getNewRegNCG PtrRep `thenUs` \ tmp1 -> - getNewRegNCG IntRep `thenUs` \ tmp2 -> - getRegister x `thenUs` \ register1 -> - getRegister y `thenUs` \ register2 -> + = getNewRegNCG PtrRep `thenNat` \ tmp1 -> + getNewRegNCG IntRep `thenNat` \ tmp2 -> + getRegister x `thenNat` \ register1 -> + getRegister y `thenNat` \ register2 -> let - code1 = registerCode register1 tmp1 asmVoid + code1 = registerCode register1 tmp1 reg1 = registerName register1 tmp1 - code2 = registerCode register2 tmp2 asmVoid + code2 = registerCode register2 tmp2 reg2 = registerName register2 tmp2 - code__2 = asmParThen [code1, code2] + code__2 = code1 `appOL` code2 base = case shift of 0 -> 1 ; 1 -> 2; 2 -> 4; 3 -> 8 in - returnUs (Amode (AddrBaseIndex (Just reg1) (Just (reg2,base)) (ImmInt 0)) - code__2) + returnNat (Amode (AddrBaseIndex (Just reg1) (Just (reg2,base)) (ImmInt 0)) + code__2) getAmode leaf | maybeToBool imm - = let - code = mkSeqInstrs [] - in - returnUs (Amode (ImmAddr imm__2 0) code) + = returnNat (Amode (ImmAddr imm__2 0) nilOL) where imm = maybeImm leaf imm__2 = case imm of Just x -> x getAmode other - = getNewRegNCG PtrRep `thenUs` \ tmp -> - getRegister other `thenUs` \ register -> + = getNewRegNCG PtrRep `thenNat` \ tmp -> + getRegister other `thenNat` \ register -> let code = registerCode register tmp reg = registerName register tmp - off = Nothing in - returnUs (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code) + returnNat (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code) #endif {- i386_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -1241,61 +1198,61 @@ getAmode other getAmode (StPrim IntSubOp [x, StInt i]) | fits13Bits (-i) - = getNewRegNCG PtrRep `thenUs` \ tmp -> - getRegister x `thenUs` \ register -> + = getNewRegNCG PtrRep `thenNat` \ tmp -> + getRegister x `thenNat` \ register -> let code = registerCode register tmp reg = registerName register tmp off = ImmInt (-(fromInteger i)) in - returnUs (Amode (AddrRegImm reg off) code) + returnNat (Amode (AddrRegImm reg off) code) getAmode (StPrim IntAddOp [x, StInt i]) | fits13Bits i - = getNewRegNCG PtrRep `thenUs` \ tmp -> - getRegister x `thenUs` \ register -> + = getNewRegNCG PtrRep `thenNat` \ tmp -> + getRegister x `thenNat` \ register -> let code = registerCode register tmp reg = registerName register tmp off = ImmInt (fromInteger i) in - returnUs (Amode (AddrRegImm reg off) code) + returnNat (Amode (AddrRegImm reg off) code) getAmode (StPrim IntAddOp [x, y]) - = getNewRegNCG PtrRep `thenUs` \ tmp1 -> - getNewRegNCG IntRep `thenUs` \ tmp2 -> - getRegister x `thenUs` \ register1 -> - getRegister y `thenUs` \ register2 -> + = getNewRegNCG PtrRep `thenNat` \ tmp1 -> + getNewRegNCG IntRep `thenNat` \ tmp2 -> + getRegister x `thenNat` \ register1 -> + getRegister y `thenNat` \ register2 -> let - code1 = registerCode register1 tmp1 asmVoid + code1 = registerCode register1 tmp1 [] reg1 = registerName register1 tmp1 - code2 = registerCode register2 tmp2 asmVoid + code2 = registerCode register2 tmp2 [] reg2 = registerName register2 tmp2 - code__2 = asmParThen [code1, code2] + code__2 = asmSeqThen [code1, code2] in - returnUs (Amode (AddrRegReg reg1 reg2) code__2) + returnNat (Amode (AddrRegReg reg1 reg2) code__2) getAmode leaf | maybeToBool imm - = getNewRegNCG PtrRep `thenUs` \ tmp -> + = getNewRegNCG PtrRep `thenNat` \ tmp -> let code = mkSeqInstr (SETHI (HI imm__2) tmp) in - returnUs (Amode (AddrRegImm tmp (LO imm__2)) code) + returnNat (Amode (AddrRegImm tmp (LO imm__2)) code) where imm = maybeImm leaf imm__2 = case imm of Just x -> x getAmode other - = getNewRegNCG PtrRep `thenUs` \ tmp -> - getRegister other `thenUs` \ register -> + = getNewRegNCG PtrRep `thenNat` \ tmp -> + getRegister other `thenNat` \ register -> let code = registerCode register tmp reg = registerName register tmp off = ImmInt 0 in - returnUs (Amode (AddrRegImm reg off) code) + returnNat (Amode (AddrRegImm reg off) code) #endif {- sparc_TARGET_ARCH -} \end{code} @@ -1318,7 +1275,7 @@ condCode (CondCode _ _ code) = code Set up a condition code for a conditional branch. \begin{code} -getCondCode :: StixTree -> UniqSM CondCode +getCondCode :: StixTree -> NatM CondCode #if alpha_TARGET_ARCH getCondCode = panic "MachCode.getCondCode: not on Alphas" @@ -1331,46 +1288,46 @@ getCondCode = panic "MachCode.getCondCode: not on Alphas" getCondCode (StPrim primop [x, y]) = case primop of CharGtOp -> condIntCode GTT x y - CharGeOp -> condIntCode GE x y + CharGeOp -> condIntCode GE x y CharEqOp -> condIntCode EQQ x y - CharNeOp -> condIntCode NE x y + CharNeOp -> condIntCode NE x y CharLtOp -> condIntCode LTT x y - CharLeOp -> condIntCode LE x y + CharLeOp -> condIntCode LE x y IntGtOp -> condIntCode GTT x y - IntGeOp -> condIntCode GE x y + IntGeOp -> condIntCode GE x y IntEqOp -> condIntCode EQQ x y - IntNeOp -> condIntCode NE x y + IntNeOp -> condIntCode NE x y IntLtOp -> condIntCode LTT x y - IntLeOp -> condIntCode LE x y + IntLeOp -> condIntCode LE x y - WordGtOp -> condIntCode GU x y - WordGeOp -> condIntCode GEU x y + WordGtOp -> condIntCode GU x y + WordGeOp -> condIntCode GEU x y WordEqOp -> condIntCode EQQ x y - WordNeOp -> condIntCode NE x y - WordLtOp -> condIntCode LU x y - WordLeOp -> condIntCode LEU x y + WordNeOp -> condIntCode NE x y + WordLtOp -> condIntCode LU x y + WordLeOp -> condIntCode LEU x y - AddrGtOp -> condIntCode GU x y - AddrGeOp -> condIntCode GEU x y + AddrGtOp -> condIntCode GU x y + AddrGeOp -> condIntCode GEU x y AddrEqOp -> condIntCode EQQ x y - AddrNeOp -> condIntCode NE x y - AddrLtOp -> condIntCode LU x y - AddrLeOp -> condIntCode LEU x y + AddrNeOp -> condIntCode NE x y + AddrLtOp -> condIntCode LU x y + AddrLeOp -> condIntCode LEU x y FloatGtOp -> condFltCode GTT x y - FloatGeOp -> condFltCode GE x y + FloatGeOp -> condFltCode GE x y FloatEqOp -> condFltCode EQQ x y - FloatNeOp -> condFltCode NE x y + FloatNeOp -> condFltCode NE x y FloatLtOp -> condFltCode LTT x y - FloatLeOp -> condFltCode LE x y + FloatLeOp -> condFltCode LE x y DoubleGtOp -> condFltCode GTT x y - DoubleGeOp -> condFltCode GE x y + DoubleGeOp -> condFltCode GE x y DoubleEqOp -> condFltCode EQQ x y - DoubleNeOp -> condFltCode NE x y + DoubleNeOp -> condFltCode NE x y DoubleLtOp -> condFltCode LTT x y - DoubleLeOp -> condFltCode LE x y + DoubleLeOp -> condFltCode LE x y #endif {- i386_TARGET_ARCH || sparc_TARGET_ARCH -} \end{code} @@ -1381,7 +1338,7 @@ getCondCode (StPrim primop [x, y]) passed back up the tree. \begin{code} -condIntCode, condFltCode :: Cond -> StixTree -> StixTree -> UniqSM CondCode +condIntCode, condFltCode :: Cond -> StixTree -> StixTree -> NatM CondCode #if alpha_TARGET_ARCH condIntCode = panic "MachCode.condIntCode: not on Alphas" @@ -1391,99 +1348,130 @@ condFltCode = panic "MachCode.condFltCode: not on Alphas" -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if i386_TARGET_ARCH --- some condIntCode clauses look pretty dodgy to me -condIntCode cond (StInd _ x) y +-- memory vs immediate +condIntCode cond (StInd pk x) y | maybeToBool imm - = getAmode x `thenUs` \ amode -> + = getAmode x `thenNat` \ amode -> let - code1 = amodeCode amode asmVoid - y__2 = amodeAddr amode - code__2 = asmParThen [code1] . - mkSeqInstr (CMP L (OpImm imm__2) (OpAddr y__2)) + code1 = amodeCode amode + x__2 = amodeAddr amode + sz = primRepToSize pk + code__2 = code1 `snocOL` + CMP sz (OpImm imm__2) (OpAddr x__2) in - returnUs (CondCode False cond code__2) + returnNat (CondCode False cond code__2) where imm = maybeImm y imm__2 = case imm of Just x -> x +-- anything vs zero condIntCode cond x (StInt 0) - = getRegister x `thenUs` \ register1 -> - getNewRegNCG IntRep `thenUs` \ tmp1 -> + = getRegister x `thenNat` \ register1 -> + getNewRegNCG IntRep `thenNat` \ tmp1 -> let - code1 = registerCode register1 tmp1 asmVoid + code1 = registerCode register1 tmp1 src1 = registerName register1 tmp1 - code__2 = asmParThen [code1] . - mkSeqInstr (TEST L (OpReg src1) (OpReg src1)) + code__2 = code1 `snocOL` + TEST L (OpReg src1) (OpReg src1) in - returnUs (CondCode False cond code__2) + returnNat (CondCode False cond code__2) +-- anything vs immediate condIntCode cond x y | maybeToBool imm - = getRegister x `thenUs` \ register1 -> - getNewRegNCG IntRep `thenUs` \ tmp1 -> + = getRegister x `thenNat` \ register1 -> + getNewRegNCG IntRep `thenNat` \ tmp1 -> let - code1 = registerCode register1 tmp1 asmVoid + code1 = registerCode register1 tmp1 src1 = registerName register1 tmp1 - code__2 = asmParThen [code1] . - mkSeqInstr (CMP L (OpImm imm__2) (OpReg src1)) + code__2 = code1 `snocOL` + CMP L (OpImm imm__2) (OpReg src1) in - returnUs (CondCode False cond code__2) + returnNat (CondCode False cond code__2) where imm = maybeImm y imm__2 = case imm of Just x -> x -condIntCode cond (StInd _ x) y - = getAmode x `thenUs` \ amode -> - getRegister y `thenUs` \ register2 -> - getNewRegNCG IntRep `thenUs` \ tmp2 -> - let - code1 = amodeCode amode asmVoid - src1 = amodeAddr amode - code2 = registerCode register2 tmp2 asmVoid - src2 = registerName register2 tmp2 - code__2 = asmParThen [code1, code2] . - mkSeqInstr (CMP L (OpReg src2) (OpAddr src1)) - in - returnUs (CondCode False cond code__2) - -condIntCode cond y (StInd _ x) - = getAmode x `thenUs` \ amode -> - getRegister y `thenUs` \ register2 -> - getNewRegNCG IntRep `thenUs` \ tmp2 -> - let - code1 = amodeCode amode asmVoid - src1 = amodeAddr amode - code2 = registerCode register2 tmp2 asmVoid - src2 = registerName register2 tmp2 - code__2 = asmParThen [code1, code2] . - mkSeqInstr (CMP L (OpAddr src1) (OpReg src2)) - in - returnUs (CondCode False cond code__2) - +-- memory vs anything +condIntCode cond (StInd pk x) y + = getAmode x `thenNat` \ amode_x -> + getRegister y `thenNat` \ reg_y -> + getNewRegNCG IntRep `thenNat` \ tmp -> + let + c_x = amodeCode amode_x + am_x = amodeAddr amode_x + c_y = registerCode reg_y tmp + r_y = registerName reg_y tmp + sz = primRepToSize pk + + -- optimisation: if there's no code for x, just an amode, + -- use whatever reg y winds up in. Assumes that c_y doesn't + -- clobber any regs in the amode am_x, which I'm not sure is + -- justified. The otherwise clause makes the same assumption. + code__2 | isNilOL c_x + = c_y `snocOL` + CMP sz (OpReg r_y) (OpAddr am_x) + + | otherwise + = c_y `snocOL` + MOV L (OpReg r_y) (OpReg tmp) `appOL` + c_x `snocOL` + CMP sz (OpReg tmp) (OpAddr am_x) + in + returnNat (CondCode False cond code__2) + +-- anything vs memory +-- +condIntCode cond y (StInd pk x) + = getAmode x `thenNat` \ amode_x -> + getRegister y `thenNat` \ reg_y -> + getNewRegNCG IntRep `thenNat` \ tmp -> + let + c_x = amodeCode amode_x + am_x = amodeAddr amode_x + c_y = registerCode reg_y tmp + r_y = registerName reg_y tmp + sz = primRepToSize pk + -- same optimisation and nagging doubts as previous clause + code__2 | isNilOL c_x + = c_y `snocOL` + CMP sz (OpAddr am_x) (OpReg r_y) + + | otherwise + = c_y `snocOL` + MOV L (OpReg r_y) (OpReg tmp) `appOL` + c_x `snocOL` + CMP sz (OpAddr am_x) (OpReg tmp) + in + returnNat (CondCode False cond code__2) + +-- anything vs anything condIntCode cond x y - = getRegister x `thenUs` \ register1 -> - getRegister y `thenUs` \ register2 -> - getNewRegNCG IntRep `thenUs` \ tmp1 -> - getNewRegNCG IntRep `thenUs` \ tmp2 -> + = getRegister x `thenNat` \ register1 -> + getRegister y `thenNat` \ register2 -> + getNewRegNCG IntRep `thenNat` \ tmp1 -> + getNewRegNCG IntRep `thenNat` \ tmp2 -> let - code1 = registerCode register1 tmp1 asmVoid + code1 = registerCode register1 tmp1 src1 = registerName register1 tmp1 - code2 = registerCode register2 tmp2 asmVoid + code2 = registerCode register2 tmp2 src2 = registerName register2 tmp2 - code__2 = asmParThen [code1, code2] . - mkSeqInstr (CMP L (OpReg src2) (OpReg src1)) + code__2 = code1 `snocOL` + MOV L (OpReg src1) (OpReg tmp1) `appOL` + code2 `snocOL` + CMP L (OpReg src2) (OpReg tmp1) in - returnUs (CondCode False cond code__2) + returnNat (CondCode False cond code__2) ----------- condFltCode cond x y - = getRegister x `thenUs` \ register1 -> - getRegister y `thenUs` \ register2 -> + = getRegister x `thenNat` \ register1 -> + getRegister y `thenNat` \ register2 -> getNewRegNCG (registerRep register1) - `thenUs` \ tmp1 -> + `thenNat` \ tmp1 -> getNewRegNCG (registerRep register2) - `thenUs` \ tmp2 -> - getNewRegNCG DoubleRep `thenUs` \ tmp -> + `thenNat` \ tmp2 -> + getNewRegNCG DoubleRep `thenNat` \ tmp -> let pk1 = registerRep register1 code1 = registerCode register1 tmp1 @@ -1493,21 +1481,29 @@ condFltCode cond x y code2 = registerCode register2 tmp2 src2 = registerName register2 tmp2 - code__2 = asmParThen [code1 asmVoid, code2 asmVoid] . - mkSeqInstr (GCMP (primRepToSize pk1) src1 src2) + code__2 | isAny register1 + = code1 `appOL` -- result in tmp1 + code2 `snocOL` + GCMP (primRepToSize pk1) tmp1 src2 + + | otherwise + = code1 `snocOL` + GMOV src1 tmp1 `appOL` + code2 `snocOL` + GCMP (primRepToSize pk1) tmp1 src2 {- On the 486, the flags set by FP compare are the unsigned ones! (This looks like a HACK to me. WDP 96/03) -} fix_FP_cond :: Cond -> Cond - fix_FP_cond GE = GEU + fix_FP_cond GE = GEU fix_FP_cond GTT = GU fix_FP_cond LTT = LU - fix_FP_cond LE = LEU - fix_FP_cond any = any + fix_FP_cond LE = LEU + fix_FP_cond any = any in - returnUs (CondCode True (fix_FP_cond cond) code__2) + returnNat (CondCode True (fix_FP_cond cond) code__2) @@ -1517,40 +1513,40 @@ condFltCode cond x y condIntCode cond x (StInt y) | fits13Bits y - = getRegister x `thenUs` \ register -> - getNewRegNCG IntRep `thenUs` \ tmp -> + = getRegister x `thenNat` \ register -> + getNewRegNCG IntRep `thenNat` \ tmp -> let code = registerCode register tmp src1 = registerName register tmp src2 = ImmInt (fromInteger y) code__2 = code . mkSeqInstr (SUB False True src1 (RIImm src2) g0) in - returnUs (CondCode False cond code__2) + returnNat (CondCode False cond code__2) condIntCode cond x y - = getRegister x `thenUs` \ register1 -> - getRegister y `thenUs` \ register2 -> - getNewRegNCG IntRep `thenUs` \ tmp1 -> - getNewRegNCG IntRep `thenUs` \ tmp2 -> + = getRegister x `thenNat` \ register1 -> + getRegister y `thenNat` \ register2 -> + getNewRegNCG IntRep `thenNat` \ tmp1 -> + getNewRegNCG IntRep `thenNat` \ tmp2 -> let - code1 = registerCode register1 tmp1 asmVoid + code1 = registerCode register1 tmp1 [] src1 = registerName register1 tmp1 - code2 = registerCode register2 tmp2 asmVoid + code2 = registerCode register2 tmp2 [] src2 = registerName register2 tmp2 - code__2 = asmParThen [code1, code2] . + code__2 = asmSeqThen [code1, code2] . mkSeqInstr (SUB False True src1 (RIReg src2) g0) in - returnUs (CondCode False cond code__2) + returnNat (CondCode False cond code__2) ----------- condFltCode cond x y - = getRegister x `thenUs` \ register1 -> - getRegister y `thenUs` \ register2 -> + = getRegister x `thenNat` \ register1 -> + getRegister y `thenNat` \ register2 -> getNewRegNCG (registerRep register1) - `thenUs` \ tmp1 -> + `thenNat` \ tmp1 -> getNewRegNCG (registerRep register2) - `thenUs` \ tmp2 -> - getNewRegNCG DoubleRep `thenUs` \ tmp -> + `thenNat` \ tmp2 -> + getNewRegNCG DoubleRep `thenNat` \ tmp -> let promote x = asmInstr (FxTOy F DF x tmp) @@ -1564,16 +1560,16 @@ condFltCode cond x y code__2 = if pk1 == pk2 then - asmParThen [code1 asmVoid, code2 asmVoid] . + asmSeqThen [code1 [], code2 []] . mkSeqInstr (FCMP True (primRepToSize pk1) src1 src2) else if pk1 == FloatRep then - asmParThen [code1 (promote src1), code2 asmVoid] . + asmSeqThen [code1 (promote src1), code2 []] . mkSeqInstr (FCMP True DF tmp src2) else - asmParThen [code1 asmVoid, code2 (promote src2)] . + asmSeqThen [code1 [], code2 (promote src2)] . mkSeqInstr (FCMP True DF src1 tmp) in - returnUs (CondCode True cond code__2) + returnNat (CondCode True cond code__2) #endif {- sparc_TARGET_ARCH -} \end{code} @@ -1594,27 +1590,27 @@ hand side is forced into a fixed register (e.g. the result of a call). \begin{code} assignIntCode, assignFltCode - :: PrimRep -> StixTree -> StixTree -> UniqSM InstrBlock + :: PrimRep -> StixTree -> StixTree -> NatM InstrBlock #if alpha_TARGET_ARCH assignIntCode pk (StInd _ dst) src - = getNewRegNCG IntRep `thenUs` \ tmp -> - getAmode dst `thenUs` \ amode -> - getRegister src `thenUs` \ register -> + = getNewRegNCG IntRep `thenNat` \ tmp -> + getAmode dst `thenNat` \ amode -> + getRegister src `thenNat` \ register -> let - code1 = amodeCode amode asmVoid + code1 = amodeCode amode [] dst__2 = amodeAddr amode - code2 = registerCode register tmp asmVoid + code2 = registerCode register tmp [] src__2 = registerName register tmp sz = primRepToSize pk - code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2) + code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2) in - returnUs code__2 + returnNat code__2 assignIntCode pk dst src - = getRegister dst `thenUs` \ register1 -> - getRegister src `thenUs` \ register2 -> + = getRegister dst `thenNat` \ register1 -> + getRegister src `thenNat` \ register2 -> let dst__2 = registerName register1 zeroh code = registerCode register2 dst__2 @@ -1623,97 +1619,123 @@ assignIntCode pk dst src then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2) else code in - returnUs code__2 + returnNat code__2 #endif {- alpha_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if i386_TARGET_ARCH --- looks dodgy to me -assignIntCode pk dd@(StInd _ dst) src - = getAmode dst `thenUs` \ amode -> - get_op_RI src `thenUs` \ (codesrc, opsrc) -> - let - code1 = amodeCode amode asmVoid - dst__2 = amodeAddr amode - code__2 = asmParThen [code1, codesrc asmVoid] . - mkSeqInstr (MOV (primRepToSize pk) opsrc (OpAddr dst__2)) - in - returnUs code__2 +-- Destination of an assignment can only be reg or mem. +-- This is the mem case. +assignIntCode pk (StInd _ dst) src + = getAmode dst `thenNat` \ amode -> + get_op_RI src `thenNat` \ (codesrc, opsrc) -> + getNewRegNCG PtrRep `thenNat` \ tmp -> + let + -- In general, if the address computation for dst may require + -- some insns preceding the addressing mode itself. So there's + -- no guarantee that the code for dst and the code for src won't + -- write the same register. This means either the address or + -- the value needs to be copied into a temporary. We detect the + -- common case where the amode has no code, and elide the copy. + codea = amodeCode amode + dst__a = amodeAddr amode + + code | isNilOL codea + = codesrc `snocOL` + MOV (primRepToSize pk) opsrc (OpAddr dst__a) + | otherwise + + = codea `snocOL` + LEA L (OpAddr dst__a) (OpReg tmp) `appOL` + codesrc `snocOL` + MOV (primRepToSize pk) opsrc + (OpAddr (AddrBaseIndex (Just tmp) Nothing (ImmInt 0))) + in + returnNat code where get_op_RI :: StixTree - -> UniqSM (InstrBlock,Operand) -- code, operator + -> NatM (InstrBlock,Operand) -- code, operator get_op_RI op | maybeToBool imm - = returnUs (asmParThen [], OpImm imm_op) + = returnNat (nilOL, OpImm imm_op) where imm = maybeImm op imm_op = case imm of Just x -> x get_op_RI op - = getRegister op `thenUs` \ register -> + = getRegister op `thenNat` \ register -> getNewRegNCG (registerRep register) - `thenUs` \ tmp -> - let - code = registerCode register tmp + `thenNat` \ tmp -> + let code = registerCode register tmp reg = registerName register tmp in - returnUs (code, OpReg reg) + returnNat (code, OpReg reg) +-- Assign; dst is a reg, rhs is mem assignIntCode pk dst (StInd pks src) - = getNewRegNCG IntRep `thenUs` \ tmp -> - getAmode src `thenUs` \ amode -> - getRegister dst `thenUs` \ register -> - let - code1 = amodeCode amode asmVoid - src__2 = amodeAddr amode - code2 = registerCode register tmp asmVoid - dst__2 = registerName register tmp - szs = primRepToSize pks - code__2 = asmParThen [code1, code2] . - case szs of - L -> mkSeqInstr (MOV L (OpAddr src__2) (OpReg dst__2)) - B -> mkSeqInstr (MOVZxL B (OpAddr src__2) (OpReg dst__2)) - in - returnUs code__2 - -assignIntCode pk dst src - = getRegister dst `thenUs` \ register1 -> - getRegister src `thenUs` \ register2 -> - getNewRegNCG IntRep `thenUs` \ tmp -> + = getNewRegNCG PtrRep `thenNat` \ tmp -> + getAmode src `thenNat` \ amode -> + getRegister dst `thenNat` \ reg_dst -> let - dst__2 = registerName register1 tmp - code = registerCode register2 dst__2 - src__2 = registerName register2 dst__2 - code__2 = if isFixed register2 && dst__2 /= src__2 - then code . mkSeqInstr (MOV L (OpReg src__2) (OpReg dst__2)) - else code + c_addr = amodeCode amode + am_addr = amodeAddr amode + + c_dst = registerCode reg_dst tmp -- should be empty + r_dst = registerName reg_dst tmp + szs = primRepToSize pks + opc = case szs of L -> MOV L ; B -> MOVZxL B + + code | isNilOL c_dst + = c_addr `snocOL` + opc (OpAddr am_addr) (OpReg r_dst) + | otherwise + = pprPanic "assignIntCode(x86): bad dst(2)" empty in - returnUs code__2 + returnNat code + +-- dst is a reg, but src could be anything +assignIntCode pk dst src + = getRegister dst `thenNat` \ registerd -> + getRegister src `thenNat` \ registers -> + getNewRegNCG IntRep `thenNat` \ tmp -> + let + r_dst = registerName registerd tmp + c_dst = registerCode registerd tmp -- should be empty + r_src = registerName registers r_dst + c_src = registerCode registers r_dst + + code | isNilOL c_dst + = c_src `snocOL` + MOV L (OpReg r_src) (OpReg r_dst) + | otherwise + = pprPanic "assignIntCode(x86): bad dst(3)" empty + in + returnNat code #endif {- i386_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if sparc_TARGET_ARCH assignIntCode pk (StInd _ dst) src - = getNewRegNCG IntRep `thenUs` \ tmp -> - getAmode dst `thenUs` \ amode -> - getRegister src `thenUs` \ register -> + = getNewRegNCG IntRep `thenNat` \ tmp -> + getAmode dst `thenNat` \ amode -> + getRegister src `thenNat` \ register -> let - code1 = amodeCode amode asmVoid + code1 = amodeCode amode [] dst__2 = amodeAddr amode - code2 = registerCode register tmp asmVoid + code2 = registerCode register tmp [] src__2 = registerName register tmp sz = primRepToSize pk - code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2) + code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2) in - returnUs code__2 + returnNat code__2 assignIntCode pk dst src - = getRegister dst `thenUs` \ register1 -> - getRegister src `thenUs` \ register2 -> + = getRegister dst `thenNat` \ register1 -> + getRegister src `thenNat` \ register2 -> let dst__2 = registerName register1 g0 code = registerCode register2 dst__2 @@ -1722,7 +1744,7 @@ assignIntCode pk dst src then code . mkSeqInstr (OR False g0 (RIReg src__2) dst__2) else code in - returnUs code__2 + returnNat code__2 #endif {- sparc_TARGET_ARCH -} \end{code} @@ -1734,22 +1756,22 @@ Floating-point assignments: #if alpha_TARGET_ARCH assignFltCode pk (StInd _ dst) src - = getNewRegNCG pk `thenUs` \ tmp -> - getAmode dst `thenUs` \ amode -> - getRegister src `thenUs` \ register -> + = getNewRegNCG pk `thenNat` \ tmp -> + getAmode dst `thenNat` \ amode -> + getRegister src `thenNat` \ register -> let - code1 = amodeCode amode asmVoid + code1 = amodeCode amode [] dst__2 = amodeAddr amode - code2 = registerCode register tmp asmVoid + code2 = registerCode register tmp [] src__2 = registerName register tmp sz = primRepToSize pk - code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2) + code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2) in - returnUs code__2 + returnNat code__2 assignFltCode pk dst src - = getRegister dst `thenUs` \ register1 -> - getRegister src `thenUs` \ register2 -> + = getRegister dst `thenNat` \ register1 -> + getRegister src `thenNat` \ register2 -> let dst__2 = registerName register1 zeroh code = registerCode register2 dst__2 @@ -1758,106 +1780,95 @@ assignFltCode pk dst src then code . mkSeqInstr (FMOV src__2 dst__2) else code in - returnUs code__2 + returnNat code__2 #endif {- alpha_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if i386_TARGET_ARCH -assignFltCode pk (StInd pk_dst dst) (StInd pk_src src) - = getNewRegNCG IntRep `thenUs` \ tmp -> - getAmode src `thenUs` \ amodesrc -> - getAmode dst `thenUs` \ amodedst -> - let - codesrc1 = amodeCode amodesrc asmVoid - addrsrc1 = amodeAddr amodesrc - codedst1 = amodeCode amodedst asmVoid - addrdst1 = amodeAddr amodedst - addrsrc2 = case (addrOffset addrsrc1 4) of Just x -> x - addrdst2 = case (addrOffset addrdst1 4) of Just x -> x - - code__2 = asmParThen [codesrc1, codedst1] . - mkSeqInstrs ([MOV L (OpAddr addrsrc1) (OpReg tmp), - MOV L (OpReg tmp) (OpAddr addrdst1)] - ++ - if pk == DoubleRep - then [MOV L (OpAddr addrsrc2) (OpReg tmp), - MOV L (OpReg tmp) (OpAddr addrdst2)] - else []) - in - returnUs code__2 - -assignFltCode pk (StInd _ dst) src - = getNewRegNCG pk `thenUs` \ tmp -> - getAmode dst `thenUs` \ amode -> - getRegister src `thenUs` \ register -> +-- dst is memory +assignFltCode pk (StInd pk_dst addr) src + | pk /= pk_dst + = pprPanic "assignFltCode(x86): src/ind sz mismatch" empty + | otherwise + = getRegister src `thenNat` \ reg_src -> + getRegister addr `thenNat` \ reg_addr -> + getNewRegNCG pk `thenNat` \ tmp_src -> + getNewRegNCG PtrRep `thenNat` \ tmp_addr -> + let r_src = registerName reg_src tmp_src + c_src = registerCode reg_src tmp_src + r_addr = registerName reg_addr tmp_addr + c_addr = registerCode reg_addr tmp_addr + sz = primRepToSize pk + + code = c_src `appOL` + -- no need to preserve r_src across the addr computation, + -- since r_src must be a float reg + -- whilst r_addr is an int reg + c_addr `snocOL` + GST sz r_src + (AddrBaseIndex (Just r_addr) Nothing (ImmInt 0)) + in + returnNat code + +-- dst must be a (FP) register +assignFltCode pk dst src + = getRegister dst `thenNat` \ reg_dst -> + getRegister src `thenNat` \ reg_src -> + getNewRegNCG pk `thenNat` \ tmp -> let - sz = primRepToSize pk - dst__2 = amodeAddr amode - - code1 = amodeCode amode asmVoid - code2 = registerCode register tmp asmVoid + r_dst = registerName reg_dst tmp + c_dst = registerCode reg_dst tmp -- should be empty - src__2 = registerName register tmp + r_src = registerName reg_src r_dst + c_src = registerCode reg_src r_dst - code__2 = asmParThen [code1, code2] . - mkSeqInstr (GST sz src__2 dst__2) + code | isNilOL c_dst + = if isFixed reg_src + then c_src `snocOL` GMOV r_src r_dst + else c_src + | otherwise + = pprPanic "assignFltCode(x86): lhs is not mem or reg" + empty in - returnUs code__2 + returnNat code -assignFltCode pk dst src - = getRegister dst `thenUs` \ register1 -> - getRegister src `thenUs` \ register2 -> - getNewRegNCG pk `thenUs` \ tmp -> - let - -- the register which is dst - dst__2 = registerName register1 tmp - -- the register into which src is computed, preferably dst__2 - src__2 = registerName register2 dst__2 - -- code to compute src into src__2 - code = registerCode register2 dst__2 - - code__2 = if isFixed register2 - then code . mkSeqInstr (GMOV src__2 dst__2) - else code - in - returnUs code__2 #endif {- i386_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if sparc_TARGET_ARCH assignFltCode pk (StInd _ dst) src - = getNewRegNCG pk `thenUs` \ tmp1 -> - getAmode dst `thenUs` \ amode -> - getRegister src `thenUs` \ register -> + = getNewRegNCG pk `thenNat` \ tmp1 -> + getAmode dst `thenNat` \ amode -> + getRegister src `thenNat` \ register -> let sz = primRepToSize pk dst__2 = amodeAddr amode - code1 = amodeCode amode asmVoid - code2 = registerCode register tmp1 asmVoid + code1 = amodeCode amode [] + code2 = registerCode register tmp1 [] src__2 = registerName register tmp1 pk__2 = registerRep register sz__2 = primRepToSize pk__2 - code__2 = asmParThen [code1, code2] . + code__2 = asmSeqThen [code1, code2] ++ if pk == pk__2 then mkSeqInstr (ST sz src__2 dst__2) else mkSeqInstrs [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2] in - returnUs code__2 + returnNat code__2 assignFltCode pk dst src - = getRegister dst `thenUs` \ register1 -> - getRegister src `thenUs` \ register2 -> + = getRegister dst `thenNat` \ register1 -> + getRegister src `thenNat` \ register2 -> let pk__2 = registerRep register2 sz__2 = primRepToSize pk__2 in - getNewRegNCG pk__2 `thenUs` \ tmp -> + getNewRegNCG pk__2 `thenNat` \ tmp -> let sz = primRepToSize pk dst__2 = registerName register1 g0 -- must be Fixed @@ -1877,7 +1888,7 @@ assignFltCode pk dst src else code in - returnUs code__2 + returnNat code__2 #endif {- sparc_TARGET_ARCH -} \end{code} @@ -1897,7 +1908,7 @@ branch instruction. Other CLabels are assumed to be far away. register allocator. \begin{code} -genJump :: StixTree{-the branch target-} -> UniqSM InstrBlock +genJump :: StixTree{-the branch target-} -> NatM InstrBlock #if alpha_TARGET_ARCH @@ -1908,8 +1919,8 @@ genJump (StCLbl lbl) target = ImmCLbl lbl genJump tree - = getRegister tree `thenUs` \ register -> - getNewRegNCG PtrRep `thenUs` \ tmp -> + = getRegister tree `thenNat` \ register -> + getNewRegNCG PtrRep `thenNat` \ tmp -> let dst = registerName register pv code = registerCode register pv @@ -1918,40 +1929,32 @@ genJump tree if isFixed register then returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0] else - returnUs (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0)) + returnNat (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0)) #endif {- alpha_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if i386_TARGET_ARCH -{- -genJump (StCLbl lbl) - | isAsmTemp lbl = returnInstrs [JXX ALWAYS lbl] - | otherwise = returnInstrs [JMP (OpImm target)] - where - target = ImmCLbl lbl --} - genJump (StInd pk mem) - = getAmode mem `thenUs` \ amode -> + = getAmode mem `thenNat` \ amode -> let code = amodeCode amode target = amodeAddr amode in - returnSeq code [JMP (OpAddr target)] + returnNat (code `snocOL` JMP (OpAddr target)) genJump tree | maybeToBool imm - = returnInstr (JMP (OpImm target)) + = returnNat (unitOL (JMP (OpImm target))) | otherwise - = getRegister tree `thenUs` \ register -> - getNewRegNCG PtrRep `thenUs` \ tmp -> + = getRegister tree `thenNat` \ register -> + getNewRegNCG PtrRep `thenNat` \ tmp -> let code = registerCode register tmp target = registerName register tmp in - returnSeq code [JMP (OpReg target)] + returnNat (code `snocOL` JMP (OpReg target)) where imm = maybeImm tree target = case imm of Just x -> x @@ -1967,8 +1970,8 @@ genJump (StCLbl lbl) target = ImmCLbl lbl genJump tree - = getRegister tree `thenUs` \ register -> - getNewRegNCG PtrRep `thenUs` \ tmp -> + = getRegister tree `thenNat` \ register -> + getNewRegNCG PtrRep `thenNat` \ tmp -> let code = registerCode register tmp target = registerName register tmp @@ -2007,14 +2010,14 @@ allocator. genCondJump :: CLabel -- the branch target -> StixTree -- the condition on which to branch - -> UniqSM InstrBlock + -> NatM InstrBlock #if alpha_TARGET_ARCH genCondJump lbl (StPrim op [x, StInt 0]) - = getRegister x `thenUs` \ register -> + = getRegister x `thenNat` \ register -> getNewRegNCG (registerRep register) - `thenUs` \ tmp -> + `thenNat` \ tmp -> let code = registerCode register tmp value = registerName register tmp @@ -2049,16 +2052,16 @@ genCondJump lbl (StPrim op [x, StInt 0]) cmpOp AddrLeOp = EQQ genCondJump lbl (StPrim op [x, StDouble 0.0]) - = getRegister x `thenUs` \ register -> + = getRegister x `thenNat` \ register -> getNewRegNCG (registerRep register) - `thenUs` \ tmp -> + `thenNat` \ tmp -> let code = registerCode register tmp value = registerName register tmp pk = registerRep register target = ImmCLbl lbl in - returnUs (code . mkSeqInstr (BF (cmpOp op) value target)) + returnNat (code . mkSeqInstr (BF (cmpOp op) value target)) where cmpOp FloatGtOp = GTT cmpOp FloatGeOp = GE @@ -2075,14 +2078,14 @@ genCondJump lbl (StPrim op [x, StDouble 0.0]) genCondJump lbl (StPrim op [x, y]) | fltCmpOp op - = trivialFCode pr instr x y `thenUs` \ register -> - getNewRegNCG DoubleRep `thenUs` \ tmp -> + = trivialFCode pr instr x y `thenNat` \ register -> + getNewRegNCG DoubleRep `thenNat` \ tmp -> let code = registerCode register tmp result = registerName register tmp target = ImmCLbl lbl in - returnUs (code . mkSeqInstr (BF cond result target)) + returnNat (code . mkSeqInstr (BF cond result target)) where pr = panic "trivialU?FCode: does not use PrimRep on Alpha" @@ -2115,14 +2118,14 @@ genCondJump lbl (StPrim op [x, y]) DoubleLeOp -> (FCMP TF LE, NE) genCondJump lbl (StPrim op [x, y]) - = trivialCode instr x y `thenUs` \ register -> - getNewRegNCG IntRep `thenUs` \ tmp -> + = trivialCode instr x y `thenNat` \ register -> + getNewRegNCG IntRep `thenNat` \ tmp -> let code = registerCode register tmp result = registerName register tmp target = ImmCLbl lbl in - returnUs (code . mkSeqInstr (BI cond result target)) + returnNat (code . mkSeqInstr (BI cond result target)) where (instr, cond) = case op of CharGtOp -> (CMP LE, EQQ) @@ -2155,20 +2158,20 @@ genCondJump lbl (StPrim op [x, y]) #if i386_TARGET_ARCH genCondJump lbl bool - = getCondCode bool `thenUs` \ condition -> + = getCondCode bool `thenNat` \ condition -> let code = condCode condition cond = condName condition target = ImmCLbl lbl in - returnSeq code [JXX cond lbl] + returnNat (code `snocOL` JXX cond lbl) #endif {- i386_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if sparc_TARGET_ARCH genCondJump lbl bool - = getCondCode bool `thenUs` \ condition -> + = getCondCode bool `thenNat` \ condition -> let code = condCode condition cond = condName condition @@ -2203,16 +2206,16 @@ genCCall -> CallConv -> PrimRep -- type of the result -> [StixTree] -- arguments (of mixed type) - -> UniqSM InstrBlock + -> NatM InstrBlock #if alpha_TARGET_ARCH genCCall fn cconv kind args - = mapAccumLUs get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args - `thenUs` \ ((unused,_), argCode) -> + = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args + `thenNat` \ ((unused,_), argCode) -> let nRegs = length allArgRegs - length unused - code = asmParThen (map ($ asmVoid) argCode) + code = asmSeqThen (map ($ []) argCode) in returnSeq code [ LDA pv (AddrImm (ImmLab (ptext fn))), @@ -2229,24 +2232,24 @@ genCCall fn cconv kind args registers to be assigned for this call and the next stack offset to use for overflowing arguments. This way, @get_Arg@ can be applied to all of a call's arguments using - @mapAccumLUs@. + @mapAccumLNat@. -} get_arg :: ([(Reg,Reg)], Int) -- Argument registers and stack offset (accumulator) -> StixTree -- Current argument - -> UniqSM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code + -> NatM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code -- We have to use up all of our argument registers first... get_arg ((iDst,fDst):dsts, offset) arg - = getRegister arg `thenUs` \ register -> + = getRegister arg `thenNat` \ register -> let reg = if isFloatingRep pk then fDst else iDst code = registerCode register reg src = registerName register reg pk = registerRep register in - returnUs ( + returnNat ( if isFloatingRep pk then ((dsts, offset), if isFixed register then code . mkSeqInstr (FMOV src fDst) @@ -2260,16 +2263,16 @@ genCCall fn cconv kind args -- stack... get_arg ([], offset) arg - = getRegister arg `thenUs` \ register -> + = getRegister arg `thenNat` \ register -> getNewRegNCG (registerRep register) - `thenUs` \ tmp -> + `thenNat` \ tmp -> let code = registerCode register tmp src = registerName register tmp pk = registerRep register sz = primRepToSize pk in - returnUs (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset))) + returnNat (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset))) #endif {- alpha_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -2277,24 +2280,31 @@ genCCall fn cconv kind args genCCall fn cconv kind [StInt i] | fn == SLIT ("PerformGC_wrapper") - = let call = [MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax), - CALL (ImmLit (ptext (if underscorePrefix - then (SLIT ("_PerformGC_wrapper")) - else (SLIT ("PerformGC_wrapper")))))] + = let call = toOL [ + MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax), + CALL (ImmLit (ptext (if underscorePrefix + then (SLIT ("_PerformGC_wrapper")) + else (SLIT ("PerformGC_wrapper"))))) + ] in - returnInstrs call + returnNat call genCCall fn cconv kind args - = get_call_args args `thenUs` \ (tot_arg_size, argCode) -> - let - code2 = asmParThen (map ($ asmVoid) argCode) - call = [SUB L (OpImm (ImmInt tot_arg_size)) (OpReg esp), - CALL fn__2 , - ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp) + = mapNat get_call_arg + (reverse args) `thenNat` \ sizes_n_codes -> + getDeltaNat `thenNat` \ delta -> + let (sizes, codes) = unzip sizes_n_codes + tot_arg_size = sum sizes + code2 = concatOL codes + call = toOL [ + CALL fn__2, + ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp), + DELTA (delta + tot_arg_size) ] in - returnSeq code2 call + setDeltaNat (delta + tot_arg_size) `thenNat` \ _ -> + returnNat (code2 `appOL` call) where -- function names that begin with '.' are assumed to be special @@ -2310,70 +2320,56 @@ genCCall fn cconv kind args arg_size _ = 4 ------------ - -- do get_call_arg on each arg, threading the total arg size along - -- process the args right-to-left - get_call_args :: [StixTree] -> UniqSM (Int, [InstrBlock]) - get_call_args args - = f 0 args - where - f curr_sz [] - = returnUs (curr_sz, []) - f curr_sz (arg:args) - = f curr_sz args `thenUs` \ (new_sz, iblocks) -> - get_call_arg arg new_sz `thenUs` \ (new_sz2, iblock) -> - returnUs (new_sz2, iblock:iblocks) - - - ------------ get_call_arg :: StixTree{-current argument-} - -> Int{-running total of arg sizes seen so far-} - -> UniqSM (Int, InstrBlock) -- updated tot argsz, code - - get_call_arg arg old_sz - = get_op arg `thenUs` \ (code, reg, sz) -> - let new_sz = old_sz + arg_size sz - in if (case sz of DF -> True; F -> True; _ -> False) - then returnUs (new_sz, - code . - mkSeqInstr (GST DF reg - (AddrBaseIndex (Just esp) - Nothing (ImmInt (- new_sz)))) - ) - else returnUs (new_sz, - code . - mkSeqInstr (MOV L (OpReg reg) - (OpAddr - (AddrBaseIndex (Just esp) - Nothing (ImmInt (- new_sz))))) - ) + -> NatM (Int, InstrBlock) -- argsz, code + + get_call_arg arg + = get_op arg `thenNat` \ (code, reg, sz) -> + getDeltaNat `thenNat` \ delta -> + arg_size sz `bind` \ size -> + setDeltaNat (delta-size) `thenNat` \ _ -> + if (case sz of DF -> True; F -> True; _ -> False) + then returnNat (size, + code `appOL` + toOL [SUB L (OpImm (ImmInt 8)) (OpReg esp), + DELTA (delta-size), + GST DF reg (AddrBaseIndex (Just esp) + Nothing + (ImmInt 0))] + ) + else returnNat (size, + code `snocOL` + PUSH L (OpReg reg) `snocOL` + DELTA (delta-size) + ) ------------ get_op :: StixTree - -> UniqSM (InstrBlock, Reg, Size) -- code, reg, size + -> NatM (InstrBlock, Reg, Size) -- code, reg, size get_op op - = getRegister op `thenUs` \ register -> + = getRegister op `thenNat` \ register -> getNewRegNCG (registerRep register) - `thenUs` \ tmp -> + `thenNat` \ tmp -> let code = registerCode register tmp reg = registerName register tmp pk = registerRep register sz = primRepToSize pk in - returnUs (code, reg, sz) + returnNat (code, reg, sz) #endif {- i386_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if sparc_TARGET_ARCH genCCall fn cconv kind args - = mapAccumLUs get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args - `thenUs` \ ((unused,_), argCode) -> + = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args + `thenNat` \ ((unused,_), argCode) -> let nRegs = length allArgRegs - length unused call = CALL fn__2 nRegs False - code = asmParThen (map ($ asmVoid) argCode) + code = asmSeqThen (map ($ []) argCode) in returnSeq code [call, NOP] where @@ -2400,21 +2396,21 @@ genCCall fn cconv kind args get_arg :: ([Reg],Int) -- Argument registers and stack offset (accumulator) -> StixTree -- Current argument - -> UniqSM (([Reg],Int), InstrBlock) -- Updated accumulator and code + -> NatM (([Reg],Int), InstrBlock) -- Updated accumulator and code -- We have to use up all of our argument registers first... get_arg (dst:dsts, offset) arg - = getRegister arg `thenUs` \ register -> + = getRegister arg `thenNat` \ register -> getNewRegNCG (registerRep register) - `thenUs` \ tmp -> + `thenNat` \ tmp -> let reg = if isFloatingRep pk then tmp else dst code = registerCode register reg src = registerName register reg pk = registerRep register in - returnUs (case pk of + returnNat (case pk of DoubleRep -> case dsts of [] -> (([], offset + 1), code . mkSeqInstrs [ @@ -2437,9 +2433,9 @@ genCCall fn cconv kind args -- stack... get_arg ([], offset) arg - = getRegister arg `thenUs` \ register -> + = getRegister arg `thenNat` \ register -> getNewRegNCG (registerRep register) - `thenUs` \ tmp -> + `thenNat` \ tmp -> let code = registerCode register tmp src = registerName register tmp @@ -2447,7 +2443,7 @@ genCCall fn cconv kind args sz = primRepToSize pk words = if pk == DoubleRep then 2 else 1 in - returnUs (([], offset + words), code . mkSeqInstr (ST sz src (spRel offset))) + returnNat (([], offset + words), code . mkSeqInstr (ST sz src (spRel offset))) #endif {- sparc_TARGET_ARCH -} \end{code} @@ -2471,7 +2467,7 @@ the right hand side of an assignment). register allocator. \begin{code} -condIntReg, condFltReg :: Cond -> StixTree -> StixTree -> UniqSM Register +condIntReg, condFltReg :: Cond -> StixTree -> StixTree -> NatM Register #if alpha_TARGET_ARCH condIntReg = panic "MachCode.condIntReg (not on Alpha)" @@ -2482,30 +2478,26 @@ condFltReg = panic "MachCode.condFltReg (not on Alpha)" #if i386_TARGET_ARCH condIntReg cond x y - = condIntCode cond x y `thenUs` \ condition -> - getNewRegNCG IntRep `thenUs` \ tmp -> - --getRegister dst `thenUs` \ register -> + = condIntCode cond x y `thenNat` \ condition -> + getNewRegNCG IntRep `thenNat` \ tmp -> let - --code2 = registerCode register tmp asmVoid - --dst__2 = registerName register tmp code = condCode condition cond = condName condition - -- ToDo: if dst is eax, ebx, ecx, or edx we would not need the move. - code__2 dst = code . mkSeqInstrs [ + code__2 dst = code `appOL` toOL [ SETCC cond (OpReg tmp), AND L (OpImm (ImmInt 1)) (OpReg tmp), MOV L (OpReg tmp) (OpReg dst)] in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) condFltReg cond x y - = getUniqLabelNCG `thenUs` \ lbl1 -> - getUniqLabelNCG `thenUs` \ lbl2 -> - condFltCode cond x y `thenUs` \ condition -> + = getNatLabelNCG `thenNat` \ lbl1 -> + getNatLabelNCG `thenNat` \ lbl2 -> + condFltCode cond x y `thenNat` \ condition -> let code = condCode condition cond = condName condition - code__2 dst = code . mkSeqInstrs [ + code__2 dst = code `appOL` toOL [ JXX cond lbl1, MOV L (OpImm (ImmInt 0)) (OpReg dst), JXX ALWAYS lbl2, @@ -2513,15 +2505,15 @@ condFltReg cond x y MOV L (OpImm (ImmInt 1)) (OpReg dst), LABEL lbl2] in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) #endif {- i386_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if sparc_TARGET_ARCH condIntReg EQQ x (StInt 0) - = getRegister x `thenUs` \ register -> - getNewRegNCG IntRep `thenUs` \ tmp -> + = getRegister x `thenNat` \ register -> + getNewRegNCG IntRep `thenNat` \ tmp -> let code = registerCode register tmp src = registerName register tmp @@ -2529,28 +2521,28 @@ condIntReg EQQ x (StInt 0) SUB False True g0 (RIReg src) g0, SUB True False g0 (RIImm (ImmInt (-1))) dst] in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) condIntReg EQQ x y - = getRegister x `thenUs` \ register1 -> - getRegister y `thenUs` \ register2 -> - getNewRegNCG IntRep `thenUs` \ tmp1 -> - getNewRegNCG IntRep `thenUs` \ tmp2 -> + = getRegister x `thenNat` \ register1 -> + getRegister y `thenNat` \ register2 -> + getNewRegNCG IntRep `thenNat` \ tmp1 -> + getNewRegNCG IntRep `thenNat` \ tmp2 -> let - code1 = registerCode register1 tmp1 asmVoid + code1 = registerCode register1 tmp1 [] src1 = registerName register1 tmp1 - code2 = registerCode register2 tmp2 asmVoid + code2 = registerCode register2 tmp2 [] src2 = registerName register2 tmp2 - code__2 dst = asmParThen [code1, code2] . mkSeqInstrs [ + code__2 dst = asmSeqThen [code1, code2] . mkSeqInstrs [ XOR False src1 (RIReg src2) dst, SUB False True g0 (RIReg dst) g0, SUB True False g0 (RIImm (ImmInt (-1))) dst] in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) condIntReg NE x (StInt 0) - = getRegister x `thenUs` \ register -> - getNewRegNCG IntRep `thenUs` \ tmp -> + = getRegister x `thenNat` \ register -> + getNewRegNCG IntRep `thenNat` \ tmp -> let code = registerCode register tmp src = registerName register tmp @@ -2558,29 +2550,29 @@ condIntReg NE x (StInt 0) SUB False True g0 (RIReg src) g0, ADD True False g0 (RIImm (ImmInt 0)) dst] in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) condIntReg NE x y - = getRegister x `thenUs` \ register1 -> - getRegister y `thenUs` \ register2 -> - getNewRegNCG IntRep `thenUs` \ tmp1 -> - getNewRegNCG IntRep `thenUs` \ tmp2 -> + = getRegister x `thenNat` \ register1 -> + getRegister y `thenNat` \ register2 -> + getNewRegNCG IntRep `thenNat` \ tmp1 -> + getNewRegNCG IntRep `thenNat` \ tmp2 -> let - code1 = registerCode register1 tmp1 asmVoid + code1 = registerCode register1 tmp1 [] src1 = registerName register1 tmp1 - code2 = registerCode register2 tmp2 asmVoid + code2 = registerCode register2 tmp2 [] src2 = registerName register2 tmp2 - code__2 dst = asmParThen [code1, code2] . mkSeqInstrs [ + code__2 dst = asmSeqThen [code1, code2] . mkSeqInstrs [ XOR False src1 (RIReg src2) dst, SUB False True g0 (RIReg dst) g0, ADD True False g0 (RIImm (ImmInt 0)) dst] in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) condIntReg cond x y - = getUniqLabelNCG `thenUs` \ lbl1 -> - getUniqLabelNCG `thenUs` \ lbl2 -> - condIntCode cond x y `thenUs` \ condition -> + = getNatLabelNCG `thenNat` \ lbl1 -> + getNatLabelNCG `thenNat` \ lbl2 -> + condIntCode cond x y `thenNat` \ condition -> let code = condCode condition cond = condName condition @@ -2592,12 +2584,12 @@ condIntReg cond x y OR False g0 (RIImm (ImmInt 1)) dst, LABEL lbl2] in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) condFltReg cond x y - = getUniqLabelNCG `thenUs` \ lbl1 -> - getUniqLabelNCG `thenUs` \ lbl2 -> - condFltCode cond x y `thenUs` \ condition -> + = getNatLabelNCG `thenNat` \ lbl1 -> + getNatLabelNCG `thenNat` \ lbl2 -> + condFltCode cond x y `thenNat` \ condition -> let code = condCode condition cond = condName condition @@ -2610,7 +2602,7 @@ condFltReg cond x y OR False g0 (RIImm (ImmInt 1)) dst, LABEL lbl2] in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) #endif {- sparc_TARGET_ARCH -} \end{code} @@ -2638,7 +2630,7 @@ trivialCode ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr) ,))) -> StixTree -> StixTree -- the two arguments - -> UniqSM Register + -> NatM Register trivialFCode :: PrimRep @@ -2647,7 +2639,7 @@ trivialFCode ,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr) ,))) -> StixTree -> StixTree -- the two arguments - -> UniqSM Register + -> NatM Register trivialUCode :: IF_ARCH_alpha((RI -> Reg -> Instr) @@ -2655,7 +2647,7 @@ trivialUCode ,IF_ARCH_sparc((RI -> Reg -> Instr) ,))) -> StixTree -- the one argument - -> UniqSM Register + -> NatM Register trivialUFCode :: PrimRep @@ -2664,54 +2656,54 @@ trivialUFCode ,IF_ARCH_sparc((Reg -> Reg -> Instr) ,))) -> StixTree -- the one argument - -> UniqSM Register + -> NatM Register #if alpha_TARGET_ARCH trivialCode instr x (StInt y) | fits8Bits y - = getRegister x `thenUs` \ register -> - getNewRegNCG IntRep `thenUs` \ tmp -> + = getRegister x `thenNat` \ register -> + getNewRegNCG IntRep `thenNat` \ tmp -> let code = registerCode register tmp src1 = registerName register tmp src2 = ImmInt (fromInteger y) code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst) in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) trivialCode instr x y - = getRegister x `thenUs` \ register1 -> - getRegister y `thenUs` \ register2 -> - getNewRegNCG IntRep `thenUs` \ tmp1 -> - getNewRegNCG IntRep `thenUs` \ tmp2 -> + = getRegister x `thenNat` \ register1 -> + getRegister y `thenNat` \ register2 -> + getNewRegNCG IntRep `thenNat` \ tmp1 -> + getNewRegNCG IntRep `thenNat` \ tmp2 -> let - code1 = registerCode register1 tmp1 asmVoid + code1 = registerCode register1 tmp1 [] src1 = registerName register1 tmp1 - code2 = registerCode register2 tmp2 asmVoid + code2 = registerCode register2 tmp2 [] src2 = registerName register2 tmp2 - code__2 dst = asmParThen [code1, code2] . + code__2 dst = asmSeqThen [code1, code2] . mkSeqInstr (instr src1 (RIReg src2) dst) in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) ------------ trivialUCode instr x - = getRegister x `thenUs` \ register -> - getNewRegNCG IntRep `thenUs` \ tmp -> + = getRegister x `thenNat` \ register -> + getNewRegNCG IntRep `thenNat` \ tmp -> let code = registerCode register tmp src = registerName register tmp code__2 dst = code . mkSeqInstr (instr (RIReg src) dst) in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) ------------ trivialFCode _ instr x y - = getRegister x `thenUs` \ register1 -> - getRegister y `thenUs` \ register2 -> - getNewRegNCG DoubleRep `thenUs` \ tmp1 -> - getNewRegNCG DoubleRep `thenUs` \ tmp2 -> + = getRegister x `thenNat` \ register1 -> + getRegister y `thenNat` \ register2 -> + getNewRegNCG DoubleRep `thenNat` \ tmp1 -> + getNewRegNCG DoubleRep `thenNat` \ tmp2 -> let code1 = registerCode register1 tmp1 src1 = registerName register1 tmp1 @@ -2719,20 +2711,20 @@ trivialFCode _ instr x y code2 = registerCode register2 tmp2 src2 = registerName register2 tmp2 - code__2 dst = asmParThen [code1 asmVoid, code2 asmVoid] . + code__2 dst = asmSeqThen [code1 [], code2 []] . mkSeqInstr (instr src1 src2 dst) in - returnUs (Any DoubleRep code__2) + returnNat (Any DoubleRep code__2) trivialUFCode _ instr x - = getRegister x `thenUs` \ register -> - getNewRegNCG DoubleRep `thenUs` \ tmp -> + = getRegister x `thenNat` \ register -> + getNewRegNCG DoubleRep `thenNat` \ tmp -> let code = registerCode register tmp src = registerName register tmp code__2 dst = code . mkSeqInstr (instr src dst) in - returnUs (Any DoubleRep code__2) + returnNat (Any DoubleRep code__2) #endif {- alpha_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -2741,7 +2733,7 @@ trivialUFCode _ instr x The Rules of the Game are: * You cannot assume anything about the destination register dst; - it may be anything, includind a fixed reg. + it may be anything, including a fixed reg. * You may compute an operand into a fixed reg, but you may not subsequently change the contents of that fixed reg. If you @@ -2758,98 +2750,95 @@ The Rules of the Game are: \begin{code} -infixr 3 `bind` -x `bind` f = f x - trivialCode instr maybe_revinstr a b | is_imm_b - = getRegister a `thenUs` \ rega -> + = getRegister a `thenNat` \ rega -> let mkcode dst - = if isFloat rega + = if isAny rega then registerCode rega dst `bind` \ code_a -> - code_a . - mkSeqInstr (instr (OpImm imm_b) (OpReg dst)) + code_a `snocOL` + instr (OpImm imm_b) (OpReg dst) else registerCodeF rega `bind` \ code_a -> registerNameF rega `bind` \ r_a -> - code_a . - mkSeqInstr (MOV L (OpReg r_a) (OpReg dst)) . - mkSeqInstr (instr (OpImm imm_b) (OpReg dst)) + code_a `snocOL` + MOV L (OpReg r_a) (OpReg dst) `snocOL` + instr (OpImm imm_b) (OpReg dst) in - returnUs (Any IntRep mkcode) + returnNat (Any IntRep mkcode) | is_imm_a - = getRegister b `thenUs` \ regb -> - getNewRegNCG IntRep `thenUs` \ tmp -> + = getRegister b `thenNat` \ regb -> + getNewRegNCG IntRep `thenNat` \ tmp -> let revinstr_avail = maybeToBool maybe_revinstr revinstr = case maybe_revinstr of Just ri -> ri mkcode dst | revinstr_avail - = if isFloat regb + = if isAny regb then registerCode regb dst `bind` \ code_b -> - code_b . - mkSeqInstr (revinstr (OpImm imm_a) (OpReg dst)) + code_b `snocOL` + revinstr (OpImm imm_a) (OpReg dst) else registerCodeF regb `bind` \ code_b -> registerNameF regb `bind` \ r_b -> - code_b . - mkSeqInstr (MOV L (OpReg r_b) (OpReg dst)) . - mkSeqInstr (revinstr (OpImm imm_a) (OpReg dst)) + code_b `snocOL` + MOV L (OpReg r_b) (OpReg dst) `snocOL` + revinstr (OpImm imm_a) (OpReg dst) | otherwise - = if isFloat regb + = if isAny regb then registerCode regb tmp `bind` \ code_b -> - code_b . - mkSeqInstr (MOV L (OpImm imm_a) (OpReg dst)) . - mkSeqInstr (instr (OpReg tmp) (OpReg dst)) + code_b `snocOL` + MOV L (OpImm imm_a) (OpReg dst) `snocOL` + instr (OpReg tmp) (OpReg dst) else registerCodeF regb `bind` \ code_b -> registerNameF regb `bind` \ r_b -> - code_b . - mkSeqInstr (MOV L (OpReg r_b) (OpReg tmp)) . - mkSeqInstr (MOV L (OpImm imm_a) (OpReg dst)) . - mkSeqInstr (instr (OpReg tmp) (OpReg dst)) + code_b `snocOL` + MOV L (OpReg r_b) (OpReg tmp) `snocOL` + MOV L (OpImm imm_a) (OpReg dst) `snocOL` + instr (OpReg tmp) (OpReg dst) in - returnUs (Any IntRep mkcode) + returnNat (Any IntRep mkcode) | otherwise - = getRegister a `thenUs` \ rega -> - getRegister b `thenUs` \ regb -> - getNewRegNCG IntRep `thenUs` \ tmp -> + = getRegister a `thenNat` \ rega -> + getRegister b `thenNat` \ regb -> + getNewRegNCG IntRep `thenNat` \ tmp -> let mkcode dst - = case (isFloat rega, isFloat regb) of + = case (isAny rega, isAny regb) of (True, True) -> registerCode regb tmp `bind` \ code_b -> registerCode rega dst `bind` \ code_a -> - code_b . - code_a . - mkSeqInstr (instr (OpReg tmp) (OpReg dst)) + code_b `appOL` + code_a `snocOL` + instr (OpReg tmp) (OpReg dst) (True, False) -> registerCode rega tmp `bind` \ code_a -> registerCodeF regb `bind` \ code_b -> registerNameF regb `bind` \ r_b -> - code_a . - code_b . - mkSeqInstr (instr (OpReg r_b) (OpReg tmp)) . - mkSeqInstr (MOV L (OpReg tmp) (OpReg dst)) + code_a `appOL` + code_b `snocOL` + instr (OpReg r_b) (OpReg tmp) `snocOL` + MOV L (OpReg tmp) (OpReg dst) (False, True) -> registerCode regb tmp `bind` \ code_b -> registerCodeF rega `bind` \ code_a -> registerNameF rega `bind` \ r_a -> - code_b . - code_a . - mkSeqInstr (MOV L (OpReg r_a) (OpReg dst)) . - mkSeqInstr (instr (OpReg tmp) (OpReg dst)) + code_b `appOL` + code_a `snocOL` + MOV L (OpReg r_a) (OpReg dst) `snocOL` + instr (OpReg tmp) (OpReg dst) (False, False) -> registerCodeF rega `bind` \ code_a -> registerNameF rega `bind` \ r_a -> registerCodeF regb `bind` \ code_b -> registerNameF regb `bind` \ r_b -> - code_a . - mkSeqInstr (MOV L (OpReg r_a) (OpReg tmp)) . - code_b . - mkSeqInstr (instr (OpReg r_b) (OpReg tmp)) . - mkSeqInstr (MOV L (OpReg tmp) (OpReg dst)) + code_a `snocOL` + MOV L (OpReg r_a) (OpReg tmp) `appOL` + code_b `snocOL` + instr (OpReg r_b) (OpReg tmp) `snocOL` + MOV L (OpReg tmp) (OpReg dst) in - returnUs (Any IntRep mkcode) + returnNat (Any IntRep mkcode) where maybe_imm_a = maybeImm a @@ -2863,24 +2852,24 @@ trivialCode instr maybe_revinstr a b ----------- trivialUCode instr x - = getRegister x `thenUs` \ register -> + = getRegister x `thenNat` \ register -> let code__2 dst = let code = registerCode register dst src = registerName register dst - in code . - if isFixed register && dst /= src - then mkSeqInstrs [MOV L (OpReg src) (OpReg dst), - instr (OpReg dst)] - else mkSeqInstr (instr (OpReg src)) + in code `appOL` + if isFixed register && dst /= src + then toOL [MOV L (OpReg src) (OpReg dst), + instr (OpReg dst)] + else unitOL (instr (OpReg src)) in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) ----------- trivialFCode pk instr x y - = getRegister x `thenUs` \ register1 -> - getRegister y `thenUs` \ register2 -> - getNewRegNCG DoubleRep `thenUs` \ tmp1 -> - getNewRegNCG DoubleRep `thenUs` \ tmp2 -> + = getRegister x `thenNat` \ register1 -> + getRegister y `thenNat` \ register2 -> + getNewRegNCG DoubleRep `thenNat` \ tmp1 -> + getNewRegNCG DoubleRep `thenNat` \ tmp2 -> let code1 = registerCode register1 tmp1 src1 = registerName register1 tmp1 @@ -2888,22 +2877,33 @@ trivialFCode pk instr x y code2 = registerCode register2 tmp2 src2 = registerName register2 tmp2 - code__2 dst = asmParThen [code1 asmVoid, code2 asmVoid] . - mkSeqInstr (instr (primRepToSize pk) src1 src2 dst) + code__2 dst + -- treat the common case specially: both operands in + -- non-fixed regs. + | isAny register1 && isAny register2 + = code1 `appOL` + code2 `snocOL` + instr (primRepToSize pk) src1 src2 dst + + -- be paranoid (and inefficient) + | otherwise + = code1 `snocOL` GMOV src1 tmp1 `appOL` + code2 `snocOL` + instr (primRepToSize pk) tmp1 src2 dst in - returnUs (Any DoubleRep code__2) + returnNat (Any DoubleRep code__2) ------------- trivialUFCode pk instr x - = getRegister x `thenUs` \ register -> - getNewRegNCG pk `thenUs` \ tmp -> + = getRegister x `thenNat` \ register -> + getNewRegNCG pk `thenNat` \ tmp -> let code = registerCode register tmp src = registerName register tmp - code__2 dst = code . mkSeqInstr (instr src dst) + code__2 dst = code `snocOL` instr src dst in - returnUs (Any pk code__2) + returnNat (Any pk code__2) #endif {- i386_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -2911,40 +2911,40 @@ trivialUFCode pk instr x trivialCode instr x (StInt y) | fits13Bits y - = getRegister x `thenUs` \ register -> - getNewRegNCG IntRep `thenUs` \ tmp -> + = getRegister x `thenNat` \ register -> + getNewRegNCG IntRep `thenNat` \ tmp -> let code = registerCode register tmp src1 = registerName register tmp src2 = ImmInt (fromInteger y) code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst) in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) trivialCode instr x y - = getRegister x `thenUs` \ register1 -> - getRegister y `thenUs` \ register2 -> - getNewRegNCG IntRep `thenUs` \ tmp1 -> - getNewRegNCG IntRep `thenUs` \ tmp2 -> + = getRegister x `thenNat` \ register1 -> + getRegister y `thenNat` \ register2 -> + getNewRegNCG IntRep `thenNat` \ tmp1 -> + getNewRegNCG IntRep `thenNat` \ tmp2 -> let - code1 = registerCode register1 tmp1 asmVoid + code1 = registerCode register1 tmp1 [] src1 = registerName register1 tmp1 - code2 = registerCode register2 tmp2 asmVoid + code2 = registerCode register2 tmp2 [] src2 = registerName register2 tmp2 - code__2 dst = asmParThen [code1, code2] . + code__2 dst = asmSeqThen [code1, code2] . mkSeqInstr (instr src1 (RIReg src2) dst) in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) ------------ trivialFCode pk instr x y - = getRegister x `thenUs` \ register1 -> - getRegister y `thenUs` \ register2 -> + = getRegister x `thenNat` \ register1 -> + getRegister y `thenNat` \ register2 -> getNewRegNCG (registerRep register1) - `thenUs` \ tmp1 -> + `thenNat` \ tmp1 -> getNewRegNCG (registerRep register2) - `thenUs` \ tmp2 -> - getNewRegNCG DoubleRep `thenUs` \ tmp -> + `thenNat` \ tmp2 -> + getNewRegNCG DoubleRep `thenNat` \ tmp -> let promote x = asmInstr (FxTOy F DF x tmp) @@ -2958,38 +2958,38 @@ trivialFCode pk instr x y code__2 dst = if pk1 == pk2 then - asmParThen [code1 asmVoid, code2 asmVoid] . + asmSeqThen [code1 [], code2 []] . mkSeqInstr (instr (primRepToSize pk) src1 src2 dst) else if pk1 == FloatRep then - asmParThen [code1 (promote src1), code2 asmVoid] . + asmSeqThen [code1 (promote src1), code2 []] . mkSeqInstr (instr DF tmp src2 dst) else - asmParThen [code1 asmVoid, code2 (promote src2)] . + asmSeqThen [code1 [], code2 (promote src2)] . mkSeqInstr (instr DF src1 tmp dst) in - returnUs (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2) + returnNat (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2) ------------ trivialUCode instr x - = getRegister x `thenUs` \ register -> - getNewRegNCG IntRep `thenUs` \ tmp -> + = getRegister x `thenNat` \ register -> + getNewRegNCG IntRep `thenNat` \ tmp -> let code = registerCode register tmp src = registerName register tmp code__2 dst = code . mkSeqInstr (instr (RIReg src) dst) in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) ------------- trivialUFCode pk instr x - = getRegister x `thenUs` \ register -> - getNewRegNCG pk `thenUs` \ tmp -> + = getRegister x `thenNat` \ register -> + getNewRegNCG pk `thenNat` \ tmp -> let code = registerCode register tmp src = registerName register tmp code__2 dst = code . mkSeqInstr (instr src dst) in - returnUs (Any pk code__2) + returnNat (Any pk code__2) #endif {- sparc_TARGET_ARCH -} \end{code} @@ -3009,15 +3009,15 @@ conversions. We have to store temporaries in memory to move between the integer and the floating point register sets. \begin{code} -coerceIntCode :: PrimRep -> StixTree -> UniqSM Register -coerceFltCode :: StixTree -> UniqSM Register +coerceIntCode :: PrimRep -> StixTree -> NatM Register +coerceFltCode :: StixTree -> NatM Register -coerceInt2FP :: PrimRep -> StixTree -> UniqSM Register -coerceFP2Int :: StixTree -> UniqSM Register +coerceInt2FP :: PrimRep -> StixTree -> NatM Register +coerceFP2Int :: StixTree -> NatM Register coerceIntCode pk x - = getRegister x `thenUs` \ register -> - returnUs ( + = getRegister x `thenNat` \ register -> + returnNat ( case register of Fixed _ reg code -> Fixed pk reg code Any _ code -> Any pk code @@ -3025,8 +3025,8 @@ coerceIntCode pk x ------------- coerceFltCode x - = getRegister x `thenUs` \ register -> - returnUs ( + = getRegister x `thenNat` \ register -> + returnNat ( case register of Fixed _ reg code -> Fixed DoubleRep reg code Any _ code -> Any DoubleRep code @@ -3037,8 +3037,8 @@ coerceFltCode x #if alpha_TARGET_ARCH coerceInt2FP _ x - = getRegister x `thenUs` \ register -> - getNewRegNCG IntRep `thenUs` \ reg -> + = getRegister x `thenNat` \ register -> + getNewRegNCG IntRep `thenNat` \ reg -> let code = registerCode register reg src = registerName register reg @@ -3048,12 +3048,12 @@ coerceInt2FP _ x LD TF dst (spRel 0), CVTxy Q TF dst dst] in - returnUs (Any DoubleRep code__2) + returnNat (Any DoubleRep code__2) ------------- coerceFP2Int x - = getRegister x `thenUs` \ register -> - getNewRegNCG DoubleRep `thenUs` \ tmp -> + = getRegister x `thenNat` \ register -> + getNewRegNCG DoubleRep `thenNat` \ tmp -> let code = registerCode register tmp src = registerName register tmp @@ -3063,46 +3063,44 @@ coerceFP2Int x ST TF tmp (spRel 0), LD Q dst (spRel 0)] in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) #endif {- alpha_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if i386_TARGET_ARCH coerceInt2FP pk x - = getRegister x `thenUs` \ register -> - getNewRegNCG IntRep `thenUs` \ reg -> + = getRegister x `thenNat` \ register -> + getNewRegNCG IntRep `thenNat` \ reg -> let code = registerCode register reg src = registerName register reg opc = case pk of FloatRep -> GITOF ; DoubleRep -> GITOD - code__2 dst = code . - mkSeqInstr (opc src dst) + code__2 dst = code `snocOL` opc src dst in - returnUs (Any pk code__2) + returnNat (Any pk code__2) ------------ coerceFP2Int x - = getRegister x `thenUs` \ register -> - getNewRegNCG DoubleRep `thenUs` \ tmp -> + = getRegister x `thenNat` \ register -> + getNewRegNCG DoubleRep `thenNat` \ tmp -> let code = registerCode register tmp src = registerName register tmp pk = registerRep register opc = case pk of FloatRep -> GFTOI ; DoubleRep -> GDTOI - code__2 dst = code . - mkSeqInstr (opc src dst) + code__2 dst = code `snocOL` opc src dst in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) #endif {- i386_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if sparc_TARGET_ARCH coerceInt2FP pk x - = getRegister x `thenUs` \ register -> - getNewRegNCG IntRep `thenUs` \ reg -> + = getRegister x `thenNat` \ register -> + getNewRegNCG IntRep `thenNat` \ reg -> let code = registerCode register reg src = registerName register reg @@ -3112,13 +3110,13 @@ coerceInt2FP pk x LD W (spRel (-2)) dst, FxTOy W (primRepToSize pk) dst dst] in - returnUs (Any pk code__2) + returnNat (Any pk code__2) ------------ coerceFP2Int x - = getRegister x `thenUs` \ register -> - getNewRegNCG IntRep `thenUs` \ reg -> - getNewRegNCG FloatRep `thenUs` \ tmp -> + = getRegister x `thenNat` \ register -> + getNewRegNCG IntRep `thenNat` \ reg -> + getNewRegNCG FloatRep `thenNat` \ tmp -> let code = registerCode register reg src = registerName register reg @@ -3129,7 +3127,7 @@ coerceFP2Int x ST W tmp (spRel (-2)), LD W (spRel (-2)) dst] in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) #endif {- sparc_TARGET_ARCH -} \end{code} @@ -3144,44 +3142,44 @@ Integer to character conversion. Where applicable, we try to do this in one step if the original object is in memory. \begin{code} -chrCode :: StixTree -> UniqSM Register +chrCode :: StixTree -> NatM Register #if alpha_TARGET_ARCH chrCode x - = getRegister x `thenUs` \ register -> - getNewRegNCG IntRep `thenUs` \ reg -> + = getRegister x `thenNat` \ register -> + getNewRegNCG IntRep `thenNat` \ reg -> let code = registerCode register reg src = registerName register reg code__2 dst = code . mkSeqInstr (ZAPNOT src (RIImm (ImmInt 1)) dst) in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) #endif {- alpha_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if i386_TARGET_ARCH chrCode x - = getRegister x `thenUs` \ register -> + = getRegister x `thenNat` \ register -> let code__2 dst = let code = registerCode register dst src = registerName register dst - in code . - if isFixed register && src /= dst - then mkSeqInstrs [MOV L (OpReg src) (OpReg dst), - AND L (OpImm (ImmInt 255)) (OpReg dst)] - else mkSeqInstr (AND L (OpImm (ImmInt 255)) (OpReg src)) + in code `appOL` + if isFixed register && src /= dst + then toOL [MOV L (OpReg src) (OpReg dst), + AND L (OpImm (ImmInt 255)) (OpReg dst)] + else unitOL (AND L (OpImm (ImmInt 255)) (OpReg src)) in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) #endif {- i386_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if sparc_TARGET_ARCH chrCode (StInd pk mem) - = getAmode mem `thenUs` \ amode -> + = getAmode mem `thenNat` \ amode -> let code = amodeCode amode src = amodeAddr amode @@ -3194,17 +3192,17 @@ chrCode (StInd pk mem) LD (primRepToSize pk) src dst, AND False dst (RIImm (ImmInt 255)) dst] in - returnUs (Any pk code__2) + returnNat (Any pk code__2) chrCode x - = getRegister x `thenUs` \ register -> - getNewRegNCG IntRep `thenUs` \ reg -> + = getRegister x `thenNat` \ register -> + getNewRegNCG IntRep `thenNat` \ reg -> let code = registerCode register reg src = registerName register reg code__2 dst = code . mkSeqInstr (AND False src (RIImm (ImmInt 255)) dst) in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) #endif {- sparc_TARGET_ARCH -} \end{code} diff --git a/ghc/compiler/nativeGen/MachMisc.lhs b/ghc/compiler/nativeGen/MachMisc.lhs index 6f5337339d..ddbc1fdd3e 100644 --- a/ghc/compiler/nativeGen/MachMisc.lhs +++ b/ghc/compiler/nativeGen/MachMisc.lhs @@ -301,6 +301,7 @@ data Size | L | F -- IEEE single-precision floating pt | DF -- IEEE single-precision floating pt + | F80 -- Intel 80-bit internal FP format; only used for spilling #endif #if sparc_TARGET_ARCH = B -- byte (signed) @@ -351,6 +352,8 @@ data Instr String -- the literal string | DATA Size [Imm] + | DELTA Int -- specify current stack offset for + -- benefit of subsequent passes \end{code} \begin{code} @@ -470,6 +473,10 @@ contents, would not impose a fixed mapping from %fake to %st regs, and hopefully could avoid most of the redundant reg-reg moves of the current translation. +We might as well make use of whatever unique FP facilities Intel have +chosen to bless us with (let's not be churlish, after all). +Hence GLDZ and GLD1. Bwahahahahahahaha! + \begin{code} #if i386_TARGET_ARCH @@ -509,10 +516,10 @@ current translation. | BT Size Imm Operand | NOP --- Float Arithmetic. -- ToDo for 386 +-- Float Arithmetic. --- Note that we cheat by treating G{ABS,MOV,NEG} of doubles as single instructions --- right up until we spit them out. +-- Note that we cheat by treating G{ABS,MOV,NEG} of doubles +-- as single instructions right up until we spit them out. -- all the 3-operand fake fp insns are src1 src2 dst -- and furthermore are constrained to be fp regs only. @@ -521,6 +528,9 @@ current translation. | GLD Size MachRegsAddr Reg -- src, dst(fpreg) | GST Size Reg MachRegsAddr -- src(fpreg), dst + | GLDZ Reg -- dst(fpreg) + | GLD1 Reg -- dst(fpreg) + | GFTOD Reg Reg -- src(fpreg), dst(fpreg) | GFTOI Reg Reg -- src(fpreg), dst(intreg) @@ -595,6 +605,7 @@ is_G_instr :: Instr -> Bool is_G_instr instr = case instr of GMOV _ _ -> True; GLD _ _ _ -> True; GST _ _ _ -> True; + GLDZ _ -> True; GLD1 _ -> True; GFTOD _ _ -> True; GFTOI _ _ -> True; GDTOF _ _ -> True; GDTOI _ _ -> True; GITOF _ _ -> True; GITOD _ _ -> True; diff --git a/ghc/compiler/nativeGen/MachRegs.lhs b/ghc/compiler/nativeGen/MachRegs.lhs index 446e7dd794..aabe13e30d 100644 --- a/ghc/compiler/nativeGen/MachRegs.lhs +++ b/ghc/compiler/nativeGen/MachRegs.lhs @@ -64,11 +64,12 @@ import AbsCUtils ( magicIdPrimRep ) import CLabel ( CLabel ) import PrimOp ( PrimOp(..) ) import PrimRep ( PrimRep(..) ) -import Stix ( sStLitLbl, StixTree(..), StixReg(..) ) +import Stix ( sStLitLbl, StixTree(..), StixReg(..), + getUniqueNat, returnNat, thenNat, NatM ) import Unique ( mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3, Uniquable(..), Unique ) -import UniqSupply ( getUniqueUs, returnUs, thenUs, UniqSM ) +--import UniqSupply ( getUniqueUs, returnUs, thenUs, UniqSM ) import Outputable \end{code} @@ -270,10 +271,10 @@ data Reg mkReg :: Unique -> PrimRep -> Reg mkReg = UnmappedReg -getNewRegNCG :: PrimRep -> UniqSM Reg +getNewRegNCG :: PrimRep -> NatM Reg getNewRegNCG pk - = getUniqueUs `thenUs` \ u -> - returnUs (UnmappedReg u pk) + = getUniqueNat `thenNat` \ u -> + returnNat (UnmappedReg u pk) instance Text Reg where showsPrec _ (FixedReg i) = showString "%" . shows IBOX(i) diff --git a/ghc/compiler/nativeGen/NOTES b/ghc/compiler/nativeGen/NOTES index bdf94aadfd..437e220a37 100644 --- a/ghc/compiler/nativeGen/NOTES +++ b/ghc/compiler/nativeGen/NOTES @@ -1,40 +1,21 @@ -Known bugs/issues in nativeGen, 000202 (JRS) +Known bugs/issues in nativeGen, 000228 (JRS) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -All these bugs are for x86; I don't know about sparc/alpha. - -- absC -> stix translation for GET_TAG and in fact anything to do with the packed-halfword layout info itbl field is pretty dubious. I think I have it fixed for big and little endian 32-bit, but it won't work at all on a 64 bit platform. --- Most of the x86 insn selector code in MachCode.lhs needs to - be checked against the Rules of the Game recorded in that file. - I think there are a lot of subtle violations. - --- When selecting spill regs, don't use %eax if there is a CALL insn - (perhaps excluding calls to newCAF, since it doesn't return a - result). - --- Keep track of the stack offset so that correct spill code can - be generated even if %esp moves. At the moment %esp doesn't - move, so the problem doesn't exist, but there is a different - problem: ccalls put args in memory below %esp and only move - %esp immediately prior to the call. This is dangerous because - (1) writing below %esp can cause a segmentation fault (as deemed - by the OS), and (2) if a signal should be handled on that stack - during argument construction, the args will get silently trashed. - - Currently, implementation of GITOF et al use the stack, so are - incompatible with current ccall implementation. When the latter - is fixed, GITOF et al should present no problem. Same issue - applies to GCOS, GSIN, GTAN, GSQRT if they have to truncate their - result to 32-bit float. - --- nofib/real/hidden gets slightly different FP answers from the - via-C route; possibly due to exp/log not being done in-line. +-- There may or may not be bugs in some of the x86 insn selector + code in MachCode.lhs. I have checked all of it against the + Rules of the Game (+ Rules of the game for Amodes) recorded in + that file, but am not 100% convinced that it is all correct. + I think most of it is, tho. --- Possibly implement GLDZ and GLD1 as analogues of FLDZ and FLD1 - (x86), to reduce number of constants emitted in f-p code. +-- It won't compile on Solaris or Alphas because the insn selectors + are not up-to-date. +-- NCG introduces a massive space leak; I think it generates all the + assembly code before printing any of it out (a depressingly + familiar story ...). Fixing this will await a working heap profiler. diff --git a/ghc/compiler/nativeGen/PprMach.lhs b/ghc/compiler/nativeGen/PprMach.lhs index 56a94c4a9e..ea296ef27a 100644 --- a/ghc/compiler/nativeGen/PprMach.lhs +++ b/ghc/compiler/nativeGen/PprMach.lhs @@ -175,12 +175,13 @@ pprSize x = ptext (case x of TF -> SLIT("t") #endif #if i386_TARGET_ARCH - B -> SLIT("b") --- HB -> SLIT("b") UNUSED --- S -> SLIT("w") UNUSED - L -> SLIT("l") - F -> SLIT("s") - DF -> SLIT("l") + B -> SLIT("b") +-- HB -> SLIT("b") UNUSED +-- S -> SLIT("w") UNUSED + L -> SLIT("l") + F -> SLIT("s") + DF -> SLIT("l") + F80 -> SLIT("t") #endif #if sparc_TARGET_ARCH B -> SLIT("sb") @@ -299,27 +300,27 @@ pprAddr (AddrRegImm r1 i) #if i386_TARGET_ARCH pprAddr (ImmAddr imm off) - = let - pp_imm = pprImm imm + = let pp_imm = pprImm imm in if (off == 0) then pp_imm else if (off < 0) then - (<>) pp_imm (int off) + pp_imm <> int off else - hcat [pp_imm, char '+', int off] + pp_imm <> char '+' <> int off pprAddr (AddrBaseIndex base index displacement) = let pp_disp = ppr_disp displacement - pp_off p = (<>) pp_disp (parens p) + pp_off p = pp_disp <> char '(' <> p <> char ')' pp_reg r = pprReg L r in case (base,index) of (Nothing, Nothing) -> pp_disp (Just b, Nothing) -> pp_off (pp_reg b) - (Nothing, Just (r,i)) -> pp_off (hcat [pp_reg r, comma, int i]) - (Just b, Just (r,i)) -> pp_off (hcat [pp_reg b, comma, pp_reg r, comma, int i]) + (Nothing, Just (r,i)) -> pp_off (pp_reg r <> comma <> int i) + (Just b, Just (r,i)) -> pp_off (pp_reg b <> comma <> pp_reg r + <> comma <> int i) where ppr_disp (ImmInt 0) = empty ppr_disp imm = pprImm imm @@ -368,6 +369,9 @@ pprInstr (COMMENT s) ,IF_ARCH_i386( ((<>) (ptext SLIT("# ")) (ptext s)) ,))) +pprInstr (DELTA d) + = pprInstr (COMMENT (_PK_ ("\tdelta = " ++ show d))) + pprInstr (SEGMENT TextSegment) = IF_ARCH_alpha(ptext SLIT("\t.text\n\t.align 3") {-word boundary-} ,IF_ARCH_sparc(ptext SLIT("\t.text\n\t.align 4") {-word boundary-} @@ -992,6 +996,11 @@ pprInstr g@(GST sz src addr) = pprG g (hcat [gtab, gpush src 0, gsemi, text "fstp", pprSize sz, gsp, pprAddr addr]) +pprInstr g@(GLDZ dst) + = pprG g (hcat [gtab, text "ffree %st(7) ; fldz ; ", gpop dst 1]) +pprInstr g@(GLD1 dst) + = pprG g (hcat [gtab, text "ffree %st(7) ; fld1 ; ", gpop dst 1]) + pprInstr g@(GFTOD src dst) = pprG g bogus pprInstr g@(GFTOI src dst) @@ -1085,6 +1094,9 @@ pprGInstr (GMOV src dst) = pprSizeRegReg SLIT("gmov") DF src dst pprGInstr (GLD sz src dst) = pprSizeAddrReg SLIT("gld") sz src dst pprGInstr (GST sz src dst) = pprSizeRegAddr SLIT("gst") sz src dst +pprGInstr (GLDZ dst) = pprSizeReg SLIT("gldz") DF dst +pprGInstr (GLD1 dst) = pprSizeReg SLIT("gld1") DF dst + pprGInstr (GFTOD src dst) = pprSizeSizeRegReg SLIT("gftod") F DF src dst pprGInstr (GFTOI src dst) = pprSizeSizeRegReg SLIT("gftoi") F L src dst @@ -1112,11 +1124,11 @@ Continue with I386-only printing bits and bobs: \begin{code} pprDollImm :: Imm -> SDoc -pprDollImm i = hcat [ ptext SLIT("$"), pprImm i] +pprDollImm i = ptext SLIT("$") <> pprImm i pprOperand :: Size -> Operand -> SDoc -pprOperand s (OpReg r) = pprReg s r -pprOperand s (OpImm i) = pprDollImm i +pprOperand s (OpReg r) = pprReg s r +pprOperand s (OpImm i) = pprDollImm i pprOperand s (OpAddr ea) = pprAddr ea pprSizeImmOp :: FAST_STRING -> Size -> Imm -> Operand -> SDoc @@ -1178,6 +1190,16 @@ pprSizeOpReg name size op1 reg pprReg size reg ] +pprSizeReg :: FAST_STRING -> Size -> Reg -> SDoc +pprSizeReg name size reg1 + = hcat [ + char '\t', + ptext name, + pprSize size, + space, + pprReg size reg1 + ] + pprSizeRegReg :: FAST_STRING -> Size -> Reg -> Reg -> SDoc pprSizeRegReg name size reg1 reg2 = hcat [ diff --git a/ghc/compiler/nativeGen/RegAllocInfo.lhs b/ghc/compiler/nativeGen/RegAllocInfo.lhs index 23aef3b035..2f3f5da6aa 100644 --- a/ghc/compiler/nativeGen/RegAllocInfo.lhs +++ b/ghc/compiler/nativeGen/RegAllocInfo.lhs @@ -54,14 +54,14 @@ module RegAllocInfo ( #include "HsVersions.h" import List ( partition ) +import OrdList ( unitOL ) import MachMisc import MachRegs -import MachCode ( InstrList ) +import MachCode ( InstrBlock ) import BitSet ( unitBS, mkBS, minusBS, unionBS, listBS, BitSet ) import CLabel ( pprCLabel_asm, CLabel{-instance Ord-} ) import FiniteMap ( addToFM, lookupFM, FiniteMap ) -import OrdList ( mkUnitList ) import PrimRep ( PrimRep(..) ) import UniqSet -- quite a bit of it import Outputable @@ -355,117 +355,121 @@ regUsage instr = case instr of #if i386_TARGET_ARCH regUsage instr = case instr of - MOV sz src dst -> usage2 src dst - MOVZxL sz src dst -> usage2 src dst - MOVSxL sz src dst -> usage2 src dst - LEA sz src dst -> usage2 src dst - ADD sz src dst -> usage2s src dst - SUB sz src dst -> usage2s src dst - IMUL sz src dst -> usage2s src dst - IDIV sz src -> usage (eax:edx:opToReg src) [eax,edx] - AND sz src dst -> usage2s src dst - OR sz src dst -> usage2s src dst - XOR sz src dst -> usage2s src dst - NOT sz op -> usage1 op - NEGI sz op -> usage1 op - SHL sz imm dst -> usage1 dst - SAR sz imm dst -> usage1 dst - SHR sz imm dst -> usage1 dst - BT sz imm src -> usage (opToReg src) [] - - PUSH sz op -> usage (opToReg op) [] - POP sz op -> usage [] (opToReg op) - TEST sz src dst -> usage (opToReg src ++ opToReg dst) [] - CMP sz src dst -> usage (opToReg src ++ opToReg dst) [] - SETCC cond op -> usage [] (opToReg op) - JXX cond lbl -> usage [] [] - JMP op -> usage (opToReg op) freeRegs - CALL imm -> usage [] callClobberedRegs - CLTD -> usage [eax] [edx] - NOP -> usage [] [] - - GMOV src dst -> usage [src] [dst] - GLD sz src dst -> usage (addrToRegs src) [dst] - GST sz src dst -> usage [src] (addrToRegs dst) - - GFTOD src dst -> usage [src] [dst] - GFTOI src dst -> usage [src] [dst] - - GDTOF src dst -> usage [src] [dst] - GDTOI src dst -> usage [src] [dst] - - GITOF src dst -> usage [src] [dst] - GITOD src dst -> usage [src] [dst] - - GADD sz s1 s2 dst -> usage [s1,s2] [dst] - GSUB sz s1 s2 dst -> usage [s1,s2] [dst] - GMUL sz s1 s2 dst -> usage [s1,s2] [dst] - GDIV sz s1 s2 dst -> usage [s1,s2] [dst] - - GCMP sz src1 src2 -> usage [src1,src2] [] - GABS sz src dst -> usage [src] [dst] - GNEG sz src dst -> usage [src] [dst] - GSQRT sz src dst -> usage [src] [dst] - GSIN sz src dst -> usage [src] [dst] - GCOS sz src dst -> usage [src] [dst] - GTAN sz src dst -> usage [src] [dst] + MOV sz src dst -> usageRW src dst + MOVZxL sz src dst -> usageRW src dst + MOVSxL sz src dst -> usageRW src dst + LEA sz src dst -> usageRW src dst + ADD sz src dst -> usageRM src dst + SUB sz src dst -> usageRM src dst + IMUL sz src dst -> usageRM src dst + IDIV sz src -> mkRU (eax:edx:use_R src) [eax,edx] + AND sz src dst -> usageRM src dst + OR sz src dst -> usageRM src dst + XOR sz src dst -> usageRM src dst + NOT sz op -> usageM op + NEGI sz op -> usageM op + SHL sz imm dst -> usageM dst + SAR sz imm dst -> usageM dst + SHR sz imm dst -> usageM dst + BT sz imm src -> mkRU (use_R src) [] + + PUSH sz op -> mkRU (use_R op) [] + POP sz op -> mkRU [] (def_W op) + TEST sz src dst -> mkRU (use_R src ++ use_R dst) [] + CMP sz src dst -> mkRU (use_R src ++ use_R dst) [] + SETCC cond op -> mkRU [] (def_W op) + JXX cond lbl -> mkRU [] [] + JMP op -> mkRU (use_R op) freeRegs + CALL imm -> mkRU [] callClobberedRegs + CLTD -> mkRU [eax] [edx] + NOP -> mkRU [] [] + + GMOV src dst -> mkRU [src] [dst] + GLD sz src dst -> mkRU (use_EA src) [dst] + GST sz src dst -> mkRU (src : use_EA dst) [] + + GLDZ dst -> mkRU [] [dst] + GLD1 dst -> mkRU [] [dst] + + GFTOD src dst -> mkRU [src] [dst] + GFTOI src dst -> mkRU [src] [dst] + + GDTOF src dst -> mkRU [src] [dst] + GDTOI src dst -> mkRU [src] [dst] + + GITOF src dst -> mkRU [src] [dst] + GITOD src dst -> mkRU [src] [dst] + + GADD sz s1 s2 dst -> mkRU [s1,s2] [dst] + GSUB sz s1 s2 dst -> mkRU [s1,s2] [dst] + GMUL sz s1 s2 dst -> mkRU [s1,s2] [dst] + GDIV sz s1 s2 dst -> mkRU [s1,s2] [dst] + + GCMP sz src1 src2 -> mkRU [src1,src2] [] + GABS sz src dst -> mkRU [src] [dst] + GNEG sz src dst -> mkRU [src] [dst] + GSQRT sz src dst -> mkRU [src] [dst] + GSIN sz src dst -> mkRU [src] [dst] + GCOS sz src dst -> mkRU [src] [dst] + GTAN sz src dst -> mkRU [src] [dst] COMMENT _ -> noUsage SEGMENT _ -> noUsage - LABEL _ -> noUsage - ASCII _ _ -> noUsage - DATA _ _ -> noUsage + LABEL _ -> noUsage + ASCII _ _ -> noUsage + DATA _ _ -> noUsage + DELTA _ -> noUsage _ -> pprPanic "regUsage(x86)" empty where - -- 2 operand form in which the second operand is purely a destination - usage2 :: Operand -> Operand -> RegUsage - usage2 op (OpReg reg) = usage (opToReg op) [reg] - usage2 op (OpAddr ea) = usage (opToReg op ++ addrToRegs ea) [] - usage2 op (OpImm imm) = usage (opToReg op) [] + -- 2 operand form; first operand Read; second Written + usageRW :: Operand -> Operand -> RegUsage + usageRW op (OpReg reg) = mkRU (use_R op) [reg] + usageRW op (OpAddr ea) = mkRU (use_R op ++ use_EA ea) [] - -- 2 operand form in which the second operand is also an input - usage2s :: Operand -> Operand -> RegUsage - usage2s op (OpReg reg) = usage (opToReg op ++ [reg]) [reg] - usage2s op (OpAddr ea) = usage (opToReg op ++ addrToRegs ea) [] - usage2s op (OpImm imm) = usage (opToReg op) [] + -- 2 operand form; first operand Read; second Modified + usageRM :: Operand -> Operand -> RegUsage + usageRM op (OpReg reg) = mkRU (use_R op ++ [reg]) [reg] + usageRM op (OpAddr ea) = mkRU (use_R op ++ use_EA ea) [] - -- 1 operand form in which the operand is both used and written - usage1 :: Operand -> RegUsage - usage1 (OpReg reg) = usage [reg] [reg] - usage1 (OpAddr ea) = usage (addrToRegs ea) [] - - allFPRegs = [fake0,fake1,fake2,fake3,fake4,fake5] + -- 1 operand form; operand Modified + usageM :: Operand -> RegUsage + usageM (OpReg reg) = mkRU [reg] [reg] + usageM (OpAddr ea) = mkRU (use_EA ea) [] --callClobberedRegs = [ eax, ecx, edx ] -- according to gcc, anyway. callClobberedRegs = [eax,fake0,fake1,fake2,fake3,fake4,fake5] --- General purpose register collecting functions. + -- Registers defd when an operand is written. + def_W (OpReg reg) = [reg] + def_W (OpAddr ea) = [] - opToReg (OpReg reg) = [reg] - opToReg (OpImm imm) = [] - opToReg (OpAddr ea) = addrToRegs ea + -- Registers used when an operand is read. + use_R (OpReg reg) = [reg] + use_R (OpImm imm) = [] + use_R (OpAddr ea) = use_EA ea - addrToRegs (AddrBaseIndex base index _) = baseToReg base ++ indexToReg index - where baseToReg Nothing = [] - baseToReg (Just r) = [r] - indexToReg Nothing = [] - indexToReg (Just (r,_)) = [r] - addrToRegs (ImmAddr _ _) = [] + -- Registers used to compute an effective address. + use_EA (ImmAddr _ _) = [] + use_EA (AddrBaseIndex Nothing Nothing _) = [] + use_EA (AddrBaseIndex (Just b) Nothing _) = [b] + use_EA (AddrBaseIndex Nothing (Just (i,_)) _) = [i] + use_EA (AddrBaseIndex (Just b) (Just (i,_)) _) = [b,i] - usage src dst = RU (mkRegSet (filter interesting src)) - (mkRegSet (filter interesting dst)) + mkRU src dst = RU (mkRegSet (filter interesting src)) + (mkRegSet (filter interesting dst)) interesting (FixedReg _) = False - interesting _ = True + interesting _ = True -- Allow the spiller to decide whether or not it can use --- %eax and %edx as spill temporaries. -hasFixedEAXorEDX instr = case instr of - IDIV _ _ -> True - CLTD -> True - other -> False +-- %edx as spill temporaries. +hasFixedEDX instr + = case instr of + IDIV _ _ -> True + CLTD -> True + other -> False #endif {- i386_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -570,25 +574,31 @@ findReservedRegs instrs error "findReservedRegs: sparc" #endif #if i386_TARGET_ARCH - -- Sigh. This is where it gets complicated. - = -- first of all, try without any at all. - map (map mappedRegNo) ( - [ [], - -- if that doesn't work, try one integer reg (which might fail) - -- and two float regs (which will always fix any float insns) - [ecx, fake4,fake5] - ] - -- dire straits (but still correct): see if we can bag %eax and %edx - ++ if any hasFixedEAXorEDX instrs - then [] -- bummer - else --[ [ecx,edx,fake4,fake5], - -- [ecx,edx,eax,fake4,fake5] ] - -- pro tem, don't use %eax until we institute a check that - -- instrs doesn't do a CALL insn, since that effectively - -- uses %eax in a fixed way - [ [ecx,edx,fake4,fake5] ] - - ) + -- We can use %fake4 and %fake5 safely for float temps. + -- Int regs are more troublesome. Only %ecx is definitely + -- available. If there are no division insns, we can use %edx + -- too. At a pinch, we also could bag %eax if there are no + -- divisions and no ccalls, but so far we've never encountered + -- a situation where three integer temporaries are necessary. + -- + -- Because registers are in short supply on x86, we give the + -- allocator a whole bunch of possibilities, starting with zero + -- temporaries and working up to all that are available. This + -- is inefficient, but spills are pretty rare, so we don't care + -- if the register allocator has to try half a dozen or so possibilities + -- before getting to one that works. + = let f1 = fake5 + f2 = fake4 + intregs_avail + = ecx : if any hasFixedEDX instrs then [] else [edx] + possibilities + = case intregs_avail of + [i1] -> [ [], [i1], [f1], [i1,f1], [f1,f2], [i1,f1,f2] ] + + [i1,i2] -> [ [], [i1], [f1], [i1,i2], [i1,f1], [f1,f2], + [i1,i2,f1], [i1,f1,f2], [i1,i2,f1,f2] ] + in + map (map mappedRegNo) possibilities #endif \end{code} @@ -764,6 +774,9 @@ patchRegs instr env = case instr of GLD sz src dst -> GLD sz (lookupAddr src) (env dst) GST sz src dst -> GST sz (env src) (lookupAddr dst) + GLDZ dst -> GLDZ (env dst) + GLD1 dst -> GLD1 (env dst) + GFTOD src dst -> GFTOD (env src) (env dst) GFTOI src dst -> GFTOI (env src) (env dst) @@ -791,6 +804,7 @@ patchRegs instr env = case instr of LABEL _ -> instr ASCII _ _ -> instr DATA _ _ -> instr + DELTA _ -> instr JXX _ _ -> instr CALL _ -> instr CLTD -> instr @@ -870,7 +884,7 @@ for a 64-bit arch) of slop. \begin{code} maxSpillSlots :: Int -maxSpillSlots = (rESERVED_C_STACK_BYTES - 64) `div` 8 +maxSpillSlots = (rESERVED_C_STACK_BYTES - 64) `div` 12 -- convert a spill slot number to a *byte* offset, with no sign: -- decide on a per arch basis whether you are spilling above or below @@ -878,45 +892,42 @@ maxSpillSlots = (rESERVED_C_STACK_BYTES - 64) `div` 8 spillSlotToOffset :: Int -> Int spillSlotToOffset slot | slot >= 0 && slot < maxSpillSlots - = 64 + 8 * slot + = 64 + 12 * slot | otherwise = pprPanic "spillSlotToOffset:" (text "invalid spill location: " <> int slot) -spillReg, loadReg :: Reg -> Reg -> InstrList +spillReg, loadReg :: Int -> Reg -> Reg -> Instr -spillReg dyn (MemoryReg i pk) +spillReg delta dyn (MemoryReg i pk) = let sz = primRepToSize pk off = spillSlotToOffset i in - mkUnitList ( {-Alpha: spill below the stack pointer (?)-} IF_ARCH_alpha( ST sz dyn (spRel (- (off `div` 8))) - {-I386: spill above stack pointer leaving 2 words/spill-} - ,IF_ARCH_i386 ( let off_w = off `div` 4 + {-I386: spill above stack pointer leaving 3 words/spill-} + ,IF_ARCH_i386 ( let off_w = (off-delta) `div` 4 in if pk == FloatRep || pk == DoubleRep - then GST DF dyn (spRel off_w) + then GST F80 dyn (spRel off_w) else MOV sz (OpReg dyn) (OpAddr (spRel off_w)) {-SPARC: spill below frame pointer leaving 2 words/spill-} ,IF_ARCH_sparc( ST sz dyn (fpRel (- (off `div` 4))) ,))) - ) + -loadReg (MemoryReg i pk) dyn +loadReg delta (MemoryReg i pk) dyn = let sz = primRepToSize pk off = spillSlotToOffset i in - mkUnitList ( IF_ARCH_alpha( LD sz dyn (spRel (- (off `div` 8))) - ,IF_ARCH_i386 ( let off_w = off `div` 4 + ,IF_ARCH_i386 ( let off_w = (off-delta) `div` 4 in if pk == FloatRep || pk == DoubleRep - then GLD DF (spRel off_w) dyn + then GLD F80 (spRel off_w) dyn else MOV sz (OpAddr (spRel off_w)) (OpReg dyn) ,IF_ARCH_sparc( LD sz (fpRel (- (off `div` 4))) dyn ,))) - ) \end{code} diff --git a/ghc/compiler/nativeGen/Stix.lhs b/ghc/compiler/nativeGen/Stix.lhs index 3b297a80ef..2b5b41ee98 100644 --- a/ghc/compiler/nativeGen/Stix.lhs +++ b/ghc/compiler/nativeGen/Stix.lhs @@ -5,13 +5,21 @@ \begin{code} module Stix ( CodeSegment(..), StixReg(..), StixTree(..), StixTreeList, - sStLitLbl, pprStixTrees, ppStixReg, + sStLitLbl, pprStixTrees, ppStixTree, ppStixReg, + stixCountTempUses, stixSubst, stgBaseReg, stgNode, stgSp, stgSu, stgSpLim, stgHp, stgHpLim, stgTagReg, stgR9, stgR10, - getUniqLabelNCG, - fixedHS, arrWordsHS, arrPtrsHS + fixedHS, arrWordsHS, arrPtrsHS, + + NatM, initNat, thenNat, returnNat, + mapNat, mapAndUnzipNat, + getUniqueNat, getDeltaNat, setDeltaNat, + NatM_State, mkNatM_State, + uniqOfNatM_State, deltaOfNatM_State, + + getUniqLabelNCG, getNatLabelNCG, ) where #include "HsVersions.h" @@ -26,7 +34,8 @@ import PrimRep ( PrimRep(..), showPrimRep ) import PrimOp ( PrimOp, pprPrimOp ) import Unique ( Unique ) import SMRep ( fixedHdrSize, arrWordsHdrSize, arrPtrsHdrSize ) -import UniqSupply ( returnUs, thenUs, getUniqueUs, UniqSM ) +import UniqSupply ( UniqSupply, splitUniqSupply, uniqFromSupply, + UniqSM, thenUs, returnUs, getUniqueUs ) import Outputable \end{code} @@ -129,32 +138,35 @@ paren t = char '(' <> t <> char ')' ppStixTree :: StixTree -> SDoc ppStixTree t = case t of - StSegment cseg -> paren (ppCodeSegment cseg) - StInt i -> paren (integer i) - StDouble rat -> paren (text "Double" <+> rational rat) - StString str -> paren (text "Str" <+> ptext str) - StComment str -> paren (text "Comment" <+> ptext str) - StLitLbl sd -> sd - StCLbl lbl -> pprCLabel lbl - StReg reg -> ppStixReg reg - StIndex k b o -> paren (ppStixTree b <+> char '+' <> - pprPrimRep k <+> ppStixTree o) - StInd k t -> pprPrimRep k <> char '[' <> ppStixTree t <> char ']' - StAssign k d s -> ppStixTree d <> text " :=" <> pprPrimRep k + StSegment cseg -> paren (ppCodeSegment cseg) + StInt i -> paren (integer i) + StDouble rat -> paren (text "Double" <+> rational rat) + StString str -> paren (text "Str" <+> ptext str) + StComment str -> paren (text "Comment" <+> ptext str) + StLitLbl sd -> sd + StCLbl lbl -> pprCLabel lbl + StReg reg -> ppStixReg reg + StIndex k b o -> paren (ppStixTree b <+> char '+' <> + pprPrimRep k <+> ppStixTree o) + StInd k t -> pprPrimRep k <> char '[' <> ppStixTree t <> char ']' + StAssign k d s -> ppStixTree d <> text " :=" <> pprPrimRep k <> text " " <> ppStixTree s - StLabel ll -> pprCLabel ll <+> char ':' - StFunBegin ll -> char ' ' $$ paren (text "FunBegin" <+> pprCLabel ll) - StFunEnd ll -> paren (text "FunEnd" <+> pprCLabel ll) - StJump t -> paren (text "Jump" <+> ppStixTree t) + StLabel ll -> pprCLabel ll <+> char ':' + StFunBegin ll -> char ' ' $$ paren (text "FunBegin" <+> pprCLabel ll) + StFunEnd ll -> paren (text "FunEnd" <+> pprCLabel ll) + StJump t -> paren (text "Jump" <+> ppStixTree t) StFallThrough ll -> paren (text "FallThru" <+> pprCLabel ll) - StCondJump l t -> paren (text "JumpC" <+> pprCLabel l <+> ppStixTree t) - StData k ds -> paren (text "Data" <+> pprPrimRep k <+> - hsep (map ppStixTree ds)) - StPrim op ts -> paren (text "Prim" <+> pprPrimOp op <+> hsep (map ppStixTree ts)) + StCondJump l t -> paren (text "JumpC" <+> pprCLabel l + <+> ppStixTree t) + StData k ds -> paren (text "Data" <+> pprPrimRep k <+> + hsep (map ppStixTree ds)) + StPrim op ts -> paren (text "Prim" <+> pprPrimOp op <+> + hsep (map ppStixTree ts)) StCall nm cc k args - -> paren (text "Call" <+> ptext nm <+> - pprCallConv cc <+> pprPrimRep k <+> hsep (map ppStixTree args)) - StScratchWord i -> text "ScratchWord" <> paren (int i) + -> paren (text "Call" <+> ptext nm <+> + pprCallConv cc <+> pprPrimRep k <+> + hsep (map ppStixTree args)) + StScratchWord i -> text "ScratchWord" <> paren (int i) pprPrimRep = text . showPrimRep \end{code} @@ -176,10 +188,12 @@ ppStixReg (StixTemp u pr) ppMId BaseReg = text "BaseReg" -ppMId (VanillaReg kind n) = hcat [pprPrimRep kind, text "IntReg(", int (I# n), char ')'] +ppMId (VanillaReg kind n) = hcat [pprPrimRep kind, text "IntReg(", + int (I# n), char ')'] ppMId (FloatReg n) = hcat [text "FltReg(", int (I# n), char ')'] ppMId (DoubleReg n) = hcat [text "DblReg(", int (I# n), char ')'] -ppMId (LongReg kind n) = hcat [pprPrimRep kind, text "LongReg(", int (I# n), char ')'] +ppMId (LongReg kind n) = hcat [pprPrimRep kind, text "LongReg(", + int (I# n), char ')'] ppMId Sp = text "Sp" ppMId Su = text "Su" ppMId SpLim = text "SpLim" @@ -216,12 +230,149 @@ stgHpLim = StReg (StixMagicId HpLim) stgR9 = StReg (StixMagicId (VanillaReg WordRep ILIT(9))) stgR10 = StReg (StixMagicId (VanillaReg WordRep ILIT(10))) +getNatLabelNCG :: NatM CLabel +getNatLabelNCG + = getUniqueNat `thenNat` \ u -> + returnNat (mkAsmTempLabel u) + getUniqLabelNCG :: UniqSM CLabel getUniqLabelNCG - = getUniqueUs `thenUs` \ u -> + = getUniqueUs `thenUs` \ u -> returnUs (mkAsmTempLabel u) fixedHS = StInt (toInteger fixedHdrSize) arrWordsHS = StInt (toInteger arrWordsHdrSize) arrPtrsHS = StInt (toInteger arrPtrsHdrSize) \end{code} + +Stix optimisation passes may wish to find out how many times a +given temporary appears in a tree, so as to be able to decide +whether or not to inline the assignment's RHS at usage site(s). + +\begin{code} +stixCountTempUses :: Unique -> StixTree -> Int +stixCountTempUses u t + = let qq = stixCountTempUses u + in + case t of + StReg reg + -> case reg of + StixTemp uu pr -> if u == uu then 1 else 0 + StixMagicId mid -> 0 + + StIndex pk t1 t2 -> qq t1 + qq t2 + StInd pk t1 -> qq t1 + StAssign pk t1 t2 -> qq t1 + qq t2 + StJump t1 -> qq t1 + StCondJump lbl t1 -> qq t1 + StData pk ts -> sum (map qq ts) + StPrim op ts -> sum (map qq ts) + StCall nm cconv pk ts -> sum (map qq ts) + + StSegment _ -> 0 + StInt _ -> 0 + StDouble _ -> 0 + StString _ -> 0 + StLitLbl _ -> 0 + StCLbl _ -> 0 + StLabel _ -> 0 + StFunBegin _ -> 0 + StFunEnd _ -> 0 + StFallThrough _ -> 0 + StScratchWord _ -> 0 + StComment _ -> 0 + + +stixSubst :: Unique -> StixTree -> StixTree -> StixTree +stixSubst u new_u in_this_tree + = stixMapUniques f in_this_tree + where + f :: Unique -> Maybe StixTree + f uu = if uu == u then Just new_u else Nothing + + +stixMapUniques :: (Unique -> Maybe StixTree) -> StixTree -> StixTree +stixMapUniques f t + = let qq = stixMapUniques f + in + case t of + StReg reg + -> case reg of + StixMagicId mid -> t + StixTemp uu pr + -> case f uu of + Just xx -> xx + Nothing -> t + + StIndex pk t1 t2 -> StIndex pk (qq t1) (qq t2) + StInd pk t1 -> StInd pk (qq t1) + StAssign pk t1 t2 -> StAssign pk (qq t1) (qq t2) + StJump t1 -> StJump (qq t1) + StCondJump lbl t1 -> StCondJump lbl (qq t1) + StData pk ts -> StData pk (map qq ts) + StPrim op ts -> StPrim op (map qq ts) + StCall nm cconv pk ts -> StCall nm cconv pk (map qq ts) + + StSegment _ -> t + StInt _ -> t + StDouble _ -> t + StString _ -> t + StLitLbl _ -> t + StCLbl _ -> t + StLabel _ -> t + StFunBegin _ -> t + StFunEnd _ -> t + StFallThrough _ -> t + StScratchWord _ -> t + StComment _ -> t +\end{code} + +\begin{code} +data NatM_State = NatM_State UniqSupply Int +type NatM result = NatM_State -> (result, NatM_State) + +mkNatM_State :: UniqSupply -> Int -> NatM_State +mkNatM_State = NatM_State + +uniqOfNatM_State (NatM_State us delta) = us +deltaOfNatM_State (NatM_State us delta) = delta + + +initNat :: NatM_State -> NatM a -> (a, NatM_State) +initNat init_st m = case m init_st of { (r,st) -> (r,st) } + +thenNat :: NatM a -> (a -> NatM b) -> NatM b +thenNat expr cont st + = case expr st of { (result, st') -> cont result st' } + +returnNat :: a -> NatM a +returnNat result st = (result, st) + +mapNat :: (a -> NatM b) -> [a] -> NatM [b] +mapNat f [] = returnNat [] +mapNat f (x:xs) + = f x `thenNat` \ r -> + mapNat f xs `thenNat` \ rs -> + returnNat (r:rs) + +mapAndUnzipNat :: (a -> NatM (b,c)) -> [a] -> NatM ([b],[c]) +mapAndUnzipNat f [] = returnNat ([],[]) +mapAndUnzipNat f (x:xs) + = f x `thenNat` \ (r1, r2) -> + mapAndUnzipNat f xs `thenNat` \ (rs1, rs2) -> + returnNat (r1:rs1, r2:rs2) + + +getUniqueNat :: NatM Unique +getUniqueNat (NatM_State us delta) + = case splitUniqSupply us of + (us1,us2) -> (uniqFromSupply us1, (NatM_State us2 delta)) + +getDeltaNat :: NatM Int +getDeltaNat st@(NatM_State us delta) + = (delta, st) + +setDeltaNat :: Int -> NatM () +setDeltaNat delta (NatM_State us _) + = ((), NatM_State us delta) +\end{code} diff --git a/ghc/compiler/nativeGen/StixInteger.lhs b/ghc/compiler/nativeGen/StixInteger.lhs index fbd96cf1a7..abd7306b15 100644 --- a/ghc/compiler/nativeGen/StixInteger.lhs +++ b/ghc/compiler/nativeGen/StixInteger.lhs @@ -20,7 +20,6 @@ import MachRegs import AbsCSyn hiding (spRel) -- bits and bobs.. import Const ( Literal(..) ) import CallConv ( cCallConv ) -import OrdList ( OrdList ) import PrimOp ( PrimOp(..) ) import PrimRep ( PrimRep(..) ) import SMRep ( arrWordsHdrSize ) diff --git a/ghc/compiler/nativeGen/StixMacro.lhs b/ghc/compiler/nativeGen/StixMacro.lhs index cf2cc8a90e..4af972d3c2 100644 --- a/ghc/compiler/nativeGen/StixMacro.lhs +++ b/ghc/compiler/nativeGen/StixMacro.lhs @@ -16,7 +16,6 @@ import AbsCSyn ( CStmtMacro(..), MagicId(..), CAddrMode, tagreg, CCheckMacro(..) ) import Constants ( uF_RET, uF_SU, uF_UPDATEE, uF_SIZE, sEQ_FRAME_SIZE ) import CallConv ( cCallConv ) -import OrdList ( OrdList ) import PrimOp ( PrimOp(..) ) import PrimRep ( PrimRep(..) ) import Stix diff --git a/ghc/compiler/utils/OrdList.lhs b/ghc/compiler/utils/OrdList.lhs index ccc4ea34ec..de95ef3e3d 100644 --- a/ghc/compiler/utils/OrdList.lhs +++ b/ghc/compiler/utils/OrdList.lhs @@ -4,54 +4,58 @@ This is useful, general stuff for the Native Code Generator. +Provide trees (of instructions), so that lists of instructions +can be appended in linear time. + \begin{code} module OrdList ( - OrdList, - - mkParList, mkSeqList, mkEmptyList, mkUnitList, + OrdList, + nilOL, isNilOL, unitOL, appOL, consOL, snocOL, concatOL, + fromOL, toOL +) where - flattenOrdList - ) where -\end{code} +infixl 5 `appOL` +infixl 5 `snocOL` +infixr 5 `consOL` -This section provides an ordering list that allows fine grain -parallelism to be expressed. This is used (ultimately) for scheduling -of assembly language instructions. - -\begin{code} data OrdList a - = SeqList (OrdList a) (OrdList a) - | ParList (OrdList a) (OrdList a) - | OrdObj a - | NoObj - deriving () - -mkSeqList a b = SeqList a b -mkParList a b = ParList a b -mkEmptyList = NoObj -mkUnitList = OrdObj -\end{code} - -%------------------------------------------------------------------------ + = Many (OrdList a) (OrdList a) + | One a + | None + +nilOL :: OrdList a +isNilOL :: OrdList a -> Bool + +unitOL :: a -> OrdList a +snocOL :: OrdList a -> a -> OrdList a +consOL :: a -> OrdList a -> OrdList a +appOL :: OrdList a -> OrdList a -> OrdList a +concatOL :: [OrdList a] -> OrdList a + +nilOL = None +unitOL as = One as +snocOL as b = Many as (One b) +consOL a bs = Many (One a) bs +concatOL aas = foldr Many None aas + +isNilOL None = True +isNilOL (One _) = False +isNilOL (Many as bs) = isNilOL as && isNilOL bs + +appOL None bs = bs +appOL as None = as +appOL as bs = Many as bs + +fromOL :: OrdList a -> [a] +fromOL ol + = flat ol [] + where + flat None rest = rest + flat (One x) rest = x:rest + flat (Many a b) rest = flat a (flat b rest) + +toOL :: [a] -> OrdList a +toOL [] = None +toOL (x:xs) = Many (One x) (toOL xs) -Notice this this throws away all potential expression of parallelism. - -\begin{code} -flattenOrdList :: OrdList a -> [a] - -flattenOrdList ol - = flat ol [] - where - flat NoObj rest = rest - flat (OrdObj x) rest = x:rest - flat (ParList a b) rest = flat a (flat b rest) - flat (SeqList a b) rest = flat a (flat b rest) - -{- DEBUGGING ONLY: -instance Text (OrdList a) where - showsPrec _ NoObj = showString "_N_" - showsPrec _ (OrdObj _) = showString "_O_" - showsPrec _ (ParList a b) = showString "(PAR " . shows a . showChar ')' - showsPrec _ (SeqList a b) = showString "(SEQ " . shows a . showChar ')' --} \end{code} diff --git a/ghc/includes/Constants.h b/ghc/includes/Constants.h index 604444aca0..dc6d3bdbe9 100644 --- a/ghc/includes/Constants.h +++ b/ghc/includes/Constants.h @@ -1,5 +1,5 @@ /* ---------------------------------------------------------------------------- - * $Id: Constants.h,v 1.10 2000/02/01 14:08:22 sewardj Exp $ + * $Id: Constants.h,v 1.11 2000/02/28 12:02:32 sewardj Exp $ * * (c) The GHC Team, 1998-1999 * @@ -201,7 +201,7 @@ world. Used in StgRun.S and StgCRun.c. -------------------------------------------------------------------------- */ -#define RESERVED_C_STACK_BYTES (1024 * SIZEOF_LONG) +#define RESERVED_C_STACK_BYTES (2048 * SIZEOF_LONG) /* ----------------------------------------------------------------------------- How much Haskell stack space to reserve for the saving of registers |