Commit f07af788 authored by Ian Lynagh's avatar Ian Lynagh

More work towards cross-compilation

There's now a variant of the Outputable class that knows what
platform we're targetting:

class PlatformOutputable a where
    pprPlatform :: Platform -> a -> SDoc
    pprPlatformPrec :: Platform -> Rational -> a -> SDoc

and various instances have had to be converted to use that class,
and we pass Platform around accordingly.
parent 58cc5ed2
......@@ -862,6 +862,8 @@ entry.
instance Outputable CLabel where
ppr = pprCLabel
instance PlatformOutputable CLabel where
pprPlatform _ = pprCLabel
pprCLabel :: CLabel -> SDoc
......
......@@ -13,6 +13,7 @@ import CmmExpr
import MkGraph
import qualified OldCmm as Old
import OldPprCmm ()
import Platform
import Compiler.Hoopl hiding ((<*>), mkLabel, mkBranch)
import Control.Monad
......@@ -21,23 +22,23 @@ import Maybes
import Outputable
import UniqSupply
cmmToZgraph :: Old.Cmm -> UniqSM Cmm
cmmOfZgraph :: Cmm -> Old.Cmm
cmmToZgraph :: Platform -> Old.Cmm -> UniqSM Cmm
cmmOfZgraph :: Cmm -> Old.Cmm
cmmToZgraph (Cmm tops) = liftM Cmm $ mapM mapTop tops
cmmToZgraph platform (Cmm tops) = liftM Cmm $ mapM mapTop tops
where mapTop (CmmProc (Old.CmmInfo _ _ info_tbl) l g) =
do (stack_info, g) <- toZgraph (showSDoc $ ppr l) g
do (stack_info, g) <- toZgraph platform (showSDoc $ ppr l) g
return $ CmmProc (TopInfo {info_tbl=info_tbl, stack_info=stack_info}) l g
mapTop (CmmData s ds) = return $ CmmData s ds
cmmOfZgraph (Cmm tops) = Cmm $ map mapTop tops
where mapTop (CmmProc h l g) = CmmProc (Old.CmmInfo Nothing Nothing (info_tbl h)) l (ofZgraph g)
mapTop (CmmData s ds) = CmmData s ds
toZgraph :: String -> Old.ListGraph Old.CmmStmt -> UniqSM (CmmStackInfo, CmmGraph)
toZgraph _ (Old.ListGraph []) =
toZgraph :: Platform -> String -> Old.ListGraph Old.CmmStmt -> UniqSM (CmmStackInfo, CmmGraph)
toZgraph _ _ (Old.ListGraph []) =
do g <- lgraphOfAGraph emptyAGraph
return (StackInfo {arg_space=0, updfr_space=Nothing}, g)
toZgraph fun_name g@(Old.ListGraph (Old.BasicBlock id ss : other_blocks)) =
toZgraph platform fun_name g@(Old.ListGraph (Old.BasicBlock id ss : other_blocks)) =
let (offset, entry) = mkCallEntry NativeNodeCall [] in
do g <- labelAGraph id $
entry <*> mkStmts ss <*> foldr addBlock emptyAGraph other_blocks
......@@ -64,7 +65,7 @@ toZgraph fun_name g@(Old.ListGraph (Old.BasicBlock id ss : other_blocks)) =
mkStmts (last : []) = mkLast last
mkStmts [] = bad "fell off end"
mkStmts (_ : _ : _) = bad "last node not at end"
bad msg = pprPanic (msg ++ " in function " ++ fun_name) (ppr g)
bad msg = pprPanic (msg ++ " in function " ++ fun_name) (pprPlatform platform g)
mkLast (Old.CmmCall (Old.CmmCallee f conv) [] args _ Old.CmmNeverReturns) =
mkFinalCall f conv (map Old.hintlessCmm args) updfr_sz
mkLast (Old.CmmCall (Old.CmmPrim {}) _ _ _ Old.CmmNeverReturns) =
......
......@@ -23,6 +23,7 @@ import Outputable
import OldPprCmm()
import Constants
import FastString
import Platform
import Data.Maybe
......@@ -30,21 +31,22 @@ import Data.Maybe
-- Exported entry points:
cmmLint :: (Outputable d, Outputable h)
=> GenCmm d h (ListGraph CmmStmt) -> Maybe SDoc
cmmLint (Cmm tops) = runCmmLint (mapM_ lintCmmTop) tops
=> Platform -> GenCmm d h (ListGraph CmmStmt) -> Maybe SDoc
cmmLint platform (Cmm tops) = runCmmLint platform (mapM_ lintCmmTop) tops
cmmLintTop :: (Outputable d, Outputable h)
=> GenCmmTop d h (ListGraph CmmStmt) -> Maybe SDoc
cmmLintTop top = runCmmLint lintCmmTop top
=> Platform -> GenCmmTop d h (ListGraph CmmStmt) -> Maybe SDoc
cmmLintTop platform top = runCmmLint platform lintCmmTop top
runCmmLint :: Outputable a => (a -> CmmLint b) -> a -> Maybe SDoc
runCmmLint l p =
runCmmLint :: PlatformOutputable a
=> Platform -> (a -> CmmLint b) -> a -> Maybe SDoc
runCmmLint platform 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
Left err -> Just (vcat [ptext $ sLit ("Cmm lint error:"),
nest 2 err,
ptext $ sLit ("Program was:"),
nest 2 (pprPlatform platform p)])
Right _ -> Nothing
lintCmmTop :: (GenCmmTop h i (ListGraph CmmStmt)) -> CmmLint ()
lintCmmTop (CmmProc _ lbl (ListGraph blocks))
......
......@@ -1075,7 +1075,7 @@ parseCmmFile dflags filename = do
if (errorsFound dflags ms)
then return (ms, Nothing)
else do
dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (ppr cmm)
dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprPlatform (targetPlatform dflags) cmm)
return (ms, Just cmm)
where
no_module = panic "parseCmmFile: no module"
......
......@@ -65,7 +65,7 @@ cmmPipeline hsc_env (topSRT, rst) prog =
let topCAFEnv = mkTopCAFInfo (concat cafEnvs)
(topSRT, tops) <- foldM (toTops hsc_env topCAFEnv) (topSRT, []) tops
let cmms = Cmm (reverse (concat tops))
dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (ppr cmms)
dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (pprPlatform (targetPlatform dflags) cmms)
-- SRT is not affected by control flow optimization pass
let prog' = map runCmmContFlowOpts (cmms : rst)
return (topSRT, prog')
......@@ -90,33 +90,33 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
----------- Eliminate common blocks -------------------
g <- return $ elimCommonBlocks g
dump Opt_D_dump_cmmz_cbe "Post common block elimination" g
dumpPlatform platform Opt_D_dump_cmmz_cbe "Post common block elimination" g
-- Any work storing block Labels must be performed _after_ elimCommonBlocks
----------- Proc points -------------------
let callPPs = callProcPoints g
procPoints <- run $ minimalProcPointSet callPPs g
procPoints <- run $ minimalProcPointSet (targetPlatform dflags) callPPs g
g <- run $ addProcPointProtocols callPPs procPoints g
dump Opt_D_dump_cmmz_proc "Post Proc Points Added" g
dumpPlatform platform Opt_D_dump_cmmz_proc "Post Proc Points Added" g
----------- Spills and reloads -------------------
g <- run $ dualLivenessWithInsertion procPoints g
dump Opt_D_dump_cmmz_spills "Post spills and reloads" g
dumpPlatform platform Opt_D_dump_cmmz_spills "Post spills and reloads" g
----------- Sink and inline assignments -------------------
g <- runOptimization $ rewriteAssignments g
dump Opt_D_dump_cmmz_rewrite "Post rewrite assignments" g
dumpPlatform platform Opt_D_dump_cmmz_rewrite "Post rewrite assignments" g
----------- Eliminate dead assignments -------------------
g <- runOptimization $ removeDeadAssignments g
dump Opt_D_dump_cmmz_dead "Post remove dead assignments" g
dumpPlatform platform Opt_D_dump_cmmz_dead "Post remove dead assignments" g
----------- Zero dead stack slots (Debug only) ---------------
-- Debugging: stubbing slots on death can cause crashes early
g <- if opt_StubDeadValues
then run $ stubSlotsOnDeath g
else return g
dump Opt_D_dump_cmmz_stub "Post stub dead stack slots" g
dumpPlatform platform Opt_D_dump_cmmz_stub "Post stub dead stack slots" g
--------------- Stack layout ----------------
slotEnv <- run $ liveSlotAnal g
......@@ -127,7 +127,7 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
------------ Manifest the stack pointer --------
g <- run $ manifestSP spEntryMap areaMap entry_off g
dump Opt_D_dump_cmmz_sp "Post manifestSP" g
dumpPlatform platform Opt_D_dump_cmmz_sp "Post manifestSP" g
-- UGH... manifestSP can require updates to the procPointMap.
-- We can probably do something quicker here for the update...
......@@ -136,7 +136,7 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
dump Opt_D_dump_cmmz_procmap "procpoint map" procPointMap
gs <- run $ splitAtProcPoints l callPPs procPoints procPointMap
(CmmProc h l g)
mapM_ (dump Opt_D_dump_cmmz_split "Post splitting") gs
mapM_ (dumpPlatform platform Opt_D_dump_cmmz_split "Post splitting") gs
------------- More CAFs and foreign calls ------------
cafEnv <- run $ cafAnal g
......@@ -144,23 +144,26 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
mbpprTrace "localCAFs" (ppr localCAFs) $ return ()
gs <- run $ mapM (lowerSafeForeignCalls areaMap) gs
mapM_ (dump Opt_D_dump_cmmz_lower "Post lowerSafeForeignCalls") gs
mapM_ (dumpPlatform platform Opt_D_dump_cmmz_lower "Post lowerSafeForeignCalls") gs
-- NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES
gs <- return $ map (setInfoTableStackMap slotEnv areaMap) gs
mapM_ (dump Opt_D_dump_cmmz_info "after setInfoTableStackMap") gs
mapM_ (dumpPlatform platform Opt_D_dump_cmmz_info "after setInfoTableStackMap") gs
gs <- return $ map (bundleCAFs cafEnv) gs
mapM_ (dump Opt_D_dump_cmmz_cafs "after bundleCAFs") gs
mapM_ (dumpPlatform platform Opt_D_dump_cmmz_cafs "after bundleCAFs") gs
return (localCAFs, gs)
where dflags = hsc_dflags hsc_env
platform = targetPlatform dflags
mbpprTrace x y z = if dopt Opt_D_dump_cmmz dflags then pprTrace x y z else z
dump f txt g = do
dump f = dumpWith ppr f
dumpPlatform platform = dumpWith (pprPlatform platform)
dumpWith pprFun f txt g = do
-- ToDo: No easy way of say "dump all the cmmz, *and* split
-- them into files." Also, -ddump-cmmz doesn't play nicely
-- with -ddump-to-file, since the headers get omitted.
dumpIfSet_dyn dflags f txt (ppr g)
dumpIfSet_dyn dflags f txt (pprFun g)
when (not (dopt f dflags)) $
dumpIfSet_dyn dflags Opt_D_dump_cmmz txt (ppr g)
dumpIfSet_dyn dflags Opt_D_dump_cmmz txt (pprFun g)
-- Runs a required transformation/analysis
run = runInfiniteFuelIO (hsc_OptFuel hsc_env)
-- Runs an optional transformation/analysis (and should
......
......@@ -25,6 +25,7 @@ import MkGraph
import Control.Monad
import OptimizationFuel
import Outputable
import Platform
import UniqSet
import UniqSupply
......@@ -139,10 +140,10 @@ callProcPoints g = foldGraphBlocks add (setSingleton (g_entry g)) g
CmmForeignCall {succ=k} -> setInsert k set
_ -> set
minimalProcPointSet :: ProcPointSet -> CmmGraph -> FuelUniqSM ProcPointSet
minimalProcPointSet :: Platform -> ProcPointSet -> CmmGraph -> FuelUniqSM ProcPointSet
-- Given the set of successors of calls (which must be proc-points)
-- figure out the minimal set of necessary proc-points
minimalProcPointSet callProcPoints g = extendPPSet g (postorderDfs g) callProcPoints
minimalProcPointSet platform callProcPoints g = extendPPSet platform g (postorderDfs g) callProcPoints
procPointAnalysis :: ProcPointSet -> CmmGraph -> FuelUniqSM (BlockEnv Status)
-- Once you know what the proc-points are, figure out
......@@ -151,8 +152,8 @@ procPointAnalysis procPoints g =
liftM snd $ dataflowPassFwd g initProcPoints $ analFwd lattice forward
where initProcPoints = [(id, ProcPoint) | id <- setElems procPoints]
extendPPSet :: CmmGraph -> [CmmBlock] -> ProcPointSet -> FuelUniqSM ProcPointSet
extendPPSet g blocks procPoints =
extendPPSet :: Platform -> CmmGraph -> [CmmBlock] -> ProcPointSet -> FuelUniqSM ProcPointSet
extendPPSet platform g blocks procPoints =
do env <- procPointAnalysis procPoints g
let add block pps = let id = entryLabel block
in case mapLookup id env of
......@@ -163,7 +164,7 @@ extendPPSet g blocks procPoints =
newPoint = listToMaybe newPoints
ppSuccessor b =
let nreached id = case mapLookup id env `orElse`
pprPanic "no ppt" (ppr id <+> ppr b) of
pprPanic "no ppt" (ppr id <+> pprPlatform platform b) of
ProcPoint -> 1
ReachedBy ps -> setSize ps
block_procpoints = nreached (entryLabel b)
......@@ -181,7 +182,7 @@ extendPPSet g blocks procPoints =
-}
case newPoint of Just id ->
if setMember id procPoints' then panic "added old proc pt"
else extendPPSet g blocks (setInsert id procPoints')
else extendPPSet platform g blocks (setInsert id procPoints')
Nothing -> return procPoints'
......
......@@ -50,20 +50,23 @@ import PprCmmExpr
import BasicTypes
import ForeignCall
import Outputable
import Platform
import FastString
import Data.List
-----------------------------------------------------------------------------
instance (Outputable instr) => Outputable (ListGraph instr) where
ppr (ListGraph blocks) = vcat (map ppr blocks)
instance PlatformOutputable instr => PlatformOutputable (ListGraph instr) where
pprPlatform platform (ListGraph blocks) = vcat (map (pprPlatform platform) blocks)
instance (Outputable instr) => Outputable (GenBasicBlock instr) where
ppr b = pprBBlock b
instance PlatformOutputable instr => PlatformOutputable (GenBasicBlock instr) where
pprPlatform platform b = pprBBlock platform b
instance Outputable CmmStmt where
ppr s = pprStmt s
instance PlatformOutputable CmmStmt where
pprPlatform _ = ppr
instance Outputable CmmInfo where
ppr e = pprInfo e
......@@ -99,9 +102,9 @@ pprInfo (CmmInfo _gc_target update_frame info_table@(CmmInfoTable _ _ _ _ _)) =
-- --------------------------------------------------------------------------
-- 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))
pprBBlock :: PlatformOutputable stmt => Platform -> GenBasicBlock stmt -> SDoc
pprBBlock platform (BasicBlock ident stmts) =
hang (ppr ident <> colon) 4 (vcat (map (pprPlatform platform) stmts))
-- --------------------------------------------------------------------------
-- Statements. C-- usually, exceptions to this should be obvious.
......
......@@ -49,6 +49,7 @@ import PprCmmExpr
import Util
import BasicTypes
import Platform
import Compiler.Hoopl
import Data.List
import Prelude hiding (succ)
......@@ -76,20 +77,20 @@ instance Outputable ForeignTarget where
ppr = pprForeignTarget
instance Outputable (Block CmmNode C C) where
ppr = pprBlock
instance Outputable (Block CmmNode C O) where
ppr = pprBlock
instance Outputable (Block CmmNode O C) where
ppr = pprBlock
instance Outputable (Block CmmNode O O) where
ppr = pprBlock
instance PlatformOutputable (Block CmmNode C C) where
pprPlatform _ = pprBlock
instance PlatformOutputable (Block CmmNode C O) where
pprPlatform _ = pprBlock
instance PlatformOutputable (Block CmmNode O C) where
pprPlatform _ = pprBlock
instance PlatformOutputable (Block CmmNode O O) where
pprPlatform _ = pprBlock
instance Outputable (Graph CmmNode e x) where
ppr = pprGraph
instance PlatformOutputable (Graph CmmNode e x) where
pprPlatform = pprGraph
instance Outputable CmmGraph where
ppr = pprCmmGraph
instance PlatformOutputable CmmGraph where
pprPlatform platform = pprCmmGraph platform
----------------------------------------------------------
-- Outputting types Cmm contains
......@@ -107,7 +108,8 @@ pprTopInfo (TopInfo {info_tbl=info_tbl, stack_info=stack_info}) =
----------------------------------------------------------
-- Outputting blocks and graphs
pprBlock :: IndexedCO x SDoc SDoc ~ SDoc => Block CmmNode e x -> IndexedCO e SDoc SDoc
pprBlock :: IndexedCO x SDoc SDoc ~ SDoc
=> Block CmmNode e x -> IndexedCO e SDoc SDoc
pprBlock block = foldBlockNodesB3 ( ($$) . ppr
, ($$) . (nest 4) . ppr
, ($$) . (nest 4) . ppr
......@@ -115,21 +117,22 @@ pprBlock block = foldBlockNodesB3 ( ($$) . ppr
block
empty
pprGraph :: Graph CmmNode e x -> SDoc
pprGraph GNil = empty
pprGraph (GUnit block) = ppr block
pprGraph (GMany entry body exit)
pprGraph :: Platform -> Graph CmmNode e x -> SDoc
pprGraph _ GNil = empty
pprGraph platform (GUnit block) = pprPlatform platform block
pprGraph platform (GMany entry body exit)
= text "{"
$$ nest 2 (pprMaybeO entry $$ (vcat $ map ppr $ bodyToBlockList body) $$ pprMaybeO exit)
$$ nest 2 (pprMaybeO entry $$ (vcat $ map (pprPlatform platform) $ bodyToBlockList body) $$ pprMaybeO exit)
$$ text "}"
where pprMaybeO :: Outputable (Block CmmNode e x) => MaybeO ex (Block CmmNode e x) -> SDoc
where pprMaybeO :: PlatformOutputable (Block CmmNode e x)
=> MaybeO ex (Block CmmNode e x) -> SDoc
pprMaybeO NothingO = empty
pprMaybeO (JustO block) = ppr block
pprMaybeO (JustO block) = pprPlatform platform block
pprCmmGraph :: CmmGraph -> SDoc
pprCmmGraph g
pprCmmGraph :: Platform -> CmmGraph -> SDoc
pprCmmGraph platform g
= text "{" <> text "offset"
$$ nest 2 (vcat $ map ppr blocks)
$$ nest 2 (vcat $ map (pprPlatform platform) blocks)
$$ text "}"
where blocks = postorderDfs g
......
......@@ -43,6 +43,7 @@ import PprCmmExpr
import Outputable
import Platform
import FastString
import Data.List
......@@ -54,23 +55,25 @@ import ClosureInfo
#include "../includes/rts/storage/FunTypes.h"
pprCmms :: (Outputable info, Outputable g) => [GenCmm CmmStatics info g] -> SDoc
pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms))
pprCmms :: (Outputable info, PlatformOutputable g)
=> Platform -> [GenCmm CmmStatics info g] -> SDoc
pprCmms platform cmms = pprCode CStyle (vcat (intersperse separator $ map (pprPlatform platform) cmms))
where
separator = space $$ ptext (sLit "-------------------") $$ space
writeCmms :: (Outputable info, Outputable g) => Handle -> [GenCmm CmmStatics info g] -> IO ()
writeCmms handle cmms = printForC handle (pprCmms cmms)
writeCmms :: (Outputable info, PlatformOutputable g)
=> Platform -> Handle -> [GenCmm CmmStatics info g] -> IO ()
writeCmms platform handle cmms = printForC handle (pprCmms platform cmms)
-----------------------------------------------------------------------------
instance (Outputable d, Outputable info, Outputable g)
=> Outputable (GenCmm d info g) where
ppr c = pprCmm c
instance (Outputable d, Outputable info, PlatformOutputable g)
=> PlatformOutputable (GenCmm d info g) where
pprPlatform platform c = pprCmm platform c
instance (Outputable d, Outputable info, Outputable i)
=> Outputable (GenCmmTop d info i) where
ppr t = pprTop t
instance (Outputable d, Outputable info, PlatformOutputable i)
=> PlatformOutputable (GenCmmTop d info i) where
pprPlatform platform t = pprTop platform t
instance Outputable CmmStatics where
ppr e = pprStatics e
......@@ -84,20 +87,22 @@ instance Outputable CmmInfoTable where
-----------------------------------------------------------------------------
pprCmm :: (Outputable d, Outputable info, Outputable g) => GenCmm d info g -> SDoc
pprCmm (Cmm tops) = vcat $ intersperse blankLine $ map pprTop tops
pprCmm :: (Outputable d, Outputable info, PlatformOutputable g)
=> Platform -> GenCmm d info g -> SDoc
pprCmm platform (Cmm tops)
= vcat $ intersperse blankLine $ map (pprTop platform) tops
-- --------------------------------------------------------------------------
-- Top level `procedure' blocks.
--
pprTop :: (Outputable d, Outputable info, Outputable i)
=> GenCmmTop d info i -> SDoc
pprTop :: (Outputable d, Outputable info, PlatformOutputable i)
=> Platform -> GenCmmTop d info i -> SDoc
pprTop (CmmProc info lbl graph)
pprTop platform (CmmProc info lbl graph)
= vcat [ pprCLabel lbl <> lparen <> rparen
, nest 8 $ lbrace <+> ppr info $$ rbrace
, nest 4 $ ppr graph
, nest 4 $ pprPlatform platform graph
, rbrace ]
-- --------------------------------------------------------------------------
......@@ -105,7 +110,7 @@ pprTop (CmmProc info lbl graph)
--
-- section "data" { ... }
--
pprTop (CmmData section ds) =
pprTop _ (CmmData section ds) =
(hang (pprSection section <+> lbrace) 4 (ppr ds))
$$ rbrace
......
......@@ -84,7 +84,7 @@ codeGen dflags this_mod data_tycons cost_centre_info stg_binds hpc_info
-- initialisation routines; see Note
-- [pipeline-split-init].
; dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprCmms code_stuff)
; dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprCmms (targetPlatform dflags) code_stuff)
; return code_stuff }
......
......@@ -81,7 +81,7 @@ codeGen dflags this_mod data_tycons
-- initialisation routines; see Note
-- [pipeline-split-init].
; dumpIfSet_dyn dflags Opt_D_dump_cmmz "New Cmm" (pprCmms code_stuff)
; dumpIfSet_dyn dflags Opt_D_dump_cmmz "New Cmm" (pprCmms (targetPlatform dflags) code_stuff)
; return code_stuff }
......
......@@ -115,7 +115,7 @@ cmmLlvmGen dflags us env cmm = do
let fixed_cmm = fixStgRegisters cmm
dumpIfSet_dyn dflags Opt_D_dump_opt_cmm "Optimised Cmm"
(pprCmm $ Cmm [fixed_cmm])
(pprCmm (targetPlatform dflags) $ Cmm [fixed_cmm])
-- generate llvm code from cmm
let ((env', llvmBC), usGen) = initUs us $ genLlvmProc env fixed_cmm
......
......@@ -61,7 +61,7 @@ codeOutput dflags this_mod location foreign_stubs pkg_deps flat_abstractC
do { when (dopt Opt_DoCmmLinting dflags) $ do
{ showPass dflags "CmmLint"
; let lints = map cmmLint flat_abstractC
; let lints = map (cmmLint (targetPlatform dflags)) flat_abstractC
; case firstJusts lints of
Just err -> do { printDump err
; ghcExit dflags 1
......
......@@ -1054,6 +1054,7 @@ hscGenHardCode cgguts mod_summary
cg_dep_pkgs = dependencies,
cg_hpc_info = hpc_info } = cgguts
dflags = hsc_dflags hsc_env
platform = targetPlatform dflags
location = ms_location mod_summary
data_tycons = filter isDataTyCon tycons
-- cg_tycons includes newtypes, for the benefit of External Core,
......@@ -1089,7 +1090,7 @@ hscGenHardCode cgguts mod_summary
-- unless certain dflags are on, the identity function
------------------ Code output -----------------------
rawcmms <- cmmToRawCmm cmms
dumpIfSet_dyn dflags Opt_D_dump_raw_cmm "Raw Cmm" (ppr rawcmms)
dumpIfSet_dyn dflags Opt_D_dump_raw_cmm "Raw Cmm" (pprPlatform platform rawcmms)
(_stub_h_exists, stub_c_exists)
<- codeOutput dflags this_mod location foreign_stubs
dependencies rawcmms
......@@ -1160,10 +1161,11 @@ tryNewCodeGen :: HscEnv -> Module -> [TyCon]
tryNewCodeGen hsc_env this_mod data_tycons
cost_centre_info stg_binds hpc_info =
do { let dflags = hsc_dflags hsc_env
platform = targetPlatform dflags
; prog <- StgCmm.codeGen dflags this_mod data_tycons
cost_centre_info stg_binds hpc_info
; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Cmm produced by new codegen"
(pprCmms prog)
(pprCmms platform prog)
-- We are building a single SRT for the entire module, so
-- we must thread it through all the procedures as we cps-convert them.
......@@ -1172,7 +1174,7 @@ tryNewCodeGen hsc_env this_mod data_tycons
; (topSRT, prog) <- foldM (cmmPipeline hsc_env) (initTopSRT, []) prog
; let prog' = map cmmOfZgraph (srtToData topSRT : prog)
; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" (ppr prog')
; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" (pprPlatform platform prog')
; return prog' }
......@@ -1189,11 +1191,12 @@ optionallyConvertAndOrCPS hsc_env cmms =
testCmmConversion :: HscEnv -> Cmm -> IO Cmm
testCmmConversion hsc_env cmm =
do let dflags = hsc_dflags hsc_env
platform = targetPlatform dflags
showPass dflags "CmmToCmm"
dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- pre-conversion" (ppr cmm)
dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- pre-conversion" (pprPlatform platform cmm)
--continuationC <- cmmCPS dflags abstractC >>= cmmToRawCmm
us <- mkSplitUniqSupply 'C'
let zgraph = initUs_ us (cmmToZgraph cmm)
let zgraph = initUs_ us (cmmToZgraph platform cmm)
chosen_graph <-
if dopt Opt_RunCPSZ dflags
then do us <- mkSplitUniqSupply 'S'
......@@ -1201,10 +1204,10 @@ testCmmConversion hsc_env cmm =
(_, [zgraph]) <- cmmPipeline hsc_env (topSRT, []) zgraph
return zgraph
else return (runCmmContFlowOpts zgraph)
dumpIfSet_dyn dflags Opt_D_dump_cmmz "C-- Zipper Graph" (ppr chosen_graph)
dumpIfSet_dyn dflags Opt_D_dump_cmmz "C-- Zipper Graph" (pprPlatform platform chosen_graph)
showPass dflags "Convert from Z back to Cmm"
let cvt = cmmOfZgraph chosen_graph
dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- post-conversion" (ppr cvt)
dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- post-conversion" (pprPlatform platform cvt)
return cvt
myCoreToStg :: DynFlags -> Module -> [CoreBind]
......
......@@ -133,7 +133,7 @@ The machine-dependent bits break down as follows:
-- Top-level of the native codegen
data NcgImpl statics instr jumpDest = NcgImpl {
cmmTopCodeGen :: RawCmmTop -> NatM [NatCmmTop statics instr],
cmmTopCodeGen :: Platform -> RawCmmTop -> NatM [NatCmmTop statics instr],
generateJumpTableForInstr :: instr -> Maybe (NatCmmTop statics instr),
getJumpDestBlockId :: jumpDest -> Maybe BlockId,
canShortcut :: instr -> Maybe jumpDest,
......@@ -150,7 +150,7 @@ data NcgImpl statics instr jumpDest = NcgImpl {
--------------------
nativeCodeGen :: DynFlags -> Handle -> UniqSupply -> [RawCmm] -> IO ()
nativeCodeGen dflags h us cmms
= let nCG' :: (Outputable statics, Outputable instr, Instruction instr) => NcgImpl statics instr jumpDest -> IO ()
= let nCG' :: (Outputable statics, PlatformOutputable instr, Instruction instr) => NcgImpl statics instr jumpDest -> IO ()
nCG' ncgImpl = nativeCodeGen' dflags ncgImpl h us cmms
x86NcgImpl = NcgImpl {
cmmTopCodeGen = X86.CodeGen.cmmTopCodeGen
......@@ -206,7 +206,7 @@ nativeCodeGen dflags h us cmms
ArchUnknown ->
panic "nativeCodeGen: No NCG for unknown arch"
nativeCodeGen' :: (Outputable statics, Outputable instr, Instruction instr)
nativeCodeGen' :: (Outputable statics, PlatformOutputable instr, Instruction instr)
=> DynFlags
-> NcgImpl statics instr jumpDest
-> Handle -> UniqSupply -> [RawCmm] -> IO ()
......@@ -272,7 +272,7 @@ nativeCodeGen' dflags ncgImpl h us cmms
-- | Do native code generation on all these cmms.
--
cmmNativeGens :: (Outputable statics, Outputable instr, Instruction instr)
cmmNativeGens :: (Outputable statics, PlatformOutputable instr, Instruction instr)
=> DynFlags
-> NcgImpl statics instr jumpDest
-> BufHandle
......@@ -327,7 +327,7 @@ cmmNativeGens dflags ncgImpl h us (cmm : cmms) impAcc profAcc count
-- Dumping the output of each stage along the way.
-- Global conflict graph and NGC stats
cmmNativeGen
:: (Outputable statics, Outputable instr, Instruction instr)
:: (Outputable statics, PlatformOutputable instr, Instruction instr)
=> DynFlags
-> NcgImpl statics instr jumpDest
-> UniqSupply
......@@ -341,6 +341,7 @@ cmmNativeGen
cmmNativeGen dflags ncgImpl us cmm count
= do
let platform = targetPlatform dflags
-- rewrite assignments to global regs
let fixed_cmm =
......@@ -354,27 +355,27 @@ cmmNativeGen dflags ncgImpl us cmm count
dumpIfSet_dyn dflags
Opt_D_dump_opt_cmm "Optimised Cmm"
(pprCmm $ Cmm [opt_cmm])
(pprCmm platform $ Cmm [opt_cmm])
-- generate native code from cmm
let ((native, lastMinuteImports), usGen) =
{-# SCC "genMachCode" #-}
initUs us $ genMachCode dflags (cmmTopCodeGen ncgImpl) opt_cmm
initUs us $ genMachCode dflags (cmmTopCodeGen ncgImpl platform) opt_cmm
dumpIfSet_dyn dflags
Opt_D_dump_asm_native "Native code"
(vcat $ map (docToSDoc . pprNatCmmTop ncgImpl (targetPlatform dflags)) native)
(vcat $ map (docToSDoc . pprNatCmmTop ncgImpl platform) native)
-- tag instructions with register liveness information
let (withLiveness, usLive) =
{-# SCC "regLiveness" #-}
initUs usGen
$ mapUs regLiveness
$ mapUs (regLiveness platform)
$ map natCmmTopToLive native
dumpIfSet_dyn dflags
Opt_D_dump_asm_liveness "Liveness annotations added"
(vcat $ map ppr withLiveness)
(vcat $ map (pprPlatform platform) withLiveness)
-- allocate registers
(alloced, usAlloc, ppr_raStatsColor, ppr_raStatsLinear) <-
......@@ -401,14 +402,14 @@ cmmNativeGen dflags ncgImpl us cmm count
-- dump out what happened during register allocation
dumpIfSet_dyn dflags
Opt_D_dump_asm_regalloc "Registers allocated"
(vcat $ map (docToSDoc . pprNatCmmTop ncgImpl (targetPlatform dflags)) alloced)
(vcat $ map (docToSDoc . pprNatCmmTop ncgImpl platform) alloced)
dumpIfSet_dyn dflags
Opt_D_dump_asm_regalloc_stages "Build/spill stages"
(vcat $ map (\(stage, stats)
-> text "# --------------------------"
$$ text "# cmm " <> int count <> text " Stage " <> int stage
$$ ppr stats)
$$ pprPlatform platform stats)
$ zip [0..] regAllocStats)
let mPprStats =
......@@ -432,7 +433,7 @@ cmmNativeGen dflags ncgImpl us cmm count
dumpIfSet_dyn dflags
Opt_D_dump_asm_regalloc "Registers allocated"
(vcat $ map (docToSDoc . pprNatCmmTop ncgImpl (targetPlatform dflags)) alloced)
(vcat $ map (docToSDoc . pprNatCmmTop ncgImpl platform) alloced)
let mPprStats =
if dopt Opt_D_dump_asm_stats dflags
......@@ -476,7 +477,7 @@ cmmNativeGen dflags ncgImpl us cmm count
dumpIfSet_dyn dflags
Opt_D_dump_asm_expanded "Synthetic instructions expanded"
(vcat $ map (docToSDoc . pprNatCmmTop ncgImpl (targetPlatform dflags)) expanded)
(vcat $ map (docToSDoc . pprNatCmmTop ncgImpl platform) expanded)
return ( usAlloc
, expanded
......
......@@ -66,10 +66,11 @@ import FastString
-- order.
cmmTopCodeGen
:: RawCmmTop
:: Platform
-> RawCmmTop
-> NatM [NatCmmTop CmmStatics Instr]
cmmTopCodeGen (CmmProc info lab (ListGraph blocks)) = do
cmmTopCodeGen _ (CmmProc info lab (ListGraph blocks)) = do
(nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks
picBaseMb <- getPicBaseMaybeNat
dflags <- getDynFlagsNat
......@@ -80,7 +81,7 @@ cmmTopCodeGen (CmmProc info lab (ListGraph blocks)) = do