diff options
Diffstat (limited to 'compiler/cmm')
| -rw-r--r-- | compiler/cmm/Cmm.hs | 39 | ||||
| -rw-r--r-- | compiler/cmm/CmmContFlowOpt.hs | 45 | ||||
| -rw-r--r-- | compiler/cmm/CmmCvt.hs | 117 | ||||
| -rw-r--r-- | compiler/cmm/CmmInfo.hs | 32 | ||||
| -rw-r--r-- | compiler/cmm/CmmNode.hs | 14 | ||||
| -rw-r--r-- | compiler/cmm/CmmOpt.hs | 7 | ||||
| -rw-r--r-- | compiler/cmm/CmmPipeline.hs | 12 | ||||
| -rw-r--r-- | compiler/cmm/CmmUtils.hs | 14 | ||||
| -rw-r--r-- | compiler/cmm/OldCmm.hs | 279 | ||||
| -rw-r--r-- | compiler/cmm/OldCmmLint.hs | 212 | ||||
| -rw-r--r-- | compiler/cmm/OldCmmUtils.hs | 100 | ||||
| -rw-r--r-- | compiler/cmm/OldPprCmm.hs | 224 | ||||
| -rw-r--r-- | compiler/cmm/PprC.hs | 131 | ||||
| -rw-r--r-- | compiler/cmm/PprCmmExpr.hs | 1 |
14 files changed, 196 insertions, 1031 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..f89c08178e 100644 --- a/compiler/cmm/CmmOpt.hs +++ b/compiler/cmm/CmmOpt.hs @@ -8,14 +8,13 @@ module CmmOpt ( cmmMachOpFold, - cmmMachOpFoldM, - cmmLoopifyForC, + cmmMachOpFoldM ) where #include "HsVersions.h" import CmmUtils -import OldCmm +import Cmm import DynFlags import CLabel @@ -416,6 +415,7 @@ exactLog2 x_ except factorial, but what the hell. -} +{- cmmLoopifyForC :: DynFlags -> RawCmmDecl -> RawCmmDecl -- XXX: revisit if we actually want to do this -- cmmLoopifyForC p@(CmmProc Nothing _ _) = p -- only if there's an info table, ignore case alts @@ -434,6 +434,7 @@ cmmLoopifyForC dflags (CmmProc infos entry_lbl live | otherwise = entry_lbl cmmLoopifyForC _ top = top +-} -- ----------------------------------------------------------------------------- -- Utils diff --git a/compiler/cmm/CmmPipeline.hs b/compiler/cmm/CmmPipeline.hs index 70ff754166..4e9a90a153 100644 --- a/compiler/cmm/CmmPipeline.hs +++ b/compiler/cmm/CmmPipeline.hs @@ -134,6 +134,8 @@ cpsTop hsc_env proc = return $ if optLevel dflags >= 1 then map (cmmCfgOptsProc splitting_proc_points) gs else gs + gs <- return (map removeUnreachableBlocksProc gs) + -- Note [unreachable blocks] dumps Opt_D_dump_cmmz_cfg "Post control-flow optimsations" gs return (cafEnv, gs) @@ -152,6 +154,8 @@ cpsTop hsc_env proc = return $ if optLevel dflags >= 1 then cmmCfgOptsProc splitting_proc_points g else g + g <- return (removeUnreachableBlocksProc g) + -- Note [unreachable blocks] dump' Opt_D_dump_cmmz_cfg "Post control-flow optimsations" g return (cafEnv, [g]) @@ -212,7 +216,15 @@ _GLOBAL_OFFSET_TABLE_, regardless of which entry point we arrived via. -} +{- Note [unreachable blocks] +The control-flow optimiser sometimes leaves unreachable blocks behind +containing junk code. If these blocks make it into the native code +generator then they trigger a register allocator panic because they +refer to undefined LocalRegs, so we must eliminate any unreachable +blocks before passing the code onwards. + +-} runUniqSM :: UniqSM a -> IO a runUniqSM m = do diff --git a/compiler/cmm/CmmUtils.hs b/compiler/cmm/CmmUtils.hs index d52c6a3a56..c822da9673 100644 --- a/compiler/cmm/CmmUtils.hs +++ b/compiler/cmm/CmmUtils.hs @@ -51,9 +51,8 @@ module CmmUtils( -- * Operations that probably don't belong here modifyGraph, - lastNode, replaceLastNode, ofBlockMap, toBlockMap, insertBlock, - ofBlockList, toBlockList, bodyToBlockList, + ofBlockList, toBlockList, bodyToBlockList, toBlockListEntryFirst, foldGraphBlocks, mapGraphNodes, postorderDfs, mapGraphNodes1, analFwd, analBwd, analRewFwd, analRewBwd, @@ -424,6 +423,17 @@ insertBlock block map = toBlockList :: CmmGraph -> [CmmBlock] toBlockList g = mapElems $ toBlockMap g +-- | like 'toBlockList', but the entry block always comes first +toBlockListEntryFirst :: CmmGraph -> [CmmBlock] +toBlockListEntryFirst g + | mapNull m = [] + | otherwise = entry_block : others + where + m = toBlockMap g + entry_id = g_entry g + Just entry_block = mapLookup entry_id m + others = filter ((/= entry_id) . entryLabel) (mapElems m) + ofBlockList :: BlockId -> [CmmBlock] -> CmmGraph ofBlockList entry blocks = CmmGraph { g_entry = entry , g_graph = GMany NothingO body NothingO } diff --git a/compiler/cmm/OldCmm.hs b/compiler/cmm/OldCmm.hs deleted file mode 100644 index fccdd8137d..0000000000 --- a/compiler/cmm/OldCmm.hs +++ /dev/null @@ -1,279 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - ------------------------------------------------------------------------------ --- --- Old-style Cmm data types --- --- (c) The University of Glasgow 2004-2006 --- ------------------------------------------------------------------------------ - -module OldCmm ( - CmmGroup, GenCmmGroup, RawCmmGroup, CmmDecl, RawCmmDecl, - ListGraph(..), - CmmInfoTable(..), ClosureTypeInfo(..), topInfoTable, - CmmStatic(..), CmmStatics(..), CmmFormal, CmmActual, - - cmmMapGraph, cmmTopMapGraph, - - GenBasicBlock(..), CmmBasicBlock, blockId, blockStmts, mapBlockStmts, - - CmmStmt(..), New.CmmReturnInfo(..), CmmHinted(..), - HintedCmmFormal, HintedCmmActual, - - CmmSafety(..), CmmCallTarget(..), - New.GenCmmDecl(..), New.ForeignHint(..), - - module CmmExpr, - - Section(..), ProfilingInfo(..), New.C_SRT(..) - ) where - -#include "HsVersions.h" - -import qualified Cmm as New -import Cmm ( CmmInfoTable(..), GenCmmGroup, CmmStatics(..), GenCmmDecl(..), - CmmFormal, CmmActual, Section(..), CmmStatic(..), - ProfilingInfo(..), ClosureTypeInfo(..) ) - -import BlockId -import CmmExpr -import FastString -import ForeignCall - - --- A [[BlockId]] is a local label. --- Local labels must be unique within an entire compilation unit, not --- just a single top-level item, because local labels map one-to-one --- with assembly-language labels. - ------------------------------------------------------------------------------ --- Cmm, CmmDecl, CmmBasicBlock ------------------------------------------------------------------------------ - --- A file is a list of top-level chunks. These may be arbitrarily --- re-orderd during code generation. - --- | A control-flow graph represented as a list of extended basic blocks. --- --- Code, may be empty. The first block is the entry point. The --- order is otherwise initially unimportant, but at some point the --- code gen will fix the order. --- --- BlockIds must be unique across an entire compilation unit, since --- they are translated to assembly-language labels, which scope --- across a whole compilation unit. -newtype ListGraph i = ListGraph [GenBasicBlock i] - -type CmmInfoTables = BlockEnv CmmInfoTable - --- | Cmm with the info table as a data type -type CmmGroup = GenCmmGroup CmmStatics CmmInfoTables (ListGraph CmmStmt) -type CmmDecl = GenCmmDecl CmmStatics CmmInfoTables (ListGraph CmmStmt) - --- | Cmm with the info tables converted to a list of 'CmmStatic' along with the info --- table label. If we are building without tables-next-to-code there will be no statics --- --- INVARIANT: if there is an info table, it has at least one CmmStatic -type RawCmmGroup = GenCmmGroup CmmStatics (BlockEnv CmmStatics) (ListGraph CmmStmt) -type RawCmmDecl = GenCmmDecl CmmStatics (BlockEnv CmmStatics) (ListGraph CmmStmt) - - --- A basic block containing a single label, at the beginning. --- The list of basic blocks in a top-level code block may be re-ordered. --- Fall-through is not allowed: there must be an explicit jump at the --- end of each basic block, but the code generator might rearrange basic --- blocks in order to turn some jumps into fallthroughs. - -data GenBasicBlock i = BasicBlock BlockId [i] -type CmmBasicBlock = GenBasicBlock CmmStmt - -instance UserOfRegs r i => UserOfRegs r (GenBasicBlock i) where - foldRegsUsed dflags f set (BasicBlock _ l) = foldRegsUsed dflags f set l - --- | The branch block id is that of the first block in --- the branch, which is that branch's entry point -blockId :: GenBasicBlock i -> BlockId -blockId (BasicBlock blk_id _ ) = blk_id - -blockStmts :: GenBasicBlock i -> [i] -blockStmts (BasicBlock _ stmts) = stmts - -mapBlockStmts :: (i -> i') -> GenBasicBlock i -> GenBasicBlock i' -mapBlockStmts f (BasicBlock id bs) = BasicBlock id (map f bs) - --- | Returns the info table associated with the CmmDecl's entry point, --- if any. -topInfoTable :: GenCmmDecl a (BlockEnv i) (ListGraph b) -> Maybe i -topInfoTable (CmmProc infos _ _ (ListGraph (b:_))) - = mapLookup (blockId b) infos -topInfoTable _ - = Nothing - ----------------------------------------------------------------- --- graph maps ----------------------------------------------------------------- - -cmmMapGraph :: (g -> g') -> GenCmmGroup d h g -> GenCmmGroup d h g' -cmmMapGraph f tops = map (cmmTopMapGraph f) tops - -cmmTopMapGraph :: (g -> g') -> GenCmmDecl d h g -> GenCmmDecl d h g' -cmmTopMapGraph f (CmmProc h l v g) = CmmProc h l v (f g) -cmmTopMapGraph _ (CmmData s ds) = CmmData s ds - ------------------------------------------------------------------------------ --- CmmStmt --- A "statement". Note that all branches are explicit: there are no --- control transfers to computed addresses, except when transfering --- control to a new function. ------------------------------------------------------------------------------ - -data CmmStmt - = CmmNop - | CmmComment FastString - - | CmmAssign CmmReg CmmExpr -- Assign to register - - | CmmStore CmmExpr CmmExpr -- Assign to memory location. Size is - -- given by cmmExprType of the rhs. - - | CmmCall -- A call (foreign, native or primitive), with - CmmCallTarget - [HintedCmmFormal] -- zero or more results - [HintedCmmActual] -- zero or more arguments - New.CmmReturnInfo - -- Some care is necessary when handling the arguments of these, see - -- [Register parameter passing] and the hack in cmm/CmmOpt.hs - - | CmmBranch BlockId -- branch to another BB in this fn - - | CmmCondBranch CmmExpr BlockId -- conditional branch - - | CmmSwitch -- Table branch - CmmExpr -- The scrutinee is zero-based; - [Maybe BlockId] -- zero -> first block - -- one -> second block etc - -- Undefined outside range, and when - -- there's a Nothing - - | CmmJump -- Jump to another C-- function, - CmmExpr -- Target - [GlobalReg] -- Live registers at call site; - -- Nothing -> no information, assume - -- all live - -- Just .. -> info on liveness, [] - -- means no live registers - -- This isn't all 'live' registers, just - -- the argument STG registers that are live - -- AND also possibly mapped to machine - -- registers. (So Sp, Hp, HpLim... ect - -- are never included here as they are - -- always live, only R2.., D1.. are - -- on this list) - - | CmmReturn -- Return from a native C-- function, - -data CmmHinted a - = CmmHinted { - hintlessCmm :: a, - cmmHint :: New.ForeignHint - } - deriving( Eq ) - -type HintedCmmFormal = CmmHinted CmmFormal -type HintedCmmActual = CmmHinted CmmActual - -data CmmSafety - = CmmUnsafe - | CmmSafe New.C_SRT - | CmmInterruptible - --- | enable us to fold used registers over '[CmmActual]' and '[CmmFormal]' -instance UserOfRegs LocalReg CmmStmt where - foldRegsUsed dflags f (set::b) s = stmt s set - where - stmt :: CmmStmt -> b -> b - stmt (CmmNop) = id - stmt (CmmComment {}) = id - stmt (CmmAssign _ e) = gen e - stmt (CmmStore e1 e2) = gen e1 . gen e2 - stmt (CmmCall target _ es _) = gen target . gen es - stmt (CmmBranch _) = id - stmt (CmmCondBranch e _) = gen e - stmt (CmmSwitch e _) = gen e - stmt (CmmJump e _) = gen e - stmt (CmmReturn) = id - - gen :: UserOfRegs LocalReg a => a -> b -> b - gen a set = foldRegsUsed dflags f set a - -instance UserOfRegs LocalReg CmmCallTarget where - foldRegsUsed dflags f set (CmmCallee e _) = foldRegsUsed dflags f set e - foldRegsUsed dflags f set (CmmPrim _ mStmts) = foldRegsUsed dflags f set mStmts - -instance UserOfRegs r a => UserOfRegs r (CmmHinted a) where - foldRegsUsed dflags f set a = foldRegsUsed dflags f set (hintlessCmm a) - -instance DefinerOfRegs r a => DefinerOfRegs r (CmmHinted a) where - foldRegsDefd dflags f set a = foldRegsDefd dflags f set (hintlessCmm a) - -{- -Discussion -~~~~~~~~~~ - -One possible problem with the above type is that the only way to do a -non-local conditional jump is to encode it as a branch to a block that -contains a single jump. This leads to inefficient code in the back end. - -[N.B. This problem will go away when we make the transition to the -'zipper' form of control-flow graph, in which both targets of a -conditional jump are explicit. ---NR] - -One possible way to fix this would be: - -data CmmStat = - ... - | CmmJump CmmBranchDest - | CmmCondJump CmmExpr CmmBranchDest - ... - -data CmmBranchDest - = Local BlockId - | NonLocal CmmExpr [LocalReg] - -In favour: - -+ one fewer constructors in CmmStmt -+ allows both cond branch and switch to jump to non-local destinations - -Against: - -- not strictly necessary: can already encode as branch+jump -- not always possible to implement any better in the back end -- could do the optimisation in the back end (but then plat-specific?) -- C-- doesn't have it -- back-end optimisation might be more general (jump shortcutting) - -So we'll stick with the way it is, and add the optimisation to the NCG. --} - ------------------------------------------------------------------------------ --- CmmCallTarget --- --- The target of a CmmCall. ------------------------------------------------------------------------------ - -data CmmCallTarget - = CmmCallee -- Call a function (foreign or native) - CmmExpr -- literal label <=> static call - -- other expression <=> dynamic call - CCallConv -- The calling convention - - | CmmPrim -- Call a "primitive" (eg. sin, cos) - CallishMachOp -- These might be implemented as inline - -- code by the backend. - -- If we don't know how to implement the - -- mach op, then we can replace it with - -- this list of statements: - (Maybe [CmmStmt]) - diff --git a/compiler/cmm/OldCmmLint.hs b/compiler/cmm/OldCmmLint.hs deleted file mode 100644 index 9a4fb42bc5..0000000000 --- a/compiler/cmm/OldCmmLint.hs +++ /dev/null @@ -1,212 +0,0 @@ ------------------------------------------------------------------------------ --- --- (c) The University of Glasgow 2004-2006 --- --- CmmLint: checking the correctness of Cmm statements and expressions --- ------------------------------------------------------------------------------ - -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - -module OldCmmLint ( - cmmLint, cmmLintTop - ) where - -import BlockId -import OldCmm -import Outputable -import OldPprCmm() -import FastString -import DynFlags - -import Data.Maybe - --- ----------------------------------------------------------------------------- --- Exported entry points: - -cmmLint :: (Outputable d, Outputable h) - => DynFlags -> GenCmmGroup d h (ListGraph CmmStmt) -> Maybe SDoc -cmmLint dflags tops = runCmmLint dflags (mapM_ (lintCmmDecl dflags)) tops - -cmmLintTop :: (Outputable d, Outputable h) - => DynFlags -> GenCmmDecl d h (ListGraph CmmStmt) -> Maybe SDoc -cmmLintTop dflags top = runCmmLint dflags (lintCmmDecl dflags) top - -runCmmLint :: Outputable a - => DynFlags -> (a -> CmmLint b) -> a -> Maybe SDoc -runCmmLint _ l p = - case unCL (l p) of - Left err -> Just (vcat [ptext $ sLit ("Cmm lint error:"), - nest 2 err, - ptext $ sLit ("Program was:"), - nest 2 (ppr p)]) - Right _ -> Nothing - -lintCmmDecl :: DynFlags -> (GenCmmDecl h i (ListGraph CmmStmt)) -> CmmLint () -lintCmmDecl dflags (CmmProc _ lbl _ (ListGraph blocks)) - = addLintInfo (text "in proc " <> ppr lbl) $ - let labels = foldl (\s b -> setInsert (blockId b) s) setEmpty blocks - in mapM_ (lintCmmBlock dflags labels) blocks - -lintCmmDecl _ (CmmData {}) - = return () - -lintCmmBlock :: DynFlags -> BlockSet -> GenBasicBlock CmmStmt -> CmmLint () -lintCmmBlock dflags labels (BasicBlock id stmts) - = addLintInfo (text "in basic block " <> ppr id) $ - mapM_ (lintCmmStmt dflags labels) stmts - --- ----------------------------------------------------------------------------- --- lintCmmExpr - --- Checks whether a CmmExpr is "type-correct", and check for obvious-looking --- byte/word mismatches. - -lintCmmExpr :: DynFlags -> CmmExpr -> CmmLint CmmType -lintCmmExpr dflags (CmmLoad expr rep) = do - _ <- lintCmmExpr dflags expr - -- Disabled, if we have the inlining phase before the lint phase, - -- we can have funny offsets due to pointer tagging. -- EZY - -- when (widthInBytes (typeWidth rep) >= wORD_SIZE) $ - -- cmmCheckWordAddress expr - return rep -lintCmmExpr dflags expr@(CmmMachOp op args) = do - tys <- mapM (lintCmmExpr dflags) args - if map (typeWidth . cmmExprType dflags) args == machOpArgReps dflags op - then cmmCheckMachOp dflags op args tys - else cmmLintMachOpErr expr (map (cmmExprType dflags) args) (machOpArgReps dflags op) -lintCmmExpr dflags (CmmRegOff reg offset) - = lintCmmExpr dflags (CmmMachOp (MO_Add rep) - [CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)]) - where rep = typeWidth (cmmRegType dflags reg) -lintCmmExpr dflags expr = - return (cmmExprType dflags expr) - --- Check for some common byte/word mismatches (eg. Sp + 1) -cmmCheckMachOp :: DynFlags -> MachOp -> [CmmExpr] -> [CmmType] -> CmmLint CmmType -cmmCheckMachOp dflags op [lit@(CmmLit (CmmInt { })), reg@(CmmReg _)] tys - = cmmCheckMachOp dflags op [reg, lit] tys -cmmCheckMachOp dflags op _ tys - = return (machOpResultType dflags op tys) - -{- -isOffsetOp :: MachOp -> Bool -isOffsetOp (MO_Add _) = True -isOffsetOp (MO_Sub _) = True -isOffsetOp _ = False - --- This expression should be an address from which a word can be loaded: --- check for funny-looking sub-word offsets. -_cmmCheckWordAddress :: CmmExpr -> CmmLint () -_cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)]) - | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (wORD_SIZE dflags) /= 0 - = cmmLintDubiousWordOffset e -_cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg]) - | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (wORD_SIZE dflags) /= 0 - = cmmLintDubiousWordOffset e -_cmmCheckWordAddress _ - = return () - --- No warnings for unaligned arithmetic with the node register, --- which is used to extract fields from tagged constructor closures. -notNodeReg :: CmmExpr -> Bool -notNodeReg (CmmReg reg) | reg == nodeReg = False -notNodeReg _ = True --} - -lintCmmStmt :: DynFlags -> BlockSet -> CmmStmt -> CmmLint () -lintCmmStmt dflags labels = lint - where lint (CmmNop) = return () - lint (CmmComment {}) = return () - lint stmt@(CmmAssign reg expr) = do - erep <- lintCmmExpr dflags expr - let reg_ty = cmmRegType dflags reg - if (erep `cmmEqType_ignoring_ptrhood` reg_ty) - then return () - else cmmLintAssignErr stmt erep reg_ty - lint (CmmStore l r) = do - _ <- lintCmmExpr dflags l - _ <- lintCmmExpr dflags r - return () - lint (CmmCall target _res args _) = - do lintTarget dflags labels target - mapM_ (lintCmmExpr dflags . hintlessCmm) args - lint (CmmCondBranch e id) = checkTarget id >> lintCmmExpr dflags e >> checkCond dflags e - lint (CmmSwitch e branches) = do - mapM_ checkTarget $ catMaybes branches - erep <- lintCmmExpr dflags e - if (erep `cmmEqType_ignoring_ptrhood` bWord dflags) - then return () - else cmmLintErr (text "switch scrutinee is not a word: " <> ppr e <> - text " :: " <> ppr erep) - lint (CmmJump e _) = lintCmmExpr dflags e >> return () - lint (CmmReturn) = return () - lint (CmmBranch id) = checkTarget id - checkTarget id = if setMember id labels then return () - else cmmLintErr (text "Branch to nonexistent id" <+> ppr id) - -lintTarget :: DynFlags -> BlockSet -> CmmCallTarget -> CmmLint () -lintTarget dflags _ (CmmCallee e _) = do _ <- lintCmmExpr dflags e - return () -lintTarget _ _ (CmmPrim _ Nothing) = return () -lintTarget dflags labels (CmmPrim _ (Just stmts)) - = mapM_ (lintCmmStmt dflags labels) stmts - - -checkCond :: DynFlags -> CmmExpr -> CmmLint () -checkCond _ (CmmMachOp mop _) | isComparisonMachOp mop = return () -checkCond dflags (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth dflags = return () -- constant values -checkCond _ expr - = cmmLintErr (hang (text "expression is not a conditional:") 2 - (ppr expr)) - --- ----------------------------------------------------------------------------- --- CmmLint monad - --- just a basic error monad: - -newtype CmmLint a = CmmLint { unCL :: Either SDoc a } - -instance Monad CmmLint where - CmmLint m >>= k = CmmLint $ case m of - Left e -> Left e - Right a -> unCL (k a) - return a = CmmLint (Right a) - -cmmLintErr :: SDoc -> CmmLint a -cmmLintErr msg = CmmLint (Left msg) - -addLintInfo :: SDoc -> CmmLint a -> CmmLint a -addLintInfo info thing = CmmLint $ - case unCL thing of - Left err -> Left (hang info 2 err) - Right a -> Right a - -cmmLintMachOpErr :: CmmExpr -> [CmmType] -> [Width] -> CmmLint a -cmmLintMachOpErr expr argsRep opExpectsRep - = cmmLintErr (text "in MachOp application: " $$ - nest 2 (ppr expr) $$ - (text "op is expecting: " <+> ppr opExpectsRep) $$ - (text "arguments provide: " <+> ppr argsRep)) - -cmmLintAssignErr :: CmmStmt -> CmmType -> CmmType -> CmmLint a -cmmLintAssignErr stmt e_ty r_ty - = cmmLintErr (text "in assignment: " $$ - nest 2 (vcat [ppr stmt, - text "Reg ty:" <+> ppr r_ty, - text "Rhs ty:" <+> ppr e_ty])) - - - -{- -cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a -cmmLintDubiousWordOffset expr - = cmmLintErr (text "offset is not a multiple of words: " $$ - nest 2 (ppr expr)) --} - diff --git a/compiler/cmm/OldCmmUtils.hs b/compiler/cmm/OldCmmUtils.hs deleted file mode 100644 index fe6ccee642..0000000000 --- a/compiler/cmm/OldCmmUtils.hs +++ /dev/null @@ -1,100 +0,0 @@ ------------------------------------------------------------------------------ --- --- Old-style Cmm utilities. --- --- (c) The University of Glasgow 2004-2006 --- ------------------------------------------------------------------------------ - -module OldCmmUtils( - CmmStmts, noStmts, oneStmt, mkStmts, plusStmts, stmtList, - isNopStmt, - - maybeAssignTemp, loadArgsIntoTemps, - - module CmmUtils, - ) where - -#include "HsVersions.h" - -import OldCmm -import CmmUtils -import OrdList -import DynFlags -import Unique - ---------------------------------------------------- --- --- CmmStmts --- ---------------------------------------------------- - -type CmmStmts = OrdList CmmStmt - -noStmts :: CmmStmts -noStmts = nilOL - -oneStmt :: CmmStmt -> CmmStmts -oneStmt = unitOL - -mkStmts :: [CmmStmt] -> CmmStmts -mkStmts = toOL - -plusStmts :: CmmStmts -> CmmStmts -> CmmStmts -plusStmts = appOL - -stmtList :: CmmStmts -> [CmmStmt] -stmtList = fromOL - - ---------------------------------------------------- --- --- CmmStmt --- ---------------------------------------------------- - -isNopStmt :: CmmStmt -> Bool --- If isNopStmt returns True, the stmt is definitely a no-op; --- but it might be a no-op even if isNopStmt returns False -isNopStmt CmmNop = True -isNopStmt (CmmAssign r e) = cheapEqReg r e -isNopStmt (CmmStore e1 (CmmLoad e2 _)) = cheapEqExpr e1 e2 -isNopStmt _ = False - -cheapEqExpr :: CmmExpr -> CmmExpr -> Bool -cheapEqExpr (CmmReg r) e = cheapEqReg r e -cheapEqExpr (CmmRegOff r 0) e = cheapEqReg r e -cheapEqExpr (CmmRegOff r n) (CmmRegOff r' n') = r==r' && n==n' -cheapEqExpr _ _ = False - -cheapEqReg :: CmmReg -> CmmExpr -> Bool -cheapEqReg r (CmmReg r') = r==r' -cheapEqReg r (CmmRegOff r' 0) = r==r' -cheapEqReg _ _ = False - ---------------------------------------------------- --- --- Helpers for foreign call arguments --- ---------------------------------------------------- - -loadArgsIntoTemps :: DynFlags -> [Unique] - -> [HintedCmmActual] - -> ([Unique], [CmmStmt], [HintedCmmActual]) -loadArgsIntoTemps _ uniques [] = (uniques, [], []) -loadArgsIntoTemps dflags uniques ((CmmHinted e hint):args) = - (uniques'', - new_stmts ++ remaining_stmts, - (CmmHinted new_e hint) : remaining_e) - where - (uniques', new_stmts, new_e) = maybeAssignTemp dflags uniques e - (uniques'', remaining_stmts, remaining_e) = - loadArgsIntoTemps dflags uniques' args - - -maybeAssignTemp :: DynFlags -> [Unique] -> CmmExpr -> ([Unique], [CmmStmt], CmmExpr) -maybeAssignTemp dflags uniques e - | hasNoGlobalRegs e = (uniques, [], e) - | otherwise = (tail uniques, [CmmAssign local e], CmmReg local) - where local = CmmLocal (LocalReg (head uniques) (cmmExprType dflags e)) - diff --git a/compiler/cmm/OldPprCmm.hs b/compiler/cmm/OldPprCmm.hs deleted file mode 100644 index edfaef8098..0000000000 --- a/compiler/cmm/OldPprCmm.hs +++ /dev/null @@ -1,224 +0,0 @@ ----------------------------------------------------------------------------- --- --- Pretty-printing of old-style Cmm as (a superset of) C-- --- --- (c) The University of Glasgow 2004-2006 --- ------------------------------------------------------------------------------ - --- --- This is where we walk over Cmm emitting an external representation, --- suitable for parsing, in a syntax strongly reminiscent of C--. This --- is the "External Core" for the Cmm layer. --- --- As such, this should be a well-defined syntax: we want it to look nice. --- Thus, we try wherever possible to use syntax defined in [1], --- "The C-- Reference Manual", http://www.cminusminus.org/. We differ --- slightly, in some cases. For one, we use I8 .. I64 for types, rather --- than C--'s bits8 .. bits64. --- --- We try to ensure that all information available in the abstract --- syntax is reproduced, or reproducible, in the concrete syntax. --- Data that is not in printed out can be reconstructed according to --- conventions used in the pretty printer. There are at least two such --- cases: --- 1) if a value has wordRep type, the type is not appended in the --- output. --- 2) MachOps that operate over wordRep type are printed in a --- C-style, rather than as their internal MachRep name. --- --- These conventions produce much more readable Cmm output. --- --- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs --- - -{-# OPTIONS_GHC -fno-warn-orphans #-} -module OldPprCmm ( - pprStmt, - module PprCmmDecl, - module PprCmmExpr - ) where - -import BlockId -import CLabel -import CmmUtils -import OldCmm -import PprCmmDecl -import PprCmmExpr - -import BasicTypes -import ForeignCall -import Outputable -import FastString - -import Data.List - ------------------------------------------------------------------------------ - -instance Outputable instr => Outputable (ListGraph instr) where - ppr (ListGraph blocks) = vcat (map ppr blocks) - -instance Outputable instr => Outputable (GenBasicBlock instr) where - ppr = pprBBlock - -instance Outputable CmmStmt where - ppr s = pprStmt s - --- -------------------------------------------------------------------------- -instance Outputable CmmSafety where - ppr CmmUnsafe = ptext (sLit "_unsafe_call_") - ppr CmmInterruptible = ptext (sLit "_interruptible_call_") - ppr (CmmSafe srt) = ppr srt - --- -------------------------------------------------------------------------- --- Basic blocks look like assembly blocks. --- lbl: stmt ; stmt ; .. -pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc -pprBBlock (BasicBlock ident stmts) = - hang (ppr ident <> colon) 4 (vcat (map ppr stmts)) - --- -------------------------------------------------------------------------- --- Statements. C-- usually, exceptions to this should be obvious. --- -pprStmt :: CmmStmt -> SDoc -pprStmt stmt = case stmt of - - -- ; - CmmNop -> semi - - -- // text - CmmComment s -> text "//" <+> ftext s - - -- reg = expr; - CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi - - -- rep[lv] = expr; - CmmStore lv expr -> - sdocWithDynFlags $ \dflags -> - let rep = ppr ( cmmExprType dflags expr ) - in rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi - - -- call "ccall" foo(x, y)[r1, r2]; - -- ToDo ppr volatile - CmmCall (CmmCallee fn cconv) results args ret -> - sep [ pp_lhs <+> pp_conv - , nest 2 (pprExpr9 fn <> - parens (commafy (map ppr_ar args))) - , case ret of CmmMayReturn -> empty - CmmNeverReturns -> ptext $ sLit (" never returns") - ] <> semi - where - pp_lhs | null results = empty - | otherwise = commafy (map ppr_ar results) <+> equals - -- Don't print the hints on a native C-- call - ppr_ar (CmmHinted ar k) = ppr (ar,k) - pp_conv = ptext (sLit("foreign")) <+> doubleQuotes (ppr cconv) - - -- Call a CallishMachOp, like sin or cos that might be implemented as a library call. - CmmCall (CmmPrim op _) results args ret -> - pprStmt (CmmCall (CmmCallee (CmmLit lbl) CCallConv) results args ret) - where - -- HACK: A CallishMachOp doesn't really correspond to a ForeignLabel, but we - -- use one to get the label printed. - lbl = CmmLabel (mkForeignLabel - (mkFastString (show op)) - Nothing ForeignLabelInThisPackage IsFunction) - - CmmBranch ident -> genBranch ident - CmmCondBranch expr ident -> genCondBranch expr ident - CmmJump expr live -> genJump expr live - CmmReturn -> genReturn - CmmSwitch arg ids -> genSwitch arg ids - --- Just look like a tuple, since it was a tuple before --- ... is that a good idea? --Isaac Dupree -instance (Outputable a) => Outputable (CmmHinted a) where - ppr (CmmHinted a k) = ppr (a, k) - --- -------------------------------------------------------------------------- --- goto local label. [1], section 6.6 --- --- goto lbl; --- -genBranch :: BlockId -> SDoc -genBranch ident = - ptext (sLit "goto") <+> ppr ident <> semi - --- -------------------------------------------------------------------------- --- Conditional. [1], section 6.4 --- --- if (expr) { goto lbl; } --- -genCondBranch :: CmmExpr -> BlockId -> SDoc -genCondBranch expr ident = - hsep [ ptext (sLit "if") - , parens (ppr expr) - , ptext (sLit "goto") - , ppr ident <> semi ] - --- -------------------------------------------------------------------------- --- A tail call. [1], Section 6.9 --- --- jump foo(a, b, c); --- -genJump :: CmmExpr -> [GlobalReg] -> SDoc -genJump expr live = - hcat [ ptext (sLit "jump") - , space - , if isTrivialCmmExpr expr - then pprExpr expr - else case expr of - CmmLoad (CmmReg _) _ -> pprExpr expr - _ -> parens (pprExpr expr) - , semi <+> ptext (sLit "// ") - , ppr live] - --- -------------------------------------------------------------------------- --- Return from a function. [1], Section 6.8.2 of version 1.128 --- --- return (a, b, c); --- -genReturn :: SDoc -genReturn = hcat [ ptext (sLit "return") , semi ] - --- -------------------------------------------------------------------------- --- Tabled jump to local label --- --- The syntax is from [1], section 6.5 --- --- switch [0 .. n] (expr) { case ... ; } --- -genSwitch :: CmmExpr -> [Maybe BlockId] -> SDoc -genSwitch expr maybe_ids - - = let pairs = groupBy snds (zip [0 .. ] maybe_ids ) - - in hang (hcat [ ptext (sLit "switch [0 .. ") - , int (length maybe_ids - 1) - , ptext (sLit "] ") - , if isTrivialCmmExpr expr - then pprExpr expr - else parens (pprExpr expr) - , ptext (sLit " {") - ]) - 4 (vcat ( map caseify pairs )) $$ rbrace - - where - snds a b = (snd a) == (snd b) - - caseify :: [(Int,Maybe BlockId)] -> SDoc - caseify ixs@((_,Nothing):_) - = ptext (sLit "/* impossible: ") <> hcat (intersperse comma (map (int.fst) ixs)) - <> ptext (sLit " */") - caseify as - = let (is,ids) = unzip as - in hsep [ ptext (sLit "case") - , hcat (punctuate comma (map int is)) - , ptext (sLit ": goto") - , ppr (head [ id | Just id <- ids]) <> semi ] - ------------------------------------------------------------------------------ - -commafy :: [SDoc] -> SDoc -commafy xs = fsep $ punctuate comma xs - diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index e0ff99cb29..ee964d8701 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -16,6 +16,7 @@ -- ----------------------------------------------------------------------------- +{-# LANGUAGE GADTs #-} module PprC ( writeCs, pprStringInCStyle @@ -27,8 +28,10 @@ module PprC ( import BlockId import CLabel import ForeignCall -import OldCmm -import OldPprCmm () +import Cmm hiding (pprBBlock) +import PprCmm () +import Hoopl +import CmmUtils -- Utils import CPrim @@ -81,8 +84,9 @@ pprC tops = vcat $ intersperse blankLine $ map pprTop tops -- top level procs -- pprTop :: RawCmmDecl -> SDoc -pprTop proc@(CmmProc _ clbl _ (ListGraph blocks)) = - (case topInfoTable proc of +pprTop (CmmProc infos clbl _ graph) = + + (case mapLookup (g_entry graph) infos of Nothing -> empty Just (Statics info_clbl info_dat) -> pprDataExterns info_dat $$ pprWordArray info_clbl info_dat) $$ @@ -93,16 +97,12 @@ pprTop proc@(CmmProc _ clbl _ (ListGraph blocks)) = then mkFN_ else mkIF_) (ppr clbl) <+> lbrace, nest 8 temp_decls, nest 8 mkFB_, - case blocks of - [] -> empty - -- the first block doesn't get a label: - (BasicBlock _ stmts : rest) -> - nest 8 (vcat (map pprStmt stmts)) $$ - vcat (map pprBBlock rest), + vcat (map pprBBlock blocks), nest 8 mkFE_, rbrace ] ) where + blocks = toBlockList graph (temp_decls, extern_decls) = pprTempAndExternDecls blocks @@ -133,14 +133,12 @@ pprTop (CmmData _section (Statics lbl lits)) = -- as many jumps as possible into fall throughs. -- -pprBBlock :: CmmBasicBlock -> SDoc -pprBBlock (BasicBlock lbl stmts) = - if null stmts then - pprTrace "pprC.pprBBlock: curious empty code block for" - (pprBlockId lbl) empty - else - nest 4 (pprBlockId lbl <> colon) $$ - nest 8 (vcat (map pprStmt stmts)) +pprBBlock :: CmmBlock -> SDoc +pprBBlock block = + nest 4 (pprBlockId lbl <> colon) $$ + nest 8 (vcat (map pprStmt (blockToList nodes)) $$ pprStmt last) + where + (CmmEntry lbl, nodes, last) = blockSplit block -- -------------------------------------------------------------------------- -- Info tables. Just arrays of words. @@ -165,13 +163,11 @@ pprLocalness lbl | not $ externallyVisibleCLabel lbl = ptext (sLit "static ") -- Statements. -- -pprStmt :: CmmStmt -> SDoc +pprStmt :: CmmNode e x -> SDoc pprStmt stmt = sdocWithDynFlags $ \dflags -> case stmt of - CmmReturn -> panic "pprStmt: return statement should have been cps'd away" - CmmNop -> empty CmmComment _ -> empty -- (hang (ptext (sLit "/*")) 3 (ftext s)) $$ ptext (sLit "*/") -- XXX if the string contains "*/", we need to fix it -- XXX we probably want to emit these comments when @@ -191,14 +187,20 @@ pprStmt stmt = where rep = cmmExprType dflags src - CmmCall (CmmCallee fn cconv) results args ret -> + CmmUnsafeForeignCall target@(ForeignTarget fn conv) results args -> maybe_proto $$ fnCall where - cast_fn = parens (cCast (pprCFunType (char '*') cconv results args) fn) + (res_hints, arg_hints) = foreignTargetHints target + hresults = zip results res_hints + hargs = zip args arg_hints + + ForeignConvention cconv _ _ ret = conv + + cast_fn = parens (cCast (pprCFunType (char '*') cconv hresults hargs) fn) real_fun_proto lbl = char ';' <> - pprCFunType (ppr lbl) cconv results args <> + pprCFunType (ppr lbl) cconv hresults hargs <> noreturn_attr <> semi noreturn_attr = case ret of @@ -210,7 +212,7 @@ pprStmt stmt = case fn of CmmLit (CmmLabel lbl) | StdCallConv <- cconv -> - let myCall = pprCall (ppr lbl) cconv results args + let myCall = pprCall (ppr lbl) cconv hresults hargs in (real_fun_proto lbl, myCall) -- stdcall functions must be declared with -- a function type, otherwise the C compiler @@ -218,40 +220,44 @@ pprStmt stmt = -- can't add the @n suffix ourselves, because -- it isn't valid C. | CmmNeverReturns <- ret -> - let myCall = pprCall (ppr lbl) cconv results args + let myCall = pprCall (ppr lbl) cconv hresults hargs in (real_fun_proto lbl, myCall) | not (isMathFun lbl) -> - pprForeignCall (ppr lbl) cconv results args + pprForeignCall (ppr lbl) cconv hresults hargs _ -> (empty {- no proto -}, - pprCall cast_fn cconv results args <> semi) + pprCall cast_fn cconv hresults hargs <> semi) -- for a dynamic call, no declaration is necessary. - CmmCall (CmmPrim _ (Just stmts)) _ _ _ -> - vcat $ map pprStmt stmts - - CmmCall (CmmPrim op _) results args _ret -> + CmmUnsafeForeignCall target@(PrimTarget op) results args -> proto $$ fn_call where cconv = CCallConv fn = pprCallishMachOp_for_C op + + (res_hints, arg_hints) = foreignTargetHints target + hresults = zip results res_hints + hargs = zip args arg_hints + (proto, fn_call) -- The mem primops carry an extra alignment arg, must drop it. -- We could maybe emit an alignment directive using this info. -- We also need to cast mem primops to prevent conflicts with GCC -- builtins (see bug #5967). | op `elem` [MO_Memcpy, MO_Memset, MO_Memmove] - = pprForeignCall fn cconv results (init args) + = pprForeignCall fn cconv hresults (init hargs) | otherwise - = (empty, pprCall fn cconv results args) + = (empty, pprCall fn cconv hresults hargs) CmmBranch ident -> pprBranch ident - CmmCondBranch expr ident -> pprCondBranch expr ident - CmmJump lbl _ -> mkJMP_(pprExpr lbl) <> semi + CmmCondBranch expr yes no -> pprCondBranch expr yes no + CmmCall { cml_target = expr } -> mkJMP_ (pprExpr expr) <> semi CmmSwitch arg ids -> sdocWithDynFlags $ \dflags -> pprSwitch dflags arg ids -pprForeignCall :: SDoc -> CCallConv -> [HintedCmmFormal] -> [HintedCmmActual] +type Hinted a = (a, ForeignHint) + +pprForeignCall :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> (SDoc, SDoc) pprForeignCall fn cconv results args = (proto, fn_call) where @@ -263,14 +269,14 @@ pprForeignCall fn cconv results args = (proto, fn_call) cast_fn = parens (parens (pprCFunType (char '*') cconv results args) <> fn) proto = ptext (sLit ";EF_(") <> fn <> char ')' <> semi -pprCFunType :: SDoc -> CCallConv -> [HintedCmmFormal] -> [HintedCmmActual] -> SDoc +pprCFunType :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc pprCFunType ppr_fn cconv ress args = sdocWithDynFlags $ \dflags -> let res_type [] = ptext (sLit "void") - res_type [CmmHinted one hint] = machRepHintCType (localRegType one) hint + res_type [(one, hint)] = machRepHintCType (localRegType one) hint res_type _ = panic "pprCFunType: only void or 1 return value supported" - arg_type (CmmHinted expr hint) = machRepHintCType (cmmExprType dflags expr) hint + arg_type (expr, hint) = machRepHintCType (cmmExprType dflags expr) hint in res_type ress <+> parens (ccallConvAttribute cconv <> ppr_fn) <> parens (commafy (map arg_type args)) @@ -283,11 +289,11 @@ pprBranch ident = ptext (sLit "goto") <+> pprBlockId ident <> semi -- --------------------------------------------------------------------- -- conditional branches to local labels -pprCondBranch :: CmmExpr -> BlockId -> SDoc -pprCondBranch expr ident +pprCondBranch :: CmmExpr -> BlockId -> BlockId -> SDoc +pprCondBranch expr yes no = hsep [ ptext (sLit "if") , parens(pprExpr expr) , - ptext (sLit "goto") , (pprBlockId ident) <> semi ] - + ptext (sLit "goto"), pprBlockId yes, + ptext (sLit "else"), pprBlockId no <> semi ] -- --------------------------------------------------------------------- -- a local table branch @@ -831,7 +837,7 @@ pprLocalReg (LocalReg uniq _) = char '_' <> ppr uniq -- ----------------------------------------------------------------------------- -- Foreign Calls -pprCall :: SDoc -> CCallConv -> [HintedCmmFormal] -> [HintedCmmActual] -> SDoc +pprCall :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc pprCall ppr_fn cconv results args | not (is_cishCC cconv) = panic $ "pprCall: unknown calling convention" @@ -841,18 +847,18 @@ pprCall ppr_fn cconv results args ppr_assign results (ppr_fn <> parens (commafy (map pprArg args))) <> semi where ppr_assign [] rhs = rhs - ppr_assign [CmmHinted one hint] rhs + ppr_assign [(one,hint)] rhs = pprLocalReg one <> ptext (sLit " = ") <> pprUnHint hint (localRegType one) <> rhs ppr_assign _other _rhs = panic "pprCall: multiple results" - pprArg (CmmHinted expr AddrHint) + pprArg (expr, AddrHint) = cCast (ptext (sLit "void *")) expr -- see comment by machRepHintCType below - pprArg (CmmHinted expr SignedHint) + pprArg (expr, SignedHint) = sdocWithDynFlags $ \dflags -> cCast (machRep_S_CType $ typeWidth $ cmmExprType dflags expr) expr - pprArg (CmmHinted expr _other) + pprArg (expr, _other) = pprExpr expr pprUnHint AddrHint rep = parens (machRepCType rep) @@ -871,7 +877,7 @@ is_cishCC PrimCallConv = False -- Find and print local and external declarations for a list of -- Cmm statements. -- -pprTempAndExternDecls :: [CmmBasicBlock] -> (SDoc{-temps-}, SDoc{-externs-}) +pprTempAndExternDecls :: [CmmBlock] -> (SDoc{-temps-}, SDoc{-externs-}) pprTempAndExternDecls stmts = (vcat (map pprTempDecl (uniqSetToList temps)), vcat (map (pprExternDecl False{-ToDo-}) (Map.keys lbls))) @@ -930,8 +936,9 @@ te_Static :: CmmStatic -> TE () te_Static (CmmStaticLit lit) = te_Lit lit te_Static _ = return () -te_BB :: CmmBasicBlock -> TE () -te_BB (BasicBlock _ ss) = mapM_ te_Stmt ss +te_BB :: CmmBlock -> TE () +te_BB block = mapM_ te_Stmt (blockToList mid) >> te_Stmt last + where (_, mid, last) = blockSplit block te_Lit :: CmmLit -> TE () te_Lit (CmmLabel l) = te_lbl l @@ -939,21 +946,21 @@ te_Lit (CmmLabelOff l _) = te_lbl l te_Lit (CmmLabelDiffOff l1 _ _) = te_lbl l1 te_Lit _ = return () -te_Stmt :: CmmStmt -> TE () +te_Stmt :: CmmNode e x -> TE () te_Stmt (CmmAssign r e) = te_Reg r >> te_Expr e te_Stmt (CmmStore l r) = te_Expr l >> te_Expr r -te_Stmt (CmmCall target rs es _) = do te_Target target - mapM_ (te_temp.hintlessCmm) rs - mapM_ (te_Expr.hintlessCmm) es -te_Stmt (CmmCondBranch e _) = te_Expr e +te_Stmt (CmmUnsafeForeignCall target rs es) + = do te_Target target + mapM_ te_temp rs + mapM_ te_Expr es +te_Stmt (CmmCondBranch e _ _) = te_Expr e te_Stmt (CmmSwitch e _) = te_Expr e -te_Stmt (CmmJump e _) = te_Expr e +te_Stmt (CmmCall { cml_target = e }) = te_Expr e te_Stmt _ = return () -te_Target :: CmmCallTarget -> TE () -te_Target (CmmCallee {}) = return () -te_Target (CmmPrim _ Nothing) = return () -te_Target (CmmPrim _ (Just stmts)) = mapM_ te_Stmt stmts +te_Target :: ForeignTarget -> TE () +te_Target (ForeignTarget e _) = te_Expr e +te_Target (PrimTarget{}) = return () te_Expr :: CmmExpr -> TE () te_Expr (CmmLit lit) = te_Lit lit diff --git a/compiler/cmm/PprCmmExpr.hs b/compiler/cmm/PprCmmExpr.hs index 7d2f4824ef..71c84464ad 100644 --- a/compiler/cmm/PprCmmExpr.hs +++ b/compiler/cmm/PprCmmExpr.hs @@ -35,7 +35,6 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module PprCmmExpr ( pprExpr, pprLit - , pprExpr9 {-only to import in OldPprCmm. When it dies, remove the export -} ) where |