diff options
Diffstat (limited to 'compiler/nativeGen')
35 files changed, 277 insertions, 257 deletions
diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index 23aca9293c..7710691457 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -7,6 +7,7 @@ -- ----------------------------------------------------------------------------- \begin{code} +{-# LANGUAGE GADTs #-} module AsmCodeGen ( nativeCodeGen ) where #include "HsVersions.h" @@ -50,9 +51,11 @@ import NCGMonad import BlockId import CgUtils ( fixStgRegisters ) -import OldCmm +import Cmm +import CmmUtils +import Hoopl import CmmOpt ( cmmMachOpFold ) -import OldPprCmm +import PprCmm import CLabel import UniqFM @@ -290,8 +293,8 @@ nativeCodeGen' dflags ncgImpl h us cmms | gopt Opt_SplitObjs dflags = split_marker : tops | otherwise = tops - split_marker = CmmProc mapEmpty mkSplitMarkerLabel [] (ListGraph []) - + split_marker = CmmProc mapEmpty mkSplitMarkerLabel [] + (ofBlockList (panic "split_marker_entry") []) cmmNativeGenStream :: (Outputable statics, Outputable instr, Instruction instr) => DynFlags @@ -878,9 +881,9 @@ Ideas for other things we could do (put these in Hoopl please!): cmmToCmm :: DynFlags -> RawCmmDecl -> (RawCmmDecl, [CLabel]) cmmToCmm _ top@(CmmData _ _) = (top, []) -cmmToCmm dflags (CmmProc info lbl live (ListGraph blocks)) = runCmmOpt dflags $ do - blocks' <- mapM cmmBlockConFold blocks - return $ CmmProc info lbl live (ListGraph blocks') +cmmToCmm dflags (CmmProc info lbl live graph) = runCmmOpt dflags $ do + blocks' <- mapM cmmBlockConFold (toBlockList graph) + return $ CmmProc info lbl live (ofBlockList (g_entry graph) blocks') newtype CmmOptM a = CmmOptM (([CLabel], DynFlags) -> (# a, [CLabel] #)) @@ -903,10 +906,13 @@ runCmmOpt :: DynFlags -> CmmOptM a -> (a, [CLabel]) runCmmOpt dflags (CmmOptM f) = case f ([], dflags) of (# result, imports #) -> (result, imports) -cmmBlockConFold :: CmmBasicBlock -> CmmOptM CmmBasicBlock -cmmBlockConFold (BasicBlock id stmts) = do +cmmBlockConFold :: CmmBlock -> CmmOptM CmmBlock +cmmBlockConFold block = do + let (entry, middle, last) = blockSplit block + stmts = blockToList middle stmts' <- mapM cmmStmtConFold stmts - return $ BasicBlock id stmts' + last' <- cmmStmtConFold last + return $ blockJoin entry (blockFromList stmts') last' -- This does three optimizations, but they're very quick to check, so we don't -- bother turning them off even when the Hoopl code is active. Since @@ -917,13 +923,13 @@ cmmBlockConFold (BasicBlock id stmts) = do -- We might be tempted to skip this step entirely of not Opt_PIC, but -- there is some PowerPC code for the non-PIC case, which would also -- have to be separated. -cmmStmtConFold :: CmmStmt -> CmmOptM CmmStmt +cmmStmtConFold :: CmmNode e x -> CmmOptM (CmmNode e x) cmmStmtConFold stmt = case stmt of CmmAssign reg src -> do src' <- cmmExprConFold DataReference src return $ case src' of - CmmReg reg' | reg == reg' -> CmmNop + CmmReg reg' | reg == reg' -> CmmComment (fsLit "nop") new_src -> CmmAssign reg new_src CmmStore addr src @@ -931,35 +937,27 @@ cmmStmtConFold stmt src' <- cmmExprConFold DataReference src return $ CmmStore addr' src' - CmmJump addr live + CmmCall { cml_target = addr } -> do addr' <- cmmExprConFold JumpReference addr - return $ CmmJump addr' live + return $ stmt { cml_target = addr' } - CmmCall target regs args returns + CmmUnsafeForeignCall target regs args -> do target' <- case target of - CmmCallee e conv -> do + ForeignTarget e conv -> do e' <- cmmExprConFold CallReference e - return $ CmmCallee e' conv - op@(CmmPrim _ Nothing) -> - return op - CmmPrim op (Just stmts) -> - do stmts' <- mapM cmmStmtConFold stmts - return $ CmmPrim op (Just stmts') - args' <- mapM (\(CmmHinted arg hint) -> do - arg' <- cmmExprConFold DataReference arg - return (CmmHinted arg' hint)) args - return $ CmmCall target' regs args' returns - - CmmCondBranch test dest + return $ ForeignTarget e' conv + PrimTarget _ -> + return target + args' <- mapM (cmmExprConFold DataReference) args + return $ CmmUnsafeForeignCall target' regs args' + + CmmCondBranch test true false -> do test' <- cmmExprConFold DataReference test dflags <- getDynFlags return $ case test' of - CmmLit (CmmInt 0 _) -> - CmmComment (mkFastString ("deleted: " ++ - showSDoc dflags (pprStmt stmt))) - - CmmLit (CmmInt _ _) -> CmmBranch dest - _other -> CmmCondBranch test' dest + CmmLit (CmmInt 0 _) -> CmmBranch false + CmmLit (CmmInt _ _) -> CmmBranch true + _other -> CmmCondBranch test' true false CmmSwitch expr ids -> do expr' <- cmmExprConFold DataReference expr diff --git a/compiler/nativeGen/Instruction.hs b/compiler/nativeGen/Instruction.hs index 86f5ae435d..48d6a33d79 100644 --- a/compiler/nativeGen/Instruction.hs +++ b/compiler/nativeGen/Instruction.hs @@ -2,9 +2,12 @@ module Instruction ( RegUsage(..), noUsage, + GenBasicBlock(..), blockId, + ListGraph(..), NatCmm, NatCmmDecl, NatBasicBlock, + topInfoTable, Instruction(..) ) @@ -14,8 +17,9 @@ import Reg import BlockId import DynFlags -import OldCmm +import Cmm hiding (topInfoTable) import Platform +import Outputable -- | Holds a list of source and destination registers used by a -- particular instruction. @@ -34,7 +38,6 @@ data RegUsage noUsage :: RegUsage noUsage = RU [] [] - -- Our flavours of the Cmm types -- Type synonyms for Cmm populated with native code type NatCmm instr @@ -54,6 +57,13 @@ type NatBasicBlock instr = GenBasicBlock instr +-- | Returns the info table associated with the CmmDecl's entry point, +-- if any. +topInfoTable :: GenCmmDecl a (BlockEnv i) (ListGraph b) -> Maybe i +topInfoTable (CmmProc infos _ _ (ListGraph (b:_))) + = mapLookup (blockId b) infos +topInfoTable _ + = Nothing -- | Common things that we can do with instructions, on all architectures. diff --git a/compiler/nativeGen/PIC.hs b/compiler/nativeGen/PIC.hs index 69f3e29add..e346e7b365 100644 --- a/compiler/nativeGen/PIC.hs +++ b/compiler/nativeGen/PIC.hs @@ -59,7 +59,7 @@ import NCGMonad import Hoopl -import OldCmm +import Cmm import CLabel ( CLabel, ForeignLabelSource(..), pprCLabel, mkDynamicLinkerLabel, DynamicLinkerLabelInfo(..), dynamicLinkerLabelInfo, mkPicBaseLabel, diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs index 848c7f933c..5e05047f34 100644 --- a/compiler/nativeGen/PPC/CodeGen.hs +++ b/compiler/nativeGen/PPC/CodeGen.hs @@ -12,6 +12,7 @@ -- (c) the #if blah_TARGET_ARCH} things, the -- structure should not be too overwhelming. +{-# LANGUAGE GADTs #-} module PPC.CodeGen ( cmmTopCodeGen, generateJumpTableForInstr, @@ -42,8 +43,10 @@ import Platform -- Our intermediate code: import BlockId import PprCmm ( pprExpr ) -import OldCmm +import Cmm +import CmmUtils import CLabel +import Hoopl -- The rest: import OrdList @@ -71,7 +74,8 @@ cmmTopCodeGen :: RawCmmDecl -> NatM [NatCmmDecl CmmStatics Instr] -cmmTopCodeGen (CmmProc info lab live (ListGraph blocks)) = do +cmmTopCodeGen (CmmProc info lab live graph) = do + let blocks = toBlockListEntryFirst graph (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks picBaseMb <- getPicBaseMaybeNat dflags <- getDynFlags @@ -86,12 +90,16 @@ cmmTopCodeGen (CmmData sec dat) = do return [CmmData sec dat] -- no translation, we just use CmmStatic basicBlockCodeGen - :: CmmBasicBlock + :: Block CmmNode C C -> NatM ( [NatBasicBlock Instr] , [NatCmmDecl CmmStatics Instr]) -basicBlockCodeGen (BasicBlock id stmts) = do - instrs <- stmtsToInstrs stmts +basicBlockCodeGen block = do + let (CmmEntry id, nodes, tail) = blockSplit block + stmts = blockToList nodes + mid_instrs <- stmtsToInstrs stmts + tail_instrs <- stmtToInstrs tail + let instrs = mid_instrs `appOL` tail_instrs -- code generation may introduce new basic block boundaries, which -- are indicated by the NEWBLOCK instruction. We must split up the -- instruction stream into basic blocks again. Also, we extract @@ -107,16 +115,15 @@ basicBlockCodeGen (BasicBlock id stmts) = do = (instr:instrs, blocks, statics) return (BasicBlock id top : other_blocks, statics) -stmtsToInstrs :: [CmmStmt] -> NatM InstrBlock +stmtsToInstrs :: [CmmNode e x] -> NatM InstrBlock stmtsToInstrs stmts = do instrss <- mapM stmtToInstrs stmts return (concatOL instrss) -stmtToInstrs :: CmmStmt -> NatM InstrBlock +stmtToInstrs :: CmmNode e x -> NatM InstrBlock stmtToInstrs stmt = do dflags <- getDynFlags case stmt of - CmmNop -> return nilOL CmmComment s -> return (unitOL (COMMENT s)) CmmAssign reg src @@ -135,16 +142,18 @@ stmtToInstrs stmt = do where ty = cmmExprType dflags src size = cmmTypeSize ty - CmmCall target result_regs args _ + CmmUnsafeForeignCall target result_regs args -> genCCall target result_regs args CmmBranch id -> genBranch id - CmmCondBranch arg id -> genCondJump id arg + CmmCondBranch arg true false -> do b1 <- genCondJump true arg + b2 <- genBranch false + return (b1 `appOL` b2) CmmSwitch arg ids -> do dflags <- getDynFlags genSwitch dflags arg ids - CmmJump arg _ -> genJump arg - CmmReturn -> - panic "stmtToInstrs: return statement should have been cps'd away" + CmmCall { cml_target = arg } -> genJump arg + _ -> + panic "stmtToInstrs: statement should have been cps'd away" -------------------------------------------------------------------------------- @@ -837,9 +846,9 @@ genCondJump id bool = do -- (If applicable) Do not fill the delay slots here; you will confuse the -- register allocator. -genCCall :: CmmCallTarget -- function to call - -> [HintedCmmFormal] -- where to put the result - -> [HintedCmmActual] -- arguments (of mixed type) +genCCall :: ForeignTarget -- function to call + -> [CmmFormal] -- where to put the result + -> [CmmActual] -- arguments (of mixed type) -> NatM InstrBlock genCCall target dest_regs argsAndHints = do dflags <- getDynFlags @@ -854,9 +863,9 @@ data GenCCallPlatform = GCPLinux | GCPDarwin genCCall' :: DynFlags -> GenCCallPlatform - -> CmmCallTarget -- function to call - -> [HintedCmmFormal] -- where to put the result - -> [HintedCmmActual] -- arguments (of mixed type) + -> ForeignTarget -- function to call + -> [CmmFormal] -- where to put the result + -> [CmmActual] -- arguments (of mixed type) -> NatM InstrBlock {- @@ -897,13 +906,13 @@ genCCall' -} -genCCall' _ _ (CmmPrim MO_WriteBarrier _) _ _ +genCCall' _ _ (PrimTarget MO_WriteBarrier) _ _ = return $ unitOL LWSYNC -genCCall' _ _ (CmmPrim _ (Just stmts)) _ _ - = stmtsToInstrs stmts +genCCall' _ _ (PrimTarget MO_Touch) _ _ + = return $ nilOL -genCCall' dflags gcp target dest_regs argsAndHints +genCCall' dflags gcp target dest_regs args0 = ASSERT (not $ any (`elem` [II16]) $ map cmmTypeSize argReps) -- we rely on argument promotion in the codeGen do @@ -915,9 +924,9 @@ genCCall' dflags gcp target dest_regs argsAndHints (toOL []) [] (labelOrExpr, reduceToFF32) <- case target of - CmmCallee (CmmLit (CmmLabel lbl)) _ -> return (Left lbl, False) - CmmCallee expr _ -> return (Right expr, False) - CmmPrim mop _ -> outOfLineMachOp mop + ForeignTarget (CmmLit (CmmLabel lbl)) _ -> return (Left lbl, False) + ForeignTarget expr _ -> return (Right expr, False) + PrimTarget mop -> outOfLineMachOp mop let codeBefore = move_sp_down finalStack `appOL` passArgumentsCode codeAfter = move_sp_up finalStack `appOL` moveResult reduceToFF32 @@ -948,17 +957,16 @@ genCCall' dflags gcp target dest_regs argsAndHints GCPLinux -> roundTo 16 finalStack -- need to remove alignment information - argsAndHints' | CmmPrim mop _ <- target, + args | PrimTarget mop <- target, (mop == MO_Memcpy || mop == MO_Memset || mop == MO_Memmove) - = init argsAndHints + = init args0 | otherwise - = argsAndHints + = args0 - args = map hintlessCmm argsAndHints' - argReps = map (cmmExprType dflags) args + argReps = map (cmmExprType dflags) args0 roundTo a x | x `mod` a == 0 = x | otherwise = x + a - (x `mod` a) @@ -1086,7 +1094,7 @@ genCCall' dflags gcp target dest_regs argsAndHints moveResult reduceToFF32 = case dest_regs of [] -> nilOL - [CmmHinted dest _hint] + [dest] | reduceToFF32 && isFloat32 rep -> unitOL (FRSP r_dest f1) | isFloat32 rep || isFloat64 rep -> unitOL (MR r_dest f1) | isWord64 rep -> toOL [MR (getHiVRegFromLo r_dest) r3, diff --git a/compiler/nativeGen/PPC/Instr.hs b/compiler/nativeGen/PPC/Instr.hs index 1f5e809abb..40827d4a6f 100644 --- a/compiler/nativeGen/PPC/Instr.hs +++ b/compiler/nativeGen/PPC/Instr.hs @@ -36,7 +36,7 @@ import Reg import CodeGen.Platform import BlockId import DynFlags -import OldCmm +import Cmm import FastString import CLabel import Outputable diff --git a/compiler/nativeGen/PPC/Ppr.hs b/compiler/nativeGen/PPC/Ppr.hs index 045ce8d48e..cbeabdd8a9 100644 --- a/compiler/nativeGen/PPC/Ppr.hs +++ b/compiler/nativeGen/PPC/Ppr.hs @@ -30,7 +30,7 @@ import Reg import RegClass import TargetReg -import OldCmm +import Cmm hiding (topInfoTable) import BlockId import CLabel diff --git a/compiler/nativeGen/PPC/RegInfo.hs b/compiler/nativeGen/PPC/RegInfo.hs index 2b74d1daea..0fd93e17d0 100644 --- a/compiler/nativeGen/PPC/RegInfo.hs +++ b/compiler/nativeGen/PPC/RegInfo.hs @@ -29,7 +29,7 @@ where import PPC.Instr import BlockId -import OldCmm +import Cmm import CLabel import Unique diff --git a/compiler/nativeGen/PPC/Regs.hs b/compiler/nativeGen/PPC/Regs.hs index d4123aca84..f92351bd22 100644 --- a/compiler/nativeGen/PPC/Regs.hs +++ b/compiler/nativeGen/PPC/Regs.hs @@ -50,7 +50,7 @@ import Reg import RegClass import Size -import OldCmm +import Cmm import CLabel ( CLabel ) import Unique diff --git a/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs b/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs index c4fb7ac378..8a0d2165bb 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs @@ -19,7 +19,7 @@ import RegAlloc.Liveness import Instruction import Reg -import OldCmm +import Cmm import Bag import Digraph import UniqFM diff --git a/compiler/nativeGen/RegAlloc/Graph/Spill.hs b/compiler/nativeGen/RegAlloc/Graph/Spill.hs index 25bd313826..dbfde5c25b 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Spill.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Spill.hs @@ -11,7 +11,7 @@ where import RegAlloc.Liveness import Instruction import Reg -import OldCmm hiding (RegSet) +import Cmm hiding (RegSet) import BlockId import State diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs index 7f86b9a884..a216d975dc 100644 --- a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs +++ b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs @@ -39,7 +39,7 @@ import Instruction import Reg import BlockId -import OldCmm +import Cmm import UniqSet import UniqFM import Unique diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs index 879597fd88..a2d9e1a91a 100644 --- a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs +++ b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs @@ -31,7 +31,7 @@ import Reg import GraphBase import BlockId -import OldCmm +import Cmm import UniqFM import UniqSet import Digraph (flattenSCCs) diff --git a/compiler/nativeGen/RegAlloc/Graph/Stats.hs b/compiler/nativeGen/RegAlloc/Graph/Stats.hs index f85cdb7eff..61a8400faa 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Stats.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Stats.hs @@ -27,8 +27,7 @@ import RegClass import Reg import TargetReg -import OldCmm -import OldPprCmm() +import PprCmm() import Outputable import UniqFM import UniqSet diff --git a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs index 6294743c48..768ddab788 100644 --- a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs +++ b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs @@ -17,7 +17,6 @@ import Instruction import Reg import BlockId -import OldCmm hiding (RegSet) import Digraph import DynFlags import Outputable diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs index fc5b992603..fa71457808 100644 --- a/compiler/nativeGen/RegAlloc/Linear/Main.hs +++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs @@ -116,7 +116,7 @@ import Instruction import Reg import BlockId -import OldCmm hiding (RegSet) +import Cmm hiding (RegSet) import Digraph import DynFlags @@ -743,12 +743,13 @@ allocateRegsAndSpill reading keep spills alloc (r:rs) Just (InMem slot) | reading -> doSpill (ReadMem slot) | otherwise -> doSpill WriteMem Nothing | reading -> - -- pprPanic "allocateRegsAndSpill: Cannot read from uninitialized register" (ppr r) - -- ToDo: This case should be a panic, but we - -- sometimes see an unreachable basic block which - -- triggers this because the register allocator - -- will start with an empty assignment. - doSpill WriteNew + pprPanic "allocateRegsAndSpill: Cannot read from uninitialized register" (ppr r) + -- NOTE: if the input to the NCG contains some + -- unreachable blocks with junk code, this panic + -- might be triggered. Make sure you only feed + -- sensible code into the NCG. In CmmPipeline we + -- call removeUnreachableBlocks at the end for this + -- reason. | otherwise -> doSpill WriteNew diff --git a/compiler/nativeGen/RegAlloc/Linear/Stats.hs b/compiler/nativeGen/RegAlloc/Linear/Stats.hs index bfd196ac05..d8ca77537d 100644 --- a/compiler/nativeGen/RegAlloc/Linear/Stats.hs +++ b/compiler/nativeGen/RegAlloc/Linear/Stats.hs @@ -17,8 +17,6 @@ import RegAlloc.Linear.Base import RegAlloc.Liveness import Instruction -import OldCmm (GenBasicBlock(..)) - import UniqFM import Outputable diff --git a/compiler/nativeGen/RegAlloc/Liveness.hs b/compiler/nativeGen/RegAlloc/Liveness.hs index 12c138897c..f49155e827 100644 --- a/compiler/nativeGen/RegAlloc/Liveness.hs +++ b/compiler/nativeGen/RegAlloc/Liveness.hs @@ -33,8 +33,8 @@ import Reg import Instruction import BlockId -import OldCmm hiding (RegSet) -import OldPprCmm() +import Cmm hiding (RegSet) +import PprCmm() import Digraph import DynFlags @@ -690,10 +690,11 @@ regLiveness platform (CmmProc info lbl live sccs) -- ----------------------------------------------------------------------------- -- | Check ordering of Blocks --- The computeLiveness function requires SCCs to be in reverse dependent order. --- If they're not the liveness information will be wrong, and we'll get a bad allocation. --- Better to check for this precondition explicitly or some other poor sucker will --- waste a day staring at bad assembly code.. +-- The computeLiveness function requires SCCs to be in reverse +-- dependent order. If they're not the liveness information will be +-- wrong, and we'll get a bad allocation. Better to check for this +-- precondition explicitly or some other poor sucker will waste a +-- day staring at bad assembly code.. -- checkIsReverseDependent :: Instruction instr diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs index c4efdf677e..f3b70e7e61 100644 --- a/compiler/nativeGen/SPARC/CodeGen.hs +++ b/compiler/nativeGen/SPARC/CodeGen.hs @@ -6,6 +6,7 @@ -- ----------------------------------------------------------------------------- +{-# LANGUAGE GADTs #-} module SPARC.CodeGen ( cmmTopCodeGen, generateJumpTableForInstr, @@ -38,7 +39,9 @@ import NCGMonad -- Our intermediate code: import BlockId -import OldCmm +import Cmm +import CmmUtils +import Hoopl import PIC import Reg import CLabel @@ -59,8 +62,9 @@ import Control.Monad ( mapAndUnzipM ) cmmTopCodeGen :: RawCmmDecl -> NatM [NatCmmDecl CmmStatics Instr] -cmmTopCodeGen (CmmProc info lab live (ListGraph blocks)) - = do (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks +cmmTopCodeGen (CmmProc info lab live graph) + = do let blocks = toBlockListEntryFirst graph + (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks let proc = CmmProc info lab live (ListGraph $ concat nat_blocks) let tops = proc : concat statics @@ -76,12 +80,16 @@ cmmTopCodeGen (CmmData sec dat) = do -- are indicated by the NEWBLOCK instruction. We must split up the -- instruction stream into basic blocks again. Also, we extract -- LDATAs here too. -basicBlockCodeGen :: CmmBasicBlock +basicBlockCodeGen :: CmmBlock -> NatM ( [NatBasicBlock Instr] , [NatCmmDecl CmmStatics Instr]) -basicBlockCodeGen cmm@(BasicBlock id stmts) = do - instrs <- stmtsToInstrs stmts +basicBlockCodeGen block = do + let (CmmEntry id, nodes, tail) = blockSplit block + stmts = blockToList nodes + mid_instrs <- stmtsToInstrs stmts + tail_instrs <- stmtToInstrs tail + let instrs = mid_instrs `appOL` tail_instrs let (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs @@ -97,24 +105,23 @@ basicBlockCodeGen cmm@(BasicBlock id stmts) = do -- do intra-block sanity checking blocksChecked - = map (checkBlock cmm) + = map (checkBlock block) $ BasicBlock id top : other_blocks return (blocksChecked, statics) -- | Convert some Cmm statements to SPARC instructions. -stmtsToInstrs :: [CmmStmt] -> NatM InstrBlock +stmtsToInstrs :: [CmmNode e x] -> NatM InstrBlock stmtsToInstrs stmts = do instrss <- mapM stmtToInstrs stmts return (concatOL instrss) -stmtToInstrs :: CmmStmt -> NatM InstrBlock +stmtToInstrs :: CmmNode e x -> NatM InstrBlock stmtToInstrs stmt = do dflags <- getDynFlags case stmt of - CmmNop -> return nilOL CmmComment s -> return (unitOL (COMMENT s)) CmmAssign reg src @@ -131,17 +138,19 @@ stmtToInstrs stmt = do where ty = cmmExprType dflags src size = cmmTypeSize ty - CmmCall target result_regs args _ + CmmUnsafeForeignCall target result_regs args -> genCCall target result_regs args CmmBranch id -> genBranch id - CmmCondBranch arg id -> genCondJump id arg + CmmCondBranch arg true false -> do b1 <- genCondJump true arg + b2 <- genBranch false + return (b1 `appOL` b2) CmmSwitch arg ids -> do dflags <- getDynFlags genSwitch dflags arg ids - CmmJump arg _ -> genJump arg + CmmCall { cml_target = arg } -> genJump arg - CmmReturn - -> panic "stmtToInstrs: return statement should have been cps'd away" + _ + -> panic "stmtToInstrs: statement should have been cps'd away" {- @@ -369,9 +378,9 @@ generateJumpTableForInstr _ _ = Nothing -} genCCall - :: CmmCallTarget -- function to call - -> [HintedCmmFormal] -- where to put the result - -> [HintedCmmActual] -- arguments (of mixed type) + :: ForeignTarget -- function to call + -> [CmmFormal] -- where to put the result + -> [CmmActual] -- arguments (of mixed type) -> NatM InstrBlock @@ -382,28 +391,20 @@ genCCall -- -- In the SPARC case we don't need a barrier. -- -genCCall (CmmPrim (MO_WriteBarrier) _) _ _ +genCCall (PrimTarget MO_WriteBarrier) _ _ = do return nilOL -genCCall (CmmPrim _ (Just stmts)) _ _ - = stmtsToInstrs stmts - -genCCall target dest_regs argsAndHints +genCCall target dest_regs args0 = do -- need to remove alignment information - let argsAndHints' | CmmPrim mop _ <- target, + let args | PrimTarget mop <- target, (mop == MO_Memcpy || mop == MO_Memset || mop == MO_Memmove) - = init argsAndHints + = init args0 | otherwise - = argsAndHints - - -- strip hints from the arg regs - let args :: [CmmExpr] - args = map hintlessCmm argsAndHints' - + = args0 -- work out the arguments, and assign them to integer regs argcode_and_vregs <- mapM arg_to_int_vregs args @@ -416,14 +417,14 @@ genCCall target dest_regs argsAndHints -- deal with static vs dynamic call targets callinsns <- case target of - CmmCallee (CmmLit (CmmLabel lbl)) _ -> + ForeignTarget (CmmLit (CmmLabel lbl)) _ -> return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False)) - CmmCallee expr _ + ForeignTarget expr _ -> do (dyn_c, [dyn_r]) <- arg_to_int_vregs expr return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False) - CmmPrim mop _ + PrimTarget mop -> do res <- outOfLineMachOp mop lblOrMopExpr <- case res of Left lbl -> do @@ -539,11 +540,11 @@ move_final (v:vs) (a:az) offset -- | Assign results returned from the call into their -- desination regs. -- -assign_code :: Platform -> [CmmHinted LocalReg] -> OrdList Instr +assign_code :: Platform -> [LocalReg] -> OrdList Instr assign_code _ [] = nilOL -assign_code platform [CmmHinted dest _hint] +assign_code platform [dest] = let rep = localRegType dest width = typeWidth rep r_dest = getRegisterReg platform (CmmLocal dest) diff --git a/compiler/nativeGen/SPARC/CodeGen/Amode.hs b/compiler/nativeGen/SPARC/CodeGen/Amode.hs index 139064ccbd..7871569dba 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Amode.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Amode.hs @@ -22,7 +22,7 @@ import SPARC.Base import NCGMonad import Size -import OldCmm +import Cmm import OrdList diff --git a/compiler/nativeGen/SPARC/CodeGen/Base.hs b/compiler/nativeGen/SPARC/CodeGen/Base.hs index 367d9230ba..16384f102a 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Base.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Base.hs @@ -30,8 +30,7 @@ import Reg import CodeGen.Platform import DynFlags -import OldCmm -import OldPprCmm () +import Cmm import Platform import Outputable diff --git a/compiler/nativeGen/SPARC/CodeGen/CondCode.hs b/compiler/nativeGen/SPARC/CodeGen/CondCode.hs index d459d98212..0e94d67a24 100644 --- a/compiler/nativeGen/SPARC/CodeGen/CondCode.hs +++ b/compiler/nativeGen/SPARC/CodeGen/CondCode.hs @@ -24,7 +24,7 @@ import SPARC.Base import NCGMonad import Size -import OldCmm +import Cmm import OrdList import Outputable diff --git a/compiler/nativeGen/SPARC/CodeGen/Expand.hs b/compiler/nativeGen/SPARC/CodeGen/Expand.hs index fa397771d7..16b9b42fcd 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Expand.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Expand.hs @@ -21,7 +21,7 @@ import SPARC.Ppr () import Instruction import Reg import Size -import OldCmm +import Cmm import Outputable diff --git a/compiler/nativeGen/SPARC/CodeGen/Gen32.hs b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs index f7c7419e15..3e255365b9 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Gen32.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs @@ -29,7 +29,7 @@ import NCGMonad import Size import Reg -import OldCmm +import Cmm import Control.Monad (liftM) import DynFlags diff --git a/compiler/nativeGen/SPARC/CodeGen/Gen32.hs-boot b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs-boot index 7de92cb659..43632c676d 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Gen32.hs-boot +++ b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs-boot @@ -10,7 +10,7 @@ import SPARC.CodeGen.Base import NCGMonad import Reg -import OldCmm +import Cmm getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock) getRegister :: CmmExpr -> NatM Register diff --git a/compiler/nativeGen/SPARC/CodeGen/Gen64.hs b/compiler/nativeGen/SPARC/CodeGen/Gen64.hs index 654875c497..7b39a371d7 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Gen64.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Gen64.hs @@ -28,7 +28,7 @@ import Instruction import Size import Reg -import OldCmm +import Cmm import DynFlags import OrdList diff --git a/compiler/nativeGen/SPARC/CodeGen/Sanity.hs b/compiler/nativeGen/SPARC/CodeGen/Sanity.hs index 7eb8bb4a53..ac8b175802 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Sanity.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Sanity.hs @@ -19,14 +19,14 @@ import SPARC.Instr import SPARC.Ppr () import Instruction -import OldCmm +import Cmm import Outputable -- | Enforce intra-block invariants. -- -checkBlock :: CmmBasicBlock +checkBlock :: CmmBlock -> NatBasicBlock Instr -> NatBasicBlock Instr diff --git a/compiler/nativeGen/SPARC/Imm.hs b/compiler/nativeGen/SPARC/Imm.hs index fe64738f7b..77761fcf35 100644 --- a/compiler/nativeGen/SPARC/Imm.hs +++ b/compiler/nativeGen/SPARC/Imm.hs @@ -15,7 +15,7 @@ module SPARC.Imm ( where -import OldCmm +import Cmm import CLabel import Outputable diff --git a/compiler/nativeGen/SPARC/Instr.hs b/compiler/nativeGen/SPARC/Instr.hs index f55c660118..4896d414a2 100644 --- a/compiler/nativeGen/SPARC/Instr.hs +++ b/compiler/nativeGen/SPARC/Instr.hs @@ -47,7 +47,7 @@ import CLabel import CodeGen.Platform import BlockId import DynFlags -import OldCmm +import Cmm import FastString import FastBool import Outputable diff --git a/compiler/nativeGen/SPARC/Ppr.hs b/compiler/nativeGen/SPARC/Ppr.hs index 9bfa3141cc..601b5288a0 100644 --- a/compiler/nativeGen/SPARC/Ppr.hs +++ b/compiler/nativeGen/SPARC/Ppr.hs @@ -35,8 +35,8 @@ import Reg import Size import PprBase -import OldCmm -import OldPprCmm() +import Cmm hiding (topInfoTable) +import PprCmm() import CLabel import BlockId diff --git a/compiler/nativeGen/SPARC/ShortcutJump.hs b/compiler/nativeGen/SPARC/ShortcutJump.hs index 5d63fd73a1..bd66d04fa1 100644 --- a/compiler/nativeGen/SPARC/ShortcutJump.hs +++ b/compiler/nativeGen/SPARC/ShortcutJump.hs @@ -21,7 +21,7 @@ import SPARC.Imm import CLabel import BlockId -import OldCmm +import Cmm import Panic import Unique diff --git a/compiler/nativeGen/Size.hs b/compiler/nativeGen/Size.hs index 99e5de679b..66f7422c31 100644 --- a/compiler/nativeGen/Size.hs +++ b/compiler/nativeGen/Size.hs @@ -30,7 +30,7 @@ module Size ( where -import OldCmm +import Cmm import Outputable -- It looks very like the old MachRep, but it's now of purely local diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index b3160ed2ca..36f9e2d231 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -10,6 +10,7 @@ -- (a) the sectioning, and (b) the type signatures, the -- structure should not be too overwhelming. +{-# LANGUAGE GADTs #-} module X86.CodeGen ( cmmTopCodeGen, generateJumpTableForInstr, @@ -41,8 +42,9 @@ import BasicTypes import BlockId import Module ( primPackageId ) import PprCmm () -import OldCmm -import OldPprCmm () +import CmmUtils +import Cmm +import Hoopl import CLabel -- The rest: @@ -93,7 +95,8 @@ cmmTopCodeGen :: RawCmmDecl -> NatM [NatCmmDecl (Alignment, CmmStatics) Instr] -cmmTopCodeGen (CmmProc info lab live (ListGraph blocks)) = do +cmmTopCodeGen (CmmProc info lab live graph) = do + let blocks = toBlockListEntryFirst graph (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks picBaseMb <- getPicBaseMaybeNat dflags <- getDynFlags @@ -110,12 +113,16 @@ cmmTopCodeGen (CmmData sec dat) = do basicBlockCodeGen - :: CmmBasicBlock + :: CmmBlock -> NatM ( [NatBasicBlock Instr] , [NatCmmDecl (Alignment, CmmStatics) Instr]) -basicBlockCodeGen (BasicBlock id stmts) = do - instrs <- stmtsToInstrs stmts +basicBlockCodeGen block = do + let (CmmEntry id, nodes, tail) = blockSplit block + stmts = blockToList nodes + mid_instrs <- stmtsToInstrs stmts + tail_instrs <- stmtToInstrs tail + let instrs = mid_instrs `appOL` tail_instrs -- code generation may introduce new basic block boundaries, which -- are indicated by the NEWBLOCK instruction. We must split up the -- instruction stream into basic blocks again. Also, we extract @@ -132,18 +139,17 @@ basicBlockCodeGen (BasicBlock id stmts) = do return (BasicBlock id top : other_blocks, statics) -stmtsToInstrs :: [CmmStmt] -> NatM InstrBlock +stmtsToInstrs :: [CmmNode e x] -> NatM InstrBlock stmtsToInstrs stmts = do instrss <- mapM stmtToInstrs stmts return (concatOL instrss) -stmtToInstrs :: CmmStmt -> NatM InstrBlock +stmtToInstrs :: CmmNode e x -> NatM InstrBlock stmtToInstrs stmt = do dflags <- getDynFlags is32Bit <- is32BitPlatform case stmt of - CmmNop -> return nilOL CmmComment s -> return (unitOL (COMMENT s)) CmmAssign reg src @@ -160,17 +166,21 @@ stmtToInstrs stmt = do where ty = cmmExprType dflags src size = cmmTypeSize ty - CmmCall target result_regs args _ + CmmUnsafeForeignCall target result_regs args -> genCCall is32Bit target result_regs args CmmBranch id -> genBranch id - CmmCondBranch arg id -> genCondJump id arg + CmmCondBranch arg true false -> do b1 <- genCondJump true arg + b2 <- genBranch false + return (b1 `appOL` b2) CmmSwitch arg ids -> do dflags <- getDynFlags genSwitch dflags arg ids - CmmJump arg gregs -> do dflags <- getDynFlags + CmmCall { cml_target = arg + , cml_args_regs = gregs } -> do + dflags <- getDynFlags genJump arg (jumpRegs dflags gregs) - CmmReturn -> - panic "stmtToInstrs: return statement should have been cps'd away" + _ -> + panic "stmtToInstrs: statement should have been cps'd away" jumpRegs :: DynFlags -> [GlobalReg] -> [Reg] @@ -1523,9 +1533,9 @@ genCondJump id bool = do genCCall :: Bool -- 32 bit platform? - -> CmmCallTarget -- function to call - -> [HintedCmmFormal] -- where to put the result - -> [HintedCmmActual] -- arguments (of mixed type) + -> ForeignTarget -- function to call + -> [CmmFormal] -- where to put the result + -> [CmmActual] -- arguments (of mixed type) -> NatM InstrBlock -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -1533,10 +1543,10 @@ genCCall -- Unroll memcpy calls if the source and destination pointers are at -- least DWORD aligned and the number of bytes to copy isn't too -- large. Otherwise, call C's memcpy. -genCCall is32Bit (CmmPrim MO_Memcpy _) _ - [CmmHinted dst _, CmmHinted src _, - CmmHinted (CmmLit (CmmInt n _)) _, - CmmHinted (CmmLit (CmmInt align _)) _] +genCCall is32Bit (PrimTarget MO_Memcpy) _ + [dst, src, + (CmmLit (CmmInt n _)), + (CmmLit (CmmInt align _))] | n <= maxInlineSizeThreshold && align .&. 3 == 0 = do code_dst <- getAnyReg dst dst_r <- getNewRegNat size @@ -1576,11 +1586,11 @@ genCCall is32Bit (CmmPrim MO_Memcpy _) _ dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone (ImmInteger (n - i)) -genCCall _ (CmmPrim MO_Memset _) _ - [CmmHinted dst _, - CmmHinted (CmmLit (CmmInt c _)) _, - CmmHinted (CmmLit (CmmInt n _)) _, - CmmHinted (CmmLit (CmmInt align _)) _] +genCCall _ (PrimTarget MO_Memset) _ + [dst, + CmmLit (CmmInt c _), + CmmLit (CmmInt n _), + CmmLit (CmmInt align _)] | n <= maxInlineSizeThreshold && align .&. 3 == 0 = do code_dst <- getAnyReg dst dst_r <- getNewRegNat size @@ -1615,12 +1625,14 @@ genCCall _ (CmmPrim MO_Memset _) _ dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone (ImmInteger (n - i)) -genCCall _ (CmmPrim MO_WriteBarrier _) _ _ = return nilOL +genCCall _ (PrimTarget MO_WriteBarrier) _ _ = return nilOL -- write barrier compiles to no code on x86/x86-64; -- we keep it this long in order to prevent earlier optimisations. -genCCall is32Bit (CmmPrim (MO_PopCnt width) _) dest_regs@[CmmHinted dst _] - args@[CmmHinted src _] = do +genCCall _ (PrimTarget MO_Touch) _ _ = return nilOL + +genCCall is32Bit (PrimTarget (MO_PopCnt width)) dest_regs@[dst] + args@[src] = do sse4_2 <- sse4_2Enabled dflags <- getDynFlags let platform = targetPlatform dflags @@ -1639,7 +1651,9 @@ genCCall is32Bit (CmmPrim (MO_PopCnt width) _) dest_regs@[CmmHinted dst _] else do targetExpr <- cmmMakeDynamicReference dflags addImportNat CallReference lbl - let target = CmmCallee targetExpr CCallConv + let target = ForeignTarget targetExpr (ForeignConvention CCallConv + [NoHint] [NoHint] + CmmMayReturn) genCCall is32Bit target dest_regs args where size = intSize width @@ -1649,25 +1663,25 @@ genCCall is32Bit target dest_regs args | is32Bit = genCCall32 target dest_regs args | otherwise = genCCall64 target dest_regs args -genCCall32 :: CmmCallTarget -- function to call - -> [HintedCmmFormal] -- where to put the result - -> [HintedCmmActual] -- arguments (of mixed type) +genCCall32 :: ForeignTarget -- function to call + -> [CmmFormal] -- where to put the result + -> [CmmActual] -- arguments (of mixed type) -> NatM InstrBlock genCCall32 target dest_regs args = do dflags <- getDynFlags let platform = targetPlatform dflags case (target, dest_regs) of -- void return type prim op - (CmmPrim op _, []) -> + (PrimTarget op, []) -> outOfLineCmmOp op Nothing args -- we only cope with a single result for foreign calls - (CmmPrim op _, [r_hinted@(CmmHinted r _)]) -> do + (PrimTarget op, [r]) -> do l1 <- getNewLabelNat l2 <- getNewLabelNat sse2 <- sse2Enabled if sse2 then - outOfLineCmmOp op (Just r_hinted) args + outOfLineCmmOp op (Just r) args else case op of MO_F32_Sqrt -> actuallyInlineFloatOp GSQRT FF32 args MO_F64_Sqrt -> actuallyInlineFloatOp GSQRT FF64 args @@ -1681,10 +1695,10 @@ genCCall32 target dest_regs args = do MO_F32_Tan -> actuallyInlineFloatOp (\s -> GTAN s l1 l2) FF32 args MO_F64_Tan -> actuallyInlineFloatOp (\s -> GTAN s l1 l2) FF64 args - _other_op -> outOfLineCmmOp op (Just r_hinted) args + _other_op -> outOfLineCmmOp op (Just r) args where - actuallyInlineFloatOp instr size [CmmHinted x _] + actuallyInlineFloatOp instr size [x] = do res <- trivialUFCode size (instr size) x any <- anyReg res return (any (getRegisterReg platform False (CmmLocal r))) @@ -1693,12 +1707,12 @@ genCCall32 target dest_regs args = do = panic $ "genCCall32.actuallyInlineFloatOp: bad number of arguments! (" ++ show (length args) ++ ")" - (CmmPrim (MO_S_QuotRem width) _, _) -> divOp1 platform True width dest_regs args - (CmmPrim (MO_U_QuotRem width) _, _) -> divOp1 platform False width dest_regs args - (CmmPrim (MO_U_QuotRem2 width) _, _) -> divOp2 platform False width dest_regs args - (CmmPrim (MO_Add2 width) _, [CmmHinted res_h _, CmmHinted res_l _]) -> + (PrimTarget (MO_S_QuotRem width), _) -> divOp1 platform True width dest_regs args + (PrimTarget (MO_U_QuotRem width), _) -> divOp1 platform False width dest_regs args + (PrimTarget (MO_U_QuotRem2 width), _) -> divOp2 platform False width dest_regs args + (PrimTarget (MO_Add2 width), [res_h, res_l]) -> case args of - [CmmHinted arg_x _, CmmHinted arg_y _] -> + [arg_x, arg_y] -> do hCode <- getAnyReg (CmmLit (CmmInt 0 width)) lCode <- getAnyReg (CmmMachOp (MO_Add width) [arg_x, arg_y]) let size = intSize width @@ -1709,9 +1723,9 @@ genCCall32 target dest_regs args = do ADC size (OpImm (ImmInteger 0)) (OpReg reg_h) return code _ -> panic "genCCall32: Wrong number of arguments/results for add2" - (CmmPrim (MO_U_Mul2 width) _, [CmmHinted res_h _, CmmHinted res_l _]) -> + (PrimTarget (MO_U_Mul2 width), [res_h, res_l]) -> case args of - [CmmHinted arg_x _, CmmHinted arg_y _] -> + [arg_x, arg_y] -> do (y_reg, y_code) <- getRegOrMem arg_y x_code <- getAnyReg arg_x let size = intSize width @@ -1725,22 +1739,17 @@ genCCall32 target dest_regs args = do return code _ -> panic "genCCall32: Wrong number of arguments/results for add2" - (CmmPrim _ (Just stmts), _) -> - stmtsToInstrs stmts - _ -> genCCall32' dflags target dest_regs args - where divOp1 platform signed width results [CmmHinted arg_x _, CmmHinted arg_y _] + where divOp1 platform signed width results [arg_x, arg_y] = divOp platform signed width results Nothing arg_x arg_y divOp1 _ _ _ _ _ = panic "genCCall32: Wrong number of arguments for divOp1" - divOp2 platform signed width results [CmmHinted arg_x_high _, - CmmHinted arg_x_low _, - CmmHinted arg_y _] + divOp2 platform signed width results [arg_x_high, arg_x_low, arg_y] = divOp platform signed width results (Just arg_x_high) arg_x_low arg_y divOp2 _ _ _ _ _ = panic "genCCall64: Wrong number of arguments for divOp2" - divOp platform signed width [CmmHinted res_q _, CmmHinted res_r _] + divOp platform signed width [res_q, res_r] m_arg_x_high arg_x_low arg_y = do let size = intSize width reg_q = getRegisterReg platform True (CmmLocal res_q) @@ -1766,16 +1775,16 @@ genCCall32 target dest_regs args = do = panic "genCCall32: Wrong number of results for divOp" genCCall32' :: DynFlags - -> CmmCallTarget -- function to call - -> [HintedCmmFormal] -- where to put the result - -> [HintedCmmActual] -- arguments (of mixed type) + -> ForeignTarget -- function to call + -> [CmmFormal] -- where to put the result + -> [CmmActual] -- arguments (of mixed type) -> NatM InstrBlock genCCall32' dflags target dest_regs args = do let -- Align stack to 16n for calls, assuming a starting stack -- alignment of 16n - word_size on procedure entry. Which we - -- maintain. See Note [rts/StgCRun.c : Stack Alignment on X86] - sizes = map (arg_size . cmmExprType dflags . hintlessCmm) (reverse args) + -- maintiain. See Note [rts/StgCRun.c : Stack Alignment on X86] + sizes = map (arg_size . cmmExprType dflags) (reverse args) raw_arg_size = sum sizes + wORD_SIZE dflags arg_pad_size = (roundTo 16 $ raw_arg_size) - raw_arg_size tot_arg_size = raw_arg_size + arg_pad_size - wORD_SIZE dflags @@ -1790,16 +1799,16 @@ genCCall32' dflags target dest_regs args = do -- deal with static vs dynamic call targets (callinsns,cconv) <- case target of - CmmCallee (CmmLit (CmmLabel lbl)) conv + ForeignTarget (CmmLit (CmmLabel lbl)) conv -> -- ToDo: stdcall arg sizes return (unitOL (CALL (Left fn_imm) []), conv) where fn_imm = ImmCLbl lbl - CmmCallee expr conv + ForeignTarget expr conv -> do { (dyn_r, dyn_c) <- getSomeReg expr ; ASSERT( isWord32 (cmmExprType dflags expr) ) return (dyn_c `snocOL` CALL (Right dyn_r) [], conv) } - CmmPrim _ _ - -> panic $ "genCCall: Can't handle CmmPrim call type here, error " + PrimTarget _ + -> panic $ "genCCall: Can't handle PrimTarget call type here, error " ++ "probably because too many return values." let push_code @@ -1815,8 +1824,9 @@ genCCall32' dflags target dest_regs args = do -- -- We have to pop any stack padding we added -- even if we are doing stdcall, though (#5052) - pop_size | cconv /= StdCallConv = tot_arg_size - | otherwise = arg_pad_size + pop_size + | ForeignConvention StdCallConv _ _ _ <- cconv = arg_pad_size + | otherwise = tot_arg_size call = callinsns `appOL` toOL ( @@ -1833,7 +1843,7 @@ genCCall32' dflags target dest_regs args = do let -- assign the results, if necessary assign_code [] = nilOL - assign_code [CmmHinted dest _hint] + assign_code [dest] | isFloatType ty = if use_sse2 then let tmp_amode = AddrBaseIndex (EABaseReg esp) @@ -1869,10 +1879,10 @@ genCCall32' dflags target dest_regs args = do roundTo a x | x `mod` a == 0 = x | otherwise = x + a - (x `mod` a) - push_arg :: Bool -> HintedCmmActual {-current argument-} + push_arg :: Bool -> CmmActual {-current argument-} -> NatM InstrBlock -- code - push_arg use_sse2 (CmmHinted arg _hint) -- we don't need the hints on x86 + push_arg use_sse2 arg -- we don't need the hints on x86 | isWord64 arg_ty = do ChildCode64 code r_lo <- iselExpr64 arg delta <- getDeltaNat @@ -1915,29 +1925,29 @@ genCCall32' dflags target dest_regs args = do arg_ty = cmmExprType dflags arg size = arg_size arg_ty -- Byte size -genCCall64 :: CmmCallTarget -- function to call - -> [HintedCmmFormal] -- where to put the result - -> [HintedCmmActual] -- arguments (of mixed type) +genCCall64 :: ForeignTarget -- function to call + -> [CmmFormal] -- where to put the result + -> [CmmActual] -- arguments (of mixed type) -> NatM InstrBlock genCCall64 target dest_regs args = do dflags <- getDynFlags let platform = targetPlatform dflags case (target, dest_regs) of - (CmmPrim op _, []) -> + (PrimTarget op, []) -> -- void return type prim op outOfLineCmmOp op Nothing args - (CmmPrim op _, [res]) -> + (PrimTarget op, [res]) -> -- we only cope with a single result for foreign calls outOfLineCmmOp op (Just res) args - (CmmPrim (MO_S_QuotRem width) _, _) -> divOp1 platform True width dest_regs args - (CmmPrim (MO_U_QuotRem width) _, _) -> divOp1 platform False width dest_regs args - (CmmPrim (MO_U_QuotRem2 width) _, _) -> divOp2 platform False width dest_regs args - (CmmPrim (MO_Add2 width) _, [CmmHinted res_h _, CmmHinted res_l _]) -> + (PrimTarget (MO_S_QuotRem width), _) -> divOp1 platform True width dest_regs args + (PrimTarget (MO_U_QuotRem width), _) -> divOp1 platform False width dest_regs args + (PrimTarget (MO_U_QuotRem2 width), _) -> divOp2 platform False width dest_regs args + (PrimTarget (MO_Add2 width), [res_h, res_l]) -> case args of - [CmmHinted arg_x _, CmmHinted arg_y _] -> + [arg_x, arg_y] -> do hCode <- getAnyReg (CmmLit (CmmInt 0 width)) lCode <- getAnyReg (CmmMachOp (MO_Add width) [arg_x, arg_y]) let size = intSize width @@ -1948,9 +1958,9 @@ genCCall64 target dest_regs args = do ADC size (OpImm (ImmInteger 0)) (OpReg reg_h) return code _ -> panic "genCCall64: Wrong number of arguments/results for add2" - (CmmPrim (MO_U_Mul2 width) _, [CmmHinted res_h _, CmmHinted res_l _]) -> + (PrimTarget (MO_U_Mul2 width), [res_h, res_l]) -> case args of - [CmmHinted arg_x _, CmmHinted arg_y _] -> + [arg_x, arg_y] -> do (y_reg, y_code) <- getRegOrMem arg_y x_code <- getAnyReg arg_x let size = intSize width @@ -1964,24 +1974,19 @@ genCCall64 target dest_regs args = do return code _ -> panic "genCCall64: Wrong number of arguments/results for add2" - (CmmPrim _ (Just stmts), _) -> - stmtsToInstrs stmts - _ -> do dflags <- getDynFlags genCCall64' dflags target dest_regs args - where divOp1 platform signed width results [CmmHinted arg_x _, CmmHinted arg_y _] + where divOp1 platform signed width results [arg_x, arg_y] = divOp platform signed width results Nothing arg_x arg_y divOp1 _ _ _ _ _ = panic "genCCall64: Wrong number of arguments for divOp1" - divOp2 platform signed width results [CmmHinted arg_x_high _, - CmmHinted arg_x_low _, - CmmHinted arg_y _] + divOp2 platform signed width results [arg_x_high, arg_x_low, arg_y] = divOp platform signed width results (Just arg_x_high) arg_x_low arg_y divOp2 _ _ _ _ _ = panic "genCCall64: Wrong number of arguments for divOp2" - divOp platform signed width [CmmHinted res_q _, CmmHinted res_r _] + divOp platform signed width [res_q, res_r] m_arg_x_high arg_x_low arg_y = do let size = intSize width reg_q = getRegisterReg platform True (CmmLocal res_q) @@ -2005,9 +2010,9 @@ genCCall64 target dest_regs args = do = panic "genCCall64: Wrong number of results for divOp" genCCall64' :: DynFlags - -> CmmCallTarget -- function to call - -> [HintedCmmFormal] -- where to put the result - -> [HintedCmmActual] -- arguments (of mixed type) + -> ForeignTarget -- function to call + -> [CmmFormal] -- where to put the result + -> [CmmActual] -- arguments (of mixed type) -> NatM InstrBlock genCCall64' dflags target dest_regs args = do -- load up the register arguments @@ -2057,15 +2062,15 @@ genCCall64' dflags target dest_regs args = do -- deal with static vs dynamic call targets (callinsns,_cconv) <- case target of - CmmCallee (CmmLit (CmmLabel lbl)) conv + ForeignTarget (CmmLit (CmmLabel lbl)) conv -> -- ToDo: stdcall arg sizes return (unitOL (CALL (Left fn_imm) arg_regs), conv) where fn_imm = ImmCLbl lbl - CmmCallee expr conv + ForeignTarget expr conv -> do (dyn_r, dyn_c) <- getSomeReg expr return (dyn_c `snocOL` CALL (Right dyn_r) arg_regs, conv) - CmmPrim _ _ - -> panic $ "genCCall: Can't handle CmmPrim call type here, error " + PrimTarget _ + -> panic $ "genCCall: Can't handle PrimTarget call type here, error " ++ "probably because too many return values." let @@ -2094,7 +2099,7 @@ genCCall64' dflags target dest_regs args = do let -- assign the results, if necessary assign_code [] = nilOL - assign_code [CmmHinted dest _hint] = + assign_code [dest] = case typeWidth rep of W32 | isFloatType rep -> unitOL (MOV (floatSize W32) (OpReg xmm0) (OpReg r_dest)) W64 | isFloatType rep -> unitOL (MOV (floatSize W64) (OpReg xmm0) (OpReg r_dest)) @@ -2115,16 +2120,16 @@ genCCall64' dflags target dest_regs args = do where platform = targetPlatform dflags arg_size = 8 -- always, at the mo - load_args :: [CmmHinted CmmExpr] + load_args :: [CmmExpr] -> [Reg] -- int regs avail for args -> [Reg] -- FP regs avail for args -> InstrBlock - -> NatM ([CmmHinted CmmExpr],[Reg],[Reg],InstrBlock) + -> NatM ([CmmExpr],[Reg],[Reg],InstrBlock) load_args args [] [] code = return (args, [], [], code) -- no more regs to use load_args [] aregs fregs code = return ([], aregs, fregs, code) -- no more args to push - load_args ((CmmHinted arg hint) : rest) aregs fregs code + load_args (arg : rest) aregs fregs code | isFloatType arg_rep = case fregs of [] -> push_this_arg @@ -2142,21 +2147,21 @@ genCCall64' dflags target dest_regs args = do push_this_arg = do (args',ars,frs,code') <- load_args rest aregs fregs code - return ((CmmHinted arg hint):args', ars, frs, code') + return (arg:args', ars, frs, code') - load_args_win :: [CmmHinted CmmExpr] + load_args_win :: [CmmExpr] -> [Reg] -- used int regs -> [Reg] -- used FP regs -> [(Reg, Reg)] -- (int, FP) regs avail for args -> InstrBlock - -> NatM ([CmmHinted CmmExpr],[Reg],[Reg],InstrBlock) + -> NatM ([CmmExpr],[Reg],[Reg],InstrBlock) load_args_win args usedInt usedFP [] code = return (args, usedInt, usedFP, code) -- no more regs to use load_args_win [] usedInt usedFP _ code = return ([], usedInt, usedFP, code) -- no more args to push - load_args_win ((CmmHinted arg _) : rest) usedInt usedFP + load_args_win (arg : rest) usedInt usedFP ((ireg, freg) : regs) code | isFloatType arg_rep = do arg_code <- getAnyReg arg @@ -2175,7 +2180,7 @@ genCCall64' dflags target dest_regs args = do arg_rep = cmmExprType dflags arg push_args [] code = return code - push_args ((CmmHinted arg _):rest) code + push_args (arg:rest) code | isFloatType arg_rep = do (arg_reg, arg_code) <- getSomeReg arg delta <- getDeltaNat @@ -2215,14 +2220,15 @@ genCCall64' dflags target dest_regs args = do maxInlineSizeThreshold :: Integer maxInlineSizeThreshold = 128 -outOfLineCmmOp :: CallishMachOp -> Maybe HintedCmmFormal -> [HintedCmmActual] -> NatM InstrBlock +outOfLineCmmOp :: CallishMachOp -> Maybe CmmFormal -> [CmmActual] -> NatM InstrBlock outOfLineCmmOp mop res args = do dflags <- getDynFlags targetExpr <- cmmMakeDynamicReference dflags addImportNat CallReference lbl - let target = CmmCallee targetExpr CCallConv + let target = ForeignTarget targetExpr + (ForeignConvention CCallConv [] [] CmmMayReturn) - stmtToInstrs (CmmCall target (catMaybes [res]) args' CmmMayReturn) + stmtToInstrs (CmmUnsafeForeignCall target (catMaybes [res]) args') where -- Assume we can call these functions directly, and that they're not in a dynamic library. -- TODO: Why is this ok? Under linux this code will be in libm.so @@ -2282,7 +2288,7 @@ outOfLineCmmOp mop res args MO_WriteBarrier -> unsupported MO_Touch -> unsupported unsupported = panic ("outOfLineCmmOp: " ++ show mop - ++ "not supported here") + ++ " not supported here") -- ----------------------------------------------------------------------------- -- Generating a table-branch diff --git a/compiler/nativeGen/X86/Instr.hs b/compiler/nativeGen/X86/Instr.hs index d089fc3ec2..7d7e85c441 100644 --- a/compiler/nativeGen/X86/Instr.hs +++ b/compiler/nativeGen/X86/Instr.hs @@ -25,7 +25,7 @@ import TargetReg import BlockId import CodeGen.Platform -import OldCmm +import Cmm import FastString import FastBool import Outputable diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs index 76715f1996..75d18a1ff4 100644 --- a/compiler/nativeGen/X86/Ppr.hs +++ b/compiler/nativeGen/X86/Ppr.hs @@ -35,7 +35,7 @@ import PprBase import BlockId import BasicTypes (Alignment) import DynFlags -import OldCmm +import Cmm hiding (topInfoTable) import CLabel import Unique ( pprUnique, Uniquable(..) ) import Platform diff --git a/compiler/nativeGen/X86/Regs.hs b/compiler/nativeGen/X86/Regs.hs index 6b2fe16855..bd60fb0281 100644 --- a/compiler/nativeGen/X86/Regs.hs +++ b/compiler/nativeGen/X86/Regs.hs @@ -51,7 +51,7 @@ import CodeGen.Platform import Reg import RegClass -import OldCmm +import Cmm import CmmCallConv import CLabel ( CLabel ) import DynFlags |