diff options
Diffstat (limited to 'compiler')
61 files changed, 689 insertions, 1486 deletions
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..f4cf86448c 100644 --- a/compiler/cmm/CmmOpt.hs +++ b/compiler/cmm/CmmOpt.hs @@ -8,16 +8,14 @@ module CmmOpt ( cmmMachOpFold, - cmmMachOpFoldM, - cmmLoopifyForC, + cmmMachOpFoldM ) where #include "HsVersions.h" import CmmUtils -import OldCmm +import Cmm import DynFlags -import CLabel import FastTypes import Outputable @@ -416,6 +414,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 +433,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/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 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..9ebb12d752 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,12 @@ 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 + 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 @@ -191,14 +188,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 +213,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 +221,46 @@ 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] + _other -> pprPanic "PprC.pprStmt" (ppr stmt) + +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 +272,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 +292,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 +840,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 +850,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 +880,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 +939,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 +949,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..4b8455f2be 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 (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..fd9d7011c4 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 (CmmProc infos lbl live graph) = do + let blocks = toBlockListEntryFirst 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,22 +173,25 @@ 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 | 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 -- 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 +199,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 +214,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 +227,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 +245,44 @@ 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 + PrimCallConv -> panic "LlvmCodeGen.CodeGen.genCall: PrimCallConv" + + 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 +290,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 +328,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 +355,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 +373,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 +405,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 +425,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 +686,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..53d1949aeb 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,26 @@ 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..076129f7fa 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,7 +17,7 @@ import Reg import BlockId import DynFlags -import OldCmm +import Cmm hiding (topInfoTable) import Platform -- | Holds a list of source and destination registers used by a @@ -34,7 +37,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 +56,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/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 "-") } ----------------------------------------------------------------------------- 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 |