Commit 5b167f5e authored by Simon Marlow's avatar Simon Marlow
Browse files

Snapshot of codegen refactoring to share with simonpj

parent 3108accd
...@@ -22,7 +22,7 @@ module CLabel ( ...@@ -22,7 +22,7 @@ module CLabel (
mkSRTLabel, mkSRTLabel,
mkInfoTableLabel, mkInfoTableLabel,
mkEntryLabel, mkEntryLabel,
mkSlowEntryLabel, mkSlowEntryLabel, slowEntryFromInfoLabel,
mkConEntryLabel, mkConEntryLabel,
mkStaticConEntryLabel, mkStaticConEntryLabel,
mkRednCountsLabel, mkRednCountsLabel,
...@@ -354,8 +354,10 @@ data DynamicLinkerLabelInfo ...@@ -354,8 +354,10 @@ data DynamicLinkerLabelInfo
-- Constructing IdLabels -- Constructing IdLabels
-- These are always local: -- These are always local:
mkSRTLabel name c = IdLabel name c SRT
mkSlowEntryLabel name c = IdLabel name c Slow mkSlowEntryLabel name c = IdLabel name c Slow
slowEntryFromInfoLabel (IdLabel n c _) = IdLabel n c Slow
mkSRTLabel name c = IdLabel name c SRT
mkRednCountsLabel name c = IdLabel name c RednCounts mkRednCountsLabel name c = IdLabel name c RednCounts
-- These have local & (possibly) external variants: -- These have local & (possibly) external variants:
......
...@@ -8,39 +8,84 @@ ...@@ -8,39 +8,84 @@
{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} {-# OPTIONS_GHC -fwarn-incomplete-patterns #-}
#endif #endif
module Cmm module Cmm (
( CmmGraph, GenCmmGraph(..), CmmBlock -- * Cmm top-level datatypes
, CmmStackInfo(..), CmmTopInfo(..), Cmm, CmmTop CmmPgm, GenCmmPgm,
, CmmReplGraph, GenCmmReplGraph, CmmFwdRewrite, CmmBwdRewrite CmmTop, GenCmmTop(..),
CmmGraph, GenCmmGraph(..),
, modifyGraph CmmBlock,
, lastNode, replaceLastNode, insertBetween Section(..), CmmStatics(..), CmmStatic(..),
, ofBlockMap, toBlockMap, insertBlock
, ofBlockList, toBlockList, bodyToBlockList -- * Cmm graphs
, foldGraphBlocks, mapGraphNodes, postorderDfs CmmReplGraph, GenCmmReplGraph, CmmFwdRewrite, CmmBwdRewrite,
, analFwd, analBwd, analRewFwd, analRewBwd -- * Info Tables
, dataflowPassFwd, dataflowPassBwd CmmTopInfo(..), CmmStackInfo(..), CmmInfoTable(..),
, module CmmNode ClosureTypeInfo(..),
) C_SRT(..), needsSRT,
where ProfilingInfo(..), ConstrDescription,
-- * Statements, expressions and types
module CmmNode,
module CmmExpr,
) where
import CLabel
import BlockId import BlockId
import CmmDecl
import CmmNode import CmmNode
import OptimizationFuel as F import OptimizationFuel as F
import SMRep import SMRep
import UniqSupply import CmmExpr
import Compiler.Hoopl import Compiler.Hoopl
import Control.Monad
import Data.Maybe import Data.Word ( Word8 )
import Panic
#include "HsVersions.h" #include "HsVersions.h"
------------------------------------------------- -----------------------------------------------------------------------------
-- CmmBlock, CmmGraph and Cmm -- Cmm, GenCmm
-----------------------------------------------------------------------------
-- A file is a list of top-level chunks. These may be arbitrarily
-- re-orderd during code generation.
-- GenCmm is abstracted over
-- d, the type of static data elements in CmmData
-- h, the static info preceding the code of a CmmProc
-- g, the control-flow graph of a CmmProc
--
-- 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 second family of instances based on Hoopl is in Cmm.hs.
--
type GenCmmPgm d h g = [GenCmmTop d h g]
type CmmPgm = GenCmmPgm CmmStatics CmmTopInfo CmmGraph
-----------------------------------------------------------------------------
-- CmmTop, GenCmmTop
-----------------------------------------------------------------------------
-- | A top-level chunk, abstracted over the type of the contents of
-- the basic blocks (Cmm or instructions are the likely instantiations).
data GenCmmTop d h g
= CmmProc -- A procedure
h -- Extra header such as the info table
CLabel -- Entry label
g -- Control-flow graph for the procedure's code
| CmmData -- Static data
Section
d
type CmmTop = GenCmmTop CmmStatics CmmTopInfo CmmGraph
-----------------------------------------------------------------------------
-- Graphs
-----------------------------------------------------------------------------
type CmmGraph = GenCmmGraph CmmNode type CmmGraph = GenCmmGraph CmmNode
data GenCmmGraph n = CmmGraph { g_entry :: BlockId, g_graph :: Graph n C C } data GenCmmGraph n = CmmGraph { g_entry :: BlockId, g_graph :: Graph n C C }
...@@ -51,131 +96,66 @@ type GenCmmReplGraph n e x = FuelUniqSM (Maybe (Graph n e x)) ...@@ -51,131 +96,66 @@ type GenCmmReplGraph n e x = FuelUniqSM (Maybe (Graph n e x))
type CmmFwdRewrite f = FwdRewrite FuelUniqSM CmmNode f type CmmFwdRewrite f = FwdRewrite FuelUniqSM CmmNode f
type CmmBwdRewrite f = BwdRewrite FuelUniqSM CmmNode f type CmmBwdRewrite f = BwdRewrite FuelUniqSM CmmNode f
data CmmStackInfo = StackInfo {arg_space :: ByteOff, updfr_space :: Maybe ByteOff} -----------------------------------------------------------------------------
-- Info Tables
-----------------------------------------------------------------------------
data CmmTopInfo = TopInfo {info_tbl :: CmmInfoTable, stack_info :: CmmStackInfo} data CmmTopInfo = TopInfo {info_tbl :: CmmInfoTable, stack_info :: CmmStackInfo}
type Cmm = GenCmm CmmStatics CmmTopInfo CmmGraph
type CmmTop = GenCmmTop CmmStatics CmmTopInfo CmmGraph
------------------------------------------------- data CmmStackInfo
-- Manipulating CmmGraphs = StackInfo {
arg_space :: ByteOff, -- XXX: comment?
modifyGraph :: (Graph n C C -> Graph n' C C) -> GenCmmGraph n -> GenCmmGraph n' updfr_space :: Maybe ByteOff -- XXX: comment?
modifyGraph f g = CmmGraph {g_entry=g_entry g, g_graph=f (g_graph g)} }
toBlockMap :: CmmGraph -> LabelMap CmmBlock -- | Info table as a haskell data type
toBlockMap (CmmGraph {g_graph=GMany NothingO body NothingO}) = body data CmmInfoTable
= CmmInfoTable {
ofBlockMap :: BlockId -> LabelMap CmmBlock -> CmmGraph cit_lbl :: CLabel, -- Info table label
ofBlockMap entry bodyMap = CmmGraph {g_entry=entry, g_graph=GMany NothingO bodyMap NothingO} cit_rep :: SMRep,
cit_prof :: ProfilingInfo,
insertBlock :: CmmBlock -> LabelMap CmmBlock -> LabelMap CmmBlock cit_srt :: C_SRT
insertBlock block map = }
ASSERT (isNothing $ mapLookup id map) | CmmNonInfoTable -- Procedure doesn't need an info table
mapInsert id block map
where id = entryLabel block data ProfilingInfo
= NoProfilingInfo
toBlockList :: CmmGraph -> [CmmBlock] | ProfilingInfo [Word8] [Word8] -- closure_type, closure_desc
toBlockList g = mapElems $ toBlockMap g
-- C_SRT is what StgSyn.SRT gets translated to...
ofBlockList :: BlockId -> [CmmBlock] -> CmmGraph -- we add a label for the table, and expect only the 'offset/length' form
ofBlockList entry blocks = CmmGraph {g_entry=entry, g_graph=GMany NothingO body NothingO}
where body = foldr addBlock emptyBody blocks data C_SRT = NoC_SRT
| C_SRT !CLabel !WordOff !StgHalfWord {-bitmap or escape-}
bodyToBlockList :: Body CmmNode -> [CmmBlock] deriving (Eq)
bodyToBlockList body = mapElems body
needsSRT :: C_SRT -> Bool
mapGraphNodes :: ( CmmNode C O -> CmmNode C O needsSRT NoC_SRT = False
, CmmNode O O -> CmmNode O O needsSRT (C_SRT _ _ _) = True
, CmmNode O C -> CmmNode O C)
-> CmmGraph -> CmmGraph -----------------------------------------------------------------------------
mapGraphNodes funs@(mf,_,_) g = -- Static Data
ofBlockMap (entryLabel $ mf $ CmmEntry $ g_entry g) $ mapMap (blockMapNodes3 funs) $ toBlockMap g -----------------------------------------------------------------------------
foldGraphBlocks :: (CmmBlock -> a -> a) -> a -> CmmGraph -> a data Section
foldGraphBlocks k z g = mapFold k z $ toBlockMap g = Text
| Data
postorderDfs :: CmmGraph -> [CmmBlock] | ReadOnlyData
postorderDfs g = postorder_dfs_from (toBlockMap g) (g_entry g) | RelocatableReadOnlyData
| UninitialisedData
------------------------------------------------- | ReadOnlyData16 -- .rodata.cst16 on x86_64, 16-byte aligned
-- Manipulating CmmBlocks | OtherSection String
lastNode :: CmmBlock -> CmmNode O C data CmmStatic
lastNode block = foldBlockNodesF3 (nothing, nothing, const) block () = CmmStaticLit CmmLit
where nothing :: a -> b -> () -- a literal value, size given by cmmLitRep of the literal.
nothing _ _ = () | CmmUninitialised Int
-- uninitialised data, N bytes long
replaceLastNode :: Block CmmNode e C -> CmmNode O C -> Block CmmNode e C | CmmString [Word8]
replaceLastNode block last = blockOfNodeList (first, middle, JustC last) -- string of 8-bit values only, not zero terminated.
where (first, middle, _) = blockToNodeList block
data CmmStatics
---------------------------------------------------------------------- = Statics
----- Splicing between blocks CLabel -- Label of statics
-- Given a middle node, a block, and a successor BlockId, [CmmStatic] -- The static data itself
-- we can insert the middle node between the block and the successor.
-- We return the updated block and a list of new blocks that must be added
-- to the graph.
-- The semantics is a bit tricky. We consider cases on the last node:
-- o For a branch, we can just insert before the branch,
-- but sometimes the optimizer does better if we actually insert
-- a fresh basic block, enabling some common blockification.
-- o For a conditional branch, switch statement, or call, we must insert
-- a new basic block.
-- o For a jump or return, this operation is impossible.
insertBetween :: MonadUnique m => CmmBlock -> [CmmNode O O] -> BlockId -> m (CmmBlock, [CmmBlock])
insertBetween b ms succId = insert $ lastNode b
where insert :: MonadUnique m => CmmNode O C -> m (CmmBlock, [CmmBlock])
insert (CmmBranch bid) =
if bid == succId then
do (bid', bs) <- newBlocks
return (replaceLastNode b (CmmBranch bid'), bs)
else panic "tried invalid block insertBetween"
insert (CmmCondBranch c t f) =
do (t', tbs) <- if t == succId then newBlocks else return $ (t, [])
(f', fbs) <- if f == succId then newBlocks else return $ (f, [])
return (replaceLastNode b (CmmCondBranch c t' f'), tbs ++ fbs)
insert (CmmSwitch e ks) =
do (ids, bs) <- mapAndUnzipM mbNewBlocks ks
return (replaceLastNode b (CmmSwitch e ids), join bs)
insert (CmmCall {}) =
panic "unimp: insertBetween after a call -- probably not a good idea"
insert (CmmForeignCall {}) =
panic "unimp: insertBetween after a foreign call -- probably not a good idea"
newBlocks :: MonadUnique m => m (BlockId, [CmmBlock])
newBlocks = do id <- liftM mkBlockId $ getUniqueM
return $ (id, [blockOfNodeList (JustC (CmmEntry id), ms, JustC (CmmBranch succId))])
mbNewBlocks :: MonadUnique m => Maybe BlockId -> m (Maybe BlockId, [CmmBlock])
mbNewBlocks (Just k) = if k == succId then liftM fstJust newBlocks
else return (Just k, [])
mbNewBlocks Nothing = return (Nothing, [])
fstJust (id, bs) = (Just id, bs)
-------------------------------------------------
-- Running dataflow analysis and/or rewrites
-- Constructing forward and backward analysis-only pass
analFwd :: Monad m => DataflowLattice f -> FwdTransfer n f -> FwdPass m n f
analBwd :: Monad m => DataflowLattice f -> BwdTransfer n f -> BwdPass m n f
analFwd lat xfer = analRewFwd lat xfer noFwdRewrite
analBwd lat xfer = analRewBwd lat xfer noBwdRewrite
-- Constructing forward and backward analysis + rewrite pass
analRewFwd :: Monad m => DataflowLattice f -> FwdTransfer n f -> FwdRewrite m n f -> FwdPass m n f
analRewBwd :: Monad m => DataflowLattice f -> BwdTransfer n f -> BwdRewrite m n f -> BwdPass m n f
analRewFwd lat xfer rew = FwdPass {fp_lattice = lat, fp_transfer = xfer, fp_rewrite = rew}
analRewBwd lat xfer rew = BwdPass {bp_lattice = lat, bp_transfer = xfer, bp_rewrite = rew}
-- Running forward and backward dataflow analysis + optional rewrite
dataflowPassFwd :: NonLocal n => GenCmmGraph n -> [(BlockId, f)] -> FwdPass FuelUniqSM n f -> FuelUniqSM (GenCmmGraph n, BlockEnv f)
dataflowPassFwd (CmmGraph {g_entry=entry, g_graph=graph}) facts fwd = do
(graph, facts, NothingO) <- analyzeAndRewriteFwd fwd (JustC [entry]) graph (mkFactBase (fp_lattice fwd) facts)
return (CmmGraph {g_entry=entry, g_graph=graph}, facts)
dataflowPassBwd :: NonLocal n => GenCmmGraph n -> [(BlockId, f)] -> BwdPass FuelUniqSM n f -> FuelUniqSM (GenCmmGraph n, BlockEnv f)
dataflowPassBwd (CmmGraph {g_entry=entry, g_graph=graph}) facts bwd = do
(graph, facts, NothingO) <- analyzeAndRewriteBwd bwd (JustC [entry]) graph (mkFactBase (bp_lattice bwd) facts)
return (CmmGraph {g_entry=entry, g_graph=graph}, facts)
...@@ -11,11 +11,16 @@ module CmmBuildInfoTables ...@@ -11,11 +11,16 @@ module CmmBuildInfoTables
, TopSRT, emptySRT, srtToData , TopSRT, emptySRT, srtToData
, bundleCAFs , bundleCAFs
, lowerSafeForeignCalls , lowerSafeForeignCalls
, cafTransfers, liveSlotTransfers) , cafTransfers, liveSlotTransfers
, mkLiveness )
where where
#include "HsVersions.h" #include "HsVersions.h"
-- These should not be imported here!
import StgCmmForeign
import StgCmmUtils
import Constants import Constants
import Digraph import Digraph
import qualified Prelude as P import qualified Prelude as P
...@@ -26,8 +31,7 @@ import BlockId ...@@ -26,8 +31,7 @@ import BlockId
import Bitmap import Bitmap
import CLabel import CLabel
import Cmm import Cmm
import CmmDecl import CmmUtils
import CmmExpr
import CmmStackLayout import CmmStackLayout
import Module import Module
import FastString import FastString
...@@ -41,9 +45,6 @@ import Name ...@@ -41,9 +45,6 @@ import Name
import OptimizationFuel import OptimizationFuel
import Outputable import Outputable
import SMRep import SMRep
import StgCmmClosure
import StgCmmForeign
import StgCmmUtils
import UniqSupply import UniqSupply
import Compiler.Hoopl import Compiler.Hoopl
...@@ -87,13 +88,14 @@ type RegSlotInfo ...@@ -87,13 +88,14 @@ type RegSlotInfo
, LocalReg -- The register , LocalReg -- The register
, Int) -- Width of the register , Int) -- Width of the register
live_ptrs :: ByteOff -> BlockEnv SubAreaSet -> AreaMap -> BlockId -> [Maybe LocalReg] live_ptrs :: ByteOff -> BlockEnv SubAreaSet -> AreaMap -> BlockId -> StackLayout
live_ptrs oldByte slotEnv areaMap bid = live_ptrs oldByte slotEnv areaMap bid =
-- pprTrace "live_ptrs for" (ppr bid <+> text (show oldByte ++ "-" ++ show youngByte) <+> -- pprTrace "live_ptrs for" (ppr bid <+> text (show oldByte ++ "-" ++ show youngByte) <+>
-- ppr liveSlots) $ -- ppr liveSlots) $
-- pprTrace ("stack layout for " ++ show bid ++ ": ") (ppr res) $ res -- pprTrace ("stack layout for " ++ show bid ++ ": ") (ppr res) $ res
res res
where res = reverse $ slotsToList youngByte liveSlots [] where
res = mkLiveness (reverse $ slotsToList youngByte liveSlots [])
slotsToList :: Int -> [RegSlotInfo] -> [Maybe LocalReg] -> [Maybe LocalReg] slotsToList :: Int -> [RegSlotInfo] -> [Maybe LocalReg] -> [Maybe LocalReg]
-- n starts at youngByte and is decremented down to oldByte -- n starts at youngByte and is decremented down to oldByte
...@@ -160,8 +162,9 @@ live_ptrs oldByte slotEnv areaMap bid = ...@@ -160,8 +162,9 @@ live_ptrs oldByte slotEnv areaMap bid =
-- is not the successor of a call. -- is not the successor of a call.
setInfoTableStackMap :: SlotEnv -> AreaMap -> CmmTop -> CmmTop setInfoTableStackMap :: SlotEnv -> AreaMap -> CmmTop -> CmmTop
setInfoTableStackMap slotEnv areaMap setInfoTableStackMap slotEnv areaMap
t@(CmmProc (TopInfo {stack_info=StackInfo {updfr_space = Just updfr_off}}) _ (CmmGraph {g_entry = eid})) = t@(CmmProc (TopInfo {stack_info=StackInfo {updfr_space = Just updfr_off}}) _
updInfo (const (live_ptrs updfr_off slotEnv areaMap eid)) id t (CmmGraph {g_entry = eid}))
= updInfo (const (live_ptrs updfr_off slotEnv areaMap eid)) id t
setInfoTableStackMap _ _ t = t setInfoTableStackMap _ _ t = t
...@@ -237,8 +240,8 @@ addCAF caf srt = ...@@ -237,8 +240,8 @@ addCAF caf srt =
, elt_map = Map.insert caf last (elt_map srt) } , elt_map = Map.insert caf last (elt_map srt) }
where last = next_elt srt where last = next_elt srt
srtToData :: TopSRT -> Cmm srtToData :: TopSRT -> CmmPgm
srtToData srt = Cmm [CmmData RelocatableReadOnlyData (Statics (lbl srt) tbl)] srtToData srt = [CmmData RelocatableReadOnlyData (Statics (lbl srt) tbl)]
where tbl = map (CmmStaticLit . CmmLabel) (reverse (rev_elts srt)) where tbl = map (CmmStaticLit . CmmLabel) (reverse (rev_elts srt))
-- Once we have found the CAFs, we need to do two things: -- Once we have found the CAFs, we need to do two things:
...@@ -336,8 +339,9 @@ localCAFInfo :: CAFEnv -> CmmTop -> Maybe (CLabel, CAFSet) ...@@ -336,8 +339,9 @@ localCAFInfo :: CAFEnv -> CmmTop -> Maybe (CLabel, CAFSet)
localCAFInfo _ (CmmData _ _) = Nothing localCAFInfo _ (CmmData _ _) = Nothing
localCAFInfo cafEnv (CmmProc top_info top_l (CmmGraph {g_entry=entry})) = localCAFInfo cafEnv (CmmProc top_info top_l (CmmGraph {g_entry=entry})) =
case info_tbl top_info of case info_tbl top_info of
CmmInfoTable _ False _ _ _ -> CmmInfoTable { cit_rep = rep }
Just (cvtToClosureLbl top_l, | not (isStaticRep rep)
-> Just (cvtToClosureLbl top_l,
expectJust "maybeBindCAFs" $ mapLookup entry cafEnv) expectJust "maybeBindCAFs" $ mapLookup entry cafEnv)
_ -> Nothing _ -> Nothing
...@@ -368,8 +372,6 @@ mkTopCAFInfo localCAFs = foldl addToTop Map.empty g ...@@ -368,8 +372,6 @@ mkTopCAFInfo localCAFs = foldl addToTop Map.empty g
g = stronglyConnCompFromEdgedVertices g = stronglyConnCompFromEdgedVertices
(map (\n@(l, cafs) -> (n, l, Map.keys cafs)) localCAFs) (map (\n@(l, cafs) -> (n, l, Map.keys cafs)) localCAFs)
type StackLayout = [Maybe LocalReg]
-- Bundle the CAFs used at a procpoint. -- Bundle the CAFs used at a procpoint.
bundleCAFs :: CAFEnv -> CmmTop -> (CAFSet, CmmTop) bundleCAFs :: CAFEnv -> CmmTop -> (CAFSet, CmmTop)
bundleCAFs cafEnv t@(CmmProc _ _ (CmmGraph {g_entry=entry})) = bundleCAFs cafEnv t@(CmmProc _ _ (CmmGraph {g_entry=entry})) =
...@@ -391,20 +393,19 @@ setSRT cafs topCAFMap topSRT t = ...@@ -391,20 +393,19 @@ setSRT cafs topCAFMap topSRT t =
Just tbl -> return (topSRT, [t', tbl]) Just tbl -> return (topSRT, [t', tbl])
Nothing -> return (topSRT, [t']) Nothing -> return (topSRT, [t'])
type StackLayout = Liveness
updInfo :: (StackLayout -> StackLayout) -> (C_SRT -> C_SRT) -> CmmTop -> CmmTop updInfo :: (StackLayout -> StackLayout) -> (C_SRT -> C_SRT) -> CmmTop -> CmmTop
updInfo toVars toSrt (CmmProc top_info top_l g) = updInfo toVars toSrt (CmmProc top_info top_l g) =
CmmProc (top_info {info_tbl=updInfoTbl toVars toSrt (info_tbl top_info)}) top_l g CmmProc (top_info {info_tbl=updInfoTbl toVars toSrt (info_tbl top_info)}) top_l g
updInfo _ _ t = t updInfo _ _ t = t
updInfoTbl :: (StackLayout -> StackLayout) -> (C_SRT -> C_SRT) -> CmmInfoTable -> CmmInfoTable updInfoTbl :: (StackLayout -> StackLayout) -> (C_SRT -> C_SRT) -> CmmInfoTable -> CmmInfoTable
updInfoTbl toVars toSrt (CmmInfoTable l s p t typeinfo) updInfoTbl toVars toSrt info_tbl@(CmmInfoTable {})
= CmmInfoTable l s p t typeinfo' = info_tbl { cit_srt = toSrt (cit_srt info_tbl)
where typeinfo' = case typeinfo of , cit_rep = case cit_rep info_tbl of
t@(ConstrInfo _ _ _) -> t StackRep ls -> StackRep (toVars ls)
(FunInfo c s a d e) -> FunInfo c (toSrt s) a d e other -> other }
(ThunkInfo c s) -> ThunkInfo c (toSrt s)
(ThunkSelectorInfo x s) -> ThunkSelectorInfo x (toSrt s)
(ContInfo v s) -> ContInfo (toVars v) (toSrt s)
updInfoTbl _ _ t@CmmNonInfoTable = t updInfoTbl _ _ t@CmmNonInfoTable = t
---------------------------------------------------------------- ----------------------------------------------------------------
...@@ -493,3 +494,4 @@ lowerSafeForeignCall entry areaMap blocks bid m ...@@ -493,3 +494,4 @@ lowerSafeForeignCall entry areaMap blocks bid m
resume <**> saveRetVals <**> M.mkLast jump resume <**> saveRetVals <**> M.mkLast jump
return $ blocks `mapUnion` toBlockMap graph' return $ blocks `mapUnion` toBlockMap graph'
lowerSafeForeignCall _ _ _ _ _ _ = panic "lowerSafeForeignCall was passed something else" lowerSafeForeignCall _ _ _ _ _ _ = panic "lowerSafeForeignCall was passed something else"
...@@ -11,7 +11,7 @@ where ...@@ -11,7 +11,7 @@ where
import BlockId import BlockId
import Cmm import Cmm
import CmmExpr import CmmUtils
import Prelude hiding (iterate, succ, unzip, zip) import Prelude hiding (iterate, succ, unzip, zip)
import Compiler.Hoopl import Compiler.Hoopl
......
...@@ -10,8 +10,7 @@ where ...@@ -10,8 +10,7 @@ where
import BlockId import BlockId
import Cmm import Cmm
import CmmDecl import CmmUtils
import CmmExpr
import qualified OldCmm as Old import qualified OldCmm as Old
import Maybes import Maybes
...@@ -22,7 +21,7 @@ import Prelude hiding (succ, unzip, zip) ...@@ -22,7 +21,7 @@ import Prelude hiding (succ, unzip, zip)
import Util import Util
------------------------------------ ------------------------------------
runCmmContFlowOpts :: Cmm -> Cmm runCmmContFlowOpts :: CmmPgm -> CmmPgm
runCmmContFlowOpts prog = runCmmOpts cmmCfgOpts prog runCmmContFlowOpts prog = runCmmOpts cmmCfgOpts prog
oldCmmCfgOpts :: Old.ListGraph Old.CmmStmt -> Old.ListGraph Old.CmmStmt oldCmmCfgOpts :: Old.ListGraph Old.CmmStmt -> Old.ListGraph Old.CmmStmt
...@@ -34,18 +33,14 @@ cmmCfgOpts = ...@@ -34,18 +33,14 @@ cmmCfgOpts =
-- Here branchChainElim can ultimately be replaced -- Here branchChainElim can ultimately be replaced
-- with a more exciting combination of optimisations -- with a more exciting combination of optimisations
runCmmOpts :: (g -> g) -> GenCmm d h g -> GenCmm d h g runCmmOpts :: (g -> g) -> GenCmmPgm d h g -> GenCmmPgm d h g
-- Lifts a transformer on a single graph to one on the whole program -- Lifts a transformer on a single graph to one on the whole program
runCmmOpts opt = mapProcs (optProc opt) runCmmOpts opt = map (optProc opt)
optProc :: (g -> g) -> GenCmmTop d h g -> GenCmmTop d h g optProc :: (g -> g) -> GenCmmTop d h g -> GenCmmTop d h g
optProc _ top@(CmmData {}) = top optProc _ top@(CmmData {}) = top
optProc opt (CmmProc info lbl g) = CmmProc info lbl (opt g) optProc opt (CmmProc info lbl g) = CmmProc info lbl (opt g)
------------------------------------
mapProcs :: (GenCmmTop d h s -> GenCmmTop d h s) -> GenCmm d h s -> GenCmm d h s
mapProcs f (Cmm tops) = Cmm (map f tops)
---------------------------------------------------------------- ----------------------------------------------------------------
oldBranchChainElim :: Old.ListGraph Old.CmmStmt -> Old.ListGraph Old.CmmStmt oldBranchChainElim :: Old.ListGraph Old.CmmStmt -> Old.ListGraph Old.CmmStmt
-- If L is not captured in an instruction, we can remove any -- If L is not captured in an instruction, we can remove any
......
...@@ -3,91 +3,25 @@ ...@@ -3,91 +3,25 @@
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
module CmmCvt module CmmCvt
( cmmToZgraph, cmmOfZgraph ) ( cmmOfZgraph )
where where
import BlockId