Skip to content
GitLab
Commit 5b167f5e authored by Simon Marlow's avatar Simon Marlow
Browse files

Snapshot of codegen refactoring to share with simonpj

parent 3108accd
Hide whitespace changes
Inline Side-by-side
compiler/cmm/CLabel.hs
View file @ 5b167f5e
......@@ -22,7 +22,7 @@ module CLabel (
mkSRTLabel,
mkInfoTableLabel,
mkEntryLabel,
mkSlowEntryLabel,
mkSlowEntryLabel, slowEntryFromInfoLabel,
mkConEntryLabel,
mkStaticConEntryLabel,
mkRednCountsLabel,
......@@ -354,8 +354,10 @@ data DynamicLinkerLabelInfo
-- Constructing IdLabels
-- These are always local:
mkSlowEntryLabel name c = IdLabel name c Slow
slowEntryFromInfoLabel (IdLabel n c _) = IdLabel n c Slow
mkSRTLabel name c = IdLabel name c SRT
mkSlowEntryLabel name c = IdLabel name c Slow
mkRednCountsLabel name c = IdLabel name c RednCounts
-- These have local & (possibly) external variants:
......@@ -372,8 +374,8 @@ mkLocalConInfoTableLabel c con = IdLabel con c ConInfoTable
mkLocalConEntryLabel c con = IdLabel con c ConEntry
mkLocalStaticInfoTableLabel c con = IdLabel con c StaticInfoTable
mkLocalStaticConEntryLabel c con = IdLabel con c StaticConEntry
mkConInfoTableLabel name c = IdLabel name c ConInfoTable
mkStaticInfoTableLabel name c = IdLabel name c StaticInfoTable
mkConInfoTableLabel name c = IdLabel name c ConInfoTable
mkStaticInfoTableLabel name c = IdLabel name c StaticInfoTable
mkConEntryLabel name c = IdLabel name c ConEntry
mkStaticConEntryLabel name c = IdLabel name c StaticConEntry
......
compiler/cmm/Cmm.hs
View file @ 5b167f5e
......@@ -8,39 +8,84 @@
{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}
#endif
module Cmm
( CmmGraph, GenCmmGraph(..), CmmBlock
, CmmStackInfo(..), CmmTopInfo(..), Cmm, CmmTop
, CmmReplGraph, GenCmmReplGraph, CmmFwdRewrite, CmmBwdRewrite
, modifyGraph
, lastNode, replaceLastNode, insertBetween
, ofBlockMap, toBlockMap, insertBlock
, ofBlockList, toBlockList, bodyToBlockList
, foldGraphBlocks, mapGraphNodes, postorderDfs
, analFwd, analBwd, analRewFwd, analRewBwd
, dataflowPassFwd, dataflowPassBwd
, module CmmNode
)
where
module Cmm (
-- * Cmm top-level datatypes
CmmPgm, GenCmmPgm,
CmmTop, GenCmmTop(..),
CmmGraph, GenCmmGraph(..),
CmmBlock,
Section(..), CmmStatics(..), CmmStatic(..),
-- * Cmm graphs
CmmReplGraph, GenCmmReplGraph, CmmFwdRewrite, CmmBwdRewrite,
-- * Info Tables
CmmTopInfo(..), CmmStackInfo(..), CmmInfoTable(..),
ClosureTypeInfo(..),
C_SRT(..), needsSRT,
ProfilingInfo(..), ConstrDescription,
-- * Statements, expressions and types
module CmmNode,
module CmmExpr,
) where
import CLabel
import BlockId
import CmmDecl
import CmmNode
import OptimizationFuel as F
import SMRep
import UniqSupply
import CmmExpr
import Compiler.Hoopl
import Control.Monad
import Data.Maybe
import Panic
import Data.Word ( Word8 )
#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
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))
type CmmFwdRewrite f = FwdRewrite 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}
type Cmm = GenCmm CmmStatics CmmTopInfo CmmGraph
type CmmTop = GenCmmTop CmmStatics CmmTopInfo CmmGraph
-------------------------------------------------
-- Manipulating CmmGraphs
modifyGraph :: (Graph n C C -> Graph n' C C) -> GenCmmGraph n -> GenCmmGraph n'
modifyGraph f g = CmmGraph {g_entry=g_entry g, g_graph=f (g_graph g)}
toBlockMap :: CmmGraph -> LabelMap CmmBlock
toBlockMap (CmmGraph {g_graph=GMany NothingO body NothingO}) = body
ofBlockMap :: BlockId -> LabelMap CmmBlock -> CmmGraph
ofBlockMap entry bodyMap = CmmGraph {g_entry=entry, g_graph=GMany NothingO bodyMap NothingO}
insertBlock :: CmmBlock -> LabelMap CmmBlock -> LabelMap CmmBlock
insertBlock block map =
ASSERT (isNothing $ mapLookup id map)
mapInsert id block map
where id = entryLabel block
toBlockList :: CmmGraph -> [CmmBlock]
toBlockList g = mapElems $ toBlockMap g
ofBlockList :: BlockId -> [CmmBlock] -> CmmGraph
ofBlockList entry blocks = CmmGraph {g_entry=entry, g_graph=GMany NothingO body NothingO}
where body = foldr addBlock emptyBody blocks
bodyToBlockList :: Body CmmNode -> [CmmBlock]
bodyToBlockList body = mapElems body
mapGraphNodes :: ( CmmNode C O -> CmmNode C O
, CmmNode O O -> CmmNode O O
, CmmNode O C -> CmmNode O C)
-> CmmGraph -> CmmGraph
mapGraphNodes funs@(mf,_,_) g =
ofBlockMap (entryLabel $ mf $ CmmEntry $ g_entry g) $ mapMap (blockMapNodes3 funs) $ toBlockMap g
foldGraphBlocks :: (CmmBlock -> a -> a) -> a -> CmmGraph -> a
foldGraphBlocks k z g = mapFold k z $ toBlockMap g
postorderDfs :: CmmGraph -> [CmmBlock]
postorderDfs g = postorder_dfs_from (toBlockMap g) (g_entry g)
-------------------------------------------------
-- Manipulating CmmBlocks
lastNode :: CmmBlock -> CmmNode O C
lastNode block = foldBlockNodesF3 (nothing, nothing, const) block ()
where nothing :: a -> b -> ()
nothing _ _ = ()
replaceLastNode :: Block CmmNode e C -> CmmNode O C -> Block CmmNode e C
replaceLastNode block last = blockOfNodeList (first, middle, JustC last)
where (first, middle, _) = blockToNodeList block
----------------------------------------------------------------------
----- Splicing between blocks
-- Given a middle node, a block, and a successor BlockId,
-- 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)
data CmmStackInfo
= StackInfo {
arg_space :: ByteOff, -- XXX: comment?
updfr_space :: Maybe ByteOff -- XXX: comment?
}
-- | Info table as a haskell data type
data CmmInfoTable
= CmmInfoTable {
cit_lbl :: CLabel, -- Info table label
cit_rep :: SMRep,
cit_prof :: ProfilingInfo,
cit_srt :: C_SRT
}
| CmmNonInfoTable -- Procedure doesn't need an info table
data ProfilingInfo
= NoProfilingInfo
| ProfilingInfo [Word8] [Word8] -- closure_type, closure_desc
-- C_SRT is what StgSyn.SRT gets translated to...
-- we add a label for the table, and expect only the 'offset/length' form
data C_SRT = NoC_SRT
| C_SRT !CLabel !WordOff !StgHalfWord {-bitmap or escape-}
deriving (Eq)
needsSRT :: C_SRT -> Bool
needsSRT NoC_SRT = False
needsSRT (C_SRT _ _ _) = True
-----------------------------------------------------------------------------
-- Static Data
-----------------------------------------------------------------------------
data Section
= Text
| Data
| ReadOnlyData
| RelocatableReadOnlyData
| UninitialisedData
| ReadOnlyData16 -- .rodata.cst16 on x86_64, 16-byte aligned
| OtherSection String
data CmmStatic
= CmmStaticLit CmmLit
-- a literal value, size given by cmmLitRep of the literal.
| CmmUninitialised Int
-- uninitialised data, N bytes long
| CmmString [Word8]
-- string of 8-bit values only, not zero terminated.
data CmmStatics
= Statics
CLabel -- Label of statics
[CmmStatic] -- The static data itself
compiler/cmm/CmmBuildInfoTables.hs
View file @ 5b167f5e
......@@ -11,11 +11,16 @@ module CmmBuildInfoTables
, TopSRT, emptySRT, srtToData
, bundleCAFs
, lowerSafeForeignCalls
, cafTransfers, liveSlotTransfers)
, cafTransfers, liveSlotTransfers
, mkLiveness )
where
#include "HsVersions.h"
-- These should not be imported here!
import StgCmmForeign
import StgCmmUtils
import Constants
import Digraph
import qualified Prelude as P
......@@ -26,8 +31,7 @@ import BlockId
import Bitmap
import CLabel
import Cmm
import CmmDecl
import CmmExpr
import CmmUtils
import CmmStackLayout
import Module
import FastString
......@@ -41,9 +45,6 @@ import Name
import OptimizationFuel
import Outputable
import SMRep
import StgCmmClosure
import StgCmmForeign
import StgCmmUtils
import UniqSupply
import Compiler.Hoopl
......@@ -87,13 +88,14 @@ type RegSlotInfo
, LocalReg -- 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 =
-- pprTrace "live_ptrs for" (ppr bid <+> text (show oldByte ++ "-" ++ show youngByte) <+>
-- ppr liveSlots) $
-- pprTrace ("stack layout for " ++ show bid ++ ": ") (ppr res) $ res
res
where res = reverse $ slotsToList youngByte liveSlots []
where
res = mkLiveness (reverse $ slotsToList youngByte liveSlots [])
slotsToList :: Int -> [RegSlotInfo] -> [Maybe LocalReg] -> [Maybe LocalReg]
-- n starts at youngByte and is decremented down to oldByte
......@@ -160,8 +162,9 @@ live_ptrs oldByte slotEnv areaMap bid =
-- is not the successor of a call.
setInfoTableStackMap :: SlotEnv -> AreaMap -> CmmTop -> CmmTop
setInfoTableStackMap slotEnv areaMap
t@(CmmProc (TopInfo {stack_info=StackInfo {updfr_space = Just updfr_off}}) _ (CmmGraph {g_entry = eid})) =
updInfo (const (live_ptrs updfr_off slotEnv areaMap eid)) id t
t@(CmmProc (TopInfo {stack_info=StackInfo {updfr_space = Just updfr_off}}) _
(CmmGraph {g_entry = eid}))
= updInfo (const (live_ptrs updfr_off slotEnv areaMap eid)) id t
setInfoTableStackMap _ _ t = t
......@@ -237,8 +240,8 @@ addCAF caf srt =
, elt_map = Map.insert caf last (elt_map srt) }
where last = next_elt srt
srtToData :: TopSRT -> Cmm
srtToData srt = Cmm [CmmData RelocatableReadOnlyData (Statics (lbl srt) tbl)]
srtToData :: TopSRT -> CmmPgm
srtToData srt = [CmmData RelocatableReadOnlyData (Statics (lbl srt) tbl)]
where tbl = map (CmmStaticLit . CmmLabel) (reverse (rev_elts srt))
-- Once we have found the CAFs, we need to do two things:
......@@ -336,9 +339,10 @@ localCAFInfo :: CAFEnv -> CmmTop -> Maybe (CLabel, CAFSet)
localCAFInfo _ (CmmData _ _) = Nothing
localCAFInfo cafEnv (CmmProc top_info top_l (CmmGraph {g_entry=entry})) =
case info_tbl top_info of
CmmInfoTable _ False _ _ _ ->
Just (cvtToClosureLbl top_l,
expectJust "maybeBindCAFs" $ mapLookup entry cafEnv)
CmmInfoTable { cit_rep = rep }
| not (isStaticRep rep)
-> Just (cvtToClosureLbl top_l,
expectJust "maybeBindCAFs" $ mapLookup entry cafEnv)
_ -> Nothing
-- Once we have the local CAF sets for some (possibly) mutually
......@@ -368,8 +372,6 @@ mkTopCAFInfo localCAFs = foldl addToTop Map.empty g
g = stronglyConnCompFromEdgedVertices
(map (\n@(l, cafs) -> (n, l, Map.keys cafs)) localCAFs)
type StackLayout = [Maybe LocalReg]
-- Bundle the CAFs used at a procpoint.
bundleCAFs :: CAFEnv -> CmmTop -> (CAFSet, CmmTop)
bundleCAFs cafEnv t@(CmmProc _ _ (CmmGraph {g_entry=entry})) =
......@@ -391,20 +393,19 @@ setSRT cafs topCAFMap topSRT t =
Just tbl -> return (topSRT, [t', tbl])
Nothing -> return (topSRT, [t'])
type StackLayout = Liveness
updInfo :: (StackLayout -> StackLayout) -> (C_SRT -> C_SRT) -> CmmTop -> CmmTop
updInfo toVars toSrt (CmmProc top_info top_l g) =
CmmProc (top_info {info_tbl=updInfoTbl toVars toSrt (info_tbl top_info)}) top_l g
updInfo _ _ t = t
updInfoTbl :: (StackLayout -> StackLayout) -> (C_SRT -> C_SRT) -> CmmInfoTable -> CmmInfoTable
updInfoTbl toVars toSrt (CmmInfoTable l s p t typeinfo)
= CmmInfoTable l s p t typeinfo'
where typeinfo' = case typeinfo of
t@(ConstrInfo _ _ _) -> t
(FunInfo c s a d e) -> FunInfo c (toSrt s) a d e
(ThunkInfo c s) -> ThunkInfo c (toSrt s)
(ThunkSelectorInfo x s) -> ThunkSelectorInfo x (toSrt s)
(ContInfo v s) -> ContInfo (toVars v) (toSrt s)
updInfoTbl toVars toSrt info_tbl@(CmmInfoTable {})
= info_tbl { cit_srt = toSrt (cit_srt info_tbl)
, cit_rep = case cit_rep info_tbl of
StackRep ls -> StackRep (toVars ls)
other -> other }
updInfoTbl _ _ t@CmmNonInfoTable = t
----------------------------------------------------------------
......@@ -493,3 +494,4 @@ lowerSafeForeignCall entry areaMap blocks bid m
resume <**> saveRetVals <**> M.mkLast jump
return $ blocks `mapUnion` toBlockMap graph'
lowerSafeForeignCall _ _ _ _ _ _ = panic "lowerSafeForeignCall was passed something else"
compiler/cmm/CmmCommonBlockElim.hs
View file @ 5b167f5e
......@@ -11,7 +11,7 @@ where
import BlockId
import Cmm
import CmmExpr
import CmmUtils
import Prelude hiding (iterate, succ, unzip, zip)
import Compiler.Hoopl
......
compiler/cmm/CmmContFlowOpt.hs
View file @ 5b167f5e
......@@ -10,8 +10,7 @@ where
import BlockId
import Cmm
import CmmDecl
import CmmExpr
import CmmUtils
import qualified OldCmm as Old
import Maybes
......@@ -22,7 +21,7 @@ import Prelude hiding (succ, unzip, zip)
import Util
------------------------------------
runCmmContFlowOpts :: Cmm -> Cmm
runCmmContFlowOpts :: CmmPgm -> CmmPgm
runCmmContFlowOpts prog = runCmmOpts cmmCfgOpts prog
oldCmmCfgOpts :: Old.ListGraph Old.CmmStmt -> Old.ListGraph Old.CmmStmt
......@@ -34,18 +33,14 @@ cmmCfgOpts =
-- Here branchChainElim can ultimately be replaced
-- 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
runCmmOpts opt = mapProcs (optProc opt)
runCmmOpts opt = map (optProc opt)
optProc :: (g -> g) -> GenCmmTop d h g -> GenCmmTop d h g
optProc _ top@(CmmData {}) = top
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
-- If L is not captured in an instruction, we can remove any
......
compiler/cmm/CmmCvt.hs
View file @ 5b167f5e
......@@ -3,91 +3,25 @@
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
module CmmCvt
( cmmToZgraph, cmmOfZgraph )
( cmmOfZgraph )
where
import BlockId
import Cmm
import CmmDecl
import CmmExpr
import MkGraph
import CmmUtils
import qualified OldCmm as Old
import OldPprCmm ()
import Platform
import Compiler.Hoopl hiding ((<*>), mkLabel, mkBranch)
import Control.Monad
import Data.Maybe
import Maybes
import Outputable
import UniqSupply
cmmToZgraph :: Platform -> Old.Cmm -> UniqSM Cmm
cmmOfZgraph :: Cmm -> Old.Cmm
cmmToZgraph platform (Cmm tops) = liftM Cmm $ mapM mapTop tops
where mapTop (CmmProc (Old.CmmInfo _ _ info_tbl) 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
cmmOfZgraph :: CmmPgm -> Old.CmmPgm
cmmOfZgraph tops = 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 :: 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 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
return (StackInfo {arg_space = offset, updfr_space = Nothing}, g)
where addBlock (Old.BasicBlock id ss) g =
mkLabel id <*> mkStmts ss <*> g
updfr_sz = 0 -- panic "upd frame size lost in cmm conversion"
mkStmts (Old.CmmNop : ss) = mkNop <*> mkStmts ss
mkStmts (Old.CmmComment s : ss) = mkComment s <*> mkStmts ss
mkStmts (Old.CmmAssign l r : ss) = mkAssign l r <*> mkStmts ss
mkStmts (Old.CmmStore l r : ss) = mkStore l r <*> mkStmts ss
mkStmts (Old.CmmCall (Old.CmmCallee f conv) res args (Old.CmmSafe _) Old.CmmMayReturn : ss) =
mkCall f (conv', conv') (map Old.hintlessCmm res) (map Old.hintlessCmm args) updfr_sz
<*> mkStmts ss
where conv' = Foreign (ForeignConvention conv [] []) -- JD: DUBIOUS
mkStmts (Old.CmmCall (Old.CmmPrim {}) _ _ (Old.CmmSafe _) _ : _) =
panic "safe call to a primitive CmmPrim CallishMachOp"
mkStmts (Old.CmmCall f res args Old.CmmUnsafe Old.CmmMayReturn : ss) =
mkUnsafeCall (convert_target f res args)
(strip_hints res) (strip_hints args)
<*> mkStmts ss
mkStmts (Old.CmmCondBranch e l : fbranch) =
mkCmmIfThenElse e (mkBranch l) (mkStmts fbranch)
mkStmts (last : []) = mkLast last
mkStmts [] = bad "fell off end"
mkStmts (_ : _ : _) = bad "last node not at end"
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) =
panic "Call to CmmPrim never returns?!"
mkLast (Old.CmmSwitch scrutinee table) = mkSwitch scrutinee table
-- SURELY, THESE HINTLESS ARGS ARE WRONG AND WILL BE FIXED WHEN CALLING
-- CONVENTIONS ARE HONORED?
mkLast (Old.CmmJump tgt args) = mkJump tgt (map Old.hintlessCmm args) updfr_sz
mkLast (Old.CmmReturn ress) =
mkReturnSimple (map Old.hintlessCmm ress) updfr_sz
mkLast (Old.CmmBranch tgt) = mkBranch tgt
mkLast (Old.CmmCall _f (_:_) _args _ Old.CmmNeverReturns) =
panic "Call never returns but has results?!"
mkLast _ = panic "fell off end of block"
strip_hints :: [Old.CmmHinted a] -> [a]
strip_hints = map Old.hintlessCmm