Skip to content

GitLab

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

Snapshot of codegen refactoring to share with simonpj

parent 3108accd
Expand all Hide whitespace changes
Inline Side-by-side
Showing with 1541 additions and 1979 deletions
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
convert_target :: Old.CmmCallTarget -> [Old.HintedCmmFormal] -> [Old.HintedCmmActual] -> ForeignTarget
convert_target (Old.CmmCallee e cc) ress args = ForeignTarget e (ForeignConvention cc (map Old.cmmHint args) (map Old.cmmHint ress))
convert_target (Old.CmmPrim op) _ress _args = PrimTarget op
data ValueDirection = Arguments | Results