* Refactor CLabel.RtsLabel to CLabel.CmmLabel

The type of the CmmLabel ctor is now
  CmmLabel :: PackageId -> FastString -> CmmLabelInfo -> CLabel
  
 - When you construct a CmmLabel you have to explicitly say what
   package it is in. Many of these will just use rtsPackageId, but
   I've left it this way to remind people not to pretend labels are
   in the RTS package when they're not. 
   
 - When parsing a Cmm file, labels that are not defined in the 
   current file are assumed to be in the RTS package. 
   
   Labels imported like
      import label
   are assumed to be in a generic "foreign" package, which is different
   from the current one.
   
   Labels imported like
      import "package-name" label
   are marked as coming from the named package.
   
   This last one is needed for the integer-gmp library as we want to
   refer to labels that are not in the same compilation unit, but
   are in the same non-rts package.
   
   This should help remove the nasty #ifdef __PIC__ stuff from
   integer-gmp/cbits/gmp-wrappers.cmm
   
parent ddb7062b
......@@ -73,13 +73,13 @@ module CLabel (
mkSelectorInfoLabel,
mkSelectorEntryLabel,
mkRtsInfoLabel,
mkRtsEntryLabel,
mkRtsRetInfoLabel,
mkRtsRetLabel,
mkRtsCodeLabel,
mkRtsDataLabel,
mkRtsGcPtrLabel,
mkCmmInfoLabel,
mkCmmEntryLabel,
mkCmmRetInfoLabel,
mkCmmRetLabel,
mkCmmCodeLabel,
mkCmmDataLabel,
mkCmmGcPtrLabel,
mkRtsApFastLabel,
......@@ -164,7 +164,7 @@ data CLabel
-- | 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
......@@ -342,38 +342,30 @@ mkStaticInfoTableLabel name c = IdLabel name c StaticInfoTable
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
......@@ -740,8 +732,9 @@ idInfoLabelType info =
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
......
......@@ -23,6 +23,7 @@ import CmmProcPointZ
import CmmStackLayout
import CmmTx
import DFMonad
import Module
import FastString
import FiniteMap
import ForeignCall
......@@ -518,8 +519,8 @@ lowerSafeForeignCall state m@(MidForeignCall (Safe infotable _) _ _ _) tail = do
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 <*>
......
......@@ -20,6 +20,7 @@ import CgInfoTbls
import SMRep
import ForeignCall
import Module
import Constants
import StaticFlags
import Unique
......@@ -259,8 +260,8 @@ foreignCall uniques call results arguments =
-- 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.
......
......@@ -3,6 +3,8 @@
-- (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.
--
-----------------------------------------------------------------------------
......@@ -16,7 +18,8 @@
module CmmParse ( parseCmmFile ) where
import CgMonad
import CgMonad hiding (getDynFlags)
import CgExtCode
import CgHeapery
import CgUtils
import CgProf
......@@ -40,6 +43,7 @@ import SMRep
import Lexer
import ForeignCall
import Module
import Literal
import Unique
import UniqFM
......@@ -54,6 +58,7 @@ import Constants
import Outputable
import BasicTypes
import Bag ( emptyBag, unitBag )
import Var
import Control.Monad
import Data.Array
......@@ -166,8 +171,9 @@ cmmtop :: { ExtCode }
| 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
......@@ -190,7 +196,10 @@ statics :: { [ExtFCode [CmmStatic]] }
-- 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
......@@ -235,29 +244,33 @@ cmmproc :: { ExtCode }
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
......@@ -270,8 +283,9 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
-- 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))
......@@ -282,35 +296,39 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
| '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) }
......@@ -322,12 +340,25 @@ body :: { ExtCode }
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 }
......@@ -768,110 +799,6 @@ stmtMacros = listToUFM [
]
-- -----------------------------------------------------------------------------
-- 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
......@@ -884,10 +811,10 @@ 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
......
......@@ -45,6 +45,7 @@ import Name
import Bitmap
import Util
import StaticFlags
import Module
import FastString
import Outputable
import Unique
......@@ -224,7 +225,7 @@ slowArgs :: [(CgRep,CmmExpr)] -> [(CgRep,CmmExpr)]
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)])
......
......@@ -560,7 +560,7 @@ link_caf cl_info _is_upd = do
-- 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
......
......@@ -46,6 +46,7 @@ import PrelInfo
import Outputable
import ListSetOps
import Util
import Module
import FastString
import StaticFlags
\end{code}
......@@ -170,7 +171,7 @@ buildDynCon binder _ con [arg_amode]
, (_, 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)
......@@ -181,7 +182,7 @@ buildDynCon binder _ con [arg_amode]
, (_, 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)
......
-- | 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