From a02e7f40afc1aab7fe466f949f505c1d7250713d Mon Sep 17 00:00:00 2001 From: "Ben.Lippmeier@anu.edu.au" Date: Fri, 6 Nov 2009 03:05:30 +0000 Subject: [PATCH] * 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 --- compiler/cmm/CLabel.hs | 69 +++++------ compiler/cmm/CmmBuildInfoTables.hs | 5 +- compiler/cmm/CmmCPSGen.hs | 5 +- compiler/cmm/CmmParse.y | 205 +++++++++++--------------------- compiler/codeGen/CgCallConv.hs | 3 +- compiler/codeGen/CgClosure.lhs | 2 +- compiler/codeGen/CgCon.lhs | 5 +- compiler/codeGen/CgExtCode.hs | 231 ++++++++++++++++++++++++++++++++++++ compiler/codeGen/CgForeignCall.hs | 5 +- compiler/codeGen/CgHeapery.lhs | 19 +-- compiler/codeGen/CgMonad.lhs | 2 +- compiler/codeGen/CgPrimOp.hs | 3 +- compiler/codeGen/CgProf.hs | 18 +-- compiler/codeGen/CgTicky.hs | 8 +- compiler/codeGen/CgUtils.hs | 34 ++++-- compiler/codeGen/StgCmmBind.hs | 6 +- compiler/codeGen/StgCmmCon.hs | 5 +- compiler/codeGen/StgCmmHeap.hs | 13 +- compiler/codeGen/StgCmmPrim.hs | 3 +- compiler/codeGen/StgCmmProf.hs | 18 +-- compiler/codeGen/StgCmmTicky.hs | 8 +- compiler/codeGen/StgCmmUtils.hs | 22 ++-- compiler/parser/Lexer.x | 13 +- 23 files changed, 446 insertions(+), 256 deletions(-) create mode 100644 compiler/codeGen/CgExtCode.hs diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs index 8b8a7f9..7dde9f9 100644 --- a/compiler/cmm/CLabel.hs +++ b/compiler/cmm/CLabel.hs @@ -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 diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs index 6b0df70..5b6625a 100644 --- a/compiler/cmm/CmmBuildInfoTables.hs +++ b/compiler/cmm/CmmBuildInfoTables.hs @@ -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 <*> diff --git a/compiler/cmm/CmmCPSGen.hs b/compiler/cmm/CmmCPSGen.hs index 5d691f8..a0baa51 100644 --- a/compiler/cmm/CmmCPSGen.hs +++ b/compiler/cmm/CmmCPSGen.hs @@ -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. diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index 0783fc4..c3a37b2 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -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 diff --git a/compiler/codeGen/CgCallConv.hs b/compiler/codeGen/CgCallConv.hs index 60f25d0..8a1ae8b 100644 --- a/compiler/codeGen/CgCallConv.hs +++ b/compiler/codeGen/CgCallConv.hs @@ -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)]) diff --git a/compiler/codeGen/CgClosure.lhs b/compiler/codeGen/CgClosure.lhs index d01b12e..104af14 100644 --- a/compiler/codeGen/CgClosure.lhs +++ b/compiler/codeGen/CgClosure.lhs @@ -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 diff --git a/compiler/codeGen/CgCon.lhs b/compiler/codeGen/CgCon.lhs index 886e60e..89a4e84 100644 --- a/compiler/codeGen/CgCon.lhs +++ b/compiler/codeGen/CgCon.lhs @@ -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) diff --git a/compiler/codeGen/CgExtCode.hs b/compiler/codeGen/CgExtCode.hs new file mode 100644 index 0000000..03ac75e --- /dev/null +++ b/compiler/codeGen/CgExtCode.hs @@ -0,0 +1,231 @@ +-- | 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) + + diff --git a/compiler/codeGen/CgForeignCall.hs b/compiler/codeGen/CgForeignCall.hs index 593de4e..809e10b 100644 --- a/compiler/codeGen/CgForeignCall.hs +++ b/compiler/codeGen/CgForeignCall.hs @@ -33,6 +33,7 @@ import ClosureInfo import Constants import StaticFlags import Outputable +import Module import FastString import BasicTypes @@ -144,8 +145,8 @@ emitForeignCall' safety results target args vols _srt ret 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 diff --git a/compiler/codeGen/CgHeapery.lhs b/compiler/codeGen/CgHeapery.lhs index 8d4f7f2..65f94d1 100644 --- a/compiler/codeGen/CgHeapery.lhs +++ b/compiler/codeGen/CgHeapery.lhs @@ -41,6 +41,7 @@ import DataCon import TyCon import CostCentre import Util +import Module import Constants import Outputable import FastString @@ -346,7 +347,7 @@ altHeapCheck alt_type code ; 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) @@ -360,14 +361,14 @@ altHeapCheck alt_type code 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} @@ -405,7 +406,7 @@ unbxTupleHeapCheck regs ptrs nptrs fail_code 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} @@ -514,7 +515,7 @@ stkChkNodePoints bytes = 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} diff --git a/compiler/codeGen/CgMonad.lhs b/compiler/codeGen/CgMonad.lhs index af6b1ed..83d2b72 100644 --- a/compiler/codeGen/CgMonad.lhs +++ b/compiler/codeGen/CgMonad.lhs @@ -47,7 +47,7 @@ module CgMonad ( 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, diff --git a/compiler/codeGen/CgPrimOp.hs b/compiler/codeGen/CgPrimOp.hs index d80fb71..7f100e2 100644 --- a/compiler/codeGen/CgPrimOp.hs +++ b/compiler/codeGen/CgPrimOp.hs @@ -23,6 +23,7 @@ import CLabel import CmmUtils import PrimOp import SMRep +import Module import Constants import Outputable import FastString @@ -122,7 +123,7 @@ emitPrimOp [res] ParOp [arg] live 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)) diff --git a/compiler/codeGen/CgProf.hs b/compiler/codeGen/CgProf.hs index c984e0d..7491334 100644 --- a/compiler/codeGen/CgProf.hs +++ b/compiler/codeGen/CgProf.hs @@ -47,6 +47,7 @@ import CostCentre import StgSyn import StaticFlags import FastString +import Module import Constants -- Lots of field offsets import Outputable @@ -65,7 +66,7 @@ curCCS = CmmLoad curCCSAddr bWord -- 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) @@ -260,7 +261,7 @@ enterCostCentreThunk closure = 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 @@ -273,7 +274,7 @@ enter_ccs_fsub = enteringPAP 0 -- 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 @@ -389,12 +390,12 @@ emitRegisterCCS ccs = do 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 @@ -413,6 +414,7 @@ emitSetCCC cc pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> Code pushCostCentre result ccs cc = emitRtsCallWithResult result AddrHint + rtsPackageId (fsLit "PushCostCentre") [CmmHinted ccs AddrHint, CmmHinted (CmmLit (mkCCostCentre cc)) AddrHint] False @@ -479,7 +481,7 @@ ldvEnter cl_ptr 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 diff --git a/compiler/codeGen/CgTicky.hs b/compiler/codeGen/CgTicky.hs index 5a885e0..7e8c5ca 100644 --- a/compiler/codeGen/CgTicky.hs +++ b/compiler/codeGen/CgTicky.hs @@ -183,7 +183,7 @@ registerTickyCtr ctr_lbl , 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 @@ -292,9 +292,9 @@ tickyAllocHeap hp (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 @@ -309,7 +309,7 @@ addToMemLbl rep lbl n = addToMem rep (CmmLit (CmmLabel lbl)) n -- 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 diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs index 0a54543..75f6b19 100644 --- a/compiler/codeGen/CgUtils.hs +++ b/compiler/codeGen/CgUtils.hs @@ -67,6 +67,7 @@ import CmmUtils import ForeignCall import ClosureInfo import StgSyn (SRT(..)) +import Module import Literal import Digraph import ListSetOps @@ -331,28 +332,39 @@ emitIfThenElse cond then_part else_part ; 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 @@ -362,7 +374,7 @@ emitRtsCall' res fun args vols safe = do where (caller_save, caller_load) = callerSaveVolatileRegs vols target = CmmCallee fun_expr CCallConv - fun_expr = mkLblExpr (mkRtsCodeLabel fun) + fun_expr = mkLblExpr (mkCmmCodeLabel pkg fun) ----------------------------------------------------------------------------- -- diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs index e7d5444..5af8f34 100644 --- a/compiler/codeGen/StgCmmBind.hs +++ b/compiler/codeGen/StgCmmBind.hs @@ -494,8 +494,8 @@ emitBlackHoleCode is_single_entry | 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 @@ -605,7 +605,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") [(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 diff --git a/compiler/codeGen/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs index cfac231..452a352 100644 --- a/compiler/codeGen/StgCmmCon.hs +++ b/compiler/codeGen/StgCmmCon.hs @@ -30,6 +30,7 @@ import CLabel import MkZipCfgCmm (CmmAGraph, mkNop) import SMRep import CostCentre +import Module import Constants import DataCon import FastString @@ -153,7 +154,7 @@ buildDynCon binder _cc con [arg] , 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 @@ -166,7 +167,7 @@ buildDynCon binder _cc con [arg] , 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 diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs index 8d23ade..d7eafe3 100644 --- a/compiler/codeGen/StgCmmHeap.hs +++ b/compiler/codeGen/StgCmmHeap.hs @@ -40,6 +40,7 @@ import DataCon import TyCon import CostCentre import Outputable +import Module import FastString( mkFastString, FastString, fsLit ) import Constants @@ -349,8 +350,9 @@ entryHeapCheck fun arity args code 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 @@ -388,8 +390,9 @@ altHeapCheck regs code | 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 @@ -413,7 +416,7 @@ altHeapCheck regs code 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"))) diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs index f0a2798..e5ff8f7 100644 --- a/compiler/codeGen/StgCmmPrim.hs +++ b/compiler/codeGen/StgCmmPrim.hs @@ -28,6 +28,7 @@ import CmmUtils import PrimOp import SMRep import Constants +import Module import FastString import Outputable @@ -201,7 +202,7 @@ emitPrimOp [res] ParOp [arg] -- 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] diff --git a/compiler/codeGen/StgCmmProf.hs b/compiler/codeGen/StgCmmProf.hs index aab9824..944729f 100644 --- a/compiler/codeGen/StgCmmProf.hs +++ b/compiler/codeGen/StgCmmProf.hs @@ -49,6 +49,7 @@ import CostCentre import StgSyn import StaticFlags import FastString +import Module import Constants -- Lots of field offsets import Outputable @@ -73,7 +74,7 @@ curCCS = CmmLoad curCCSAddr ccsType -- 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) @@ -315,7 +316,7 @@ enterCostCentreThunk closure = 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 () @@ -328,7 +329,7 @@ enter_ccs_fsub = enteringPAP 0 -- 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 () @@ -447,12 +448,12 @@ mkRegisterCCS ccs 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 @@ -471,6 +472,7 @@ emitSetCCC cc pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode () pushCostCentre result ccs cc = emitRtsCallWithResult result AddrHint + rtsPackageId (fsLit "PushCostCentre") [(ccs,AddrHint), (CmmLit (mkCCostCentre cc), AddrHint)] False @@ -538,7 +540,7 @@ ldvEnter cl_ptr 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 diff --git a/compiler/codeGen/StgCmmTicky.hs b/compiler/codeGen/StgCmmTicky.hs index 579544b..3fa579b 100644 --- a/compiler/codeGen/StgCmmTicky.hs +++ b/compiler/codeGen/StgCmmTicky.hs @@ -187,7 +187,7 @@ registerTickyCtr ctr_lbl , 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 @@ -317,9 +317,9 @@ tickyAllocHeap hp (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 @@ -331,7 +331,7 @@ ifTicky code = do dflags <- getDynFlags -- 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 diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs index bf452c4..a9532e5 100644 --- a/compiler/codeGen/StgCmmUtils.hs +++ b/compiler/codeGen/StgCmmUtils.hs @@ -62,6 +62,7 @@ import TyCon import Constants import SMRep import StgSyn ( SRT(..) ) +import Module import Literal import Digraph import ListSetOps @@ -283,28 +284,29 @@ tagToClosure tycon tag -- ------------------------------------------------------------------------- -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 @@ -320,7 +322,7 @@ emitRtsCall' res fun args _vols safe (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) ----------------------------------------------------------------------------- diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 1037a1a..bbdd2a1 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -46,9 +46,9 @@ 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, @@ -64,6 +64,7 @@ import FastString import SrcLoc import UniqFM import DynFlags +import Module import Ctype import Util ( readRational ) @@ -1515,6 +1516,14 @@ failSpanMsgP span msg = P $ \_ -> PFailed span msg 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) -- 1.7.10.4