Commit f96e9aa0 authored by Michael D. Adams's avatar Michael D. Adams

First pass at implementing info tables for CPS

This is a fairly complete implementation, however
two 'panic's have been placed in the critical path
where the implementation is still a bit lacking so
do not expect it to run quite yet.

One call to panic is because we still need to create
a GC block for procedures that don't have them yet.
(cmm/CmmCPS.hs:continuationToProc)

The other is due to the need to convert from a
ContinuationInfo to a CmmInfo.
(codeGen/CgInfoTbls.hs:emitClosureCodeAndInfoTable)
(codeGen/CgInfoTbls.hs:emitReturnTarget)
parent affbe8da
......@@ -213,6 +213,9 @@ data CLabel
| LargeSRTLabel -- Label of an StgLargeSRT
{-# UNPACK #-} !Unique
| LargeBitmapLabel -- A bitmap (function or case return)
{-# UNPACK #-} !Unique
deriving (Eq, Ord)
data IdLabelInfo
......@@ -225,8 +228,6 @@ data IdLabelInfo
| RednCounts -- Label of place to keep Ticky-ticky info for
-- this Id
| Bitmap -- A bitmap (function or case return)
| ConEntry -- constructor entry point
| ConInfoTable -- corresponding info table
| StaticConEntry -- static constructor entry point
......@@ -290,7 +291,6 @@ data DynamicLinkerLabelInfo
-- These are always local:
mkSRTLabel name = IdLabel name SRT
mkSlowEntryLabel name = IdLabel name Slow
mkBitmapLabel name = IdLabel name Bitmap
mkRednCountsLabel name = IdLabel name RednCounts
-- These have local & (possibly) external variants:
......@@ -335,6 +335,7 @@ mkStaticConEntryLabel this_pkg name
| otherwise = IdLabel name StaticConEntry
mkLargeSRTLabel uniq = LargeSRTLabel uniq
mkBitmapLabel uniq = LargeBitmapLabel uniq
mkReturnPtLabel uniq = CaseLabel uniq CaseReturnPt
mkReturnInfoLabel uniq = CaseLabel uniq CaseReturnInfo
......@@ -470,7 +471,7 @@ needsCDecl :: CLabel -> Bool
-- they are defined before use.
needsCDecl (IdLabel _ SRT) = False
needsCDecl (LargeSRTLabel _) = False
needsCDecl (IdLabel _ Bitmap) = False
needsCDecl (LargeBitmapLabel _) = False
needsCDecl (IdLabel _ _) = True
needsCDecl (DynIdLabel _ _) = True
needsCDecl (CaseLabel _ _) = True
......@@ -550,6 +551,8 @@ labelType (CaseLabel _ CaseReturnInfo) = DataLabel
labelType (CaseLabel _ _) = CodeLabel
labelType (ModuleInitLabel _ _ _) = CodeLabel
labelType (PlainModuleInitLabel _ _) = CodeLabel
labelType (LargeSRTLabel _) = DataLabel
labelType (LargeBitmapLabel _) = DataLabel
labelType (IdLabel _ info) = idInfoLabelType info
labelType (DynIdLabel _ info) = idInfoLabelType info
......@@ -559,7 +562,6 @@ idInfoLabelType info =
case info of
InfoTable -> DataLabel
Closure -> DataLabel
Bitmap -> DataLabel
ConInfoTable -> DataLabel
StaticInfoTable -> DataLabel
ClosureTable -> DataLabel
......@@ -700,6 +702,7 @@ pprCLbl (CaseLabel u CaseDefault)
= hcat [pprUnique u, ptext SLIT("_dflt")]
pprCLbl (LargeSRTLabel u) = pprUnique u <> pp_cSEP <> ptext SLIT("srtd")
pprCLbl (LargeBitmapLabel u) = pprUnique u <> pp_cSEP <> ptext SLIT("btm")
pprCLbl (RtsLabel (RtsCode str)) = ptext str
pprCLbl (RtsLabel (RtsData str)) = ptext str
......@@ -799,7 +802,6 @@ ppIdFlavor x = pp_cSEP <>
Entry -> ptext SLIT("entry")
Slow -> ptext SLIT("slow")
RednCounts -> ptext SLIT("ct")
Bitmap -> ptext SLIT("btm")
ConEntry -> ptext SLIT("con_entry")
ConInfoTable -> ptext SLIT("con_info")
StaticConEntry -> ptext SLIT("static_entry")
......
......@@ -7,8 +7,9 @@
-----------------------------------------------------------------------------
module Cmm (
GenCmm(..), Cmm,
GenCmmTop(..), CmmTop,
GenCmm(..), Cmm, RawCmm,
GenCmmTop(..), CmmTop, RawCmmTop,
CmmInfo(..), ClosureTypeInfo(..), ProfilingInfo(..),
GenBasicBlock(..), CmmBasicBlock, blockId, blockStmts,
CmmStmt(..), CmmActuals, CmmFormal, CmmFormals, CmmHintFormals,
CmmCallTarget(..),
......@@ -16,7 +17,7 @@ module Cmm (
CmmExpr(..), cmmExprRep,
CmmReg(..), cmmRegRep,
CmmLit(..), cmmLitRep,
LocalReg(..), localRegRep, Kind(..),
LocalReg(..), localRegRep, localRegGCFollow, Kind(..),
BlockId(..), BlockEnv,
GlobalReg(..), globalRegRep,
......@@ -28,6 +29,7 @@ module Cmm (
import MachOp
import CLabel
import ForeignCall
import SMRep
import ClosureInfo
import Unique
import UniqFM
......@@ -49,15 +51,19 @@ import Data.Word
-- (a) Plain C--, i.e. populated with CmmLit and CmmExpr respectively,
-- (b) Native code, populated with instructions
--
newtype GenCmm d i = Cmm [GenCmmTop d i]
newtype GenCmm d h i = Cmm [GenCmmTop d h i]
type Cmm = GenCmm CmmStatic CmmStmt
-- | Cmm with the info table as a data type
type Cmm = GenCmm CmmStatic CmmInfo CmmStmt
-- | Cmm with the info tables converted to a list of 'CmmStatic'
type RawCmm = GenCmm CmmStatic [CmmStatic] CmmStmt
-- 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 i
data GenCmmTop d h i
= CmmProc
[d] -- Info table, may be empty
h -- Extra header such as the info table
CLabel -- Used to generate both info & entry labels
CmmFormals -- Argument locals live on entry (C-- procedure params)
[GenBasicBlock i] -- Code, may be empty. The first block is
......@@ -72,7 +78,8 @@ data GenCmmTop d i
-- some static data.
| CmmData Section [d] -- constant values only
type CmmTop = GenCmmTop CmmStatic CmmStmt
type CmmTop = GenCmmTop CmmStatic CmmInfo CmmStmt
type RawCmmTop = GenCmmTop CmmStatic [CmmStatic] CmmStmt
-- A basic block containing a single label, at the beginning.
-- The list of basic blocks in a top-level code block may be re-ordered.
......@@ -96,6 +103,36 @@ blockId (BasicBlock blk_id _ ) = blk_id
blockStmts :: GenBasicBlock i -> [i]
blockStmts (BasicBlock _ stmts) = stmts
-----------------------------------------------------------------------------
-- Info Tables
-----------------------------------------------------------------------------
-- Info table as a haskell data type
data CmmInfo
= CmmInfo
ProfilingInfo
(Maybe BlockId) -- GC target
ClosureTypeTag -- Int
ClosureTypeInfo
| CmmNonInfo -- Procedure doesn't need an info table
data ClosureTypeInfo
= ConstrInfo ClosureLayout ConstrTag ConstrDescription
| FunInfo ClosureLayout C_SRT FunType FunArity ArgDescr SlowEntry
| ThunkInfo ClosureLayout C_SRT
| ContInfo
[Maybe LocalReg] -- Forced stack parameters
C_SRT
-- TODO: These types may need refinement
data ProfilingInfo = ProfilingInfo CmmLit CmmLit -- closure_type, closure_desc
type ClosureTypeTag = StgHalfWord
type ClosureLayout = (StgHalfWord, StgHalfWord) -- pts, nptrs
type ConstrTag = StgHalfWord
type ConstrDescription = CLabel
type FunType = StgHalfWord
type FunArity = StgHalfWord
type SlowEntry = CLabel
-----------------------------------------------------------------------------
-- CmmStmt
......
......@@ -37,7 +37,7 @@ data BrokenBlock
brokenBlockTargets :: [BlockId],
-- ^ Blocks that this block could
-- branch to one either by conditional
-- branch to either by conditional
-- branches or via the last statement
brokenBlockExit :: FinalStmt
......@@ -47,6 +47,7 @@ data BrokenBlock
-- | How a block could be entered
data BlockEntryInfo
= FunctionEntry -- ^ Block is the beginning of a function
CmmInfo -- ^ Function header info
CLabel -- ^ The function name
CmmFormals -- ^ Aguments to function
......
This diff is collapsed.
......@@ -25,10 +25,10 @@ import Control.Monad
-- -----------------------------------------------------------------------------
-- Exported entry points:
cmmLint :: Cmm -> Maybe SDoc
cmmLint :: GenCmm d h CmmStmt -> Maybe SDoc
cmmLint (Cmm tops) = runCmmLint $ mapM_ lintCmmTop tops
cmmLintTop :: CmmTop -> Maybe SDoc
cmmLintTop :: GenCmmTop d h CmmStmt -> Maybe SDoc
cmmLintTop top = runCmmLint $ lintCmmTop top
runCmmLint :: CmmLint a -> Maybe SDoc
......@@ -37,7 +37,7 @@ runCmmLint l =
Left err -> Just (ptext SLIT("Cmm lint error:") $$ nest 2 err)
Right _ -> Nothing
lintCmmTop (CmmProc _info lbl _args blocks)
lintCmmTop (CmmProc _ lbl _ blocks)
= addLintInfo (text "in proc " <> pprCLabel lbl) $
mapM_ lintCmmBlock blocks
lintCmmTop _other
......
......@@ -531,7 +531,7 @@ narrowS _ _ = panic "narrowTo"
except factorial, but what the hell.
-}
cmmLoopifyForC :: CmmTop -> CmmTop
cmmLoopifyForC :: RawCmmTop -> RawCmmTop
cmmLoopifyForC p@(CmmProc info entry_lbl [] blocks@(BasicBlock top_id _ : _))
| null info = p -- only if there's an info table, ignore case alts
| otherwise =
......
......@@ -199,23 +199,24 @@ lits :: { [ExtFCode CmmExpr] }
| ',' expr lits { $2 : $3 }
cmmproc :: { ExtCode }
: info maybe_formals '{' body '}'
{ do (info_lbl, info1, info2) <- $1;
formals <- sequence $2;
stmts <- getCgStmtsEC (loopDecls $4)
blks <- code (cgStmtsToBlocks stmts)
code (emitInfoTableAndCode info_lbl info1 info2 formals blks) }
| info maybe_formals ';'
{ do (info_lbl, info1, info2) <- $1;
formals <- sequence $2;
code (emitInfoTableAndCode info_lbl info1 info2 formals []) }
| NAME maybe_formals '{' body '}'
-- TODO: add real SRT/info tables to parsed Cmm
-- : info maybe_formals '{' body '}'
-- { do (info_lbl, info1, info2) <- $1;
-- formals <- sequence $2;
-- stmts <- getCgStmtsEC (loopDecls $4)
-- blks <- code (cgStmtsToBlocks stmts)
-- code (emitInfoTableAndCode info_lbl info1 info2 formals blks) }
--
-- | info maybe_formals ';'
-- { do (info_lbl, info1, info2) <- $1;
-- formals <- sequence $2;
-- code (emitInfoTableAndCode info_lbl info1 info2 formals []) }
: NAME maybe_formals '{' body '}'
{ do formals <- sequence $2;
stmts <- getCgStmtsEC (loopDecls $4);
blks <- code (cgStmtsToBlocks stmts);
code (emitProc [] (mkRtsCodeLabelFS $1) formals blks) }
code (emitProc CmmNonInfo (mkRtsCodeLabelFS $1) formals blks) }
info :: { ExtFCode (CLabel, [CmmLit],[CmmLit]) }
: 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
......@@ -261,13 +262,17 @@ stmt :: { ExtCode }
| NAME ':'
{ do l <- newLabel $1; code (labelC l) }
-- HACK: this should just be lregs but that causes a shift/reduce conflict
-- with foreign calls
-- | hint_lregs '=' expr ';'
-- { do reg <- head $1; e <- $3; stmtEC (CmmAssign (fst reg) e) }
| lreg '=' expr ';'
{ do reg <- $1; e <- $3; stmtEC (CmmAssign reg e) }
| type '[' expr ']' '=' expr ';'
{ doStore $1 $3 $6 }
-- TODO: add real SRT to parsed Cmm
-- Gah! We really want to say "maybe_results" but that causes
-- a shift/reduce conflict with assignment. We either
-- we expand out the no-result and single result cases or
-- we tweak the syntax to avoid the conflict. The later
-- option is taken here because the other way would require
-- multiple levels of expanding and get unwieldy.
| maybe_results 'foreign' STRING expr '(' hint_exprs0 ')' vols ';'
{% foreignCall $3 $1 $4 $6 $8 NoC_SRT }
| maybe_results 'prim' '%' NAME '(' hint_exprs0 ')' vols ';'
......@@ -407,15 +412,11 @@ reg :: { ExtFCode CmmExpr }
maybe_results :: { [ExtFCode (CmmFormal, MachHint)] }
: {- empty -} { [] }
| hint_lregs '=' { $1 }
hint_lregs0 :: { [ExtFCode (CmmFormal, MachHint)] }
: {- empty -} { [] }
| hint_lregs { $1 }
| '(' hint_lregs ')' '=' { $2 }
hint_lregs :: { [ExtFCode (CmmFormal, MachHint)] }
: hint_lreg ',' { [$1] }
| hint_lreg { [$1] }
: hint_lreg { [$1] }
| hint_lreg ',' { [$1] }
| hint_lreg ',' hint_lregs { $1 : $3 }
hint_lreg :: { ExtFCode (CmmFormal, MachHint) }
......
......@@ -45,7 +45,7 @@ calculateProcPoints blocks = calculateProcPoints' init_proc_points blocks
map brokenBlockId $
filter always_proc_point blocks
always_proc_point BrokenBlock {
brokenBlockEntry = FunctionEntry _ _ } = True
brokenBlockEntry = FunctionEntry _ _ _ } = True
always_proc_point BrokenBlock {
brokenBlockEntry = ContinuationEntry _ _ } = True
always_proc_point _ = False
......
......@@ -66,7 +66,7 @@ import StaticFlags ( opt_Unregisterised )
-- --------------------------------------------------------------------------
-- Top level
pprCs :: DynFlags -> [Cmm] -> SDoc
pprCs :: DynFlags -> [RawCmm] -> SDoc
pprCs dflags cmms
= pprCode CStyle (vcat $ map (\c -> split_marker $$ pprC c) cmms)
where
......@@ -74,7 +74,7 @@ pprCs dflags cmms
| dopt Opt_SplitObjs dflags = ptext SLIT("__STG_SPLIT_MARKER")
| otherwise = empty
writeCs :: DynFlags -> Handle -> [Cmm] -> IO ()
writeCs :: DynFlags -> Handle -> [RawCmm] -> IO ()
writeCs dflags handle cmms
= printForC handle (pprCs dflags cmms)
......@@ -84,13 +84,13 @@ writeCs dflags handle cmms
-- for fun, we could call cmmToCmm over the tops...
--
pprC :: Cmm -> SDoc
pprC :: RawCmm -> SDoc
pprC (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops
--
-- top level procs
--
pprTop :: CmmTop -> SDoc
pprTop :: RawCmmTop -> SDoc
pprTop (CmmProc info clbl _params blocks) =
(if not (null info)
then pprDataExterns info $$
......
......@@ -52,7 +52,7 @@ import Data.List
import System.IO
import Data.Maybe
pprCmms :: [Cmm] -> SDoc
pprCmms :: (Outputable info) => [GenCmm CmmStatic info CmmStmt] -> SDoc
pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms))
where
separator = space $$ ptext SLIT("-------------------") $$ space
......@@ -62,10 +62,10 @@ writeCmms handle cmms = printForC handle (pprCmms cmms)
-----------------------------------------------------------------------------
instance Outputable Cmm where
instance (Outputable info) => Outputable (GenCmm CmmStatic info CmmStmt) where
ppr c = pprCmm c
instance Outputable CmmTop where
instance (Outputable info) => Outputable (GenCmmTop CmmStatic info CmmStmt) where
ppr t = pprTop t
instance Outputable CmmBasicBlock where
......@@ -86,31 +86,28 @@ instance Outputable LocalReg where
instance Outputable GlobalReg where
ppr e = pprGlobalReg e
instance Outputable CmmStatic where
ppr e = pprStatic e
instance Outputable CmmInfo where
ppr e = pprInfo e
-----------------------------------------------------------------------------
pprCmm :: Cmm -> SDoc
pprCmm :: (Outputable info) => GenCmm CmmStatic info CmmStmt -> SDoc
pprCmm (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops
-- --------------------------------------------------------------------------
-- Top level `procedure' blocks. The info tables, if not null, are
-- printed in the style of C--'s 'stackdata' declaration, just inside
-- the proc body, and are labelled with the procedure name ++ "_info".
-- Top level `procedure' blocks.
--
pprTop :: CmmTop -> SDoc
pprTop :: (Outputable info) => GenCmmTop CmmStatic info CmmStmt -> SDoc
pprTop (CmmProc info lbl params blocks )
= vcat [ pprCLabel lbl <> parens (commafy $ map ppr params) <+> lbrace
, nest 8 $ pprInfo info lbl
, nest 8 $ lbrace <+> ppr info $$ rbrace
, nest 4 $ vcat (map ppr blocks)
, rbrace ]
where
pprInfo [] _ = empty
pprInfo i label =
(hang (pprCLabel (entryLblToInfoLbl label) <+> lbrace )
4 $ vcat (map pprStatic i))
$$ rbrace
-- --------------------------------------------------------------------------
-- We follow [1], 4.5
--
......@@ -121,6 +118,46 @@ pprTop (CmmData section ds) =
$$ rbrace
-- --------------------------------------------------------------------------
-- Info tables. The current pretty printer needs refinement
-- but will work for now.
--
-- For ideas on how to refine it, they used to be printed in the
-- style of C--'s 'stackdata' declaration, just inside the proc body,
-- and were labelled with the procedure name ++ "_info".
pprInfo CmmNonInfo = empty
pprInfo (CmmInfo (ProfilingInfo closure_type closure_desc)
gc_target tag info) =
vcat [ptext SLIT("type: ") <> pprLit closure_type,
ptext SLIT("desc: ") <> pprLit closure_desc,
ptext SLIT("gc_target: ") <>
maybe (ptext SLIT("<none>")) pprBlockId gc_target,
ptext SLIT("tag: ") <> integer (toInteger tag),
pprTypeInfo info]
pprTypeInfo (ConstrInfo layout constr descr) =
vcat [ptext SLIT("ptrs: ") <> integer (toInteger (fst layout)),
ptext SLIT("nptrs: ") <> integer (toInteger (snd layout)),
ptext SLIT("constructor: ") <> integer (toInteger constr),
ppr descr]
pprTypeInfo (FunInfo layout srt fun_type arity args slow_entry) =
vcat [ptext SLIT("ptrs: ") <> integer (toInteger (fst layout)),
ptext SLIT("nptrs: ") <> integer (toInteger (snd layout)),
ptext SLIT("srt: ") <> ppr srt,
ptext SLIT("fun_type: ") <> integer (toInteger fun_type),
ptext SLIT("arity: ") <> integer (toInteger arity)
--ppr args, -- TODO: needs to be printed
--ppr slow_entry -- TODO: needs to be printed
]
pprTypeInfo (ThunkInfo layout srt) =
vcat [ptext SLIT("ptrs: ") <> integer (toInteger (fst layout)),
ptext SLIT("nptrs: ") <> integer (toInteger (snd layout)),
ptext SLIT("srt: ") <> ppr srt]
pprTypeInfo (ContInfo stack srt) =
vcat [ptext SLIT("stack: ") <> ppr stack,
ptext SLIT("srt: ") <> ppr srt]
-- --------------------------------------------------------------------------
-- Basic blocks look like assembly blocks.
-- lbl: stmt ; stmt ; ..
......@@ -151,12 +188,13 @@ pprStmt stmt = case stmt of
-- call "ccall" foo(x, y)[r1, r2];
-- ToDo ppr volatile
CmmCall (CmmForeignCall fn cconv) results args srt ->
hcat [ ptext SLIT("call"), space,
hcat [ if null results
then empty
else parens (commafy $ map ppr results) <>
ptext SLIT(" = "),
ptext SLIT("call"), space,
doubleQuotes(ppr cconv), space,
target fn, parens ( commafy $ map ppr args ),
(if null results
then empty
else brackets( commafy $ map ppr results)),
brackets (ppr srt), semi ]
where
target (CmmLit lit) = pprLit lit
......
......@@ -51,6 +51,7 @@ import Util
import StaticFlags
import FastString
import Outputable
import Unique
import Data.Bits
......@@ -135,7 +136,7 @@ stdPattern other = Nothing
mkLiveness :: Name -> Int -> Bitmap -> FCode Liveness
mkLiveness name size bits
| size > mAX_SMALL_BITMAP_SIZE -- Bitmap does not fit in one word
= do { let lbl = mkBitmapLabel name
= do { let lbl = mkBitmapLabel (getUnique name)
; emitRODataLits lbl ( mkWordCLit (fromIntegral size)
: map mkWordCLit bits)
; return (BigLiveness lbl) }
......
......@@ -45,6 +45,7 @@ import StaticFlags
import Maybes
import Constants
import Panic
-------------------------------------------------------------------------
--
......@@ -92,7 +93,7 @@ emitClosureCodeAndInfoTable cl_info args body
return (makeRelativeRefTo info_lbl cstr)
else return (mkIntCLit 0)
; emitInfoTableAndCode info_lbl std_info (extra_bits conName) args blks }
; panic "emitClosureCodeAndInfoTable" } --emitInfoTableAndCode info_lbl std_info (extra_bits conName) args blks }
where
info_lbl = infoTableLabelFromCI cl_info
......@@ -200,7 +201,7 @@ emitReturnTarget name stmts
mkRetInfoTable info_lbl liveness srt_info cl_type
; blks <- cgStmtsToBlocks stmts
; emitInfoTableAndCode info_lbl std_info extra_bits args blks
; panic "emitReturnTarget" --emitInfoTableAndCode info_lbl std_info extra_bits args blks
; return info_lbl }
where
args = {- trace "emitReturnTarget: missing args" -} []
......@@ -212,7 +213,7 @@ mkRetInfoTable
:: CLabel -- info label
-> Liveness -- liveness
-> C_SRT -- SRT Info
-> Int -- type (eg. rET_SMALL)
-> StgHalfWord -- type (eg. rET_SMALL)
-> ([CmmLit],[CmmLit])
mkRetInfoTable info_lbl liveness srt_info cl_type
= (std_info, srt_slot)
......@@ -264,7 +265,7 @@ emitReturnInstr
mkStdInfoTable
:: CmmLit -- closure type descr (profiling)
-> CmmLit -- closure descr (profiling)
-> Int -- closure type
-> StgHalfWord -- closure type
-> StgHalfWord -- SRT length
-> CmmLit -- layout field
-> [CmmLit]
......@@ -389,6 +390,19 @@ funInfoTable info_ptr
-- The complication here concerns whether or not we can
-- put the info table next to the code
emitInfoTableAndCode
:: CLabel -- Label of info table
-> CmmInfo -- ...the info table
-> CmmFormals -- ...args
-> [CmmBasicBlock] -- ...and body
-> Code
emitInfoTableAndCode info_lbl info args blocks
= emitProc info entry_lbl args blocks
where
entry_lbl = infoLblToEntryLbl info_lbl
{-
emitInfoTableAndCode
:: CLabel -- Label of info table
-> [CmmLit] -- ...its invariant part
......@@ -415,6 +429,7 @@ emitInfoTableAndCode info_lbl std_info extra_bits args blocks
where
entry_lbl = infoLblToEntryLbl info_lbl
-}
-------------------------------------------------------------------------
--
......
......@@ -734,9 +734,9 @@ emitData sect lits
where
data_block = CmmData sect lits
emitProc :: [CmmLit] -> CLabel -> CmmFormals -> [CmmBasicBlock] -> Code
emitProc lits lbl args blocks
= do { let proc_block = CmmProc (map CmmStaticLit lits) lbl args blocks
emitProc :: CmmInfo -> CLabel -> CmmFormals -> [CmmBasicBlock] -> Code
emitProc info lbl args blocks
= do { let proc_block = CmmProc info lbl args blocks
; state <- getState
; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
......@@ -745,7 +745,7 @@ emitSimpleProc :: CLabel -> Code -> Code
emitSimpleProc lbl code
= do { stmts <- getCgStmts code
; blks <- cgStmtsToBlocks stmts
; emitProc [] lbl [] blks }
; emitProc CmmNonInfo lbl [] blks }
getCmm :: Code -> FCode Cmm
-- Get all the CmmTops (there should be no stmts)
......
......@@ -9,7 +9,9 @@
module CgUtils (
addIdReps,
cgLit,
emitDataLits, emitRODataLits, emitIf, emitIfThenElse,
emitDataLits, mkDataLits,
emitRODataLits, mkRODataLits,
emitIf, emitIfThenElse,
emitRtsCall, emitRtsCallWithVols, emitRtsCallWithResult,
assignNonPtrTemp, newNonPtrTemp,
assignPtrTemp, newPtrTemp,
......@@ -309,6 +311,11 @@ emitDataLits :: CLabel -> [CmmLit] -> Code
emitDataLits lbl lits
= emitData Data (CmmDataLabel lbl : map CmmStaticLit lits)
mkDataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info stmt
-- Emit a data-segment data block
mkDataLits lbl lits
= CmmData Data (CmmDataLabel lbl : map CmmStaticLit lits)
emitRODataLits :: CLabel -> [CmmLit] -> Code
-- Emit a read-only data block
emitRODataLits lbl lits
......@@ -319,6 +326,15 @@ emitRODataLits lbl lits
needsRelocation (CmmLabelOff _ _) = True
needsRelocation _ = False
mkRODataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info stmt
mkRODataLits lbl lits
= CmmData section (CmmDataLabel lbl : map CmmStaticLit lits)
where section | any needsRelocation lits = RelocatableReadOnlyData
| otherwise = ReadOnlyData
needsRelocation (CmmLabel _) = True
needsRelocation (CmmLabelOff _ _) = True
needsRelocation _ = False
mkStringCLit :: String -> FCode CmmLit
-- Make a global definition for the string,
-- and return its label
......
......@@ -304,7 +304,7 @@ smRepClosureType :: SMRep -> Maybe ClosureType
smRepClosureType (GenericRep _ _ _ ty) = Just ty
smRepClosureType BlackHoleRep = Nothing
smRepClosureTypeInt :: SMRep -> Int
smRepClosureTypeInt :: SMRep -> StgHalfWord
smRepClosureTypeInt (GenericRep False 1 0 Constr) = CONSTR_1_0
smRepClosureTypeInt (GenericRep False 0 1 Constr) = CONSTR_0_1
smRepClosureTypeInt (GenericRep False 2 0 Constr) = CONSTR_2_0
......@@ -339,7 +339,7 @@ smRepClosureTypeInt rep = panic "smRepClosuretypeint"
-- We export these ones
rET_SMALL = (RET_SMALL :: Int)
rET_BIG = (RET_BIG :: Int)
rET_SMALL = (RET_SMALL :: StgHalfWord)
rET_BIG = (RET_BIG :: StgHalfWord)
\end{code}
......@@ -26,7 +26,7 @@ import Packages
import PackageConfig ( rtsPackageId )
import Util
import FastString ( unpackFS )
import Cmm ( Cmm )
import Cmm ( RawCmm )
import HscTypes
import DynFlags
......@@ -55,7 +55,7 @@ codeOutput :: DynFlags
-> ModLocation
-> ForeignStubs
-> [PackageId]
-> [Cmm] -- Compiled C--
-> [RawCmm] -- Compiled C--
-> IO (Bool{-stub_h_exists-}, Bool{-stub_c_exists-})
codeOutput dflags this_mod location foreign_stubs pkg_deps flat_abstractC
......
......@@ -605,7 +605,7 @@ hscCompile cgguts
foreign_stubs dir_imps cost_centre_info
stg_binds hpc_info
------------------ Convert to CPS --------------------
continuationC <- cmmCPS dflags abstractC
continuationC <- {-return abstractC-} cmmCPS dflags abstractC
------------------ Code output -----------------------
(stub_h_exists,stub_c_exists)
<- codeOutput dflags this_mod location foreign_stubs
......@@ -721,7 +721,7 @@ hscCmmFile dflags filename = do
case maybe_cmm of
Nothing -> return False
Just cmm -> do
continuationC <- cmmCPS dflags [cmm]
continuationC <- {-return [cmm]-} cmmCPS dflags [cmm]
codeOutput dflags no_mod no_loc NoStubs [] continuationC
return True
where
......
......@@ -108,12 +108,12 @@ The machine-dependent bits break down as follows:
-- NB. We *lazilly* compile each block of code for space reasons.
nativeCodeGen :: DynFlags -> [Cmm] -> UniqSupply -> IO Pretty.Doc
nativeCodeGen :: DynFlags -> [RawCmm] -> UniqSupply -> IO Pretty.Doc
nativeCodeGen dflags cmms us
= let (res, _) = initUs us $
cgCmm (concat (map add_split cmms))
cgCmm :: [CmmTop] -> UniqSM (Cmm, Pretty.Doc, [CLabel])
cgCmm :: [RawCmmTop] -> UniqSM (RawCmm, Pretty.Doc, [CLabel])
cgCmm tops =
lazyMapUs (cmmNativeGen dflags) tops `thenUs` \ results ->
case unzip3 results of { (cmms,docs,imps) ->
......@@ -196,7 +196,7 @@ nativeCodeGen dflags cmms us
-- Complete native code generation phase for a single top-level chunk
-- of Cmm.
cmmNativeGen :: DynFlags -> CmmTop -> UniqSM (CmmTop, Pretty.Doc, [CLabel])
cmmNativeGen :: DynFlags -> RawCmmTop -> UniqSM (RawCmmTop, Pretty.Doc, [CLabel])
cmmNativeGen dflags cmm
= {-# SCC "fixAssigns" #-}
fixAssignsTop cmm `thenUs` \ fixed_cmm ->
......@@ -390,7 +390,7 @@ apply_mapping ufm (CmmProc info lbl params blocks)
-- Switching between the two monads whilst carrying along the same
-- Unique supply breaks abstraction. Is that bad?
genMachCode :: CmmTop -> UniqSM ([NatCmmTop], [CLabel])
genMachCode :: RawCmmTop -> UniqSM ([NatCmmTop], [CLabel])
genMachCode cmm_top
= do { initial_us <- getUs
......@@ -412,7 +412,7 @@ genMachCode cmm_top
-- the generic optimiser below, to avoid having two separate passes
-- over the Cmm.
fixAssignsTop :: CmmTop -> UniqSM CmmTop
fixAssignsTop :: RawCmmTop -> UniqSM RawCmmTop
fixAssignsTop top@(CmmData _ _) = returnUs top
fixAssignsTop (CmmProc info lbl params blocks) =
mapUs fixAssignsBlock blocks `thenUs` \ blocks' ->
......@@ -490,7 +490,7 @@ Ideas for other things we could do (ToDo):
temp assignments, and certain assigns to mem...)
-}
cmmToCmm :: CmmTop -> (CmmTop, [CLabel])
cmmToCmm :: RawCmmTop -> (RawCmmTop, [CLabel])
cmmToCmm top@(CmmData _ _) = (top, [])
cmmToCmm (CmmProc info lbl params blocks) = runCmmOpt $ do
blocks' <- mapM cmmBlockConFold (cmmMiniInline blocks)
......
......@@ -62,7 +62,7 @@ import Data.Int
type InstrBlock = OrdList Instr