mkSelectorInfoLabel,
mkSelectorEntryLabel,
- mkRtsInfoLabel,
- mkRtsEntryLabel,
- mkRtsRetInfoLabel,
- mkRtsRetLabel,
- mkRtsCodeLabel,
- mkRtsDataLabel,
- mkRtsGcPtrLabel,
+ mkCmmInfoLabel,
+ mkCmmEntryLabel,
+ mkCmmRetInfoLabel,
+ mkCmmRetLabel,
+ mkCmmCodeLabel,
+ mkCmmDataLabel,
+ mkCmmGcPtrLabel,
mkRtsApFastLabel,
-- | A label from a .cmm file that is not associated with a .hs level Id.
| CmmLabel
- Module -- what Cmm source module the label belongs to
+ PackageId -- what package the label belongs to.
FastString -- identifier giving the prefix of the label
CmmLabelInfo -- encodes the suffix of the label
mkConEntryLabel name c = IdLabel name c ConEntry
mkStaticConEntryLabel name c = IdLabel name c StaticConEntry
-
-- Constructing Cmm Labels
-
--- | Pretend that wired-in names from the RTS are in a top-level module called RTS,
--- located in the RTS package. It doesn't matter what module they're actually in
--- as long as that module is in the correct package.
-topRtsModule :: Module
-topRtsModule = mkModule rtsPackageId (mkModuleNameFS (fsLit "RTS"))
-
-mkSplitMarkerLabel = CmmLabel topRtsModule (fsLit "__stg_split_marker") CmmCode
-mkDirty_MUT_VAR_Label = CmmLabel topRtsModule (fsLit "dirty_MUT_VAR") CmmCode
-mkUpdInfoLabel = CmmLabel topRtsModule (fsLit "stg_upd_frame") CmmInfo
-mkIndStaticInfoLabel = CmmLabel topRtsModule (fsLit "stg_IND_STATIC") CmmInfo
-mkMainCapabilityLabel = CmmLabel topRtsModule (fsLit "MainCapability") CmmData
-mkMAP_FROZEN_infoLabel = CmmLabel topRtsModule (fsLit "stg_MUT_ARR_PTRS_FROZEN0") CmmInfo
-mkMAP_DIRTY_infoLabel = CmmLabel topRtsModule (fsLit "stg_MUT_ARR_PTRS_DIRTY") CmmInfo
-mkEMPTY_MVAR_infoLabel = CmmLabel topRtsModule (fsLit "stg_EMPTY_MVAR") CmmInfo
-mkTopTickyCtrLabel = CmmLabel topRtsModule (fsLit "top_ct") CmmData
-mkCAFBlackHoleInfoTableLabel = CmmLabel topRtsModule (fsLit "stg_CAF_BLACKHOLE") CmmInfo
+mkSplitMarkerLabel = CmmLabel rtsPackageId (fsLit "__stg_split_marker") CmmCode
+mkDirty_MUT_VAR_Label = CmmLabel rtsPackageId (fsLit "dirty_MUT_VAR") CmmCode
+mkUpdInfoLabel = CmmLabel rtsPackageId (fsLit "stg_upd_frame") CmmInfo
+mkIndStaticInfoLabel = CmmLabel rtsPackageId (fsLit "stg_IND_STATIC") CmmInfo
+mkMainCapabilityLabel = CmmLabel rtsPackageId (fsLit "MainCapability") CmmData
+mkMAP_FROZEN_infoLabel = CmmLabel rtsPackageId (fsLit "stg_MUT_ARR_PTRS_FROZEN0") CmmInfo
+mkMAP_DIRTY_infoLabel = CmmLabel rtsPackageId (fsLit "stg_MUT_ARR_PTRS_DIRTY") CmmInfo
+mkEMPTY_MVAR_infoLabel = CmmLabel rtsPackageId (fsLit "stg_EMPTY_MVAR") CmmInfo
+mkTopTickyCtrLabel = CmmLabel rtsPackageId (fsLit "top_ct") CmmData
+mkCAFBlackHoleInfoTableLabel = CmmLabel rtsPackageId (fsLit "stg_CAF_BLACKHOLE") CmmInfo
-----
-mkRtsInfoLabel, mkRtsEntryLabel, mkRtsRetInfoLabel, mkRtsRetLabel,
- mkRtsCodeLabel, mkRtsDataLabel, mkRtsGcPtrLabel
- :: FastString -> CLabel
+mkCmmInfoLabel, mkCmmEntryLabel, mkCmmRetInfoLabel, mkCmmRetLabel,
+ mkCmmCodeLabel, mkCmmDataLabel, mkCmmGcPtrLabel
+ :: PackageId -> FastString -> CLabel
-mkRtsInfoLabel str = CmmLabel topRtsModule str CmmInfo
-mkRtsEntryLabel str = CmmLabel topRtsModule str CmmEntry
-mkRtsRetInfoLabel str = CmmLabel topRtsModule str CmmRetInfo
-mkRtsRetLabel str = CmmLabel topRtsModule str CmmRet
-mkRtsCodeLabel str = CmmLabel topRtsModule str CmmCode
-mkRtsDataLabel str = CmmLabel topRtsModule str CmmData
-mkRtsGcPtrLabel str = CmmLabel topRtsModule str CmmGcPtr
+mkCmmInfoLabel pkg str = CmmLabel pkg str CmmInfo
+mkCmmEntryLabel pkg str = CmmLabel pkg str CmmEntry
+mkCmmRetInfoLabel pkg str = CmmLabel pkg str CmmRetInfo
+mkCmmRetLabel pkg str = CmmLabel pkg str CmmRet
+mkCmmCodeLabel pkg str = CmmLabel pkg str CmmCode
+mkCmmDataLabel pkg str = CmmLabel pkg str CmmData
+mkCmmGcPtrLabel pkg str = CmmLabel pkg str CmmGcPtr
-- Constructing RtsLabels
labelDynamic :: PackageId -> CLabel -> Bool
labelDynamic this_pkg lbl =
case lbl of
- RtsLabel _ -> not opt_Static && (this_pkg /= rtsPackageId) -- i.e., is the RTS in a DLL or not?
- IdLabel n _ k -> isDllName this_pkg n
+ RtsLabel _ -> not opt_Static && (this_pkg /= rtsPackageId) -- i.e., is the RTS in a DLL or not?
+ CmmLabel pkg _ _ -> not opt_Static && (this_pkg /= pkg)
+ IdLabel n _ k -> isDllName this_pkg n
#if mingw32_TARGET_OS
ForeignLabel _ _ d _ -> d
#else
import CmmStackLayout
import CmmTx
import DFMonad
+import Module
import FastString
import FiniteMap
import ForeignCall
new_base <- newTemp (cmmRegType (CmmGlobal BaseReg))
let (caller_save, caller_load) = callerSaveVolatileRegs
load_tso <- newTemp gcWord -- TODO FIXME NOW
- let suspendThread = CmmLit (CmmLabel (mkRtsCodeLabel (fsLit "suspendThread")))
- resumeThread = CmmLit (CmmLabel (mkRtsCodeLabel (fsLit "resumeThread")))
+ let suspendThread = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "suspendThread")))
+ resumeThread = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "resumeThread")))
suspend = mkStore (CmmReg spReg) (CmmLit (CmmBlock infotable)) <*>
saveThreadState <*>
caller_save <*>
import SMRep
import ForeignCall
+import Module
import Constants
import StaticFlags
import Unique
-- Save/restore the thread state in the TSO
suspendThread, resumeThread :: CmmExpr
-suspendThread = CmmLit (CmmLabel (mkRtsCodeLabel (fsLit "suspendThread")))
-resumeThread = CmmLit (CmmLabel (mkRtsCodeLabel (fsLit "resumeThread")))
+suspendThread = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "suspendThread")))
+resumeThread = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "resumeThread")))
-- This stuff can't be done in suspendThread/resumeThread, because it
-- refers to global registers which aren't available in the C world.
-- (c) The University of Glasgow, 2004-2006
--
-- Parser for concrete Cmm.
+-- This doesn't just parse the Cmm file, we also do some code generation
+-- along the way for switches and foreign calls etc.
--
-----------------------------------------------------------------------------
module CmmParse ( parseCmmFile ) where
-import CgMonad
+import CgMonad hiding (getDynFlags)
+import CgExtCode
import CgHeapery
import CgUtils
import CgProf
import Lexer
import ForeignCall
+import Module
import Literal
import Unique
import UniqFM
import Outputable
import BasicTypes
import Bag ( emptyBag, unitBag )
+import Var
import Control.Monad
import Data.Array
| cmmdata { $1 }
| decl { $1 }
| 'CLOSURE' '(' NAME ',' NAME lits ')' ';'
- { do lits <- sequence $6;
- staticClosure $3 $5 (map getLit lits) }
+ {% withThisPackage $ \pkg ->
+ do lits <- sequence $6;
+ staticClosure pkg $3 $5 (map getLit lits) }
-- The only static closures in the RTS are dummy closures like
-- stg_END_TSO_QUEUE_closure and stg_dummy_ret. We don't need
-- Strings aren't used much in the RTS HC code, so it doesn't seem
-- worth allowing inline strings. C-- doesn't allow them anyway.
static :: { ExtFCode [CmmStatic] }
- : NAME ':' { return [CmmDataLabel (mkRtsDataLabel $1)] }
+ : NAME ':'
+ {% withThisPackage $ \pkg ->
+ return [CmmDataLabel (mkCmmDataLabel pkg $1)] }
+
| type expr ';' { do e <- $2;
return [CmmStaticLit (getLit e)] }
| type ';' { return [CmmUninitialised
code (emitInfoTableAndCode entry_ret_label (CmmInfo Nothing Nothing info) formals []) }
| NAME maybe_formals_without_hints maybe_gc_block maybe_frame '{' body '}'
- { do ((formals, gc_block, frame), stmts) <-
- getCgStmtsEC' $ loopDecls $ do {
- formals <- sequence $2;
- gc_block <- $3;
- frame <- $4;
- $6;
- return (formals, gc_block, frame) }
- blks <- code (cgStmtsToBlocks stmts)
- code (emitProc (CmmInfo gc_block frame CmmNonInfoTable) (mkRtsCodeLabel $1) formals blks) }
+ {% withThisPackage $ \pkg ->
+ do newFunctionName $1 pkg
+ ((formals, gc_block, frame), stmts) <-
+ getCgStmtsEC' $ loopDecls $ do {
+ formals <- sequence $2;
+ gc_block <- $3;
+ frame <- $4;
+ $6;
+ return (formals, gc_block, frame) }
+ blks <- code (cgStmtsToBlocks stmts)
+ code (emitProc (CmmInfo gc_block frame CmmNonInfoTable) (mkCmmCodeLabel pkg $1) formals blks) }
info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
: 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
-- ptrs, nptrs, closure type, description, type
- { do prof <- profilingInfo $11 $13
- return (mkRtsEntryLabel $3,
+ {% withThisPackage $ \pkg ->
+ do prof <- profilingInfo $11 $13
+ return (mkCmmEntryLabel pkg $3,
CmmInfoTable False prof (fromIntegral $9)
(ThunkInfo (fromIntegral $5, fromIntegral $7) NoC_SRT),
[]) }
| 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')'
-- ptrs, nptrs, closure type, description, type, fun type
- { do prof <- profilingInfo $11 $13
- return (mkRtsEntryLabel $3,
+ {% withThisPackage $ \pkg ->
+ do prof <- profilingInfo $11 $13
+ return (mkCmmEntryLabel pkg $3,
CmmInfoTable False prof (fromIntegral $9)
(FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT
0 -- Arity zero
-- A variant with a non-zero arity (needed to write Main_main in Cmm)
| 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ',' INT ')'
-- ptrs, nptrs, closure type, description, type, fun type, arity
- { do prof <- profilingInfo $11 $13
- return (mkRtsEntryLabel $3,
+ {% withThisPackage $ \pkg ->
+ do prof <- profilingInfo $11 $13
+ return (mkCmmEntryLabel pkg $3,
CmmInfoTable False prof (fromIntegral $9)
(FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT (fromIntegral $17)
(ArgSpec (fromIntegral $15))
| 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
-- ptrs, nptrs, tag, closure type, description, type
- { do prof <- profilingInfo $13 $15
+ {% withThisPackage $ \pkg ->
+ do prof <- profilingInfo $13 $15
-- If profiling is on, this string gets duplicated,
-- but that's the way the old code did it we can fix it some other time.
- desc_lit <- code $ mkStringCLit $13
- return (mkRtsEntryLabel $3,
+ desc_lit <- code $ mkStringCLit $13
+ return (mkCmmEntryLabel pkg $3,
CmmInfoTable False prof (fromIntegral $11)
(ConstrInfo (fromIntegral $5, fromIntegral $7) (fromIntegral $9) desc_lit),
[]) }
| 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'
-- selector, closure type, description, type
- { do prof <- profilingInfo $9 $11
- return (mkRtsEntryLabel $3,
+ {% withThisPackage $ \pkg ->
+ do prof <- profilingInfo $9 $11
+ return (mkCmmEntryLabel pkg $3,
CmmInfoTable False prof (fromIntegral $7)
(ThunkSelectorInfo (fromIntegral $5) NoC_SRT),
[]) }
| 'INFO_TABLE_RET' '(' NAME ',' INT ')'
-- closure type (no live regs)
- { do let infoLabel = mkRtsInfoLabel $3
- return (mkRtsRetLabel $3,
+ {% withThisPackage $ \pkg ->
+ do let infoLabel = mkCmmInfoLabel pkg $3
+ return (mkCmmRetLabel pkg $3,
CmmInfoTable False (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5)
(ContInfo [] NoC_SRT),
[]) }
| 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals_without_hints0 ')'
-- closure type, live regs
- { do live <- sequence (map (liftM Just) $7)
- return (mkRtsRetLabel $3,
+ {% withThisPackage $ \pkg ->
+ do live <- sequence (map (liftM Just) $7)
+ return (mkCmmRetLabel pkg $3,
CmmInfoTable False (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5)
(ContInfo live NoC_SRT),
live) }
decl :: { ExtCode }
: type names ';' { mapM_ (newLocal $1) $2 }
- | 'import' names ';' { mapM_ newImport $2 }
+ | 'import' importNames ';' { mapM_ newImport $2 }
| 'export' names ';' { return () } -- ignore exports
+
+-- an imported function name, with optional packageId
+importNames
+ :: { [(Maybe PackageId, FastString)] }
+ : importName { [$1] }
+ | importName ',' importNames { $1 : $3 }
+
+importName
+ :: { (Maybe PackageId, FastString) }
+ : NAME { (Nothing, $1) }
+ | STRING NAME { (Just (fsToPackageId (mkFastString $1)), $2) }
+
+
names :: { [FastString] }
- : NAME { [$1] }
- | NAME ',' names { $1 : $3 }
+ : NAME { [$1] }
+ | NAME ',' names { $1 : $3 }
stmt :: { ExtCode }
: ';' { nopEC }
]
--- -----------------------------------------------------------------------------
--- Our extended FCode monad.
-
--- We add a mapping from names to CmmExpr, to support local variable names in
--- the concrete C-- code. The unique supply of the underlying FCode monad
--- is used to grab a new unique for each local variable.
-
--- In C--, a local variable can be declared anywhere within a proc,
--- and it scopes from the beginning of the proc to the end. Hence, we have
--- to collect declarations as we parse the proc, and feed the environment
--- back in circularly (to avoid a two-pass algorithm).
-
-data Named = Var CmmExpr | Label BlockId
-type Decls = [(FastString,Named)]
-type Env = UniqFM Named
-
-newtype ExtFCode a = EC { unEC :: Env -> Decls -> FCode (Decls, a) }
-
-type ExtCode = ExtFCode ()
-
-returnExtFC a = EC $ \e s -> return (s, a)
-thenExtFC (EC m) k = EC $ \e s -> do (s',r) <- m e s; unEC (k r) e s'
-
-instance Monad ExtFCode where
- (>>=) = thenExtFC
- return = returnExtFC
-
--- This function takes the variable decarations and imports and makes
--- an environment, which is looped back into the computation. In this
--- way, we can have embedded declarations that scope over the whole
--- procedure, and imports that scope over the entire module.
--- Discards the local declaration contained within decl'
-loopDecls :: ExtFCode a -> ExtFCode a
-loopDecls (EC fcode) =
- EC $ \e globalDecls -> do
- (decls', a) <- fixC (\ ~(decls,a) -> fcode (addListToUFM e (decls ++ globalDecls)) globalDecls)
- return (globalDecls, a)
-
-getEnv :: ExtFCode Env
-getEnv = EC $ \e s -> return (s, e)
-
-addVarDecl :: FastString -> CmmExpr -> ExtCode
-addVarDecl var expr = EC $ \e s -> return ((var, Var expr):s, ())
-
-addLabel :: FastString -> BlockId -> ExtCode
-addLabel name block_id = EC $ \e s -> return ((name, Label block_id):s, ())
-
-newLocal :: CmmType -> FastString -> ExtFCode LocalReg
-newLocal ty name = do
- u <- code newUnique
- let reg = LocalReg u ty
- addVarDecl name (CmmReg (CmmLocal reg))
- return reg
-
--- Creates a foreign label in the import. CLabel's labelDynamic
--- classifies these labels as dynamic, hence the code generator emits the
--- PIC code for them.
-newImport :: FastString -> ExtFCode ()
-newImport name
- = addVarDecl name (CmmLit (CmmLabel (mkForeignLabel name Nothing True IsFunction)))
-
-newLabel :: FastString -> ExtFCode BlockId
-newLabel name = do
- u <- code newUnique
- addLabel name (BlockId u)
- return (BlockId u)
-
-lookupLabel :: FastString -> ExtFCode BlockId
-lookupLabel name = do
- env <- getEnv
- return $
- case lookupUFM env name of
- Just (Label l) -> l
- _other -> BlockId (newTagUnique (getUnique name) 'L')
-
--- Unknown names are treated as if they had been 'import'ed.
--- This saves us a lot of bother in the RTS sources, at the expense of
--- deferring some errors to link time.
-lookupName :: FastString -> ExtFCode CmmExpr
-lookupName name = do
- env <- getEnv
- return $
- case lookupUFM env name of
- Just (Var e) -> e
- _other -> CmmLit (CmmLabel (mkRtsCodeLabel name))
-
--- Lifting FCode computations into the ExtFCode monad:
-code :: FCode a -> ExtFCode a
-code fc = EC $ \e s -> do r <- fc; return (s, r)
-
-code2 :: (FCode (Decls,b) -> FCode ((Decls,b),c))
- -> ExtFCode b -> ExtFCode c
-code2 f (EC ec) = EC $ \e s -> do ((s',b),c) <- f (ec e s); return (s',c)
-
-nopEC = code nopC
-stmtEC stmt = code (stmtC stmt)
-stmtsEC stmts = code (stmtsC stmts)
-getCgStmtsEC = code2 getCgStmts'
-getCgStmtsEC' = code2 (\m -> getCgStmts' m >>= f)
- where f ((decl, b), c) = return ((decl, b), (b, c))
-
-forkLabelledCodeEC ec = do
- stmts <- getCgStmtsEC ec
- code (forkCgStmts stmts)
profilingInfo desc_str ty_str = do
return (ProfilingInfo lit1 lit2)
-staticClosure :: FastString -> FastString -> [CmmLit] -> ExtCode
-staticClosure cl_label info payload
- = code $ emitDataLits (mkRtsDataLabel cl_label) lits
- where lits = mkStaticClosure (mkRtsInfoLabel info) dontCareCCS payload [] [] []
+staticClosure :: PackageId -> FastString -> FastString -> [CmmLit] -> ExtCode
+staticClosure pkg cl_label info payload
+ = code $ emitDataLits (mkCmmDataLabel pkg cl_label) lits
+ where lits = mkStaticClosure (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] []
foreignCall
:: String
import Bitmap
import Util
import StaticFlags
+import Module
import FastString
import Outputable
import Unique
slowArgs [] = []
slowArgs amodes = (NonPtrArg, mkLblExpr stg_ap_pat) : args ++ slowArgs rest
where (arg_pat, args, rest) = matchSlowPattern amodes
- stg_ap_pat = mkRtsRetInfoLabel arg_pat
+ stg_ap_pat = mkCmmRetInfoLabel rtsPackageId arg_pat
matchSlowPattern :: [(CgRep,CmmExpr)]
-> (FastString, [(CgRep,CmmExpr)], [(CgRep,CmmExpr)])
-- so that the garbage collector can find them
-- This must be done *before* the info table pointer is overwritten,
-- because the old info table ptr is needed for reversion
- ; emitRtsCallWithVols (fsLit "newCAF") [CmmHinted (CmmReg nodeReg) AddrHint] [node] False
+ ; emitRtsCallWithVols rtsPackageId (fsLit "newCAF") [CmmHinted (CmmReg nodeReg) AddrHint] [node] False
-- node is live, so save it.
-- Overwrite the closure with a (static) indirection
import Outputable
import ListSetOps
import Util
+import Module
import FastString
import StaticFlags
\end{code}
, (_, CmmLit (CmmInt val _)) <- arg_amode
, let val_int = (fromIntegral val) :: Int
, val_int <= mAX_INTLIKE && val_int >= mIN_INTLIKE
- = do { let intlike_lbl = mkRtsGcPtrLabel (fsLit "stg_INTLIKE_closure")
+ = do { let intlike_lbl = mkCmmGcPtrLabel rtsPackageId (fsLit "stg_INTLIKE_closure")
offsetW = (val_int - mIN_INTLIKE) * (fixedHdrSize + 1)
-- INTLIKE closures consist of a header and one word payload
intlike_amode = CmmLit (cmmLabelOffW intlike_lbl offsetW)
, (_, CmmLit (CmmInt val _)) <- arg_amode
, let val_int = (fromIntegral val) :: Int
, val_int <= mAX_CHARLIKE && val_int >= mIN_CHARLIKE
- = do { let charlike_lbl = mkRtsGcPtrLabel (fsLit "stg_CHARLIKE_closure")
+ = do { let charlike_lbl = mkCmmGcPtrLabel rtsPackageId (fsLit "stg_CHARLIKE_closure")
offsetW = (val_int - mIN_CHARLIKE) * (fixedHdrSize + 1)
-- CHARLIKE closures consist of a header and one word payload
charlike_amode = CmmLit (cmmLabelOffW charlike_lbl offsetW)
--- /dev/null
+-- | Our extended FCode monad.
+
+-- We add a mapping from names to CmmExpr, to support local variable names in
+-- the concrete C-- code. The unique supply of the underlying FCode monad
+-- is used to grab a new unique for each local variable.
+
+-- In C--, a local variable can be declared anywhere within a proc,
+-- and it scopes from the beginning of the proc to the end. Hence, we have
+-- to collect declarations as we parse the proc, and feed the environment
+-- back in circularly (to avoid a two-pass algorithm).
+
+module CgExtCode (
+ ExtFCode(..),
+ ExtCode,
+ Named(..), Env,
+
+ loopDecls,
+ getEnv,
+
+ newLocal,
+ newLabel,
+ newFunctionName,
+ newImport,
+
+ lookupLabel,
+ lookupName,
+
+ code,
+ code2,
+ nopEC,
+ stmtEC,
+ stmtsEC,
+ getCgStmtsEC,
+ getCgStmtsEC',
+ forkLabelledCodeEC
+)
+
+where
+
+import CgMonad
+
+import CLabel
+import Cmm
+
+import BasicTypes
+import BlockId
+import FastString
+import Module
+import UniqFM
+import Unique
+
+
+-- | The environment contains variable definitions or blockids.
+data Named
+ = Var CmmExpr -- ^ Holds CmmLit(CmmLabel ..) which gives the label type,
+ -- eg, RtsLabel, ForeignLabel, CmmLabel etc.
+
+ | Fun PackageId -- ^ A function name from this package
+ | Label BlockId -- ^ A blockid of some code or data.
+
+-- | An environment of named things.
+type Env = UniqFM Named
+
+-- | Local declarations that are in scope during code generation.
+type Decls = [(FastString,Named)]
+
+-- | Does a computation in the FCode monad, with a current environment
+-- and a list of local declarations. Returns the resulting list of declarations.
+newtype ExtFCode a
+ = EC { unEC :: Env -> Decls -> FCode (Decls, a) }
+
+type ExtCode = ExtFCode ()
+
+returnExtFC :: a -> ExtFCode a
+returnExtFC a = EC $ \_ s -> return (s, a)
+
+thenExtFC :: ExtFCode a -> (a -> ExtFCode b) -> ExtFCode b
+thenExtFC (EC m) k = EC $ \e s -> do (s',r) <- m e s; unEC (k r) e s'
+
+instance Monad ExtFCode where
+ (>>=) = thenExtFC
+ return = returnExtFC
+
+
+-- | Takes the variable decarations and imports from the monad
+-- and makes an environment, which is looped back into the computation.
+-- In this way, we can have embedded declarations that scope over the whole
+-- procedure, and imports that scope over the entire module.
+-- Discards the local declaration contained within decl'
+--
+loopDecls :: ExtFCode a -> ExtFCode a
+loopDecls (EC fcode) =
+ EC $ \e globalDecls -> do
+ (_, a) <- fixC (\ ~(decls, _) -> fcode (addListToUFM e (decls ++ globalDecls)) globalDecls)
+ return (globalDecls, a)
+
+
+-- | Get the current environment from the monad.
+getEnv :: ExtFCode Env
+getEnv = EC $ \e s -> return (s, e)
+
+
+-- | Add a new variable to the list of local declarations.
+-- The CmmExpr says where the value is stored.
+addVarDecl :: FastString -> CmmExpr -> ExtCode
+addVarDecl var expr
+ = EC $ \_ s -> return ((var, Var expr):s, ())
+
+-- | Add a new label to the list of local declarations.
+addLabel :: FastString -> BlockId -> ExtCode
+addLabel name block_id
+ = EC $ \_ s -> return ((name, Label block_id):s, ())
+
+
+-- | Create a fresh local variable of a given type.
+newLocal
+ :: CmmType -- ^ data type
+ -> FastString -- ^ name of variable
+ -> ExtFCode LocalReg -- ^ register holding the value
+
+newLocal ty name = do
+ u <- code newUnique
+ let reg = LocalReg u ty
+ addVarDecl name (CmmReg (CmmLocal reg))
+ return reg
+
+
+-- | Allocate a fresh label.
+newLabel :: FastString -> ExtFCode BlockId
+newLabel name = do
+ u <- code newUnique
+ addLabel name (BlockId u)
+ return (BlockId u)
+
+
+-- | Add add a local function to the environment.
+newFunctionName
+ :: FastString -- ^ name of the function
+ -> PackageId -- ^ package of the current module
+ -> ExtCode
+
+newFunctionName name pkg
+ = EC $ \_ s -> return ((name, Fun pkg):s, ())
+
+
+-- | Add an imported foreign label to the list of local declarations.
+-- If this is done at the start of the module the declaration will scope
+-- over the whole module.
+-- CLabel's labelDynamic classifies these labels as dynamic, hence the
+-- code generator emits PIC code for them.
+newImport :: (Maybe PackageId, FastString) -> ExtFCode ()
+newImport (Nothing, name)
+ = addVarDecl name (CmmLit (CmmLabel (mkForeignLabel name Nothing True IsFunction)))
+
+newImport (Just pkg, name)
+ = addVarDecl name (CmmLit (CmmLabel (mkCmmCodeLabel pkg name)))
+
+-- | Lookup the BlockId bound to the label with this name.
+-- If one hasn't been bound yet, create a fresh one based on the
+-- Unique of the name.
+lookupLabel :: FastString -> ExtFCode BlockId
+lookupLabel name = do
+ env <- getEnv
+ return $
+ case lookupUFM env name of
+ Just (Label l) -> l
+ _other -> BlockId (newTagUnique (getUnique name) 'L')
+
+
+-- | Lookup the location of a named variable.
+-- Unknown names are treated as if they had been 'import'ed from the runtime system.
+-- This saves us a lot of bother in the RTS sources, at the expense of
+-- deferring some errors to link time.
+lookupName :: FastString -> ExtFCode CmmExpr
+lookupName name = do
+ env <- getEnv
+ return $
+ case lookupUFM env name of
+ Just (Var e) -> e
+ Just (Fun pkg) -> CmmLit (CmmLabel (mkCmmCodeLabel pkg name))
+ _other -> CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId name))
+
+
+-- | Lift an FCode computation into the ExtFCode monad
+code :: FCode a -> ExtFCode a
+code fc = EC $ \_ s -> do
+ r <- fc
+ return (s, r)
+
+
+code2 :: (FCode (Decls,b) -> FCode ((Decls,b),c)) -> ExtFCode b -> ExtFCode c
+code2 f (EC ec)
+ = EC $ \e s -> do
+ ((s', _),c) <- f (ec e s)
+ return (s',c)
+
+
+-- | Do nothing in the ExtFCode monad.
+nopEC :: ExtFCode ()
+nopEC = code nopC
+
+
+-- | Accumulate a CmmStmt into the monad state.
+stmtEC :: CmmStmt -> ExtFCode ()
+stmtEC stmt = code (stmtC stmt)
+
+
+-- | Accumulate some CmmStmts into the monad state.
+stmtsEC :: [CmmStmt] -> ExtFCode ()
+stmtsEC stmts = code (stmtsC stmts)
+
+
+-- | Get the generated statements out of the monad state.
+getCgStmtsEC :: ExtFCode a -> ExtFCode CgStmts
+getCgStmtsEC = code2 getCgStmts'
+
+
+-- | Get the generated statements, and the return value out of the monad state.
+getCgStmtsEC' :: ExtFCode a -> ExtFCode (a, CgStmts)
+getCgStmtsEC' = code2 (\m -> getCgStmts' m >>= f)
+ where f ((decl, b), c) = return ((decl, b), (b, c))
+
+
+-- | Emit a chunk of code outside the instruction stream,
+-- and return its block id.
+forkLabelledCodeEC :: ExtFCode a -> ExtFCode BlockId
+forkLabelledCodeEC ec = do
+ stmts <- getCgStmtsEC ec
+ code (forkCgStmts stmts)
+
+
import Constants
import StaticFlags
import Outputable
+import Module
import FastString
import BasicTypes
emitLoadThreadState
suspendThread, resumeThread :: CmmExpr
-suspendThread = CmmLit (CmmLabel (mkRtsCodeLabel (fsLit "suspendThread")))
-resumeThread = CmmLit (CmmLabel (mkRtsCodeLabel (fsLit "resumeThread")))
+suspendThread = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "suspendThread")))
+resumeThread = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "resumeThread")))
-- we might need to load arguments into temporaries before
import TyCon
import CostCentre
import Util
+import Module
import Constants
import Outputable
import FastString
; setRealHp hpHw
; code }
where
- rts_label PolyAlt = CmmLit (CmmLabel (mkRtsCodeLabel (fsLit "stg_gc_unpt_r1")))
+ rts_label PolyAlt = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_unpt_r1")))
-- Do *not* enter R1 after a heap check in
-- a polymorphic case. It might be a function
-- and the entry code for a function (currently)
rts_label (PrimAlt tc)
= CmmLit $ CmmLabel $
case primRepToCgRep (tyConPrimRep tc) of
- VoidArg -> mkRtsCodeLabel (fsLit "stg_gc_noregs")
- FloatArg -> mkRtsCodeLabel (fsLit "stg_gc_f1")
- DoubleArg -> mkRtsCodeLabel (fsLit "stg_gc_d1")
- LongArg -> mkRtsCodeLabel (fsLit "stg_gc_l1")
+ VoidArg -> mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_noregs")
+ FloatArg -> mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_f1")
+ DoubleArg -> mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_d1")
+ LongArg -> mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_l1")
-- R1 is boxed but unlifted:
- PtrArg -> mkRtsCodeLabel (fsLit "stg_gc_unpt_r1")
+ PtrArg -> mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_unpt_r1")
-- R1 is unboxed:
- NonPtrArg -> mkRtsCodeLabel (fsLit "stg_gc_unbx_r1")
+ NonPtrArg -> mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_unbx_r1")
rts_label (UbxTupAlt _) = panic "altHeapCheck"
\end{code}
assign_liveness = CmmAssign (CmmGlobal (VanillaReg 9 VNonGcPtr)) -- Ho ho ho!
(CmmLit (mkWordCLit liveness))
liveness = mkRegLiveness regs ptrs nptrs
- rts_label = CmmLit (CmmLabel (mkRtsCodeLabel (fsLit "stg_gc_ut")))
+ rts_label = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_ut")))
\end{code}
= do_checks' bytes (CmmLit (mkIntCLit 0)) True False noStmts stg_gc_enter1
stg_gc_gen :: CmmExpr
-stg_gc_gen = CmmLit (CmmLabel (mkRtsCodeLabel (fsLit "stg_gc_gen")))
+stg_gc_gen = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_gen")))
stg_gc_enter1 :: CmmExpr
stg_gc_enter1 = CmmReg (CmmGlobal GCEnter1)
\end{code}
Sequel(..), -- ToDo: unabstract?
-- ideally we wouldn't export these, but some other modules access internal state
- getState, setState, getInfoDown, getDynFlags, getThisPackage,
+ getState, setState, getInfoDown, getDynFlags, getThisPackage,
-- more localised access to monad state
getStkUsage, setStkUsage,
import CmmUtils
import PrimOp
import SMRep
+import Module
import Constants
import Outputable
import FastString
NoC_SRT -- No SRT b/c we do PlayRisky
CmmMayReturn
where
- newspark = CmmLit (CmmLabel (mkRtsCodeLabel (fsLit "newSpark")))
+ newspark = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "newSpark")))
emitPrimOp [res] ReadMutVarOp [mutv] _
= stmtC (CmmAssign (CmmLocal res) (cmmLoadIndexW mutv fixedHdrSize gcWord))
import StgSyn
import StaticFlags
import FastString
+import Module
import Constants -- Lots of field offsets
import Outputable
-- Address of current CCS variable, for storing into
curCCSAddr :: CmmExpr
-curCCSAddr = CmmLit (CmmLabel (mkRtsDataLabel (fsLit "CCCS")))
+curCCSAddr = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CCCS")))
mkCCostCentre :: CostCentre -> CmmLit
mkCCostCentre cc = CmmLabel (mkCCLabel cc)
stmtC $ CmmStore curCCSAddr (costCentreFrom closure)
enter_ccs_fun :: CmmExpr -> Code
-enter_ccs_fun stack = emitRtsCall (fsLit "EnterFunCCS") [CmmHinted stack AddrHint] False
+enter_ccs_fun stack = emitRtsCall rtsPackageId (fsLit "EnterFunCCS") [CmmHinted stack AddrHint] False
-- ToDo: vols
enter_ccs_fsub :: Code
-- entering via a PAP.
enteringPAP :: Integer -> Code
enteringPAP n
- = stmtC (CmmStore (CmmLit (CmmLabel (mkRtsDataLabel (fsLit "entering_PAP"))))
+ = stmtC (CmmStore (CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "entering_PAP"))))
(CmmLit (CmmInt n cIntWidth)))
ifProfiling :: Code -> Code
cC_LIST, cC_ID :: CmmExpr
-cC_LIST = CmmLit (CmmLabel (mkRtsDataLabel (fsLit "CC_LIST")))
-cC_ID = CmmLit (CmmLabel (mkRtsDataLabel (fsLit "CC_ID")))
+cC_LIST = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CC_LIST")))
+cC_ID = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CC_ID")))
cCS_LIST, cCS_ID :: CmmExpr
-cCS_LIST = CmmLit (CmmLabel (mkRtsDataLabel (fsLit "CCS_LIST")))
-cCS_ID = CmmLit (CmmLabel (mkRtsDataLabel (fsLit "CCS_ID")))
+cCS_LIST = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CCS_LIST")))
+cCS_ID = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CCS_ID")))
-- ---------------------------------------------------------------------------
-- Set the current cost centre stack
pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> Code
pushCostCentre result ccs cc
= emitRtsCallWithResult result AddrHint
+ rtsPackageId
(fsLit "PushCostCentre") [CmmHinted ccs AddrHint,
CmmHinted (CmmLit (mkCCostCentre cc)) AddrHint]
False
loadEra :: CmmExpr
loadEra = CmmMachOp (MO_UU_Conv cIntWidth wordWidth)
- [CmmLoad (mkLblExpr (mkRtsDataLabel $ fsLit("era"))) cInt]
+ [CmmLoad (mkLblExpr (mkCmmDataLabel rtsPackageId $ fsLit("era"))) cInt]
ldvWord :: CmmExpr -> CmmExpr
-- Takes the address of a closure, and returns
, CmmStore (CmmLit (cmmLabelOffB ctr_lbl
oFFSET_StgEntCounter_registeredp))
(CmmLit (mkIntCLit 1)) ]
- ticky_entry_ctrs = mkLblExpr (mkRtsDataLabel (fsLit "ticky_entry_ctrs"))
+ ticky_entry_ctrs = mkLblExpr (mkCmmDataLabel rtsPackageId (fsLit "ticky_entry_ctrs"))
tickyReturnOldCon, tickyReturnNewCon :: Arity -> Code
tickyReturnOldCon arity
(CmmLit (cmmLabelOffB ticky_ctr
oFFSET_StgEntCounter_allocs)) hp,
-- Bump ALLOC_HEAP_ctr
- addToMemLbl cLongWidth (mkRtsDataLabel $ fsLit "ALLOC_HEAP_ctr") 1,
+ addToMemLbl cLongWidth (mkCmmDataLabel rtsPackageId $ fsLit "ALLOC_HEAP_ctr") 1,
-- Bump ALLOC_HEAP_tot
- addToMemLbl cLongWidth (mkRtsDataLabel $ fsLit "ALLOC_HEAP_tot") hp] }
+ addToMemLbl cLongWidth (mkCmmDataLabel rtsPackageId $ fsLit "ALLOC_HEAP_tot") hp] }
-- -----------------------------------------------------------------------------
-- Ticky utils
-- All the ticky-ticky counters are declared "unsigned long" in C
bumpTickyCounter :: FastString -> Code
-bumpTickyCounter lbl = bumpTickyCounter' (cmmLabelOffB (mkRtsDataLabel lbl) 0)
+bumpTickyCounter lbl = bumpTickyCounter' (cmmLabelOffB (mkCmmDataLabel rtsPackageId lbl) 0)
bumpTickyCounter' :: CmmLit -> Code
-- krc: note that we're incrementing the _entry_count_ field of the ticky counter
import ForeignCall
import ClosureInfo
import StgSyn (SRT(..))
+import Module
import Literal
import Digraph
import ListSetOps
; labelC join_id
}
-emitRtsCall :: FastString -> [CmmHinted CmmExpr] -> Bool -> Code
-emitRtsCall fun args safe = emitRtsCall' [] fun args Nothing safe
+
+-- | Emit code to call a Cmm function.
+emitRtsCall
+ :: PackageId -- ^ package the function is in
+ -> FastString -- ^ name of function
+ -> [CmmHinted CmmExpr] -- ^ function args
+ -> Bool -- ^ whether this is a safe call
+ -> Code -- ^ cmm code
+
+emitRtsCall pkg fun args safe = emitRtsCall' [] pkg fun args Nothing safe
-- The 'Nothing' says "save all global registers"
-emitRtsCallWithVols :: FastString -> [CmmHinted CmmExpr] -> [GlobalReg] -> Bool -> Code
-emitRtsCallWithVols fun args vols safe
- = emitRtsCall' [] fun args (Just vols) safe
+emitRtsCallWithVols :: PackageId -> FastString -> [CmmHinted CmmExpr] -> [GlobalReg] -> Bool -> Code
+emitRtsCallWithVols pkg fun args vols safe
+ = emitRtsCall' [] pkg fun args (Just vols) safe
-emitRtsCallWithResult :: LocalReg -> ForeignHint -> FastString
- -> [CmmHinted CmmExpr] -> Bool -> Code
-emitRtsCallWithResult res hint fun args safe
- = emitRtsCall' [CmmHinted res hint] fun args Nothing safe
+emitRtsCallWithResult
+ :: LocalReg -> ForeignHint
+ -> PackageId -> FastString
+ -> [CmmHinted CmmExpr] -> Bool -> Code
+emitRtsCallWithResult res hint pkg fun args safe
+ = emitRtsCall' [CmmHinted res hint] pkg fun args Nothing safe
-- Make a call to an RTS C procedure
emitRtsCall'
:: [CmmHinted LocalReg]
+ -> PackageId
-> FastString
-> [CmmHinted CmmExpr]
-> Maybe [GlobalReg]
-> Bool -- True <=> CmmSafe call
-> Code
-emitRtsCall' res fun args vols safe = do
+emitRtsCall' res pkg fun args vols safe = do
safety <- if safe
then getSRTInfo >>= (return . CmmSafe)
else return CmmUnsafe
where
(caller_save, caller_load) = callerSaveVolatileRegs vols
target = CmmCallee fun_expr CCallConv
- fun_expr = mkLblExpr (mkRtsCodeLabel fun)
+ fun_expr = mkLblExpr (mkCmmCodeLabel pkg fun)
-----------------------------------------------------------------------------
--
| otherwise =
nopC
where
- bh_lbl | is_single_entry = mkRtsDataLabel (fsLit "stg_SE_BLACKHOLE_info")
- | otherwise = mkRtsDataLabel (fsLit "stg_BLACKHOLE_info")
+ bh_lbl | is_single_entry = mkCmmDataLabel rtsPackageId (fsLit "stg_SE_BLACKHOLE_info")
+ | otherwise = mkCmmDataLabel rtsPackageId (fsLit "stg_BLACKHOLE_info")
-- If we wanted to do eager blackholing with slop filling,
-- we'd need to do it at the *end* of a basic block, otherwise
-- so that the garbage collector can find them
-- This must be done *before* the info table pointer is overwritten,
-- because the old info table ptr is needed for reversion
- ; emitRtsCallWithVols (fsLit "newCAF") [(CmmReg nodeReg,AddrHint)] [node] False
+ ; emitRtsCallWithVols rtsPackageId (fsLit "newCAF") [(CmmReg nodeReg,AddrHint)] [node] False
-- node is live, so save it.
-- Overwrite the closure with a (static) indirection
import MkZipCfgCmm (CmmAGraph, mkNop)
import SMRep
import CostCentre
+import Module
import Constants
import DataCon
import FastString
, StgLitArg (MachInt val) <- arg
, val <= fromIntegral mAX_INTLIKE -- Comparisons at type Integer!
, val >= fromIntegral mIN_INTLIKE -- ...ditto...
- = do { let intlike_lbl = mkRtsGcPtrLabel (fsLit "stg_INTLIKE_closure")
+ = do { let intlike_lbl = mkCmmGcPtrLabel rtsPackageId (fsLit "stg_INTLIKE_closure")
val_int = fromIntegral val :: Int
offsetW = (val_int - mIN_INTLIKE) * (fixedHdrSize + 1)
-- INTLIKE closures consist of a header and one word payload
, let val_int = ord val :: Int
, val_int <= mAX_CHARLIKE
, val_int >= mIN_CHARLIKE
- = do { let charlike_lbl = mkRtsGcPtrLabel (fsLit "stg_CHARLIKE_closure")
+ = do { let charlike_lbl = mkCmmGcPtrLabel rtsPackageId (fsLit "stg_CHARLIKE_closure")
offsetW = (val_int - mIN_CHARLIKE) * (fixedHdrSize + 1)
-- CHARLIKE closures consist of a header and one word payload
charlike_amode = cmmLabelOffW charlike_lbl offsetW
import TyCon
import CostCentre
import Outputable
+import Module
import FastString( mkFastString, FastString, fsLit )
import Constants
gc_call updfr_sz
| arity == 0 = mkJumpGC (CmmReg (CmmGlobal GCEnter1)) arg_exprs updfr_sz
| otherwise = case gc_lbl args' of
- Just lbl -> mkJumpGC (CmmLit (CmmLabel (mkRtsCodeLabel lbl)))
- arg_exprs updfr_sz
+ Just _lbl -> panic "StgCmmHeap.entryHeapCheck: gc_lbl not finished"
+ -- mkJumpGC (CmmLit (CmmLabel (mkRtsCodeLabel lbl)))
+ -- arg_exprs updfr_sz
Nothing -> mkCall generic_gc (GC, GC) [] [] updfr_sz
gc_lbl :: [LocalReg] -> Maybe FastString
| null regs = mkCall generic_gc (GC, GC) [] [] updfr_sz
| Just gc_lbl <- rts_label regs -- Canned call
- = mkCall (CmmLit (CmmLabel (mkRtsCodeLabel gc_lbl))) (GC, GC)
- regs (map (CmmReg . CmmLocal) regs) updfr_sz
+ = panic "StgCmmHeap.altHeapCheck: rts_label not finished"
+ -- mkCall (CmmLit (CmmLabel (mkRtsCodeLabel gc_lbl))) (GC, GC)
+ -- regs (map (CmmReg . CmmLocal) regs) updfr_sz
| otherwise -- No canned call, and non-empty live vars
= mkCall generic_gc (GC, GC) [] [] updfr_sz
generic_gc :: CmmExpr -- The generic GC procedure; no params, no resuls
-generic_gc = CmmLit (CmmLabel (mkRtsCodeLabel (fsLit "stg_gc_noregs")))
+generic_gc = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_noregs")))
-- JD: TEMPORARY -- UNTIL THOSE FUNCTIONS EXIST...
-- generic_gc = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "stg_gc_fun")))
import PrimOp
import SMRep
import Constants
+import Module
import FastString
import Outputable
-- later, we might want to inline it.
emitCCall
[(res,NoHint)]
- (CmmLit (CmmLabel (mkRtsCodeLabel (fsLit "newSpark"))))
+ (CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "newSpark"))))
[(CmmReg (CmmGlobal BaseReg), AddrHint), (arg,AddrHint)]
emitPrimOp [res] ReadMutVarOp [mutv]
import StgSyn
import StaticFlags
import FastString
+import Module
import Constants -- Lots of field offsets
import Outputable
-- Address of current CCS variable, for storing into
curCCSAddr :: CmmExpr
-curCCSAddr = CmmLit (CmmLabel (mkRtsDataLabel (fsLit "CCCS")))
+curCCSAddr = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CCCS")))
mkCCostCentre :: CostCentre -> CmmLit
mkCCostCentre cc = CmmLabel (mkCCLabel cc)
emit $ mkStore curCCSAddr (costCentreFrom closure)
enter_ccs_fun :: CmmExpr -> FCode ()
-enter_ccs_fun stack = emitRtsCall (fsLit "EnterFunCCS") [(stack,AddrHint)] False
+enter_ccs_fun stack = emitRtsCall rtsPackageId (fsLit "EnterFunCCS") [(stack,AddrHint)] False
-- ToDo: vols
enter_ccs_fsub :: FCode ()
-- entering via a PAP.
enteringPAP :: Integer -> FCode ()
enteringPAP n
- = emit (mkStore (CmmLit (CmmLabel (mkRtsDataLabel (fsLit "entering_PAP"))))
+ = emit (mkStore (CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "entering_PAP"))))
(CmmLit (CmmInt n cIntWidth)))
ifProfiling :: FCode () -> FCode ()
cC_LIST, cC_ID :: CmmExpr
-cC_LIST = CmmLit (CmmLabel (mkRtsDataLabel (fsLit "CC_LIST")))
-cC_ID = CmmLit (CmmLabel (mkRtsDataLabel (fsLit "CC_ID")))
+cC_LIST = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CC_LIST")))
+cC_ID = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CC_ID")))
cCS_LIST, cCS_ID :: CmmExpr
-cCS_LIST = CmmLit (CmmLabel (mkRtsDataLabel (fsLit "CCS_LIST")))
-cCS_ID = CmmLit (CmmLabel (mkRtsDataLabel (fsLit "CCS_ID")))
+cCS_LIST = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CCS_LIST")))
+cCS_ID = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CCS_ID")))
-- ---------------------------------------------------------------------------
-- Set the current cost centre stack
pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode ()
pushCostCentre result ccs cc
= emitRtsCallWithResult result AddrHint
+ rtsPackageId
(fsLit "PushCostCentre") [(ccs,AddrHint),
(CmmLit (mkCCostCentre cc), AddrHint)]
False
loadEra :: CmmExpr
loadEra = CmmMachOp (MO_UU_Conv cIntWidth wordWidth)
- [CmmLoad (mkLblExpr (mkRtsDataLabel (fsLit "era"))) cInt]
+ [CmmLoad (mkLblExpr (mkCmmDataLabel rtsPackageId (fsLit "era"))) cInt]
ldvWord :: CmmExpr -> CmmExpr
-- Takes the address of a closure, and returns
, mkStore (CmmLit (cmmLabelOffB ctr_lbl
oFFSET_StgEntCounter_registeredp))
(CmmLit (mkIntCLit 1)) ]
- ticky_entry_ctrs = mkLblExpr (mkRtsDataLabel (fsLit "ticky_entry_ctrs"))
+ ticky_entry_ctrs = mkLblExpr (mkCmmDataLabel rtsPackageId (fsLit "ticky_entry_ctrs"))
tickyReturnOldCon, tickyReturnNewCon :: Arity -> FCode ()
tickyReturnOldCon arity
(CmmLit (cmmLabelOffB ticky_ctr
oFFSET_StgEntCounter_allocs)) hp,
-- Bump ALLOC_HEAP_ctr
- addToMemLbl cLong (mkRtsDataLabel (fsLit "ALLOC_HEAP_ctr")) 1,
+ addToMemLbl cLong (mkCmmDataLabel rtsPackageId (fsLit "ALLOC_HEAP_ctr")) 1,
-- Bump ALLOC_HEAP_tot
- addToMemLbl cLong (mkRtsDataLabel (fsLit "ALLOC_HEAP_tot")) hp] }
+ addToMemLbl cLong (mkCmmDataLabel rtsPackageId (fsLit "ALLOC_HEAP_tot")) hp] }
-- -----------------------------------------------------------------------------
-- Ticky utils
-- All the ticky-ticky counters are declared "unsigned long" in C
bumpTickyCounter :: FastString -> FCode ()
-bumpTickyCounter lbl = bumpTickyCounter' (cmmLabelOffB (mkRtsDataLabel lbl) 0)
+bumpTickyCounter lbl = bumpTickyCounter' (cmmLabelOffB (mkCmmDataLabel rtsPackageId lbl) 0)
bumpTickyCounter' :: CmmLit -> FCode ()
-- krc: note that we're incrementing the _entry_count_ field of the ticky counter
import Constants
import SMRep
import StgSyn ( SRT(..) )
+import Module
import Literal
import Digraph
import ListSetOps
--
-------------------------------------------------------------------------
-emitRtsCall :: FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
-emitRtsCall fun args safe = emitRtsCall' [] fun args Nothing safe
+emitRtsCall :: PackageId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
+emitRtsCall pkg fun args safe = emitRtsCall' [] pkg fun args Nothing safe
-- The 'Nothing' says "save all global registers"
-emitRtsCallWithVols :: FastString -> [(CmmExpr,ForeignHint)] -> [GlobalReg] -> Bool -> FCode ()
-emitRtsCallWithVols fun args vols safe
- = emitRtsCall' [] fun args (Just vols) safe
+emitRtsCallWithVols :: PackageId -> FastString -> [(CmmExpr,ForeignHint)] -> [GlobalReg] -> Bool -> FCode ()
+emitRtsCallWithVols pkg fun args vols safe
+ = emitRtsCall' [] pkg fun args (Just vols) safe
-emitRtsCallWithResult :: LocalReg -> ForeignHint -> FastString
+emitRtsCallWithResult :: LocalReg -> ForeignHint -> PackageId -> FastString
-> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
-emitRtsCallWithResult res hint fun args safe
- = emitRtsCall' [(res,hint)] fun args Nothing safe
+emitRtsCallWithResult res hint pkg fun args safe
+ = emitRtsCall' [(res,hint)] pkg fun args Nothing safe
-- Make a call to an RTS C procedure
emitRtsCall'
:: [(LocalReg,ForeignHint)]
+ -> PackageId
-> FastString
-> [(CmmExpr,ForeignHint)]
-> Maybe [GlobalReg]
-> Bool -- True <=> CmmSafe call
-> FCode ()
-emitRtsCall' res fun args _vols safe
+emitRtsCall' res pkg fun args _vols safe
= --error "emitRtsCall'"
do { updfr_off <- getUpdFrameOff
; emit caller_save
(args', arg_hints) = unzip args
(res', res_hints) = unzip res
(caller_save, caller_load) = callerSaveVolatileRegs
- fun_expr = mkLblExpr (mkRtsCodeLabel fun)
+ fun_expr = mkLblExpr (mkCmmCodeLabel pkg fun)
-----------------------------------------------------------------------------
module Lexer (
Token(..), lexer, pragState, mkPState, PState(..),
P(..), ParseResult(..), getSrcLoc,
- getPState,
+ getPState, getDynFlags, withThisPackage,
failLocMsgP, failSpanMsgP, srcParseFail,
- getMessages,
+ getMessages,
popContext, pushCurrentContext, setLastToken, setSrcLoc,
getLexState, popLexState, pushLexState,
extension, standaloneDerivingEnabled, bangPatEnabled,
import SrcLoc
import UniqFM
import DynFlags
+import Module
import Ctype
import Util ( readRational )
getPState :: P PState
getPState = P $ \s -> POk s s
+getDynFlags :: P DynFlags
+getDynFlags = P $ \s -> POk s (dflags s)
+
+withThisPackage :: (PackageId -> a) -> P a
+withThisPackage f
+ = do pkg <- liftM thisPackage getDynFlags
+ return $ f pkg
+
extension :: (Int -> Bool) -> P Bool
extension p = P $ \s -> POk s (p $! extsBitmap s)
projects / ghc-hetmet.git / commitdiff