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