From df04d2d875f4f17b04cd8bd396b62b1eadd932e8 Mon Sep 17 00:00:00 2001 From: "Iavor S. Diatchki" Date: Sat, 10 Nov 2012 12:24:25 -0800 Subject: Allow '-' to be used as an infix type constructor. --- compiler/parser/Parser.y.pp | 1 + 1 file changed, 1 insertion(+) (limited to 'compiler') diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 3c184989b1..3029930903 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -1887,6 +1887,7 @@ tyconsym :: { Located RdrName } : CONSYM { L1 $! mkUnqual tcClsName (getCONSYM $1) } | VARSYM { L1 $! mkUnqual tcClsName (getVARSYM $1) } | '*' { L1 $! mkUnqual tcClsName (fsLit "*") } + | '-' { L1 $! mkUnqual tcClsName (fsLit "-") } ----------------------------------------------------------------------------- -- cgit v1.2.1 From d92bd17ffd8715f77fd49de0fed6e39c8d0ec28b Mon Sep 17 00:00:00 2001 From: Simon Marlow Date: Mon, 12 Nov 2012 11:47:51 +0000 Subject: Remove OldCmm, convert backends to consume new Cmm This removes the OldCmm data type and the CmmCvt pass that converts new Cmm to OldCmm. The backends (NCGs, LLVM and C) have all been converted to consume new Cmm. The main difference between the two data types is that conditional branches in new Cmm have both true/false successors, whereas in OldCmm the false case was a fallthrough. To generate slightly better code we occasionally need to invert a conditional to ensure that the branch-not-taken becomes a fallthrough; this was previously done in CmmCvt, and it is now done in CmmContFlowOpt. We could go further and use the Hoopl Block representation for native code, which would mean that we could use Hoopl's postorderDfs and analyses for native code, but for now I've left it as is, using the old ListGraph representation for native code. --- compiler/cmm/Cmm.hs | 39 ++- compiler/cmm/CmmContFlowOpt.hs | 45 +++- compiler/cmm/CmmCvt.hs | 117 --------- compiler/cmm/CmmInfo.hs | 32 +-- compiler/cmm/CmmNode.hs | 14 +- compiler/cmm/CmmOpt.hs | 7 +- compiler/cmm/CmmPipeline.hs | 12 + compiler/cmm/CmmUtils.hs | 14 +- compiler/cmm/OldCmm.hs | 279 --------------------- compiler/cmm/OldCmmLint.hs | 212 ---------------- compiler/cmm/OldCmmUtils.hs | 100 -------- compiler/cmm/OldPprCmm.hs | 224 ----------------- compiler/cmm/PprC.hs | 131 +++++----- compiler/cmm/PprCmmExpr.hs | 1 - compiler/codeGen/CgUtils.hs | 87 +++---- compiler/ghc.cabal.in | 5 - compiler/llvmGen/LlvmCodeGen.hs | 17 +- compiler/llvmGen/LlvmCodeGen/Base.hs | 2 +- compiler/llvmGen/LlvmCodeGen/CodeGen.hs | 197 ++++++++------- compiler/llvmGen/LlvmCodeGen/Data.hs | 2 +- compiler/llvmGen/LlvmCodeGen/Ppr.hs | 2 +- compiler/main/CodeOutput.lhs | 4 +- compiler/main/HscMain.hs | 16 +- compiler/nativeGen/AsmCodeGen.lhs | 66 +++-- compiler/nativeGen/Instruction.hs | 14 +- compiler/nativeGen/PIC.hs | 2 +- compiler/nativeGen/PPC/CodeGen.hs | 72 +++--- compiler/nativeGen/PPC/Instr.hs | 2 +- compiler/nativeGen/PPC/Ppr.hs | 2 +- compiler/nativeGen/PPC/RegInfo.hs | 2 +- compiler/nativeGen/PPC/Regs.hs | 2 +- compiler/nativeGen/RegAlloc/Graph/Coalesce.hs | 2 +- compiler/nativeGen/RegAlloc/Graph/Spill.hs | 2 +- compiler/nativeGen/RegAlloc/Graph/SpillClean.hs | 2 +- compiler/nativeGen/RegAlloc/Graph/SpillCost.hs | 2 +- compiler/nativeGen/RegAlloc/Graph/Stats.hs | 3 +- .../nativeGen/RegAlloc/Linear/JoinToTargets.hs | 1 - compiler/nativeGen/RegAlloc/Linear/Main.hs | 15 +- compiler/nativeGen/RegAlloc/Linear/Stats.hs | 2 - compiler/nativeGen/RegAlloc/Liveness.hs | 13 +- compiler/nativeGen/SPARC/CodeGen.hs | 73 +++--- compiler/nativeGen/SPARC/CodeGen/Amode.hs | 2 +- compiler/nativeGen/SPARC/CodeGen/Base.hs | 3 +- compiler/nativeGen/SPARC/CodeGen/CondCode.hs | 2 +- compiler/nativeGen/SPARC/CodeGen/Expand.hs | 2 +- compiler/nativeGen/SPARC/CodeGen/Gen32.hs | 2 +- compiler/nativeGen/SPARC/CodeGen/Gen32.hs-boot | 2 +- compiler/nativeGen/SPARC/CodeGen/Gen64.hs | 2 +- compiler/nativeGen/SPARC/CodeGen/Sanity.hs | 4 +- compiler/nativeGen/SPARC/Imm.hs | 2 +- compiler/nativeGen/SPARC/Instr.hs | 2 +- compiler/nativeGen/SPARC/Ppr.hs | 4 +- compiler/nativeGen/SPARC/ShortcutJump.hs | 2 +- compiler/nativeGen/Size.hs | 2 +- compiler/nativeGen/X86/CodeGen.hs | 220 ++++++++-------- compiler/nativeGen/X86/Instr.hs | 2 +- compiler/nativeGen/X86/Ppr.hs | 2 +- compiler/nativeGen/X86/Regs.hs | 2 +- compiler/types/TyCon.lhs | 68 ++++- 59 files changed, 678 insertions(+), 1483 deletions(-) delete mode 100644 compiler/cmm/CmmCvt.hs delete mode 100644 compiler/cmm/OldCmm.hs delete mode 100644 compiler/cmm/OldCmmLint.hs delete mode 100644 compiler/cmm/OldCmmUtils.hs delete mode 100644 compiler/cmm/OldPprCmm.hs (limited to 'compiler') diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs index e1701bd4c5..0b3040d597 100644 --- a/compiler/cmm/Cmm.hs +++ b/compiler/cmm/Cmm.hs @@ -8,8 +8,13 @@ module Cmm ( CmmDecl, GenCmmDecl(..), CmmGraph, GenCmmGraph(..), CmmBlock, + RawCmmDecl, RawCmmGroup, Section(..), CmmStatics(..), CmmStatic(..), + -- ** Blocks containing lists + GenBasicBlock(..), blockId, + ListGraph(..), pprBBlock, + -- * Cmm graphs CmmReplGraph, GenCmmReplGraph, CmmFwdRewrite, CmmBwdRewrite, @@ -31,6 +36,7 @@ import SMRep import CmmExpr import UniqSupply import Compiler.Hoopl +import Outputable import Data.Word ( Word8 ) @@ -50,6 +56,7 @@ type CmmProgram = [CmmGroup] type GenCmmGroup d h g = [GenCmmDecl d h g] type CmmGroup = GenCmmGroup CmmStatics CmmTopInfo CmmGraph +type RawCmmGroup = GenCmmGroup CmmStatics (BlockEnv CmmStatics) CmmGraph ----------------------------------------------------------------------------- -- CmmDecl, GenCmmDecl @@ -62,7 +69,6 @@ type CmmGroup = GenCmmGroup CmmStatics CmmTopInfo CmmGraph -- -- We expect there to be two main instances of this type: -- (a) C--, i.e. populated with various C-- constructs --- (Cmm and RawCmm in OldCmm.hs) -- (b) Native code, populated with data/instructions -- | A top-level chunk, abstracted over the type of the contents of @@ -87,6 +93,12 @@ data GenCmmDecl d h g type CmmDecl = GenCmmDecl CmmStatics CmmTopInfo CmmGraph +type RawCmmDecl + = GenCmmDecl + CmmStatics + (BlockEnv CmmStatics) + CmmGraph + ----------------------------------------------------------------------------- -- Graphs ----------------------------------------------------------------------------- @@ -177,3 +189,28 @@ data CmmStatics CLabel -- Label of statics [CmmStatic] -- The static data itself +-- ----------------------------------------------------------------------------- +-- Basic blocks consisting of lists + +-- These are used by the LLVM and NCG backends, when populating Cmm +-- with lists of instructions. + +data GenBasicBlock i = BasicBlock BlockId [i] + +-- | The branch block id is that of the first block in +-- the branch, which is that branch's entry point +blockId :: GenBasicBlock i -> BlockId +blockId (BasicBlock blk_id _ ) = blk_id + +newtype ListGraph i = ListGraph [GenBasicBlock i] + +instance Outputable instr => Outputable (ListGraph instr) where + ppr (ListGraph blocks) = vcat (map ppr blocks) + +instance Outputable instr => Outputable (GenBasicBlock instr) where + ppr = pprBBlock + +pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc +pprBBlock (BasicBlock ident stmts) = + hang (ppr ident <> colon) 4 (vcat (map ppr stmts)) + diff --git a/compiler/cmm/CmmContFlowOpt.hs b/compiler/cmm/CmmContFlowOpt.hs index 82f7243e73..c59a4342b4 100644 --- a/compiler/cmm/CmmContFlowOpt.hs +++ b/compiler/cmm/CmmContFlowOpt.hs @@ -4,17 +4,18 @@ module CmmContFlowOpt ( cmmCfgOpts , cmmCfgOptsProc + , removeUnreachableBlocksProc , removeUnreachableBlocks , replaceLabels ) where +import Hoopl import BlockId import Cmm import CmmUtils import Maybes -import Hoopl import Control.Monad import Prelude hiding (succ, unzip, zip) @@ -136,9 +137,10 @@ blockConcat splitting_procs g@CmmGraph { g_entry = entry_id } = (blocks, mapInsert b' dest shortcut_map) -- replaceLabels will substitute dest for b' everywhere, later - -- non-calls: see if we can shortcut any of the successors. + -- non-calls: see if we can shortcut any of the successors, + -- and check whether we should invert the conditional | Nothing <- callContinuation_maybe last - = ( mapInsert bid (blockJoinTail head shortcut_last) blocks + = ( mapInsert bid (blockJoinTail head swapcond_last) blocks , shortcut_map ) | otherwise @@ -146,17 +148,38 @@ blockConcat splitting_procs g@CmmGraph { g_entry = entry_id } where (head, last) = blockSplitTail block bid = entryLabel block + shortcut_last = mapSuccessors shortcut last - shortcut l = - case mapLookup l blocks of - Just b | Just dest <- canShortcut b -> dest - _otherwise -> l + where + shortcut l = + case mapLookup l blocks of + Just b | Just dest <- canShortcut b -> dest + _otherwise -> l + + -- for a conditional, we invert the conditional if that + -- would make it more likely that the branch-not-taken case + -- becomes a fallthrough. This helps the native codegen a + -- little bit, and probably has no effect on LLVM. It's + -- convenient to do it here, where we have the information + -- about predecessors. + -- + swapcond_last + | CmmCondBranch cond t f <- shortcut_last + , numPreds f > 1 + , numPreds t == 1 + , Just cond' <- maybeInvertCmmExpr cond + = CmmCondBranch cond' f t + + | otherwise + = shortcut_last + shouldConcatWith b block | okToDuplicate block = True -- short enough to duplicate - | num_preds b == 1 = True -- only one predecessor: go for it + | numPreds b == 1 = True -- only one predecessor: go for it | otherwise = False - where num_preds bid = mapLookup bid backEdges `orElse` 0 + + numPreds bid = mapLookup bid backEdges `orElse` 0 canShortcut :: CmmBlock -> Maybe BlockId canShortcut block @@ -265,6 +288,10 @@ predMap blocks = foldr add_preds mapEmpty blocks -- find the back edges -- -- Removing unreachable blocks +removeUnreachableBlocksProc :: CmmDecl -> CmmDecl +removeUnreachableBlocksProc (CmmProc info lbl live g) + = CmmProc info lbl live (removeUnreachableBlocks g) + removeUnreachableBlocks :: CmmGraph -> CmmGraph removeUnreachableBlocks g | length blocks < mapSize (toBlockMap g) = ofBlockList (g_entry g) blocks diff --git a/compiler/cmm/CmmCvt.hs b/compiler/cmm/CmmCvt.hs deleted file mode 100644 index 39f0b86ec8..0000000000 --- a/compiler/cmm/CmmCvt.hs +++ /dev/null @@ -1,117 +0,0 @@ -{-# LANGUAGE GADTs #-} --- ToDo: remove -fno-warn-incomplete-patterns -{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} - -module CmmCvt - ( cmmOfZgraph ) -where - -import BlockId -import Cmm -import CmmUtils -import qualified OldCmm as Old -import OldPprCmm () - -import Hoopl -import Data.Maybe -import Maybes -import Outputable - -cmmOfZgraph :: CmmGroup -> Old.CmmGroup -cmmOfZgraph tops = map mapTop tops - where mapTop (CmmProc h l v g) = CmmProc (info_tbls h) l v (ofZgraph g) - mapTop (CmmData s ds) = CmmData s ds - -add_hints :: [a] -> [ForeignHint] -> [Old.CmmHinted a] -add_hints args hints = zipWith Old.CmmHinted args hints - -get_hints :: ForeignTarget -> ([ForeignHint], [ForeignHint]) -get_hints (PrimTarget op) = (res_hints ++ repeat NoHint, - arg_hints ++ repeat NoHint) - where (res_hints, arg_hints) = callishMachOpHints op -get_hints (ForeignTarget _ (ForeignConvention _ arg_hints res_hints _)) - = (res_hints, arg_hints) - -cmm_target :: ForeignTarget -> Old.CmmCallTarget -cmm_target (PrimTarget op) = Old.CmmPrim op Nothing -cmm_target (ForeignTarget e (ForeignConvention cc _ _ _)) = Old.CmmCallee e cc - -get_ret :: ForeignTarget -> CmmReturnInfo -get_ret (PrimTarget _) = CmmMayReturn -get_ret (ForeignTarget _ (ForeignConvention _ _ _ ret)) = ret - -ofZgraph :: CmmGraph -> Old.ListGraph Old.CmmStmt -ofZgraph g = Old.ListGraph $ mapMaybe convert_block $ postorderDfs g - -- We catenated some blocks in the conversion process, - -- because of the CmmCondBranch -- the machine code does not have - -- 'jump here or there' instruction, but has 'jump if true' instruction. - -- As OldCmm has the same instruction, so we use it. - -- When we are doing this, we also catenate normal goto-s (it is for free). - - -- Exactly, we catenate blocks with nonentry labes, that are - -- a) mentioned exactly once as a successor - -- b) any of 1) are a target of a goto - -- 2) are false branch target of a conditional jump - -- 3) are true branch target of a conditional jump, and - -- the false branch target is a successor of at least 2 blocks - -- and the condition can be inverted - -- The complicated rule 3) is here because we need to assign at most one - -- catenable block to a CmmCondBranch. - where preds :: BlockEnv [CmmNode O C] - preds = mapFold add mapEmpty $ toBlockMap g - where add block env = foldr (add' $ lastNode block) env (successors block) - add' :: CmmNode O C -> BlockId -> BlockEnv [CmmNode O C] -> BlockEnv [CmmNode O C] - add' node succ env = mapInsert succ (node : (mapLookup succ env `orElse` [])) env - - to_be_catenated :: BlockId -> Bool - to_be_catenated id | id == g_entry g = False - | Just [CmmBranch _] <- mapLookup id preds = True - | Just [CmmCondBranch _ _ f] <- mapLookup id preds - , f == id = True - | Just [CmmCondBranch e t f] <- mapLookup id preds - , t == id - , Just (_:_:_) <- mapLookup f preds - , Just _ <- maybeInvertCmmExpr e = True - to_be_catenated _ = False - - convert_block block | to_be_catenated (entryLabel block) = Nothing - convert_block block = Just $ foldBlockNodesB3 (first, middle, last) block () - where first :: CmmNode C O -> [Old.CmmStmt] -> Old.CmmBasicBlock - first (CmmEntry bid) stmts = Old.BasicBlock bid stmts - - middle :: CmmNode O O -> [Old.CmmStmt] -> [Old.CmmStmt] - middle node stmts = stmt : stmts - where stmt :: Old.CmmStmt - stmt = case node of - CmmComment s -> Old.CmmComment s - CmmAssign l r -> Old.CmmAssign l r - CmmStore l r -> Old.CmmStore l r - CmmUnsafeForeignCall (PrimTarget MO_Touch) _ _ -> Old.CmmNop - CmmUnsafeForeignCall target ress args -> - Old.CmmCall (cmm_target target) - (add_hints ress res_hints) - (add_hints args arg_hints) - (get_ret target) - where - (res_hints, arg_hints) = get_hints target - - - last :: CmmNode O C -> () -> [Old.CmmStmt] - last node _ = stmts - where stmts :: [Old.CmmStmt] - stmts = case node of - CmmBranch tgt | to_be_catenated tgt -> tail_of tgt - | otherwise -> [Old.CmmBranch tgt] - CmmCondBranch expr tid fid - | to_be_catenated fid -> Old.CmmCondBranch expr tid : tail_of fid - | to_be_catenated tid - , Just expr' <- maybeInvertCmmExpr expr -> Old.CmmCondBranch expr' fid : tail_of tid - | otherwise -> [Old.CmmCondBranch expr tid, Old.CmmBranch fid] - CmmSwitch arg ids -> [Old.CmmSwitch arg ids] - -- ToDo: STG Live - CmmCall e _ r _ _ _ -> [Old.CmmJump e r] - CmmForeignCall {} -> panic "ofZgraph: CmmForeignCall" - tail_of bid = case foldBlockNodesB3 (first, middle, last) block () of - Old.BasicBlock _ stmts -> stmts - where Just block = mapLookup bid $ toBlockMap g - diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs index 699469c116..b4e2cd66dd 100644 --- a/compiler/cmm/CmmInfo.hs +++ b/compiler/cmm/CmmInfo.hs @@ -14,8 +14,7 @@ module CmmInfo ( #include "HsVersions.h" -import OldCmm as Old - +import Cmm import CmmUtils import CLabel import SMRep @@ -42,8 +41,8 @@ mkEmptyContInfoTable info_lbl , cit_prof = NoProfilingInfo , cit_srt = NoC_SRT } -cmmToRawCmm :: DynFlags -> Stream IO Old.CmmGroup () - -> IO (Stream IO Old.RawCmmGroup ()) +cmmToRawCmm :: DynFlags -> Stream IO CmmGroup () + -> IO (Stream IO RawCmmGroup ()) cmmToRawCmm dflags cmms = do { uniqs <- mkSplitUniqSupply 'i' ; let do_one uniqs cmm = do @@ -108,21 +107,13 @@ mkInfoTable dflags proc@(CmmProc infos entry_lbl live blocks) rel_std_info = map (makeRelativeRefTo dflags info_lbl) std_info rel_extra_bits = map (makeRelativeRefTo dflags info_lbl) extra_bits -- - case blocks of - ListGraph [] -> - -- No code; only the info table is significant - -- Use a zero place-holder in place of the - -- entry-label in the info table - return (top_decls ++ - [mkRODataLits info_lbl (zeroCLit dflags : rel_std_info ++ - rel_extra_bits)]) - _nonempty -> - -- Separately emit info table (with the function entry - -- point as first entry) and the entry code - return (top_decls ++ - [CmmProc mapEmpty entry_lbl live blocks, - mkDataLits Data info_lbl - (CmmLabel entry_lbl : rel_std_info ++ rel_extra_bits)]) + -- Separately emit info table (with the function entry + -- point as first entry) and the entry code + -- + return (top_decls ++ + [CmmProc mapEmpty entry_lbl live blocks, + mkDataLits Data info_lbl + (CmmLabel entry_lbl : rel_std_info ++ rel_extra_bits)]) -- -- With tables-next-to-code, we can have many info tables, @@ -132,7 +123,8 @@ mkInfoTable dflags proc@(CmmProc infos entry_lbl live blocks) -- | otherwise = do - (top_declss, raw_infos) <- unzip `fmap` mapM do_one_info (mapToList infos) + (top_declss, raw_infos) <- + unzip `fmap` mapM do_one_info (mapToList (info_tbls infos)) return (concat top_declss ++ [CmmProc (mapFromList raw_infos) entry_lbl live blocks]) diff --git a/compiler/cmm/CmmNode.hs b/compiler/cmm/CmmNode.hs index 6fa3007fbe..d808c7ff0d 100644 --- a/compiler/cmm/CmmNode.hs +++ b/compiler/cmm/CmmNode.hs @@ -12,7 +12,8 @@ module CmmNode ( CmmNode(..), CmmFormal, CmmActual, - UpdFrameOffset, Convention(..), ForeignConvention(..), ForeignTarget(..), + UpdFrameOffset, Convention(..), + ForeignConvention(..), ForeignTarget(..), foreignTargetHints, CmmReturnInfo(..), mapExp, mapExpDeep, wrapRecExp, foldExp, foldExpDeep, wrapRecExpf, mapExpM, mapExpDeepM, wrapRecExpM, mapSuccessors @@ -281,6 +282,17 @@ data ForeignTarget -- The target of a foreign call CallishMachOp -- Which one deriving Eq +foreignTargetHints :: ForeignTarget -> ([ForeignHint], [ForeignHint]) +foreignTargetHints target + = ( res_hints ++ repeat NoHint + , arg_hints ++ repeat NoHint ) + where + (res_hints, arg_hints) = + case target of + PrimTarget op -> callishMachOpHints op + ForeignTarget _ (ForeignConvention _ arg_hints res_hints _) -> + (res_hints, arg_hints) + -------------------------------------------------- -- Instances of register and slot users / definers diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs index 0d44f0ffd5..f89c08178e 100644 --- a/compiler/cmm/CmmOpt.hs +++ b/compiler/cmm/CmmOpt.hs @@ -8,14 +8,13 @@ module CmmOpt ( cmmMachOpFold, - cmmMachOpFoldM, - cmmLoopifyForC, + cmmMachOpFoldM ) where #include "HsVersions.h" import CmmUtils -import OldCmm +import Cmm import DynFlags import CLabel @@ -416,6 +415,7 @@ exactLog2 x_ except factorial, but what the hell. -} +{- cmmLoopifyForC :: DynFlags -> RawCmmDecl -> RawCmmDecl -- XXX: revisit if we actually want to do this -- cmmLoopifyForC p@(CmmProc Nothing _ _) = p -- only if there's an info table, ignore case alts @@ -434,6 +434,7 @@ cmmLoopifyForC dflags (CmmProc infos entry_lbl live | otherwise = entry_lbl cmmLoopifyForC _ top = top +-} -- ----------------------------------------------------------------------------- -- Utils diff --git a/compiler/cmm/CmmPipeline.hs b/compiler/cmm/CmmPipeline.hs index 70ff754166..4e9a90a153 100644 --- a/compiler/cmm/CmmPipeline.hs +++ b/compiler/cmm/CmmPipeline.hs @@ -134,6 +134,8 @@ cpsTop hsc_env proc = return $ if optLevel dflags >= 1 then map (cmmCfgOptsProc splitting_proc_points) gs else gs + gs <- return (map removeUnreachableBlocksProc gs) + -- Note [unreachable blocks] dumps Opt_D_dump_cmmz_cfg "Post control-flow optimsations" gs return (cafEnv, gs) @@ -152,6 +154,8 @@ cpsTop hsc_env proc = return $ if optLevel dflags >= 1 then cmmCfgOptsProc splitting_proc_points g else g + g <- return (removeUnreachableBlocksProc g) + -- Note [unreachable blocks] dump' Opt_D_dump_cmmz_cfg "Post control-flow optimsations" g return (cafEnv, [g]) @@ -212,7 +216,15 @@ _GLOBAL_OFFSET_TABLE_, regardless of which entry point we arrived via. -} +{- Note [unreachable blocks] +The control-flow optimiser sometimes leaves unreachable blocks behind +containing junk code. If these blocks make it into the native code +generator then they trigger a register allocator panic because they +refer to undefined LocalRegs, so we must eliminate any unreachable +blocks before passing the code onwards. + +-} runUniqSM :: UniqSM a -> IO a runUniqSM m = do diff --git a/compiler/cmm/CmmUtils.hs b/compiler/cmm/CmmUtils.hs index d52c6a3a56..c822da9673 100644 --- a/compiler/cmm/CmmUtils.hs +++ b/compiler/cmm/CmmUtils.hs @@ -51,9 +51,8 @@ module CmmUtils( -- * Operations that probably don't belong here modifyGraph, - lastNode, replaceLastNode, ofBlockMap, toBlockMap, insertBlock, - ofBlockList, toBlockList, bodyToBlockList, + ofBlockList, toBlockList, bodyToBlockList, toBlockListEntryFirst, foldGraphBlocks, mapGraphNodes, postorderDfs, mapGraphNodes1, analFwd, analBwd, analRewFwd, analRewBwd, @@ -424,6 +423,17 @@ insertBlock block map = toBlockList :: CmmGraph -> [CmmBlock] toBlockList g = mapElems $ toBlockMap g +-- | like 'toBlockList', but the entry block always comes first +toBlockListEntryFirst :: CmmGraph -> [CmmBlock] +toBlockListEntryFirst g + | mapNull m = [] + | otherwise = entry_block : others + where + m = toBlockMap g + entry_id = g_entry g + Just entry_block = mapLookup entry_id m + others = filter ((/= entry_id) . entryLabel) (mapElems m) + ofBlockList :: BlockId -> [CmmBlock] -> CmmGraph ofBlockList entry blocks = CmmGraph { g_entry = entry , g_graph = GMany NothingO body NothingO } diff --git a/compiler/cmm/OldCmm.hs b/compiler/cmm/OldCmm.hs deleted file mode 100644 index fccdd8137d..0000000000 --- a/compiler/cmm/OldCmm.hs +++ /dev/null @@ -1,279 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - ------------------------------------------------------------------------------ --- --- Old-style Cmm data types --- --- (c) The University of Glasgow 2004-2006 --- ------------------------------------------------------------------------------ - -module OldCmm ( - CmmGroup, GenCmmGroup, RawCmmGroup, CmmDecl, RawCmmDecl, - ListGraph(..), - CmmInfoTable(..), ClosureTypeInfo(..), topInfoTable, - CmmStatic(..), CmmStatics(..), CmmFormal, CmmActual, - - cmmMapGraph, cmmTopMapGraph, - - GenBasicBlock(..), CmmBasicBlock, blockId, blockStmts, mapBlockStmts, - - CmmStmt(..), New.CmmReturnInfo(..), CmmHinted(..), - HintedCmmFormal, HintedCmmActual, - - CmmSafety(..), CmmCallTarget(..), - New.GenCmmDecl(..), New.ForeignHint(..), - - module CmmExpr, - - Section(..), ProfilingInfo(..), New.C_SRT(..) - ) where - -#include "HsVersions.h" - -import qualified Cmm as New -import Cmm ( CmmInfoTable(..), GenCmmGroup, CmmStatics(..), GenCmmDecl(..), - CmmFormal, CmmActual, Section(..), CmmStatic(..), - ProfilingInfo(..), ClosureTypeInfo(..) ) - -import BlockId -import CmmExpr -import FastString -import ForeignCall - - --- A [[BlockId]] is a local label. --- Local labels must be unique within an entire compilation unit, not --- just a single top-level item, because local labels map one-to-one --- with assembly-language labels. - ------------------------------------------------------------------------------ --- Cmm, CmmDecl, CmmBasicBlock ------------------------------------------------------------------------------ - --- A file is a list of top-level chunks. These may be arbitrarily --- re-orderd during code generation. - --- | A control-flow graph represented as a list of extended basic blocks. --- --- Code, may be empty. The first block is the entry point. The --- order is otherwise initially unimportant, but at some point the --- code gen will fix the order. --- --- BlockIds must be unique across an entire compilation unit, since --- they are translated to assembly-language labels, which scope --- across a whole compilation unit. -newtype ListGraph i = ListGraph [GenBasicBlock i] - -type CmmInfoTables = BlockEnv CmmInfoTable - --- | Cmm with the info table as a data type -type CmmGroup = GenCmmGroup CmmStatics CmmInfoTables (ListGraph CmmStmt) -type CmmDecl = GenCmmDecl CmmStatics CmmInfoTables (ListGraph CmmStmt) - --- | Cmm with the info tables converted to a list of 'CmmStatic' along with the info --- table label. If we are building without tables-next-to-code there will be no statics --- --- INVARIANT: if there is an info table, it has at least one CmmStatic -type RawCmmGroup = GenCmmGroup CmmStatics (BlockEnv CmmStatics) (ListGraph CmmStmt) -type RawCmmDecl = GenCmmDecl CmmStatics (BlockEnv CmmStatics) (ListGraph CmmStmt) - - --- A basic block containing a single label, at the beginning. --- The list of basic blocks in a top-level code block may be re-ordered. --- Fall-through is not allowed: there must be an explicit jump at the --- end of each basic block, but the code generator might rearrange basic --- blocks in order to turn some jumps into fallthroughs. - -data GenBasicBlock i = BasicBlock BlockId [i] -type CmmBasicBlock = GenBasicBlock CmmStmt - -instance UserOfRegs r i => UserOfRegs r (GenBasicBlock i) where - foldRegsUsed dflags f set (BasicBlock _ l) = foldRegsUsed dflags f set l - --- | The branch block id is that of the first block in --- the branch, which is that branch's entry point -blockId :: GenBasicBlock i -> BlockId -blockId (BasicBlock blk_id _ ) = blk_id - -blockStmts :: GenBasicBlock i -> [i] -blockStmts (BasicBlock _ stmts) = stmts - -mapBlockStmts :: (i -> i') -> GenBasicBlock i -> GenBasicBlock i' -mapBlockStmts f (BasicBlock id bs) = BasicBlock id (map f bs) - --- | 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 - ----------------------------------------------------------------- --- graph maps ----------------------------------------------------------------- - -cmmMapGraph :: (g -> g') -> GenCmmGroup d h g -> GenCmmGroup d h g' -cmmMapGraph f tops = map (cmmTopMapGraph f) tops - -cmmTopMapGraph :: (g -> g') -> GenCmmDecl d h g -> GenCmmDecl d h g' -cmmTopMapGraph f (CmmProc h l v g) = CmmProc h l v (f g) -cmmTopMapGraph _ (CmmData s ds) = CmmData s ds - ------------------------------------------------------------------------------ --- CmmStmt --- A "statement". Note that all branches are explicit: there are no --- control transfers to computed addresses, except when transfering --- control to a new function. ------------------------------------------------------------------------------ - -data CmmStmt - = CmmNop - | CmmComment FastString - - | CmmAssign CmmReg CmmExpr -- Assign to register - - | CmmStore CmmExpr CmmExpr -- Assign to memory location. Size is - -- given by cmmExprType of the rhs. - - | CmmCall -- A call (foreign, native or primitive), with - CmmCallTarget - [HintedCmmFormal] -- zero or more results - [HintedCmmActual] -- zero or more arguments - New.CmmReturnInfo - -- Some care is necessary when handling the arguments of these, see - -- [Register parameter passing] and the hack in cmm/CmmOpt.hs - - | CmmBranch BlockId -- branch to another BB in this fn - - | CmmCondBranch CmmExpr BlockId -- conditional branch - - | CmmSwitch -- Table branch - CmmExpr -- The scrutinee is zero-based; - [Maybe BlockId] -- zero -> first block - -- one -> second block etc - -- Undefined outside range, and when - -- there's a Nothing - - | CmmJump -- Jump to another C-- function, - CmmExpr -- Target - [GlobalReg] -- Live registers at call site; - -- Nothing -> no information, assume - -- all live - -- Just .. -> info on liveness, [] - -- means no live registers - -- This isn't all 'live' registers, just - -- the argument STG registers that are live - -- AND also possibly mapped to machine - -- registers. (So Sp, Hp, HpLim... ect - -- are never included here as they are - -- always live, only R2.., D1.. are - -- on this list) - - | CmmReturn -- Return from a native C-- function, - -data CmmHinted a - = CmmHinted { - hintlessCmm :: a, - cmmHint :: New.ForeignHint - } - deriving( Eq ) - -type HintedCmmFormal = CmmHinted CmmFormal -type HintedCmmActual = CmmHinted CmmActual - -data CmmSafety - = CmmUnsafe - | CmmSafe New.C_SRT - | CmmInterruptible - --- | enable us to fold used registers over '[CmmActual]' and '[CmmFormal]' -instance UserOfRegs LocalReg CmmStmt where - foldRegsUsed dflags f (set::b) s = stmt s set - where - stmt :: CmmStmt -> b -> b - stmt (CmmNop) = id - stmt (CmmComment {}) = id - stmt (CmmAssign _ e) = gen e - stmt (CmmStore e1 e2) = gen e1 . gen e2 - stmt (CmmCall target _ es _) = gen target . gen es - stmt (CmmBranch _) = id - stmt (CmmCondBranch e _) = gen e - stmt (CmmSwitch e _) = gen e - stmt (CmmJump e _) = gen e - stmt (CmmReturn) = id - - gen :: UserOfRegs LocalReg a => a -> b -> b - gen a set = foldRegsUsed dflags f set a - -instance UserOfRegs LocalReg CmmCallTarget where - foldRegsUsed dflags f set (CmmCallee e _) = foldRegsUsed dflags f set e - foldRegsUsed dflags f set (CmmPrim _ mStmts) = foldRegsUsed dflags f set mStmts - -instance UserOfRegs r a => UserOfRegs r (CmmHinted a) where - foldRegsUsed dflags f set a = foldRegsUsed dflags f set (hintlessCmm a) - -instance DefinerOfRegs r a => DefinerOfRegs r (CmmHinted a) where - foldRegsDefd dflags f set a = foldRegsDefd dflags f set (hintlessCmm a) - -{- -Discussion -~~~~~~~~~~ - -One possible problem with the above type is that the only way to do a -non-local conditional jump is to encode it as a branch to a block that -contains a single jump. This leads to inefficient code in the back end. - -[N.B. This problem will go away when we make the transition to the -'zipper' form of control-flow graph, in which both targets of a -conditional jump are explicit. ---NR] - -One possible way to fix this would be: - -data CmmStat = - ... - | CmmJump CmmBranchDest - | CmmCondJump CmmExpr CmmBranchDest - ... - -data CmmBranchDest - = Local BlockId - | NonLocal CmmExpr [LocalReg] - -In favour: - -+ one fewer constructors in CmmStmt -+ allows both cond branch and switch to jump to non-local destinations - -Against: - -- not strictly necessary: can already encode as branch+jump -- not always possible to implement any better in the back end -- could do the optimisation in the back end (but then plat-specific?) -- C-- doesn't have it -- back-end optimisation might be more general (jump shortcutting) - -So we'll stick with the way it is, and add the optimisation to the NCG. --} - ------------------------------------------------------------------------------ --- CmmCallTarget --- --- The target of a CmmCall. ------------------------------------------------------------------------------ - -data CmmCallTarget - = CmmCallee -- Call a function (foreign or native) - CmmExpr -- literal label <=> static call - -- other expression <=> dynamic call - CCallConv -- The calling convention - - | CmmPrim -- Call a "primitive" (eg. sin, cos) - CallishMachOp -- These might be implemented as inline - -- code by the backend. - -- If we don't know how to implement the - -- mach op, then we can replace it with - -- this list of statements: - (Maybe [CmmStmt]) - diff --git a/compiler/cmm/OldCmmLint.hs b/compiler/cmm/OldCmmLint.hs deleted file mode 100644 index 9a4fb42bc5..0000000000 --- a/compiler/cmm/OldCmmLint.hs +++ /dev/null @@ -1,212 +0,0 @@ ------------------------------------------------------------------------------ --- --- (c) The University of Glasgow 2004-2006 --- --- CmmLint: checking the correctness of Cmm statements and expressions --- ------------------------------------------------------------------------------ - -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - -module OldCmmLint ( - cmmLint, cmmLintTop - ) where - -import BlockId -import OldCmm -import Outputable -import OldPprCmm() -import FastString -import DynFlags - -import Data.Maybe - --- ----------------------------------------------------------------------------- --- Exported entry points: - -cmmLint :: (Outputable d, Outputable h) - => DynFlags -> GenCmmGroup d h (ListGraph CmmStmt) -> Maybe SDoc -cmmLint dflags tops = runCmmLint dflags (mapM_ (lintCmmDecl dflags)) tops - -cmmLintTop :: (Outputable d, Outputable h) - => DynFlags -> GenCmmDecl d h (ListGraph CmmStmt) -> Maybe SDoc -cmmLintTop dflags top = runCmmLint dflags (lintCmmDecl dflags) top - -runCmmLint :: Outputable a - => DynFlags -> (a -> CmmLint b) -> a -> Maybe SDoc -runCmmLint _ l p = - case unCL (l p) of - Left err -> Just (vcat [ptext $ sLit ("Cmm lint error:"), - nest 2 err, - ptext $ sLit ("Program was:"), - nest 2 (ppr p)]) - Right _ -> Nothing - -lintCmmDecl :: DynFlags -> (GenCmmDecl h i (ListGraph CmmStmt)) -> CmmLint () -lintCmmDecl dflags (CmmProc _ lbl _ (ListGraph blocks)) - = addLintInfo (text "in proc " <> ppr lbl) $ - let labels = foldl (\s b -> setInsert (blockId b) s) setEmpty blocks - in mapM_ (lintCmmBlock dflags labels) blocks - -lintCmmDecl _ (CmmData {}) - = return () - -lintCmmBlock :: DynFlags -> BlockSet -> GenBasicBlock CmmStmt -> CmmLint () -lintCmmBlock dflags labels (BasicBlock id stmts) - = addLintInfo (text "in basic block " <> ppr id) $ - mapM_ (lintCmmStmt dflags labels) stmts - --- ----------------------------------------------------------------------------- --- lintCmmExpr - --- Checks whether a CmmExpr is "type-correct", and check for obvious-looking --- byte/word mismatches. - -lintCmmExpr :: DynFlags -> CmmExpr -> CmmLint CmmType -lintCmmExpr dflags (CmmLoad expr rep) = do - _ <- lintCmmExpr dflags expr - -- Disabled, if we have the inlining phase before the lint phase, - -- we can have funny offsets due to pointer tagging. -- EZY - -- when (widthInBytes (typeWidth rep) >= wORD_SIZE) $ - -- cmmCheckWordAddress expr - return rep -lintCmmExpr dflags expr@(CmmMachOp op args) = do - tys <- mapM (lintCmmExpr dflags) args - if map (typeWidth . cmmExprType dflags) args == machOpArgReps dflags op - then cmmCheckMachOp dflags op args tys - else cmmLintMachOpErr expr (map (cmmExprType dflags) args) (machOpArgReps dflags op) -lintCmmExpr dflags (CmmRegOff reg offset) - = lintCmmExpr dflags (CmmMachOp (MO_Add rep) - [CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)]) - where rep = typeWidth (cmmRegType dflags reg) -lintCmmExpr dflags expr = - return (cmmExprType dflags expr) - --- Check for some common byte/word mismatches (eg. Sp + 1) -cmmCheckMachOp :: DynFlags -> MachOp -> [CmmExpr] -> [CmmType] -> CmmLint CmmType -cmmCheckMachOp dflags op [lit@(CmmLit (CmmInt { })), reg@(CmmReg _)] tys - = cmmCheckMachOp dflags op [reg, lit] tys -cmmCheckMachOp dflags op _ tys - = return (machOpResultType dflags op tys) - -{- -isOffsetOp :: MachOp -> Bool -isOffsetOp (MO_Add _) = True -isOffsetOp (MO_Sub _) = True -isOffsetOp _ = False - --- This expression should be an address from which a word can be loaded: --- check for funny-looking sub-word offsets. -_cmmCheckWordAddress :: CmmExpr -> CmmLint () -_cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)]) - | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (wORD_SIZE dflags) /= 0 - = cmmLintDubiousWordOffset e -_cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg]) - | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (wORD_SIZE dflags) /= 0 - = cmmLintDubiousWordOffset e -_cmmCheckWordAddress _ - = return () - --- No warnings for unaligned arithmetic with the node register, --- which is used to extract fields from tagged constructor closures. -notNodeReg :: CmmExpr -> Bool -notNodeReg (CmmReg reg) | reg == nodeReg = False -notNodeReg _ = True --} - -lintCmmStmt :: DynFlags -> BlockSet -> CmmStmt -> CmmLint () -lintCmmStmt dflags labels = lint - where lint (CmmNop) = return () - lint (CmmComment {}) = return () - lint stmt@(CmmAssign reg expr) = do - erep <- lintCmmExpr dflags expr - let reg_ty = cmmRegType dflags reg - if (erep `cmmEqType_ignoring_ptrhood` reg_ty) - then return () - else cmmLintAssignErr stmt erep reg_ty - lint (CmmStore l r) = do - _ <- lintCmmExpr dflags l - _ <- lintCmmExpr dflags r - return () - lint (CmmCall target _res args _) = - do lintTarget dflags labels target - mapM_ (lintCmmExpr dflags . hintlessCmm) args - lint (CmmCondBranch e id) = checkTarget id >> lintCmmExpr dflags e >> checkCond dflags e - lint (CmmSwitch e branches) = do - mapM_ checkTarget $ catMaybes branches - erep <- lintCmmExpr dflags e - if (erep `cmmEqType_ignoring_ptrhood` bWord dflags) - then return () - else cmmLintErr (text "switch scrutinee is not a word: " <> ppr e <> - text " :: " <> ppr erep) - lint (CmmJump e _) = lintCmmExpr dflags e >> return () - lint (CmmReturn) = return () - lint (CmmBranch id) = checkTarget id - checkTarget id = if setMember id labels then return () - else cmmLintErr (text "Branch to nonexistent id" <+> ppr id) - -lintTarget :: DynFlags -> BlockSet -> CmmCallTarget -> CmmLint () -lintTarget dflags _ (CmmCallee e _) = do _ <- lintCmmExpr dflags e - return () -lintTarget _ _ (CmmPrim _ Nothing) = return () -lintTarget dflags labels (CmmPrim _ (Just stmts)) - = mapM_ (lintCmmStmt dflags labels) stmts - - -checkCond :: DynFlags -> CmmExpr -> CmmLint () -checkCond _ (CmmMachOp mop _) | isComparisonMachOp mop = return () -checkCond dflags (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth dflags = return () -- constant values -checkCond _ expr - = cmmLintErr (hang (text "expression is not a conditional:") 2 - (ppr expr)) - --- ----------------------------------------------------------------------------- --- CmmLint monad - --- just a basic error monad: - -newtype CmmLint a = CmmLint { unCL :: Either SDoc a } - -instance Monad CmmLint where - CmmLint m >>= k = CmmLint $ case m of - Left e -> Left e - Right a -> unCL (k a) - return a = CmmLint (Right a) - -cmmLintErr :: SDoc -> CmmLint a -cmmLintErr msg = CmmLint (Left msg) - -addLintInfo :: SDoc -> CmmLint a -> CmmLint a -addLintInfo info thing = CmmLint $ - case unCL thing of - Left err -> Left (hang info 2 err) - Right a -> Right a - -cmmLintMachOpErr :: CmmExpr -> [CmmType] -> [Width] -> CmmLint a -cmmLintMachOpErr expr argsRep opExpectsRep - = cmmLintErr (text "in MachOp application: " $$ - nest 2 (ppr expr) $$ - (text "op is expecting: " <+> ppr opExpectsRep) $$ - (text "arguments provide: " <+> ppr argsRep)) - -cmmLintAssignErr :: CmmStmt -> CmmType -> CmmType -> CmmLint a -cmmLintAssignErr stmt e_ty r_ty - = cmmLintErr (text "in assignment: " $$ - nest 2 (vcat [ppr stmt, - text "Reg ty:" <+> ppr r_ty, - text "Rhs ty:" <+> ppr e_ty])) - - - -{- -cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a -cmmLintDubiousWordOffset expr - = cmmLintErr (text "offset is not a multiple of words: " $$ - nest 2 (ppr expr)) --} - diff --git a/compiler/cmm/OldCmmUtils.hs b/compiler/cmm/OldCmmUtils.hs deleted file mode 100644 index fe6ccee642..0000000000 --- a/compiler/cmm/OldCmmUtils.hs +++ /dev/null @@ -1,100 +0,0 @@ ------------------------------------------------------------------------------ --- --- Old-style Cmm utilities. --- --- (c) The University of Glasgow 2004-2006 --- ------------------------------------------------------------------------------ - -module OldCmmUtils( - CmmStmts, noStmts, oneStmt, mkStmts, plusStmts, stmtList, - isNopStmt, - - maybeAssignTemp, loadArgsIntoTemps, - - module CmmUtils, - ) where - -#include "HsVersions.h" - -import OldCmm -import CmmUtils -import OrdList -import DynFlags -import Unique - ---------------------------------------------------- --- --- CmmStmts --- ---------------------------------------------------- - -type CmmStmts = OrdList CmmStmt - -noStmts :: CmmStmts -noStmts = nilOL - -oneStmt :: CmmStmt -> CmmStmts -oneStmt = unitOL - -mkStmts :: [CmmStmt] -> CmmStmts -mkStmts = toOL - -plusStmts :: CmmStmts -> CmmStmts -> CmmStmts -plusStmts = appOL - -stmtList :: CmmStmts -> [CmmStmt] -stmtList = fromOL - - ---------------------------------------------------- --- --- CmmStmt --- ---------------------------------------------------- - -isNopStmt :: CmmStmt -> Bool --- If isNopStmt returns True, the stmt is definitely a no-op; --- but it might be a no-op even if isNopStmt returns False -isNopStmt CmmNop = True -isNopStmt (CmmAssign r e) = cheapEqReg r e -isNopStmt (CmmStore e1 (CmmLoad e2 _)) = cheapEqExpr e1 e2 -isNopStmt _ = False - -cheapEqExpr :: CmmExpr -> CmmExpr -> Bool -cheapEqExpr (CmmReg r) e = cheapEqReg r e -cheapEqExpr (CmmRegOff r 0) e = cheapEqReg r e -cheapEqExpr (CmmRegOff r n) (CmmRegOff r' n') = r==r' && n==n' -cheapEqExpr _ _ = False - -cheapEqReg :: CmmReg -> CmmExpr -> Bool -cheapEqReg r (CmmReg r') = r==r' -cheapEqReg r (CmmRegOff r' 0) = r==r' -cheapEqReg _ _ = False - ---------------------------------------------------- --- --- Helpers for foreign call arguments --- ---------------------------------------------------- - -loadArgsIntoTemps :: DynFlags -> [Unique] - -> [HintedCmmActual] - -> ([Unique], [CmmStmt], [HintedCmmActual]) -loadArgsIntoTemps _ uniques [] = (uniques, [], []) -loadArgsIntoTemps dflags uniques ((CmmHinted e hint):args) = - (uniques'', - new_stmts ++ remaining_stmts, - (CmmHinted new_e hint) : remaining_e) - where - (uniques', new_stmts, new_e) = maybeAssignTemp dflags uniques e - (uniques'', remaining_stmts, remaining_e) = - loadArgsIntoTemps dflags uniques' args - - -maybeAssignTemp :: DynFlags -> [Unique] -> CmmExpr -> ([Unique], [CmmStmt], CmmExpr) -maybeAssignTemp dflags uniques e - | hasNoGlobalRegs e = (uniques, [], e) - | otherwise = (tail uniques, [CmmAssign local e], CmmReg local) - where local = CmmLocal (LocalReg (head uniques) (cmmExprType dflags e)) - diff --git a/compiler/cmm/OldPprCmm.hs b/compiler/cmm/OldPprCmm.hs deleted file mode 100644 index edfaef8098..0000000000 --- a/compiler/cmm/OldPprCmm.hs +++ /dev/null @@ -1,224 +0,0 @@ ----------------------------------------------------------------------------- --- --- Pretty-printing of old-style Cmm as (a superset of) C-- --- --- (c) The University of Glasgow 2004-2006 --- ------------------------------------------------------------------------------ - --- --- This is where we walk over Cmm emitting an external representation, --- suitable for parsing, in a syntax strongly reminiscent of C--. This --- is the "External Core" for the Cmm layer. --- --- As such, this should be a well-defined syntax: we want it to look nice. --- Thus, we try wherever possible to use syntax defined in [1], --- "The C-- Reference Manual", http://www.cminusminus.org/. We differ --- slightly, in some cases. For one, we use I8 .. I64 for types, rather --- than C--'s bits8 .. bits64. --- --- We try to ensure that all information available in the abstract --- syntax is reproduced, or reproducible, in the concrete syntax. --- Data that is not in printed out can be reconstructed according to --- conventions used in the pretty printer. There are at least two such --- cases: --- 1) if a value has wordRep type, the type is not appended in the --- output. --- 2) MachOps that operate over wordRep type are printed in a --- C-style, rather than as their internal MachRep name. --- --- These conventions produce much more readable Cmm output. --- --- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs --- - -{-# OPTIONS_GHC -fno-warn-orphans #-} -module OldPprCmm ( - pprStmt, - module PprCmmDecl, - module PprCmmExpr - ) where - -import BlockId -import CLabel -import CmmUtils -import OldCmm -import PprCmmDecl -import PprCmmExpr - -import BasicTypes -import ForeignCall -import Outputable -import FastString - -import Data.List - ------------------------------------------------------------------------------ - -instance Outputable instr => Outputable (ListGraph instr) where - ppr (ListGraph blocks) = vcat (map ppr blocks) - -instance Outputable instr => Outputable (GenBasicBlock instr) where - ppr = pprBBlock - -instance Outputable CmmStmt where - ppr s = pprStmt s - --- -------------------------------------------------------------------------- -instance Outputable CmmSafety where - ppr CmmUnsafe = ptext (sLit "_unsafe_call_") - ppr CmmInterruptible = ptext (sLit "_interruptible_call_") - ppr (CmmSafe srt) = ppr srt - --- -------------------------------------------------------------------------- --- Basic blocks look like assembly blocks. --- lbl: stmt ; stmt ; .. -pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc -pprBBlock (BasicBlock ident stmts) = - hang (ppr ident <> colon) 4 (vcat (map ppr stmts)) - --- -------------------------------------------------------------------------- --- Statements. C-- usually, exceptions to this should be obvious. --- -pprStmt :: CmmStmt -> SDoc -pprStmt stmt = case stmt of - - -- ; - CmmNop -> semi - - -- // text - CmmComment s -> text "//" <+> ftext s - - -- reg = expr; - CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi - - -- rep[lv] = expr; - CmmStore lv expr -> - sdocWithDynFlags $ \dflags -> - let rep = ppr ( cmmExprType dflags expr ) - in rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi - - -- call "ccall" foo(x, y)[r1, r2]; - -- ToDo ppr volatile - CmmCall (CmmCallee fn cconv) results args ret -> - sep [ pp_lhs <+> pp_conv - , nest 2 (pprExpr9 fn <> - parens (commafy (map ppr_ar args))) - , case ret of CmmMayReturn -> empty - CmmNeverReturns -> ptext $ sLit (" never returns") - ] <> semi - where - pp_lhs | null results = empty - | otherwise = commafy (map ppr_ar results) <+> equals - -- Don't print the hints on a native C-- call - ppr_ar (CmmHinted ar k) = ppr (ar,k) - pp_conv = ptext (sLit("foreign")) <+> doubleQuotes (ppr cconv) - - -- Call a CallishMachOp, like sin or cos that might be implemented as a library call. - CmmCall (CmmPrim op _) results args ret -> - pprStmt (CmmCall (CmmCallee (CmmLit lbl) CCallConv) results args ret) - where - -- HACK: A CallishMachOp doesn't really correspond to a ForeignLabel, but we - -- use one to get the label printed. - lbl = CmmLabel (mkForeignLabel - (mkFastString (show op)) - Nothing ForeignLabelInThisPackage IsFunction) - - CmmBranch ident -> genBranch ident - CmmCondBranch expr ident -> genCondBranch expr ident - CmmJump expr live -> genJump expr live - CmmReturn -> genReturn - CmmSwitch arg ids -> genSwitch arg ids - --- Just look like a tuple, since it was a tuple before --- ... is that a good idea? --Isaac Dupree -instance (Outputable a) => Outputable (CmmHinted a) where - ppr (CmmHinted a k) = ppr (a, k) - --- -------------------------------------------------------------------------- --- goto local label. [1], section 6.6 --- --- goto lbl; --- -genBranch :: BlockId -> SDoc -genBranch ident = - ptext (sLit "goto") <+> ppr ident <> semi - --- -------------------------------------------------------------------------- --- Conditional. [1], section 6.4 --- --- if (expr) { goto lbl; } --- -genCondBranch :: CmmExpr -> BlockId -> SDoc -genCondBranch expr ident = - hsep [ ptext (sLit "if") - , parens (ppr expr) - , ptext (sLit "goto") - , ppr ident <> semi ] - --- -------------------------------------------------------------------------- --- A tail call. [1], Section 6.9 --- --- jump foo(a, b, c); --- -genJump :: CmmExpr -> [GlobalReg] -> SDoc -genJump expr live = - hcat [ ptext (sLit "jump") - , space - , if isTrivialCmmExpr expr - then pprExpr expr - else case expr of - CmmLoad (CmmReg _) _ -> pprExpr expr - _ -> parens (pprExpr expr) - , semi <+> ptext (sLit "// ") - , ppr live] - --- -------------------------------------------------------------------------- --- Return from a function. [1], Section 6.8.2 of version 1.128 --- --- return (a, b, c); --- -genReturn :: SDoc -genReturn = hcat [ ptext (sLit "return") , semi ] - --- -------------------------------------------------------------------------- --- Tabled jump to local label --- --- The syntax is from [1], section 6.5 --- --- switch [0 .. n] (expr) { case ... ; } --- -genSwitch :: CmmExpr -> [Maybe BlockId] -> SDoc -genSwitch expr maybe_ids - - = let pairs = groupBy snds (zip [0 .. ] maybe_ids ) - - in hang (hcat [ ptext (sLit "switch [0 .. ") - , int (length maybe_ids - 1) - , ptext (sLit "] ") - , if isTrivialCmmExpr expr - then pprExpr expr - else parens (pprExpr expr) - , ptext (sLit " {") - ]) - 4 (vcat ( map caseify pairs )) $$ rbrace - - where - snds a b = (snd a) == (snd b) - - caseify :: [(Int,Maybe BlockId)] -> SDoc - caseify ixs@((_,Nothing):_) - = ptext (sLit "/* impossible: ") <> hcat (intersperse comma (map (int.fst) ixs)) - <> ptext (sLit " */") - caseify as - = let (is,ids) = unzip as - in hsep [ ptext (sLit "case") - , hcat (punctuate comma (map int is)) - , ptext (sLit ": goto") - , ppr (head [ id | Just id <- ids]) <> semi ] - ------------------------------------------------------------------------------ - -commafy :: [SDoc] -> SDoc -commafy xs = fsep $ punctuate comma xs - diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index e0ff99cb29..ee964d8701 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -16,6 +16,7 @@ -- ----------------------------------------------------------------------------- +{-# LANGUAGE GADTs #-} module PprC ( writeCs, pprStringInCStyle @@ -27,8 +28,10 @@ module PprC ( import BlockId import CLabel import ForeignCall -import OldCmm -import OldPprCmm () +import Cmm hiding (pprBBlock) +import PprCmm () +import Hoopl +import CmmUtils -- Utils import CPrim @@ -81,8 +84,9 @@ pprC tops = vcat $ intersperse blankLine $ map pprTop tops -- top level procs -- pprTop :: RawCmmDecl -> SDoc -pprTop proc@(CmmProc _ clbl _ (ListGraph blocks)) = - (case topInfoTable proc of +pprTop (CmmProc infos clbl _ graph) = + + (case mapLookup (g_entry graph) infos of Nothing -> empty Just (Statics info_clbl info_dat) -> pprDataExterns info_dat $$ pprWordArray info_clbl info_dat) $$ @@ -93,16 +97,12 @@ pprTop proc@(CmmProc _ clbl _ (ListGraph blocks)) = then mkFN_ else mkIF_) (ppr clbl) <+> lbrace, nest 8 temp_decls, nest 8 mkFB_, - case blocks of - [] -> empty - -- the first block doesn't get a label: - (BasicBlock _ stmts : rest) -> - nest 8 (vcat (map pprStmt stmts)) $$ - vcat (map pprBBlock rest), + vcat (map pprBBlock blocks), nest 8 mkFE_, rbrace ] ) where + blocks = toBlockList graph (temp_decls, extern_decls) = pprTempAndExternDecls blocks @@ -133,14 +133,12 @@ pprTop (CmmData _section (Statics lbl lits)) = -- as many jumps as possible into fall throughs. -- -pprBBlock :: CmmBasicBlock -> SDoc -pprBBlock (BasicBlock lbl stmts) = - if null stmts then - pprTrace "pprC.pprBBlock: curious empty code block for" - (pprBlockId lbl) empty - else - nest 4 (pprBlockId lbl <> colon) $$ - nest 8 (vcat (map pprStmt stmts)) +pprBBlock :: CmmBlock -> SDoc +pprBBlock block = + nest 4 (pprBlockId lbl <> colon) $$ + nest 8 (vcat (map pprStmt (blockToList nodes)) $$ pprStmt last) + where + (CmmEntry lbl, nodes, last) = blockSplit block -- -------------------------------------------------------------------------- -- Info tables. Just arrays of words. @@ -165,13 +163,11 @@ pprLocalness lbl | not $ externallyVisibleCLabel lbl = ptext (sLit "static ") -- Statements. -- -pprStmt :: CmmStmt -> SDoc +pprStmt :: CmmNode e x -> SDoc pprStmt stmt = sdocWithDynFlags $ \dflags -> case stmt of - CmmReturn -> panic "pprStmt: return statement should have been cps'd away" - CmmNop -> empty CmmComment _ -> empty -- (hang (ptext (sLit "/*")) 3 (ftext s)) $$ ptext (sLit "*/") -- XXX if the string contains "*/", we need to fix it -- XXX we probably want to emit these comments when @@ -191,14 +187,20 @@ pprStmt stmt = where rep = cmmExprType dflags src - CmmCall (CmmCallee fn cconv) results args ret -> + CmmUnsafeForeignCall target@(ForeignTarget fn conv) results args -> maybe_proto $$ fnCall where - cast_fn = parens (cCast (pprCFunType (char '*') cconv results args) fn) + (res_hints, arg_hints) = foreignTargetHints target + hresults = zip results res_hints + hargs = zip args arg_hints + + ForeignConvention cconv _ _ ret = conv + + cast_fn = parens (cCast (pprCFunType (char '*') cconv hresults hargs) fn) real_fun_proto lbl = char ';' <> - pprCFunType (ppr lbl) cconv results args <> + pprCFunType (ppr lbl) cconv hresults hargs <> noreturn_attr <> semi noreturn_attr = case ret of @@ -210,7 +212,7 @@ pprStmt stmt = case fn of CmmLit (CmmLabel lbl) | StdCallConv <- cconv -> - let myCall = pprCall (ppr lbl) cconv results args + let myCall = pprCall (ppr lbl) cconv hresults hargs in (real_fun_proto lbl, myCall) -- stdcall functions must be declared with -- a function type, otherwise the C compiler @@ -218,40 +220,44 @@ pprStmt stmt = -- can't add the @n suffix ourselves, because -- it isn't valid C. | CmmNeverReturns <- ret -> - let myCall = pprCall (ppr lbl) cconv results args + let myCall = pprCall (ppr lbl) cconv hresults hargs in (real_fun_proto lbl, myCall) | not (isMathFun lbl) -> - pprForeignCall (ppr lbl) cconv results args + pprForeignCall (ppr lbl) cconv hresults hargs _ -> (empty {- no proto -}, - pprCall cast_fn cconv results args <> semi) + pprCall cast_fn cconv hresults hargs <> semi) -- for a dynamic call, no declaration is necessary. - CmmCall (CmmPrim _ (Just stmts)) _ _ _ -> - vcat $ map pprStmt stmts - - CmmCall (CmmPrim op _) results args _ret -> + CmmUnsafeForeignCall target@(PrimTarget op) results args -> proto $$ fn_call where cconv = CCallConv fn = pprCallishMachOp_for_C op + + (res_hints, arg_hints) = foreignTargetHints target + hresults = zip results res_hints + hargs = zip args arg_hints + (proto, fn_call) -- The mem primops carry an extra alignment arg, must drop it. -- We could maybe emit an alignment directive using this info. -- We also need to cast mem primops to prevent conflicts with GCC -- builtins (see bug #5967). | op `elem` [MO_Memcpy, MO_Memset, MO_Memmove] - = pprForeignCall fn cconv results (init args) + = pprForeignCall fn cconv hresults (init hargs) | otherwise - = (empty, pprCall fn cconv results args) + = (empty, pprCall fn cconv hresults hargs) CmmBranch ident -> pprBranch ident - CmmCondBranch expr ident -> pprCondBranch expr ident - CmmJump lbl _ -> mkJMP_(pprExpr lbl) <> semi + CmmCondBranch expr yes no -> pprCondBranch expr yes no + CmmCall { cml_target = expr } -> mkJMP_ (pprExpr expr) <> semi CmmSwitch arg ids -> sdocWithDynFlags $ \dflags -> pprSwitch dflags arg ids -pprForeignCall :: SDoc -> CCallConv -> [HintedCmmFormal] -> [HintedCmmActual] +type Hinted a = (a, ForeignHint) + +pprForeignCall :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> (SDoc, SDoc) pprForeignCall fn cconv results args = (proto, fn_call) where @@ -263,14 +269,14 @@ pprForeignCall fn cconv results args = (proto, fn_call) cast_fn = parens (parens (pprCFunType (char '*') cconv results args) <> fn) proto = ptext (sLit ";EF_(") <> fn <> char ')' <> semi -pprCFunType :: SDoc -> CCallConv -> [HintedCmmFormal] -> [HintedCmmActual] -> SDoc +pprCFunType :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc pprCFunType ppr_fn cconv ress args = sdocWithDynFlags $ \dflags -> let res_type [] = ptext (sLit "void") - res_type [CmmHinted one hint] = machRepHintCType (localRegType one) hint + res_type [(one, hint)] = machRepHintCType (localRegType one) hint res_type _ = panic "pprCFunType: only void or 1 return value supported" - arg_type (CmmHinted expr hint) = machRepHintCType (cmmExprType dflags expr) hint + arg_type (expr, hint) = machRepHintCType (cmmExprType dflags expr) hint in res_type ress <+> parens (ccallConvAttribute cconv <> ppr_fn) <> parens (commafy (map arg_type args)) @@ -283,11 +289,11 @@ pprBranch ident = ptext (sLit "goto") <+> pprBlockId ident <> semi -- --------------------------------------------------------------------- -- conditional branches to local labels -pprCondBranch :: CmmExpr -> BlockId -> SDoc -pprCondBranch expr ident +pprCondBranch :: CmmExpr -> BlockId -> BlockId -> SDoc +pprCondBranch expr yes no = hsep [ ptext (sLit "if") , parens(pprExpr expr) , - ptext (sLit "goto") , (pprBlockId ident) <> semi ] - + ptext (sLit "goto"), pprBlockId yes, + ptext (sLit "else"), pprBlockId no <> semi ] -- --------------------------------------------------------------------- -- a local table branch @@ -831,7 +837,7 @@ pprLocalReg (LocalReg uniq _) = char '_' <> ppr uniq -- ----------------------------------------------------------------------------- -- Foreign Calls -pprCall :: SDoc -> CCallConv -> [HintedCmmFormal] -> [HintedCmmActual] -> SDoc +pprCall :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc pprCall ppr_fn cconv results args | not (is_cishCC cconv) = panic $ "pprCall: unknown calling convention" @@ -841,18 +847,18 @@ pprCall ppr_fn cconv results args ppr_assign results (ppr_fn <> parens (commafy (map pprArg args))) <> semi where ppr_assign [] rhs = rhs - ppr_assign [CmmHinted one hint] rhs + ppr_assign [(one,hint)] rhs = pprLocalReg one <> ptext (sLit " = ") <> pprUnHint hint (localRegType one) <> rhs ppr_assign _other _rhs = panic "pprCall: multiple results" - pprArg (CmmHinted expr AddrHint) + pprArg (expr, AddrHint) = cCast (ptext (sLit "void *")) expr -- see comment by machRepHintCType below - pprArg (CmmHinted expr SignedHint) + pprArg (expr, SignedHint) = sdocWithDynFlags $ \dflags -> cCast (machRep_S_CType $ typeWidth $ cmmExprType dflags expr) expr - pprArg (CmmHinted expr _other) + pprArg (expr, _other) = pprExpr expr pprUnHint AddrHint rep = parens (machRepCType rep) @@ -871,7 +877,7 @@ is_cishCC PrimCallConv = False -- Find and print local and external declarations for a list of -- Cmm statements. -- -pprTempAndExternDecls :: [CmmBasicBlock] -> (SDoc{-temps-}, SDoc{-externs-}) +pprTempAndExternDecls :: [CmmBlock] -> (SDoc{-temps-}, SDoc{-externs-}) pprTempAndExternDecls stmts = (vcat (map pprTempDecl (uniqSetToList temps)), vcat (map (pprExternDecl False{-ToDo-}) (Map.keys lbls))) @@ -930,8 +936,9 @@ te_Static :: CmmStatic -> TE () te_Static (CmmStaticLit lit) = te_Lit lit te_Static _ = return () -te_BB :: CmmBasicBlock -> TE () -te_BB (BasicBlock _ ss) = mapM_ te_Stmt ss +te_BB :: CmmBlock -> TE () +te_BB block = mapM_ te_Stmt (blockToList mid) >> te_Stmt last + where (_, mid, last) = blockSplit block te_Lit :: CmmLit -> TE () te_Lit (CmmLabel l) = te_lbl l @@ -939,21 +946,21 @@ te_Lit (CmmLabelOff l _) = te_lbl l te_Lit (CmmLabelDiffOff l1 _ _) = te_lbl l1 te_Lit _ = return () -te_Stmt :: CmmStmt -> TE () +te_Stmt :: CmmNode e x -> TE () te_Stmt (CmmAssign r e) = te_Reg r >> te_Expr e te_Stmt (CmmStore l r) = te_Expr l >> te_Expr r -te_Stmt (CmmCall target rs es _) = do te_Target target - mapM_ (te_temp.hintlessCmm) rs - mapM_ (te_Expr.hintlessCmm) es -te_Stmt (CmmCondBranch e _) = te_Expr e +te_Stmt (CmmUnsafeForeignCall target rs es) + = do te_Target target + mapM_ te_temp rs + mapM_ te_Expr es +te_Stmt (CmmCondBranch e _ _) = te_Expr e te_Stmt (CmmSwitch e _) = te_Expr e -te_Stmt (CmmJump e _) = te_Expr e +te_Stmt (CmmCall { cml_target = e }) = te_Expr e te_Stmt _ = return () -te_Target :: CmmCallTarget -> TE () -te_Target (CmmCallee {}) = return () -te_Target (CmmPrim _ Nothing) = return () -te_Target (CmmPrim _ (Just stmts)) = mapM_ te_Stmt stmts +te_Target :: ForeignTarget -> TE () +te_Target (ForeignTarget e _) = te_Expr e +te_Target (PrimTarget{}) = return () te_Expr :: CmmExpr -> TE () te_Expr (CmmLit lit) = te_Lit lit diff --git a/compiler/cmm/PprCmmExpr.hs b/compiler/cmm/PprCmmExpr.hs index 7d2f4824ef..71c84464ad 100644 --- a/compiler/cmm/PprCmmExpr.hs +++ b/compiler/cmm/PprCmmExpr.hs @@ -35,7 +35,6 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module PprCmmExpr ( pprExpr, pprLit - , pprExpr9 {-only to import in OldPprCmm. When it dies, remove the export -} ) where diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs index 67d8fd8817..bdb7f69b11 100644 --- a/compiler/codeGen/CgUtils.hs +++ b/compiler/codeGen/CgUtils.hs @@ -6,12 +6,15 @@ -- ----------------------------------------------------------------------------- +{-# LANGUAGE GADTs #-} module CgUtils ( fixStgRegisters ) where #include "HsVersions.h" import CodeGen.Platform -import OldCmm +import Cmm +import Hoopl +import CmmUtils import CLabel import DynFlags import Outputable @@ -96,59 +99,28 @@ get_Regtable_addr_from_offset dflags _ offset = fixStgRegisters :: DynFlags -> RawCmmDecl -> RawCmmDecl fixStgRegisters _ top@(CmmData _ _) = top -fixStgRegisters dflags (CmmProc info lbl live (ListGraph blocks)) = - let blocks' = map (fixStgRegBlock dflags) blocks - in CmmProc info lbl live $ ListGraph blocks' +fixStgRegisters dflags (CmmProc info lbl live graph) = + let graph' = modifyGraph (mapGraphBlocks (fixStgRegBlock dflags)) graph + in CmmProc info lbl live graph' -fixStgRegBlock :: DynFlags -> CmmBasicBlock -> CmmBasicBlock -fixStgRegBlock dflags (BasicBlock id stmts) = - let stmts' = map (fixStgRegStmt dflags) stmts - in BasicBlock id stmts' +fixStgRegBlock :: DynFlags -> Block CmmNode e x -> Block CmmNode e x +fixStgRegBlock dflags block = mapBlock (fixStgRegStmt dflags) block -fixStgRegStmt :: DynFlags -> CmmStmt -> CmmStmt -fixStgRegStmt dflags stmt - = case stmt of - CmmAssign (CmmGlobal reg) src -> - let src' = fixStgRegExpr dflags src - baseAddr = get_GlobalReg_addr dflags reg - in case reg `elem` activeStgRegs platform of - True -> CmmAssign (CmmGlobal reg) src' - False -> CmmStore baseAddr src' - - CmmAssign reg src -> - let src' = fixStgRegExpr dflags src - in CmmAssign reg src' - - CmmStore addr src -> CmmStore (fixStgRegExpr dflags addr) (fixStgRegExpr dflags src) - - CmmCall target regs args returns -> - let target' = case target of - CmmCallee e conv -> CmmCallee (fixStgRegExpr dflags e) conv - CmmPrim op mStmts -> - CmmPrim op (fmap (map (fixStgRegStmt dflags)) mStmts) - args' = map (\(CmmHinted arg hint) -> - (CmmHinted (fixStgRegExpr dflags arg) hint)) args - in CmmCall target' regs args' returns - - CmmCondBranch test dest -> CmmCondBranch (fixStgRegExpr dflags test) dest - - CmmSwitch expr ids -> CmmSwitch (fixStgRegExpr dflags expr) ids +fixStgRegStmt :: DynFlags -> CmmNode e x -> CmmNode e x +fixStgRegStmt dflags stmt = fixAssign $ mapExpDeep fixExpr stmt + where + platform = targetPlatform dflags - CmmJump addr live -> CmmJump (fixStgRegExpr dflags addr) live - - -- CmmNop, CmmComment, CmmBranch, CmmReturn - _other -> stmt - where platform = targetPlatform dflags - - -fixStgRegExpr :: DynFlags -> CmmExpr -> CmmExpr -fixStgRegExpr dflags expr - = case expr of - CmmLoad addr ty -> CmmLoad (fixStgRegExpr dflags addr) ty - - CmmMachOp mop args -> CmmMachOp mop args' - where args' = map (fixStgRegExpr dflags) args + fixAssign stmt = + case stmt of + CmmAssign (CmmGlobal reg) src -> + let baseAddr = get_GlobalReg_addr dflags reg + in case reg `elem` activeStgRegs (targetPlatform dflags) of + True -> CmmAssign (CmmGlobal reg) src + False -> CmmStore baseAddr src + other_stmt -> other_stmt + fixExpr expr = case expr of CmmReg (CmmGlobal reg) -> -- Replace register leaves with appropriate StixTrees for -- the given target. MagicIds which map to a reg on this @@ -161,9 +133,8 @@ fixStgRegExpr dflags expr False -> let baseAddr = get_GlobalReg_addr dflags reg in case reg of - BaseReg -> fixStgRegExpr dflags baseAddr - _other -> fixStgRegExpr dflags - (CmmLoad baseAddr (globalRegType dflags reg)) + BaseReg -> baseAddr + _other -> CmmLoad baseAddr (globalRegType dflags reg) CmmRegOff (CmmGlobal reg) offset -> -- RegOf leaves are just a shorthand form. If the reg maps @@ -171,12 +142,10 @@ fixStgRegExpr dflags expr -- expand it and defer to the above code. case reg `elem` activeStgRegs platform of True -> expr - False -> fixStgRegExpr dflags (CmmMachOp (MO_Add (wordWidth dflags)) [ - CmmReg (CmmGlobal reg), + False -> CmmMachOp (MO_Add (wordWidth dflags)) [ + fixExpr (CmmReg (CmmGlobal reg)), CmmLit (CmmInt (fromIntegral offset) - (wordWidth dflags))]) + (wordWidth dflags))] - -- CmmLit, CmmReg (CmmLocal), CmmStackSlot - _other -> expr - where platform = targetPlatform dflags + other_expr -> other_expr diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 1a10cd162e..d2ef375642 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -173,7 +173,6 @@ Library CmmCallConv CmmCommonBlockElim CmmContFlowOpt - CmmCvt CmmExpr CmmInfo CmmLex @@ -190,10 +189,6 @@ Library CmmUtils CmmLayoutStack MkGraph - OldCmm - OldCmmLint - OldCmmUtils - OldPprCmm PprBase PprC PprCmm diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs index 571348f577..241e52e392 100644 --- a/compiler/llvmGen/LlvmCodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen.hs @@ -14,8 +14,9 @@ import LlvmCodeGen.Ppr import LlvmMangler import CgUtils ( fixStgRegisters ) -import OldCmm -import OldPprCmm +import Cmm +import Hoopl +import PprCmm import BufWrite import DynFlags @@ -41,10 +42,11 @@ llvmCodeGen dflags h us cmms (cdata,env) = {-# SCC "llvm_split" #-} foldr split ([], initLlvmEnv dflags) cmm split (CmmData s d' ) (d,e) = ((s,d'):d,e) - split p@(CmmProc _ l live _) (d,e) = - let lbl = strCLabel_llvm env $ case topInfoTable p of - Nothing -> l - Just (Statics info_lbl _) -> info_lbl + split p@(CmmProc h l live g) (d,e) = + let lbl = strCLabel_llvm env $ + case mapLookup (g_entry g) h of + Nothing -> l + Just (Statics info_lbl _) -> info_lbl env' = funInsert lbl (llvmFunTy dflags live) e in (d,env') in do @@ -129,9 +131,6 @@ cmmProcLlvmGens dflags h _ _ [] _ ivars cmmProcLlvmGens dflags h us env ((CmmData _ _) : cmms) count ivars = cmmProcLlvmGens dflags h us env cmms count ivars -cmmProcLlvmGens dflags h us env ((CmmProc _ _ _ (ListGraph [])) : cmms) count ivars - = cmmProcLlvmGens dflags h us env cmms count ivars - cmmProcLlvmGens dflags h us env (cmm : cmms) count ivars = do (us', env', llvm) <- cmmLlvmGen dflags us (clearVars env) cmm let (docs, ivar) = mapAndUnzip (pprLlvmCmmDecl env' count) llvm diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs index 849e40d203..56537d2ae2 100644 --- a/compiler/llvmGen/LlvmCodeGen/Base.hs +++ b/compiler/llvmGen/LlvmCodeGen/Base.hs @@ -34,7 +34,7 @@ import CLabel import CodeGen.Platform ( activeStgRegs ) import DynFlags import FastString -import OldCmm +import Cmm import qualified Outputable as Outp import Platform import UniqFM diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index d62fbf4397..b5d4b4a76c 100644 --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -3,6 +3,7 @@ -- | Handle conversion of CmmProc to LLVM code. -- +{-# LANGUAGE GADTs #-} module LlvmCodeGen.CodeGen ( genLlvmProc ) where #include "HsVersions.h" @@ -14,8 +15,10 @@ import LlvmCodeGen.Regs import BlockId import CodeGen.Platform ( activeStgRegs, callerSaves ) import CLabel -import OldCmm -import qualified OldPprCmm as PprCmm +import Cmm +import PprCmm +import CmmUtils +import Hoopl import DynFlags import FastString @@ -37,9 +40,10 @@ type LlvmStatements = OrdList LlvmStatement -- | Top-level of the LLVM proc Code generator -- genLlvmProc :: LlvmEnv -> RawCmmDecl -> UniqSM (LlvmEnv, [LlvmCmmDecl]) -genLlvmProc env proc0@(CmmProc _ lbl live (ListGraph blocks)) = do +genLlvmProc env proc0@(CmmProc infos lbl live graph) = do + let blocks = toBlockList graph (env', lmblocks, lmdata) <- basicBlocksCodeGen env live blocks ([], []) - let info = topInfoTable proc0 + let info = mapLookup (g_entry graph) infos proc = CmmProc info lbl live (ListGraph lmblocks) return (env', proc:lmdata) @@ -52,22 +56,23 @@ genLlvmProc _ _ = panic "genLlvmProc: case that shouldn't reach here!" -- | Generate code for a list of blocks that make up a complete procedure. basicBlocksCodeGen :: LlvmEnv -> LiveGlobalRegs - -> [CmmBasicBlock] + -> [CmmBlock] -> ( [LlvmBasicBlock] , [LlvmCmmDecl] ) -> UniqSM (LlvmEnv, [LlvmBasicBlock] , [LlvmCmmDecl] ) -basicBlocksCodeGen env live ([]) (blocks, tops) - = do let dflags = getDflags env - let (blocks', allocs) = mapAndUnzip dominateAllocs blocks - let allocs' = concat allocs - let ((BasicBlock id fstmts):rblks) = blocks' - let fblocks = (BasicBlock id $ funPrologue dflags live ++ allocs' ++ fstmts):rblks - return (env, fblocks, tops) - -basicBlocksCodeGen env live (block:blocks) (lblocks', ltops') +basicBlocksCodeGen env live [] (blocks0, tops0) + = return (env, fblocks, tops) + where + dflags = getDflags env + blocks = reverse blocks0 + tops = reverse tops0 + (blocks', allocs) = mapAndUnzip dominateAllocs blocks + allocs' = concat allocs + (BasicBlock id fstmts : rblks) = blocks' + fblocks = (BasicBlock id $ funPrologue dflags live ++ allocs' ++ fstmts):rblks + +basicBlocksCodeGen env live (block:blocks) (lblocks, ltops) = do (env', lb, lt) <- basicBlockCodeGen env block - let lblocks = lblocks' ++ lb - let ltops = ltops' ++ lt - basicBlocksCodeGen env' live blocks (lblocks, ltops) + basicBlocksCodeGen env' live blocks (lb : lblocks, reverse lt ++ ltops) -- | Allocations need to be extracted so they can be moved to the entry @@ -81,16 +86,19 @@ dominateAllocs (BasicBlock id stmts) -- | Generate code for one block -basicBlockCodeGen :: LlvmEnv - -> CmmBasicBlock - -> UniqSM ( LlvmEnv, [LlvmBasicBlock], [LlvmCmmDecl] ) -basicBlockCodeGen env (BasicBlock id stmts) - = do (env', instrs, top) <- stmtsToInstrs env stmts (nilOL, []) - return (env', [BasicBlock id (fromOL instrs)], top) - +basicBlockCodeGen :: LlvmEnv + -> CmmBlock + -> UniqSM ( LlvmEnv, LlvmBasicBlock, [LlvmCmmDecl] ) +basicBlockCodeGen env block + = do let (CmmEntry id, nodes, tail) = blockSplit block + let stmts = blockToList nodes + (env', mid_instrs, top) <- stmtsToInstrs env stmts (nilOL, []) + (env'', tail_instrs, top') <- stmtToInstrs env' tail + let instrs = fromOL (mid_instrs `appOL` tail_instrs) + return (env'', BasicBlock id instrs, top' ++ top) -- ----------------------------------------------------------------------------- --- * CmmStmt code generation +-- * CmmNode code generation -- -- A statement conversion return data. @@ -100,8 +108,8 @@ basicBlockCodeGen env (BasicBlock id stmts) type StmtData = (LlvmEnv, LlvmStatements, [LlvmCmmDecl]) --- | Convert a list of CmmStmt's to LlvmStatement's -stmtsToInstrs :: LlvmEnv -> [CmmStmt] -> (LlvmStatements, [LlvmCmmDecl]) +-- | Convert a list of CmmNode's to LlvmStatement's +stmtsToInstrs :: LlvmEnv -> [CmmNode e x] -> (LlvmStatements, [LlvmCmmDecl]) -> UniqSM StmtData stmtsToInstrs env [] (llvm, top) = return (env, llvm, top) @@ -111,34 +119,28 @@ stmtsToInstrs env (stmt : stmts) (llvm, top) stmtsToInstrs env' stmts (llvm `appOL` instrs, top ++ tops) --- | Convert a CmmStmt to a list of LlvmStatement's -stmtToInstrs :: LlvmEnv -> CmmStmt +-- | Convert a CmmNode to a list of LlvmStatement's +stmtToInstrs :: LlvmEnv -> CmmNode e x -> UniqSM StmtData stmtToInstrs env stmt = case stmt of - CmmNop -> return (env, nilOL, []) CmmComment _ -> return (env, nilOL, []) -- nuke comments CmmAssign reg src -> genAssign env reg src CmmStore addr src -> genStore env addr src CmmBranch id -> genBranch env id - CmmCondBranch arg id -> genCondBranch env arg id + CmmCondBranch arg true false -> genCondBranch env arg true false CmmSwitch arg ids -> genSwitch env arg ids -- Foreign Call - CmmCall target res args ret - -> genCall env target res args ret + CmmUnsafeForeignCall target res args -> genCall env target res args -- Tail call - CmmJump arg live -> genJump env arg live - - -- CPS, only tail calls, no return's - -- Actually, there are a few return statements that occur because of hand - -- written Cmm code. - CmmReturn - -> return (env, unitOL $ Return Nothing, []) + CmmCall { cml_target = arg, + cml_args_regs = live } -> genJump env arg live + _ -> panic "Llvm.CodeGen.stmtToInstrs" -- | Memory barrier instruction for LLVM >= 3.0 barrier :: LlvmEnv -> UniqSM StmtData @@ -171,12 +173,12 @@ oldBarrier env = do lmTrue = mkIntLit i1 (-1) -- | Foreign Calls -genCall :: LlvmEnv -> CmmCallTarget -> [HintedCmmFormal] -> [HintedCmmActual] - -> CmmReturnInfo -> UniqSM StmtData +genCall :: LlvmEnv -> ForeignTarget -> [CmmFormal] -> [CmmActual] + -> UniqSM StmtData -- Write barrier needs to be handled specially as it is implemented as an LLVM -- intrinsic function. -genCall env (CmmPrim MO_WriteBarrier _) _ _ _ +genCall env (PrimTarget MO_WriteBarrier) _ _ | platformArch (getLlvmPlatform env) `elem` [ArchX86, ArchX86_64, ArchSPARC] = return (env, nilOL, []) | getLlvmVer env > 29 = barrier env @@ -186,7 +188,7 @@ genCall env (CmmPrim MO_WriteBarrier _) _ _ _ -- types and things like Word8 are backed by an i32 and just present a logical -- i8 range. So we must handle conversions from i32 to i8 explicitly as LLVM -- is strict about types. -genCall env t@(CmmPrim (MO_PopCnt w) _) [CmmHinted dst _] args _ = do +genCall env t@(PrimTarget (MO_PopCnt w)) [dst] args = do let dflags = getDflags env width = widthToLlvmInt w dstTy = cmmToLlvmType $ localRegType dst @@ -194,7 +196,9 @@ genCall env t@(CmmPrim (MO_PopCnt w) _) [CmmHinted dst _] args _ = do CC_Ccc width FixedArgs (tysToParams [width]) Nothing (env1, dstV, stmts1, top1) = getCmmReg env (CmmLocal dst) - (env2, argsV, stmts2, top2) <- arg_vars env1 args ([], nilOL, []) + let (_, arg_hints) = foreignTargetHints t + let args_hints = zip args arg_hints + (env2, argsV, stmts2, top2) <- arg_vars env1 args_hints ([], nilOL, []) (env3, fptr, stmts3, top3) <- getFunPtr env2 funTy t (argsV', stmts4) <- castVars dflags $ zip argsV [width] (retV, s1) <- doExpr width $ Call StdCall fptr argsV' [] @@ -207,7 +211,7 @@ genCall env t@(CmmPrim (MO_PopCnt w) _) [CmmHinted dst _] args _ = do -- Handle memcpy function specifically since llvm's intrinsic version takes -- some extra parameters. -genCall env t@(CmmPrim op _) [] args' CmmMayReturn +genCall env t@(PrimTarget op) [] args' | op == MO_Memcpy || op == MO_Memset || op == MO_Memmove = do @@ -220,7 +224,9 @@ genCall env t@(CmmPrim op _) [] args' CmmMayReturn funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible CC_Ccc LMVoid FixedArgs (tysToParams argTy) Nothing - (env1, argVars, stmts1, top1) <- arg_vars env args ([], nilOL, []) + let (_, arg_hints) = foreignTargetHints t + let args_hints = zip args arg_hints + (env1, argVars, stmts1, top1) <- arg_vars env args_hints ([], nilOL, []) (env2, fptr, stmts2, top2) <- getFunPtr env1 funTy t (argVars', stmts3) <- castVars dflags $ zip argVars argTy @@ -236,48 +242,43 @@ genCall env t@(CmmPrim op _) [] args' CmmMayReturn -- Fix for trac #6158. Since LLVM 3.1, opt fails when given anything other -- than a direct constant (i.e. 'i32 8') as the alignment argument for the -- memcpy & co llvm intrinsic functions. So we handle this directly now. - extractLit (CmmHinted (CmmLit (CmmInt i _)) _) = mkIntLit i32 i + extractLit (CmmLit (CmmInt i _)) = mkIntLit i32 i extractLit _other = trace ("WARNING: Non constant alignment value given" ++ " for memcpy! Please report to GHC developers") mkIntLit i32 0 -genCall env (CmmPrim _ (Just stmts)) _ _ _ - = stmtsToInstrs env stmts (nilOL, []) - -- Handle all other foreign calls and prim ops. -genCall env target res args ret = do +genCall env target res args = do let dflags = getDflags env -- parameter types - let arg_type (CmmHinted _ AddrHint) = i8Ptr + let arg_type (_, AddrHint) = i8Ptr -- cast pointers to i8*. Llvm equivalent of void* - arg_type (CmmHinted expr _ ) = cmmToLlvmType $ cmmExprType dflags expr + arg_type (expr, _) = cmmToLlvmType $ cmmExprType dflags expr -- ret type - let ret_type ([]) = LMVoid - ret_type ([CmmHinted _ AddrHint]) = i8Ptr - ret_type ([CmmHinted reg _]) = cmmToLlvmType $ localRegType reg + let ret_type [] = LMVoid + ret_type [(_, AddrHint)] = i8Ptr + ret_type [(reg, _)] = cmmToLlvmType $ localRegType reg ret_type t = panic $ "genCall: Too many return values! Can only handle" ++ " 0 or 1, given " ++ show (length t) ++ "." - -- extract Cmm call convention - let cconv = case target of - CmmCallee _ conv -> conv - CmmPrim _ _ -> PrimCallConv - - -- translate to LLVM call convention - let lmconv = case cconv of - StdCallConv -> case platformArch (getLlvmPlatform env) of - ArchX86 -> CC_X86_Stdcc - ArchX86_64 -> CC_X86_Stdcc - _ -> CC_Ccc - CCallConv -> CC_Ccc - CApiConv -> CC_Ccc - PrimCallConv -> CC_Ccc + -- extract Cmm call convention, and translate to LLVM call convention + let lmconv = case target of + ForeignTarget _ (ForeignConvention conv _ _ _) -> + case conv of + StdCallConv -> case platformArch (getLlvmPlatform env) of + ArchX86 -> CC_X86_Stdcc + ArchX86_64 -> CC_X86_Stdcc + _ -> CC_Ccc + CCallConv -> CC_Ccc + CApiConv -> CC_Ccc + + PrimTarget _ -> CC_Ccc {- - Some of the possibilities here are a worry with the use of a custom + CC_Ccc of the possibilities here are a worry with the use of a custom calling convention for passing STG args. In practice the more dangerous combinations (e.g StdCall + llvmGhcCC) don't occur. @@ -285,23 +286,31 @@ genCall env target res args ret = do -} -- call attributes - let fnAttrs | ret == CmmNeverReturns = NoReturn : llvmStdFunAttrs - | otherwise = llvmStdFunAttrs + let fnAttrs | never_returns = NoReturn : llvmStdFunAttrs + | otherwise = llvmStdFunAttrs + + never_returns = case target of + ForeignTarget _ (ForeignConvention _ _ _ CmmNeverReturns) -> True + _ -> False -- fun type + let (res_hints, arg_hints) = foreignTargetHints target + let args_hints = zip args arg_hints + let ress_hints = zip res res_hints let ccTy = StdCall -- tail calls should be done through CmmJump - let retTy = ret_type res - let argTy = tysToParams $ map arg_type args + let retTy = ret_type ress_hints + let argTy = tysToParams $ map arg_type args_hints let funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible lmconv retTy FixedArgs argTy (llvmFunAlign dflags) - (env1, argVars, stmts1, top1) <- arg_vars env args ([], nilOL, []) + + (env1, argVars, stmts1, top1) <- arg_vars env args_hints ([], nilOL, []) (env2, fptr, stmts2, top2) <- getFunPtr env1 funTy target - let retStmt | ccTy == TailCall = unitOL $ Return Nothing - | ret == CmmNeverReturns = unitOL $ Unreachable - | otherwise = nilOL + let retStmt | ccTy == TailCall = unitOL $ Return Nothing + | never_returns = unitOL $ Unreachable + | otherwise = nilOL let stmts = stmts1 `appOL` stmts2 `appOL` trashStmts (getDflags env) @@ -315,10 +324,10 @@ genCall env target res args ret = do _ -> do (v1, s1) <- doExpr retTy $ Call ccTy fptr argVars fnAttrs -- get the return register - let ret_reg ([CmmHinted reg hint]) = (reg, hint) + let ret_reg [reg] = reg ret_reg t = panic $ "genCall: Bad number of registers! Can only handle" ++ " 1, given " ++ show (length t) ++ "." - let (creg, _) = ret_reg res + let creg = ret_reg res let (env3, vreg, stmts3, top3) = getCmmReg env2 (CmmLocal creg) let allStmts = stmts `snocOL` s1 `appOL` stmts3 if retTy == pLower (getVarType vreg) @@ -342,12 +351,12 @@ genCall env target res args ret = do -- | Create a function pointer from a target. -getFunPtr :: LlvmEnv -> (LMString -> LlvmType) -> CmmCallTarget +getFunPtr :: LlvmEnv -> (LMString -> LlvmType) -> ForeignTarget -> UniqSM ExprData getFunPtr env funTy targ = case targ of - CmmCallee (CmmLit (CmmLabel lbl)) _ -> litCase $ strCLabel_llvm env lbl + ForeignTarget (CmmLit (CmmLabel lbl)) _ -> litCase $ strCLabel_llvm env lbl - CmmCallee expr _ -> do + ForeignTarget expr _ -> do (env', v1, stmts, top) <- exprToVar env expr let fty = funTy $ fsLit "dynamic" cast = case getVarType v1 of @@ -360,7 +369,7 @@ getFunPtr env funTy targ = case targ of (v2,s1) <- doExpr (pLift fty) $ Cast cast v1 (pLift fty) return (env', v2, stmts `snocOL` s1, top) - CmmPrim mop _ -> litCase $ cmmPrimOpFunctions env mop + PrimTarget mop -> litCase $ cmmPrimOpFunctions env mop where litCase name = do @@ -392,14 +401,14 @@ getFunPtr env funTy targ = case targ of -- | Conversion of call arguments. arg_vars :: LlvmEnv - -> [HintedCmmActual] + -> [(CmmActual, ForeignHint)] -> ([LlvmVar], LlvmStatements, [LlvmCmmDecl]) -> UniqSM (LlvmEnv, [LlvmVar], LlvmStatements, [LlvmCmmDecl]) arg_vars env [] (vars, stmts, tops) = return (env, vars, stmts, tops) -arg_vars env (CmmHinted e AddrHint:rest) (vars, stmts, tops) +arg_vars env ((e, AddrHint):rest) (vars, stmts, tops) = do (env', v1, stmts', top') <- exprToVar env e let op = case getVarType v1 of ty | isPointer ty -> LM_Bitcast @@ -412,7 +421,7 @@ arg_vars env (CmmHinted e AddrHint:rest) (vars, stmts, tops) arg_vars env' rest (vars ++ [v2], stmts `appOL` stmts' `snocOL` s1, tops ++ top') -arg_vars env (CmmHinted e _:rest) (vars, stmts, tops) +arg_vars env ((e, _):rest) (vars, stmts, tops) = do (env', v1, stmts', top') <- exprToVar env e arg_vars env' rest (vars ++ [v1], stmts `appOL` stmts', tops ++ top') @@ -673,17 +682,15 @@ genBranch env id = -- | Conditional branch -genCondBranch :: LlvmEnv -> CmmExpr -> BlockId -> UniqSM StmtData -genCondBranch env cond idT = do - idF <- getUniqueUs +genCondBranch :: LlvmEnv -> CmmExpr -> BlockId -> BlockId -> UniqSM StmtData +genCondBranch env cond idT idF = do let labelT = blockIdToLlvm idT - let labelF = LMLocalVar idF LMLabel + let labelF = blockIdToLlvm idF (env', vc, stmts, top) <- exprToVarOpt env i1Option cond if getVarType vc == i1 then do let s1 = BranchIf vc labelT labelF - let s2 = MkLabel idF - return $ (env', stmts `snocOL` s1 `snocOL` s2, top) + return $ (env', stmts `snocOL` s1, top) else panic $ "genCondBranch: Cond expr not bool! (" ++ show vc ++ ")" diff --git a/compiler/llvmGen/LlvmCodeGen/Data.hs b/compiler/llvmGen/LlvmCodeGen/Data.hs index 9c57ab3cd4..fd0d7ccd99 100644 --- a/compiler/llvmGen/LlvmCodeGen/Data.hs +++ b/compiler/llvmGen/LlvmCodeGen/Data.hs @@ -13,7 +13,7 @@ import LlvmCodeGen.Base import BlockId import CLabel -import OldCmm +import Cmm import FastString import qualified Outputable diff --git a/compiler/llvmGen/LlvmCodeGen/Ppr.hs b/compiler/llvmGen/LlvmCodeGen/Ppr.hs index 73632f5fd4..218870a5b8 100644 --- a/compiler/llvmGen/LlvmCodeGen/Ppr.hs +++ b/compiler/llvmGen/LlvmCodeGen/Ppr.hs @@ -14,7 +14,7 @@ import LlvmCodeGen.Data import LlvmCodeGen.Regs import CLabel -import OldCmm +import Cmm import Platform import FastString diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs index beaf7c8eec..230ba71c3a 100644 --- a/compiler/main/CodeOutput.lhs +++ b/compiler/main/CodeOutput.lhs @@ -15,9 +15,9 @@ import UniqSupply ( mkSplitUniqSupply ) import Finder ( mkStubPaths ) import PprC ( writeCs ) -import OldCmmLint ( cmmLint ) +import CmmLint ( cmmLint ) import Packages -import OldCmm ( RawCmmGroup ) +import Cmm ( RawCmmGroup ) import HscTypes import DynFlags import Config diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index ab48d35bf4..fe827e3cee 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -119,13 +119,11 @@ import ProfInit import TyCon import Name import SimplStg ( stg2stg ) -import qualified OldCmm as Old -import qualified Cmm as New +import Cmm import CmmParse ( parseCmmFile ) import CmmBuildInfoTables import CmmPipeline import CmmInfo -import CmmCvt import CodeOutput import NameEnv ( emptyNameEnv ) import NameSet ( emptyNameSet ) @@ -1353,7 +1351,7 @@ hscCompileCmmFile hsc_env filename = runHsc hsc_env $ do let initTopSRT = initUs_ us emptySRT dumpIfSet_dyn dflags Opt_D_dump_cmmz "Parsed Cmm" (ppr cmm) (_, cmmgroup) <- cmmPipeline hsc_env initTopSRT cmm - rawCmms <- cmmToRawCmm dflags (Stream.yield (cmmOfZgraph cmmgroup)) + rawCmms <- cmmToRawCmm dflags (Stream.yield cmmgroup) _ <- codeOutput dflags no_mod no_loc NoStubs [] rawCmms return () where @@ -1368,7 +1366,7 @@ tryNewCodeGen :: HscEnv -> Module -> [TyCon] -> CollectedCCs -> [StgBinding] -> HpcInfo - -> IO (Stream IO Old.CmmGroup ()) + -> IO (Stream IO CmmGroup ()) -- Note we produce a 'Stream' of CmmGroups, so that the -- backend can be run incrementally. Otherwise it generates all -- the C-- up front, which has a significant space cost. @@ -1376,7 +1374,7 @@ tryNewCodeGen hsc_env this_mod data_tycons cost_centre_info stg_binds hpc_info = do let dflags = hsc_dflags hsc_env - let cmm_stream :: Stream IO New.CmmGroup () + let cmm_stream :: Stream IO CmmGroup () cmm_stream = {-# SCC "StgCmm" #-} StgCmm.codeGen dflags this_mod data_tycons cost_centre_info stg_binds hpc_info @@ -1407,7 +1405,7 @@ tryNewCodeGen hsc_env this_mod data_tycons (topSRT, cmmgroup) <- cmmPipeline hsc_env topSRT' cmmgroup let srt | isEmptySRT topSRT = [] | otherwise = srtToData topSRT - return (us',cmmOfZgraph (srt ++ cmmgroup)) + return (us', srt ++ cmmgroup) in do _ <- Stream.mapAccumL run_pipeline us ppr_stream1 return () @@ -1418,10 +1416,10 @@ tryNewCodeGen hsc_env this_mod data_tycons let run_pipeline topSRT cmmgroup = do (topSRT, cmmgroup) <- cmmPipeline hsc_env topSRT cmmgroup - return (topSRT,cmmOfZgraph cmmgroup) + return (topSRT,cmmgroup) in do topSRT <- Stream.mapAccumL run_pipeline initTopSRT ppr_stream1 - Stream.yield (cmmOfZgraph (srtToData topSRT)) + Stream.yield (srtToData topSRT) let dump2 a = do dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" $ ppr a 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 diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs index 88fbb3a7e9..1573562d78 100644 --- a/compiler/types/TyCon.lhs +++ b/compiler/types/TyCon.lhs @@ -755,19 +755,61 @@ See also Note [Implicit TyThings] in HscTypes %* * %************************************************************************ -A PrimRep is somewhat similar to a CgRep (see codeGen/SMRep) and a -MachRep (see cmm/CmmExpr), although each of these types has a distinct -and clearly defined purpose: - - - A PrimRep is a CgRep + information about signedness + information - about primitive pointers (AddrRep). Signedness and primitive - pointers are required when passing a primitive type to a foreign - function, but aren't needed for call/return conventions of Haskell - functions. - - - A MachRep is a basic machine type (non-void, doesn't contain - information on pointerhood or signedness, but contains some - reps that don't have corresponding Haskell types). +Note [rep swamp] + +GHC has a rich selection of types that represent "primitive types" of +one kind or another. Each of them makes a different set of +distinctions, and mostly the differences are for good reasons, +although it's probably true that we could merge some of these. + +Roughly in order of "includes more information": + + - A Width (cmm/CmmType) is simply a binary value with the specified + number of bits. It may represent a signed or unsigned integer, a + floating-point value, or an address. + + data Width = W8 | W16 | W32 | W64 | W80 | W128 + + - Size, which is used in the native code generator, is Width + + floating point information. + + data Size = II8 | II16 | II32 | II64 | FF32 | FF64 | FF80 + + it is necessary because e.g. the instruction to move a 64-bit float + on x86 (movsd) is different from the instruction to move a 64-bit + integer (movq), so the mov instruction is parameterised by Size. + + - CmmType wraps Width with more information: GC ptr, float, or + other value. + + data CmmType = CmmType CmmCat Width + + data CmmCat -- "Category" (not exported) + = GcPtrCat -- GC pointer + | BitsCat -- Non-pointer + | FloatCat -- Float + + It is important to have GcPtr information in Cmm, since we generate + info tables containing pointerhood for the GC from this. As for + why we have float (and not signed/unsigned) here, see Note [Signed + vs unsigned]. + + - ArgRep makes only the distinctions necessary for the call and + return conventions of the STG machine. It is essentially CmmType + + void. + + - PrimRep makes a few more distinctions than ArgRep: it divides + non-GC-pointers into signed/unsigned and addresses, information + that is necessary for passing these values to foreign functions. + +There's another tension here: whether the type encodes its size in +bytes, or whether its size depends on the machine word size. Width +and CmmType have the size built-in, whereas ArgRep and PrimRep do not. + +This means to turn an ArgRep/PrimRep into a CmmType requires DynFlags. + +On the other hand, CmmType includes some "nonsense" values, such as +CmmType GcPtrCat W32 on a 64-bit machine. \begin{code} -- | A 'PrimRep' is an abstraction of a type. It contains information that -- cgit v1.2.1 From 929578081e8b2b0f14e9518329f516eebf4315ce Mon Sep 17 00:00:00 2001 From: Simon Marlow Date: Mon, 12 Nov 2012 12:02:44 +0000 Subject: Fix warnings --- compiler/cmm/CmmOpt.hs | 1 - compiler/cmm/PprC.hs | 3 +++ compiler/llvmGen/LlvmCodeGen.hs | 2 +- compiler/llvmGen/LlvmCodeGen/CodeGen.hs | 5 +++-- compiler/nativeGen/AsmCodeGen.lhs | 1 - compiler/nativeGen/Instruction.hs | 1 - 6 files changed, 7 insertions(+), 6 deletions(-) (limited to 'compiler') diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs index f89c08178e..f4cf86448c 100644 --- a/compiler/cmm/CmmOpt.hs +++ b/compiler/cmm/CmmOpt.hs @@ -16,7 +16,6 @@ module CmmOpt ( import CmmUtils import Cmm import DynFlags -import CLabel import FastTypes import Outputable diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index ee964d8701..9ebb12d752 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -168,6 +168,7 @@ pprStmt :: CmmNode e x -> SDoc pprStmt stmt = sdocWithDynFlags $ \dflags -> case stmt of + CmmEntry _ -> empty CmmComment _ -> empty -- (hang (ptext (sLit "/*")) 3 (ftext s)) $$ ptext (sLit "*/") -- XXX if the string contains "*/", we need to fix it -- XXX we probably want to emit these comments when @@ -255,6 +256,8 @@ pprStmt stmt = CmmSwitch arg ids -> sdocWithDynFlags $ \dflags -> pprSwitch dflags arg ids + _other -> pprPanic "PprC.pprStmt" (ppr stmt) + type Hinted a = (a, ForeignHint) pprForeignCall :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs index 241e52e392..4b8455f2be 100644 --- a/compiler/llvmGen/LlvmCodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen.hs @@ -42,7 +42,7 @@ llvmCodeGen dflags h us cmms (cdata,env) = {-# SCC "llvm_split" #-} foldr split ([], initLlvmEnv dflags) cmm split (CmmData s d' ) (d,e) = ((s,d'):d,e) - split p@(CmmProc h l live g) (d,e) = + split (CmmProc h l live g) (d,e) = let lbl = strCLabel_llvm env $ case mapLookup (g_entry g) h of Nothing -> l diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index b5d4b4a76c..ef9fc2b666 100644 --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -40,8 +40,8 @@ type LlvmStatements = OrdList LlvmStatement -- | Top-level of the LLVM proc Code generator -- genLlvmProc :: LlvmEnv -> RawCmmDecl -> UniqSM (LlvmEnv, [LlvmCmmDecl]) -genLlvmProc env proc0@(CmmProc infos lbl live graph) = do - let blocks = toBlockList graph +genLlvmProc env (CmmProc infos lbl live graph) = do + let blocks = toBlockListEntryFirst graph (env', lmblocks, lmdata) <- basicBlocksCodeGen env live blocks ([], []) let info = mapLookup (g_entry graph) infos proc = CmmProc info lbl live (ListGraph lmblocks) @@ -274,6 +274,7 @@ genCall env target res args = do _ -> CC_Ccc CCallConv -> CC_Ccc CApiConv -> CC_Ccc + PrimCallConv -> panic "LlvmCodeGen.CodeGen.genCall: PrimCallConv" PrimTarget _ -> CC_Ccc diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index 7710691457..53d1949aeb 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -953,7 +953,6 @@ cmmStmtConFold stmt CmmCondBranch test true false -> do test' <- cmmExprConFold DataReference test - dflags <- getDynFlags return $ case test' of CmmLit (CmmInt 0 _) -> CmmBranch false CmmLit (CmmInt _ _) -> CmmBranch true diff --git a/compiler/nativeGen/Instruction.hs b/compiler/nativeGen/Instruction.hs index 48d6a33d79..076129f7fa 100644 --- a/compiler/nativeGen/Instruction.hs +++ b/compiler/nativeGen/Instruction.hs @@ -19,7 +19,6 @@ import BlockId import DynFlags import Cmm hiding (topInfoTable) import Platform -import Outputable -- | Holds a list of source and destination registers used by a -- particular instruction. -- cgit v1.2.1 From 4dc7d04e59161be4ea33192f82aa94be3c68bf20 Mon Sep 17 00:00:00 2001 From: Simon Marlow Date: Mon, 12 Nov 2012 14:01:01 +0000 Subject: replaceLabels: null out the cml_cont field of CmmCall This fixes a CmmLint complaint when doing proc-point splitting. --- compiler/cmm/CmmProcPoint.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) (limited to 'compiler') diff --git a/compiler/cmm/CmmProcPoint.hs b/compiler/cmm/CmmProcPoint.hs index 02b232d488..fb94b95e51 100644 --- a/compiler/cmm/CmmProcPoint.hs +++ b/compiler/cmm/CmmProcPoint.hs @@ -354,7 +354,10 @@ replaceBranches env cmmg last (CmmBranch id) = CmmBranch (lookup id) last (CmmCondBranch e ti fi) = CmmCondBranch e (lookup ti) (lookup fi) last (CmmSwitch e tbl) = CmmSwitch e (map (fmap lookup) tbl) - last l@(CmmCall {}) = l + last l@(CmmCall {}) = l { cml_cont = Nothing } + -- NB. remove the continuation of a CmmCall, since this + -- label will now be in a different CmmProc. Not only + -- is this tidier, it stops CmmLint from complaining. last l@(CmmForeignCall {}) = l lookup id = fmap lookup (mapLookup id env) `orElse` id -- XXX: this is a recursive lookup, it follows chains -- cgit v1.2.1 From a1ebe37d8394e35d0a29f21511626d0895db634a Mon Sep 17 00:00:00 2001 From: Simon Marlow Date: Mon, 12 Nov 2012 14:01:22 +0000 Subject: handle MO_Touch, and generate no code for it. --- compiler/llvmGen/LlvmCodeGen/CodeGen.hs | 3 +++ 1 file changed, 3 insertions(+) (limited to 'compiler') diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index ef9fc2b666..fd9d7011c4 100644 --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -184,6 +184,9 @@ genCall env (PrimTarget MO_WriteBarrier) _ _ | getLlvmVer env > 29 = barrier env | otherwise = oldBarrier env +genCall env (PrimTarget MO_Touch) _ _ + = return (env, nilOL, []) + -- Handle popcnt function specifically since GHC only really has i32 and i64 -- types and things like Word8 are backed by an i32 and just present a logical -- i8 range. So we must handle conversions from i32 to i8 explicitly as LLVM -- cgit v1.2.1