diff options
| -rw-r--r-- | compiler/cmm/CLabel.hs | 69 | ||||
| -rw-r--r-- | compiler/cmm/CmmBuildInfoTables.hs | 5 | ||||
| -rw-r--r-- | compiler/cmm/CmmCPSGen.hs | 5 | ||||
| -rw-r--r-- | compiler/cmm/CmmParse.y | 205 | ||||
| -rw-r--r-- | compiler/codeGen/CgCallConv.hs | 3 | ||||
| -rw-r--r-- | compiler/codeGen/CgClosure.lhs | 2 | ||||
| -rw-r--r-- | compiler/codeGen/CgCon.lhs | 5 | ||||
| -rw-r--r-- | compiler/codeGen/CgExtCode.hs | 231 | ||||
| -rw-r--r-- | compiler/codeGen/CgForeignCall.hs | 5 | ||||
| -rw-r--r-- | compiler/codeGen/CgHeapery.lhs | 19 | ||||
| -rw-r--r-- | compiler/codeGen/CgMonad.lhs | 2 | ||||
| -rw-r--r-- | compiler/codeGen/CgPrimOp.hs | 3 | ||||
| -rw-r--r-- | compiler/codeGen/CgProf.hs | 18 | ||||
| -rw-r--r-- | compiler/codeGen/CgTicky.hs | 8 | ||||
| -rw-r--r-- | compiler/codeGen/CgUtils.hs | 34 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmBind.hs | 6 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmCon.hs | 5 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmHeap.hs | 13 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmPrim.hs | 3 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmProf.hs | 18 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmTicky.hs | 8 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmUtils.hs | 22 | ||||
| -rw-r--r-- | compiler/parser/Lexer.x | 13 |
23 files changed, 446 insertions, 256 deletions
diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs index 8b8a7f98e6..7dde9f9f75 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 6b0df700c2..5b6625a003 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 5d691f8e5c..a0baa51fa1 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 0783fc4ce1..c3a37b2f23 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 60f25d0686..8a1ae8be0c 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 d01b12e788..104af14754 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 886e60eed4..89a4e84400 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 0000000000..03ac75e0ba --- /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 593de4e829..809e10b875 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 8d4f7f232a..65f94d1fa2 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 af6b1ed311..83d2b72747 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 d80fb718f5..7f100e283b 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 c984e0d16a..7491334c21 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 5a885e05a7..7e8c5ca964 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 0a545432d6..75f6b19292 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 e7d5444761..5af8f341ad 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 cfac231eda..452a352bab 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 8d23ade2c7..d7eafe3dba 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 f0a2798bf1..e5ff8f73ff 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 aab9824199..944729f287 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 579544b055..3fa579b80c 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 bf452c4651..a9532e5eff 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 1037a1a589..bbdd2a1cce 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) |