import CostCentre
import Outputable
import FastString
+import DynFlags
-- -----------------------------------------------------------------------------
-- The CLabel type
Name -- definition of a particular Id or Con
IdLabelInfo
- | DynIdLabel -- like IdLabel, but in a separate package,
- Name -- and might therefore need a dynamic
- IdLabelInfo -- reference.
-
| CaseLabel -- A family of labels related to a particular
-- case expression.
{-# UNPACK #-} !Unique -- Unique says which case expression
| ModuleInitLabel
Module -- the module name
String -- its "way"
- Bool -- True <=> is in a different package
-- at some point we might want some kind of version number in
-- the module init label, to guard against compiling modules in
-- the wrong order. We can't use the interface file version however,
| PlainModuleInitLabel -- without the vesrion & way info
Module
- Bool -- True <=> is in a different package
| ModuleRegdLabel
mkLocalEntryLabel name = IdLabel name Entry
mkLocalClosureTableLabel name = IdLabel name ClosureTable
-mkClosureLabel this_pkg name
- | isDllName this_pkg name = DynIdLabel name Closure
- | otherwise = IdLabel name Closure
-
-mkInfoTableLabel this_pkg name
- | isDllName this_pkg name = DynIdLabel name InfoTable
- | otherwise = IdLabel name InfoTable
-
-mkEntryLabel this_pkg name
- | isDllName this_pkg name = DynIdLabel name Entry
- | otherwise = IdLabel name Entry
-
-mkClosureTableLabel this_pkg name
- | isDllName this_pkg name = DynIdLabel name ClosureTable
- | otherwise = IdLabel name ClosureTable
-
-mkLocalConInfoTableLabel con = IdLabel con ConInfoTable
-mkLocalConEntryLabel con = IdLabel con ConEntry
-mkLocalStaticInfoTableLabel con = IdLabel con StaticInfoTable
-mkLocalStaticConEntryLabel con = IdLabel con StaticConEntry
-
-mkConInfoTableLabel name False = IdLabel name ConInfoTable
-mkConInfoTableLabel name True = DynIdLabel name ConInfoTable
-
-mkStaticInfoTableLabel name False = IdLabel name StaticInfoTable
-mkStaticInfoTableLabel name True = DynIdLabel name StaticInfoTable
-
-mkConEntryLabel this_pkg name
- | isDllName this_pkg name = DynIdLabel name ConEntry
- | otherwise = IdLabel name ConEntry
+mkClosureLabel name = IdLabel name Closure
+mkInfoTableLabel name = IdLabel name InfoTable
+mkEntryLabel name = IdLabel name Entry
+mkClosureTableLabel name = IdLabel name ClosureTable
+mkLocalConInfoTableLabel con = IdLabel con ConInfoTable
+mkLocalConEntryLabel con = IdLabel con ConEntry
+mkLocalStaticInfoTableLabel con = IdLabel con StaticInfoTable
+mkLocalStaticConEntryLabel con = IdLabel con StaticConEntry
+mkConInfoTableLabel name = IdLabel name ConInfoTable
+mkStaticInfoTableLabel name = IdLabel name StaticInfoTable
-mkStaticConEntryLabel this_pkg name
- | isDllName this_pkg name = DynIdLabel name StaticConEntry
- | otherwise = IdLabel name StaticConEntry
+mkConEntryLabel name = IdLabel name ConEntry
+mkStaticConEntryLabel name = IdLabel name StaticConEntry
mkLargeSRTLabel uniq = LargeSRTLabel uniq
mkBitmapLabel uniq = LargeBitmapLabel uniq
mkStringLitLabel = StringLitLabel
mkAsmTempLabel = AsmTempLabel
-mkModuleInitLabel :: PackageId -> Module -> String -> CLabel
-mkModuleInitLabel this_pkg mod way
- = ModuleInitLabel mod way $! modulePackageId mod /= this_pkg
+mkModuleInitLabel :: Module -> String -> CLabel
+mkModuleInitLabel mod way = ModuleInitLabel mod way
-mkPlainModuleInitLabel :: PackageId -> Module -> CLabel
-mkPlainModuleInitLabel this_pkg mod
- = PlainModuleInitLabel mod $! modulePackageId mod /= this_pkg
+mkPlainModuleInitLabel :: Module -> CLabel
+mkPlainModuleInitLabel mod = PlainModuleInitLabel mod
-- Some fixed runtime system labels
infoLblToEntryLbl (IdLabel n InfoTable) = IdLabel n Entry
infoLblToEntryLbl (IdLabel n ConInfoTable) = IdLabel n ConEntry
infoLblToEntryLbl (IdLabel n StaticInfoTable) = IdLabel n StaticConEntry
-infoLblToEntryLbl (DynIdLabel n InfoTable) = DynIdLabel n Entry
-infoLblToEntryLbl (DynIdLabel n ConInfoTable) = DynIdLabel n ConEntry
-infoLblToEntryLbl (DynIdLabel n StaticInfoTable) = DynIdLabel n StaticConEntry
infoLblToEntryLbl (CaseLabel n CaseReturnInfo) = CaseLabel n CaseReturnPt
infoLblToEntryLbl (RtsLabel (RtsInfo s)) = RtsLabel (RtsEntry s)
infoLblToEntryLbl (RtsLabel (RtsRetInfo s)) = RtsLabel (RtsRet s)
entryLblToInfoLbl (IdLabel n Entry) = IdLabel n InfoTable
entryLblToInfoLbl (IdLabel n ConEntry) = IdLabel n ConInfoTable
entryLblToInfoLbl (IdLabel n StaticConEntry) = IdLabel n StaticInfoTable
-entryLblToInfoLbl (DynIdLabel n Entry) = DynIdLabel n InfoTable
-entryLblToInfoLbl (DynIdLabel n ConEntry) = DynIdLabel n ConInfoTable
-entryLblToInfoLbl (DynIdLabel n StaticConEntry) = DynIdLabel n StaticInfoTable
entryLblToInfoLbl (CaseLabel n CaseReturnPt) = CaseLabel n CaseReturnInfo
entryLblToInfoLbl (RtsLabel (RtsEntry s)) = RtsLabel (RtsInfo s)
entryLblToInfoLbl (RtsLabel (RtsRet s)) = RtsLabel (RtsRetInfo s)
needsCDecl (LargeSRTLabel _) = False
needsCDecl (LargeBitmapLabel _) = False
needsCDecl (IdLabel _ _) = True
-needsCDecl (DynIdLabel _ _) = True
needsCDecl (CaseLabel _ _) = True
-needsCDecl (ModuleInitLabel _ _ _) = True
-needsCDecl (PlainModuleInitLabel _ _) = True
+needsCDecl (ModuleInitLabel _ _) = True
+needsCDecl (PlainModuleInitLabel _) = True
needsCDecl ModuleRegdLabel = False
needsCDecl (StringLitLabel _) = False
externallyVisibleCLabel (CaseLabel _ _) = False
externallyVisibleCLabel (StringLitLabel _) = False
externallyVisibleCLabel (AsmTempLabel _) = False
-externallyVisibleCLabel (ModuleInitLabel _ _ _)= True
-externallyVisibleCLabel (PlainModuleInitLabel _ _)= True
+externallyVisibleCLabel (ModuleInitLabel _ _) = True
+externallyVisibleCLabel (PlainModuleInitLabel _)= True
externallyVisibleCLabel ModuleRegdLabel = False
externallyVisibleCLabel (RtsLabel _) = True
externallyVisibleCLabel (ForeignLabel _ _ _) = True
externallyVisibleCLabel (IdLabel name _) = isExternalName name
-externallyVisibleCLabel (DynIdLabel name _) = isExternalName name
externallyVisibleCLabel (CC_Label _) = True
externallyVisibleCLabel (CCS_Label _) = True
externallyVisibleCLabel (DynamicLinkerLabel _ _) = False
labelType (RtsLabel (RtsApFast _)) = CodeLabel
labelType (CaseLabel _ CaseReturnInfo) = DataLabel
labelType (CaseLabel _ _) = CodeLabel
-labelType (ModuleInitLabel _ _ _) = CodeLabel
-labelType (PlainModuleInitLabel _ _) = CodeLabel
+labelType (ModuleInitLabel _ _) = CodeLabel
+labelType (PlainModuleInitLabel _) = CodeLabel
labelType (LargeSRTLabel _) = DataLabel
labelType (LargeBitmapLabel _) = DataLabel
labelType (IdLabel _ info) = idInfoLabelType info
-labelType (DynIdLabel _ info) = idInfoLabelType info
labelType _ = DataLabel
idInfoLabelType info =
-- @labelDynamic@ returns @True@ if the label is located
-- in a DLL, be it a data reference or not.
-labelDynamic :: CLabel -> Bool
-labelDynamic lbl =
+labelDynamic :: PackageId -> CLabel -> Bool
+labelDynamic this_pkg lbl =
case lbl of
- RtsLabel _ -> not opt_Static -- i.e., is the RTS in a DLL or not?
- IdLabel n k -> False
- DynIdLabel n k -> True
+ RtsLabel _ -> not opt_Static && (this_pkg /= rtsPackageId) -- i.e., is the RTS in a DLL or not?
+ IdLabel n k -> isDllName this_pkg n
#if mingw32_TARGET_OS
ForeignLabel _ _ d -> d
#else
-- so we claim that all foreign imports come from dynamic libraries
ForeignLabel _ _ _ -> True
#endif
- ModuleInitLabel m _ dyn -> not opt_Static && dyn
- PlainModuleInitLabel m dyn -> not opt_Static && dyn
+ ModuleInitLabel m _ -> not opt_Static && this_pkg /= (modulePackageId m)
+ PlainModuleInitLabel m -> not opt_Static && this_pkg /= (modulePackageId m)
-- Note that DynamicLinkerLabels do NOT require dynamic linking themselves.
_ -> False
= ftext str
pprCLbl (IdLabel name flavor) = ppr name <> ppIdFlavor flavor
-pprCLbl (DynIdLabel name flavor) = ppr name <> ppIdFlavor flavor
pprCLbl (CC_Label cc) = ppr cc
pprCLbl (CCS_Label ccs) = ppr ccs
-pprCLbl (ModuleInitLabel mod way _)
+pprCLbl (ModuleInitLabel mod way)
= ptext SLIT("__stginit_") <> ppr mod
<> char '_' <> text way
-pprCLbl (PlainModuleInitLabel mod _)
+pprCLbl (PlainModuleInitLabel mod)
= ptext SLIT("__stginit_") <> ppr mod
pprCLbl (HpcTicksLabel mod)
| not (needsCDecl lbl) = empty
| otherwise =
hcat [ visibility, label_type (labelType lbl),
- lparen, dyn_wrapper (pprCLabel lbl), text ");" ]
+ lparen, pprCLabel lbl, text ");" ]
where
- dyn_wrapper d
- | in_srt && labelDynamic lbl = text "DLL_IMPORT_DATA_VAR" <> parens d
- | otherwise = d
-
label_type CodeLabel = ptext SLIT("F_")
label_type DataLabel = ptext SLIT("I_")
name = idName id
in
if isExternalName name then do
- this_pkg <- getThisPackage
- let ext_lbl = CmmLit (CmmLabel (mkClosureLabel this_pkg name))
+ let ext_lbl = CmmLit (CmmLabel (mkClosureLabel name))
return (stableIdInfo id ext_lbl (mkLFImported id))
else
if isVoidArg (idCgRep id) then
(do { tmp_reg <- bindNewToTemp bndr
; stmtC (CmmAssign
(CmmLocal tmp_reg)
- (tagToClosure this_pkg tycon tag_amode)) })
+ (tagToClosure tycon tag_amode)) })
-- Compile the alts
; (branches, mb_deflt) <- cgAlgAlts NoGC Nothing{-cc_slot-}
-> FCode (Id, CgIdInfo)
cgTopRhsCon id con args
= do {
- ; this_pkg <- getThisPackage
#if mingw32_TARGET_OS
-- Windows DLLs have a problem with static cross-DLL refs.
+ ; this_pkg <- getThisPackage
; ASSERT( not (isDllConApp this_pkg con args) ) return ()
#endif
; ASSERT( args `lengthIs` dataConRepArity con ) return ()
; let
name = idName id
lf_info = mkConLFInfo con
- closure_label = mkClosureLabel this_pkg name
+ closure_label = mkClosureLabel name
caffy = any stgArgHasCafRefs args
- (closure_info, amodes_w_offsets) = layOutStaticConstr this_pkg con amodes
+ (closure_info, amodes_w_offsets) = layOutStaticConstr con amodes
closure_rep = mkStaticClosureFields
closure_info
dontCareCCS -- Because it's static data
\begin{code}
buildDynCon binder cc con []
- = do this_pkg <- getThisPackage
- returnFC (taggedStableIdInfo binder
- (mkLblExpr (mkClosureLabel this_pkg (dataConName con)))
+ = returnFC (taggedStableIdInfo binder
+ (mkLblExpr (mkClosureLabel (dataConName con)))
(mkConLFInfo con)
con)
\end{code}
\begin{code}
buildDynCon binder ccs con args
= do {
- ; this_pkg <- getThisPackage
; let
- (closure_info, amodes_w_offsets) = layOutDynConstr this_pkg con args
+ (closure_info, amodes_w_offsets) = layOutDynConstr con args
; hp_off <- allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
; returnFC (taggedHeapIdInfo binder hp_off lf_info con) }
\begin{code}
bindConArgs :: DataCon -> [Id] -> Code
bindConArgs con args
- = do this_pkg <- getThisPackage
+ = do
let
-- The binding below forces the masking out of the tag bits
-- when accessing the constructor field.
bind_arg (arg, offset) = bindNewToUntagNode arg offset (mkLFArgument arg) (tagForCon con)
- (_, args_w_offsets) = layOutDynConstr this_pkg con (addIdReps args)
+ (_, args_w_offsets) = layOutDynConstr con (addIdReps args)
--
ASSERT(not (isUnboxedTupleCon con)) return ()
mapCs bind_arg args_w_offsets
cgDataCon :: DataCon -> Code
cgDataCon data_con
= do { -- Don't need any dynamic closure code for zero-arity constructors
- this_pkg <- getThisPackage
; let
-- To allow the debuggers, interpreters, etc to cope with
-- time), we take care that info-table contains the
-- information we need.
(static_cl_info, _) =
- layOutStaticConstr this_pkg data_con arg_reps
+ layOutStaticConstr data_con arg_reps
(dyn_cl_info, arg_things) =
- layOutDynConstr this_pkg data_con arg_reps
+ layOutDynConstr data_con arg_reps
emit_info cl_info ticky_code
= do { code_blks <- getCgStmts the_code
else assignNonPtrTemp amode
-- We're going to use it twice,
-- so save in a temp if non-trivial
- ; this_pkg <- getThisPackage
- ; stmtC (CmmAssign nodeReg (tagToClosure this_pkg tycon amode'))
+ ; stmtC (CmmAssign nodeReg (tagToClosure tycon amode'))
; performReturn emitReturnInstr }
where
-- If you're reading this code in the attempt to figure
= do tag_reg <- if isFollowableArg (typeCgRep res_ty)
then newPtrTemp wordRep
else newNonPtrTemp wordRep
- this_pkg <- getThisPackage
cgPrimOp [tag_reg] primop args emptyVarSet
stmtC (CmmAssign nodeReg
- (tagToClosure this_pkg tycon
+ (tagToClosure tycon
(CmmReg (CmmLocal tag_reg))))
performReturn emitReturnInstr
where
; returnFC (name, idinfo) }
cgRhs name (StgRhsClosure cc bi fvs upd_flag srt args body)
- = do this_pkg <- getThisPackage
- setSRT srt $ mkRhsClosure this_pkg name cc bi fvs upd_flag args body
+ = setSRT srt $ mkRhsClosure name cc bi fvs upd_flag args body
\end{code}
mkRhsClosure looks for two special forms of the right-hand side:
\begin{code}
-mkRhsClosure this_pkg bndr cc bi
+mkRhsClosure bndr cc bi
[the_fv] -- Just one free var
upd_flag -- Updatable thunk
[] -- A thunk
where
lf_info = mkSelectorLFInfo bndr offset_into_int
(isUpdatable upd_flag)
- (_, params_w_offsets) = layOutDynConstr this_pkg con (addIdReps params)
+ (_, params_w_offsets) = layOutDynConstr con (addIdReps params)
-- Just want the layout
maybe_offset = assocMaybe params_w_offsets selectee
Just the_offset = maybe_offset
for semi-obvious reasons.
\begin{code}
-mkRhsClosure this_pkg bndr cc bi
+mkRhsClosure bndr cc bi
fvs
upd_flag
[] -- No args; a thunk
The default case
~~~~~~~~~~~~~~~~
\begin{code}
-mkRhsClosure this_pkg bndr cc bi fvs upd_flag args body
+mkRhsClosure bndr cc bi fvs upd_flag args body
= cgRhsClosure bndr cc bi fvs upd_flag args body
\end{code}
\begin{code}
layOutDynConstr, layOutStaticConstr
- :: PackageId
- -> DataCon
+ :: DataCon
-> [(CgRep,a)]
-> (ClosureInfo,
[(a,VirtualHpOffset)])
layOutDynConstr = layOutConstr False
layOutStaticConstr = layOutConstr True
-layOutConstr is_static this_pkg data_con args
- = (mkConInfo this_pkg is_static data_con tot_wds ptr_wds,
+layOutConstr is_static data_con args
+ = (mkConInfo is_static data_con tot_wds ptr_wds,
things_w_offsets)
where
(tot_wds, -- #ptr_wds + #nonptr_wds
; EndOfBlockInfo sp _ <- getEndOfBlockInfo
; this_pkg <- getThisPackage
- ; case (getCallMethod this_pkg fun_name lf_info (length arg_amodes)) of
+ ; case (getCallMethod fun_name lf_info (length arg_amodes)) of
-- Node must always point to things we enter
EnterIt -> do
--
-------------------------------------------------------------------------
-tagToClosure :: PackageId -> TyCon -> CmmExpr -> CmmExpr
-tagToClosure this_pkg tycon tag
+tagToClosure :: TyCon -> CmmExpr -> CmmExpr
+tagToClosure tycon tag
= CmmLoad (cmmOffsetExprW closure_tbl tag) wordRep
where closure_tbl = CmmLit (CmmLabel lbl)
- lbl = mkClosureTableLabel this_pkg (tyConName tycon)
+ lbl = mkClosureTableLabel (tyConName tycon)
-------------------------------------------------------------------------
--
-- the constructor's info table), and they don't have an SRT.
| ConInfo {
closureCon :: !DataCon,
- closureSMRep :: !SMRep,
- closureDllCon :: !Bool -- is in a separate DLL
+ closureSMRep :: !SMRep
}
-- C_SRT is what StgSyn.SRT gets translated to...
name = idName id
sm_rep = chooseSMRep is_static lf_info tot_wds ptr_wds
-mkConInfo :: PackageId
- -> Bool -- Is static
+mkConInfo :: Bool -- Is static
-> DataCon
-> Int -> Int -- Total and pointer words
-> ClosureInfo
-mkConInfo this_pkg is_static data_con tot_wds ptr_wds
+mkConInfo is_static data_con tot_wds ptr_wds
= ConInfo { closureSMRep = sm_rep,
- closureCon = data_con,
- closureDllCon = isDllName this_pkg (dataConName data_con) }
+ closureCon = data_con }
where
sm_rep = chooseSMRep is_static (mkConLFInfo data_con) tot_wds ptr_wds
\end{code}
CLabel -- The code label
Int -- Its arity
-getCallMethod :: PackageId
- -> Name -- Function being applied
+getCallMethod :: Name -- Function being applied
-> LambdaFormInfo -- Its info
-> Int -- Number of available arguments
-> CallMethod
-getCallMethod this_pkg name lf_info n_args
+getCallMethod name lf_info n_args
| nodeMustPointToIt lf_info && opt_Parallel
= -- If we're parallel, then we must always enter via node.
-- The reason is that the closure may have been
-- fetched since we allocated it.
EnterIt
-getCallMethod this_pkg name (LFReEntrant _ arity _ _) n_args
+getCallMethod name (LFReEntrant _ arity _ _) n_args
| n_args == 0 = ASSERT( arity /= 0 )
ReturnIt -- No args at all
| n_args < arity = SlowCall -- Not enough args
- | otherwise = DirectEntry (enterIdLabel this_pkg name) arity
+ | otherwise = DirectEntry (enterIdLabel name) arity
-getCallMethod this_pkg name (LFCon con) n_args
+getCallMethod name (LFCon con) n_args
= ASSERT( n_args == 0 )
ReturnCon con
-getCallMethod this_pkg name (LFThunk _ _ updatable std_form_info is_fun) n_args
+getCallMethod name (LFThunk _ _ updatable std_form_info is_fun) n_args
| is_fun -- *Might* be a function, so we must "call" it (which is always safe)
= SlowCall -- We cannot just enter it [in eval/apply, the entry code
-- is the fast-entry code]
| otherwise -- Jump direct to code for single-entry thunks
= ASSERT( n_args == 0 )
- JumpToIt (thunkEntryLabel this_pkg name std_form_info updatable)
+ JumpToIt (thunkEntryLabel name std_form_info updatable)
-getCallMethod this_pkg name (LFUnknown True) n_args
+getCallMethod name (LFUnknown True) n_args
= SlowCall -- might be a function
-getCallMethod this_pkg name (LFUnknown False) n_args
+getCallMethod name (LFUnknown False) n_args
= ASSERT2 ( n_args == 0, ppr name <+> ppr n_args )
EnterIt -- Not a function
-getCallMethod this_pkg name (LFBlackHole _) n_args
+getCallMethod name (LFBlackHole _) n_args
= SlowCall -- Presumably the black hole has by now
-- been updated, but we don't know with
-- what, so we slow call it
-getCallMethod this_pkg name (LFLetNoEscape 0) n_args
+getCallMethod name (LFLetNoEscape 0) n_args
= JumpToIt (enterReturnPtLabel (nameUnique name))
-getCallMethod this_pkg name (LFLetNoEscape arity) n_args
+getCallMethod name (LFLetNoEscape arity) n_args
| n_args == arity = DirectEntry (enterReturnPtLabel (nameUnique name)) arity
| otherwise = pprPanic "let-no-escape: " (ppr name <+> ppr arity)
other -> panic "infoTableLabelFromCI"
infoTableLabelFromCI (ConInfo { closureCon = con,
- closureSMRep = rep,
- closureDllCon = dll })
- | isStaticRep rep = mkStaticInfoTableLabel name dll
- | otherwise = mkConInfoTableLabel name dll
+ closureSMRep = rep })
+ | isStaticRep rep = mkStaticInfoTableLabel name
+ | otherwise = mkConInfoTableLabel name
where
name = dataConName con
-- thunkEntryLabel is a local help function, not exported. It's used from both
-- entryLabelFromCI and getCallMethod.
-thunkEntryLabel this_pkg thunk_id (ApThunk arity) is_updatable
+thunkEntryLabel thunk_id (ApThunk arity) is_updatable
= enterApLabel is_updatable arity
-thunkEntryLabel this_pkg thunk_id (SelectorThunk offset) upd_flag
+thunkEntryLabel thunk_id (SelectorThunk offset) upd_flag
= enterSelectorLabel upd_flag offset
-thunkEntryLabel this_pkg thunk_id _ is_updatable
- = enterIdLabel this_pkg thunk_id
+thunkEntryLabel thunk_id _ is_updatable
+ = enterIdLabel thunk_id
enterApLabel is_updatable arity
| tablesNextToCode = mkApInfoTableLabel is_updatable arity
| tablesNextToCode = mkSelectorInfoLabel upd_flag offset
| otherwise = mkSelectorEntryLabel upd_flag offset
-enterIdLabel this_pkg id
- | tablesNextToCode = mkInfoTableLabel this_pkg id
- | otherwise = mkEntryLabel this_pkg id
+enterIdLabel id
+ | tablesNextToCode = mkInfoTableLabel id
+ | otherwise = mkEntryLabel id
enterLocalIdLabel id
| tablesNextToCode = mkLocalInfoTableLabel id
; code_stuff <- initC dflags this_mod $ do
{ cmm_binds <- mapM (getCmm . cgTopBinding dflags) stg_binds
; cmm_tycons <- mapM cgTyCon data_tycons
- ; cmm_init <- getCmm (mkModuleInit dflags way cost_centre_info
+ ; cmm_init <- getCmm (mkModuleInit way cost_centre_info
this_mod main_mod
foreign_stubs imported_mods hpc_info)
; return (cmm_binds ++ concat cmm_tycons ++ [cmm_init])
\begin{code}
mkModuleInit
- :: DynFlags
- -> String -- the "way"
+ :: String -- the "way"
-> CollectedCCs -- cost centre info
-> Module
-> Module -- name of the Main module
-> [Module]
-> HpcInfo
-> Code
-mkModuleInit dflags way cost_centre_info this_mod main_mod foreign_stubs imported_mods hpc_info
+mkModuleInit way cost_centre_info this_mod main_mod foreign_stubs imported_mods hpc_info
= do { -- Allocate the static boolean that records if this
-- module has been registered already
emitData Data [CmmDataLabel moduleRegdLabel,
(emitSimpleProc plain_main_init_lbl rec_descent_init)
}
where
- this_pkg = thisPackage dflags
-
- plain_init_lbl = mkPlainModuleInitLabel this_pkg this_mod
- real_init_lbl = mkModuleInitLabel this_pkg this_mod way
- plain_main_init_lbl = mkPlainModuleInitLabel this_pkg rOOT_MAIN
+ plain_init_lbl = mkPlainModuleInitLabel this_mod
+ real_init_lbl = mkModuleInitLabel this_mod way
+ plain_main_init_lbl = mkPlainModuleInitLabel rOOT_MAIN
jump_to_init = stmtC (CmmJump (mkLblExpr real_init_lbl) [])
; whenC (opt_Hpc) $
initHpc this_mod hpc_info
- ; mapCs (registerModuleImport this_pkg way)
+ ; mapCs (registerModuleImport way)
(imported_mods++extra_imported_mods)
}
else ret_code
-----------------------
-registerModuleImport :: PackageId -> String -> Module -> Code
-registerModuleImport this_pkg way mod
+registerModuleImport :: String -> Module -> Code
+registerModuleImport way mod
| mod == gHC_PRIM
= nopC
| otherwise -- Push the init procedure onto the work stack
= stmtsC [ CmmAssign spReg (cmmRegOffW spReg (-1))
- , CmmStore (CmmReg spReg) (mkLblExpr (mkModuleInitLabel this_pkg mod way)) ]
+ , CmmStore (CmmReg spReg) (mkLblExpr (mkModuleInitLabel mod way)) ]
\end{code}
cgTopBinding :: DynFlags -> (StgBinding,[(Id,[Id])]) -> Code
cgTopBinding dflags (StgNonRec id rhs, srts)
= do { id' <- maybeExternaliseId dflags id
- ; mapM_ (mkSRT (thisPackage dflags) [id']) srts
+ ; mapM_ (mkSRT [id']) srts
; (id,info) <- cgTopRhs id' rhs
; addBindC id info -- Add the *un-externalised* Id to the envt,
-- so we find it when we look up occurrences
= do { let (bndrs, rhss) = unzip pairs
; bndrs' <- mapFCs (maybeExternaliseId dflags) bndrs
; let pairs' = zip bndrs' rhss
- ; mapM_ (mkSRT (thisPackage dflags) bndrs') srts
+ ; mapM_ (mkSRT bndrs') srts
; _new_binds <- fixC (\ new_binds -> do
{ addBindsC new_binds
; mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs' })
; nopC }
-mkSRT :: PackageId -> [Id] -> (Id,[Id]) -> Code
-mkSRT this_pkg these (id,[]) = nopC
-mkSRT this_pkg these (id,ids)
+mkSRT :: [Id] -> (Id,[Id]) -> Code
+mkSRT these (id,[]) = nopC
+mkSRT these (id,ids)
= do { ids <- mapFCs remap ids
; id <- remap id
; emitRODataLits (mkSRTLabel (idName id))
- (map (CmmLabel . mkClosureLabel this_pkg . idName) ids)
+ (map (CmmLabel . mkClosureLabel . idName) ids)
}
where
-- Sigh, better map all the ids against the environment in
= {-# SCC "fixAssigns" #-}
fixAssignsTop cmm `thenUs` \ fixed_cmm ->
{-# SCC "genericOpt" #-}
- cmmToCmm fixed_cmm `bind` \ (cmm, imports) ->
+ cmmToCmm dflags fixed_cmm `bind` \ (cmm, imports) ->
(if dopt Opt_D_dump_opt_cmm dflags -- space leak avoidance
then cmm
else CmmData Text []) `bind` \ ppr_cmm ->
{-# SCC "genMachCode" #-}
- genMachCode cmm `thenUs` \ (pre_regalloc, lastMinuteImports) ->
+ genMachCode dflags cmm `thenUs` \ (pre_regalloc, lastMinuteImports) ->
{-# SCC "regAlloc" #-}
mapUs regAlloc pre_regalloc `thenUs` \ with_regs ->
{-# SCC "shortcutBranches" #-}
-- Switching between the two monads whilst carrying along the same
-- Unique supply breaks abstraction. Is that bad?
-genMachCode :: RawCmmTop -> UniqSM ([NatCmmTop], [CLabel])
+genMachCode :: DynFlags -> RawCmmTop -> UniqSM ([NatCmmTop], [CLabel])
-genMachCode cmm_top
+genMachCode dflags cmm_top
= do { initial_us <- getUs
- ; let initial_st = mkNatM_State initial_us 0
+ ; let initial_st = mkNatM_State initial_us 0 dflags
(new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top)
final_delta = natm_delta final_st
final_imports = natm_imports final_st
temp assignments, and certain assigns to mem...)
-}
-cmmToCmm :: RawCmmTop -> (RawCmmTop, [CLabel])
-cmmToCmm top@(CmmData _ _) = (top, [])
-cmmToCmm (CmmProc info lbl params blocks) = runCmmOpt $ do
+cmmToCmm :: DynFlags -> RawCmmTop -> (RawCmmTop, [CLabel])
+cmmToCmm _ top@(CmmData _ _) = (top, [])
+cmmToCmm dflags (CmmProc info lbl params blocks) = runCmmOpt dflags $ do
blocks' <- mapM cmmBlockConFold (cmmMiniInline blocks)
return $ CmmProc info lbl params blocks'
-newtype CmmOptM a = CmmOptM ([CLabel] -> (# a, [CLabel] #))
+newtype CmmOptM a = CmmOptM (([CLabel], DynFlags) -> (# a, [CLabel] #))
instance Monad CmmOptM where
- return x = CmmOptM $ \imports -> (# x,imports #)
+ return x = CmmOptM $ \(imports, _) -> (# x,imports #)
(CmmOptM f) >>= g =
- CmmOptM $ \imports ->
- case f imports of
+ CmmOptM $ \(imports, dflags) ->
+ case f (imports, dflags) of
(# x, imports' #) ->
case g x of
- CmmOptM g' -> g' imports'
+ CmmOptM g' -> g' (imports', dflags)
addImportCmmOpt :: CLabel -> CmmOptM ()
-addImportCmmOpt lbl = CmmOptM $ \imports -> (# (), lbl:imports #)
+addImportCmmOpt lbl = CmmOptM $ \(imports, dflags) -> (# (), lbl:imports #)
-runCmmOpt :: CmmOptM a -> (a, [CLabel])
-runCmmOpt (CmmOptM f) = case f [] of
+getDynFlagsCmmOpt :: CmmOptM DynFlags
+getDynFlagsCmmOpt = CmmOptM $ \(imports, dflags) -> (# dflags, imports #)
+
+runCmmOpt :: DynFlags -> CmmOptM a -> (a, [CLabel])
+runCmmOpt dflags (CmmOptM f) = case f ([], dflags) of
(# result, imports #) -> (result, imports)
cmmBlockConFold :: CmmBasicBlock -> CmmOptM CmmBasicBlock
return $ cmmMachOpFold mop args'
CmmLit (CmmLabel lbl)
- -> cmmMakeDynamicReference addImportCmmOpt referenceKind lbl
+ -> do
+ dflags <- getDynFlagsCmmOpt
+ cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
CmmLit (CmmLabelOff lbl off)
- -> do dynRef <- cmmMakeDynamicReference addImportCmmOpt referenceKind lbl
+ -> do
+ dflags <- getDynFlagsCmmOpt
+ dynRef <- cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
return $ cmmMachOpFold (MO_Add wordRep) [
dynRef,
(CmmLit $ CmmInt (fromIntegral off) wordRep)
import Constants ( wORD_SIZE )
#ifdef DEBUG
+import Outputable ( assertPanic )
import Debug.Trace ( trace )
#endif
+import Debug.Trace ( trace )
import Control.Monad ( mapAndUnzipM )
import Data.Maybe ( fromJust )
getRegister (CmmLit (CmmFloat f F32)) = do
lbl <- getNewLabelNat
- dynRef <- cmmMakeDynamicReference addImportNat DataReference lbl
+ dflags <- getDynFlagsNat
+ dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl
Amode addr addr_code <- getAmode dynRef
let code dst =
LDATA ReadOnlyData
| otherwise = do
lbl <- getNewLabelNat
- dynRef <- cmmMakeDynamicReference addImportNat DataReference lbl
+ dflags <- getDynFlagsNat
+ dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl
Amode addr addr_code <- getAmode dynRef
let code dst =
LDATA ReadOnlyData
getRegister (CmmLit (CmmFloat f frep)) = do
lbl <- getNewLabelNat
- dynRef <- cmmMakeDynamicReference addImportNat DataReference lbl
+ dflags <- getDynFlagsNat
+ dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl
Amode addr addr_code <- getAmode dynRef
let code dst =
LDATA ReadOnlyData [CmmDataLabel lbl,
-> NatM InstrBlock
outOfLineFloatOp mop res args
= do
- targetExpr <- cmmMakeDynamicReference addImportNat CallReference lbl
+ dflags <- getDynFlagsNat
+ targetExpr <- cmmMakeDynamicReference dflags addImportNat CallReference lbl
let target = CmmForeignCall targetExpr CCallConv
if localRegRep res == F64
)
outOfLineFloatOp mop =
do
- mopExpr <- cmmMakeDynamicReference addImportNat CallReference $
+ dflags <- getDynFlagsNat
+ mopExpr <- cmmMakeDynamicReference dflags addImportNat CallReference $
mkForeignLabel functionName Nothing True
let mopLabelOrExpr = case mopExpr of
CmmLit (CmmLabel lbl) -> Left lbl
outOfLineFloatOp mop =
do
- mopExpr <- cmmMakeDynamicReference addImportNat CallReference $
+ dflags <- getDynFlagsNat
+ mopExpr <- cmmMakeDynamicReference dflags addImportNat CallReference $
mkForeignLabel functionName Nothing True
let mopLabelOrExpr = case mopExpr of
CmmLit (CmmLabel lbl) -> Left lbl
= do
(reg,e_code) <- getSomeReg expr
lbl <- getNewLabelNat
- dynRef <- cmmMakeDynamicReference addImportNat DataReference lbl
+ dflags <- getDynFlagsNat
+ dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl
(tableReg,t_code) <- getSomeReg $ dynRef
let
jumpTable = map jumpTableEntryRel ids
(reg,e_code) <- getSomeReg expr
tmp <- getNewRegNat I32
lbl <- getNewLabelNat
- dynRef <- cmmMakeDynamicReference addImportNat DataReference lbl
+ dflags <- getDynFlagsNat
+ dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl
(tableReg,t_code) <- getSomeReg $ dynRef
let
jumpTable = map jumpTableEntryRel ids
lbl <- getNewLabelNat
itmp <- getNewRegNat I32
ftmp <- getNewRegNat F64
- dynRef <- cmmMakeDynamicReference addImportNat DataReference lbl
+ dflags <- getDynFlagsNat
+ dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl
Amode addr addr_code <- getAmode dynRef
let
code' dst = code `appOL` maybe_exts `appOL` toOL [
initNat, addImportNat, getUniqueNat,
mapAccumLNat, setDeltaNat, getDeltaNat,
getBlockIdNat, getNewLabelNat, getNewRegNat, getNewRegPairNat,
- getPicBaseMaybeNat, getPicBaseNat
+ getPicBaseMaybeNat, getPicBaseNat, getDynFlagsNat
) where
#include "HsVersions.h"
import MachOp ( MachRep )
import UniqSupply
import Unique ( Unique )
-
+import DynFlags
data NatM_State = NatM_State {
natm_us :: UniqSupply,
natm_delta :: Int,
natm_imports :: [(CLabel)],
- natm_pic :: Maybe Reg
+ natm_pic :: Maybe Reg,
+ natm_dflags :: DynFlags
}
newtype NatM result = NatM (NatM_State -> (result, NatM_State))
unNat (NatM a) = a
-mkNatM_State :: UniqSupply -> Int -> NatM_State
-mkNatM_State us delta = NatM_State us delta [] Nothing
+mkNatM_State :: UniqSupply -> Int -> DynFlags -> NatM_State
+mkNatM_State us delta dflags = NatM_State us delta [] Nothing dflags
initNat :: NatM_State -> NatM a -> (a, NatM_State)
initNat init_st m = case unNat m init_st of { (r,st) -> (r,st) }
return (b__3, x__2:xs__2)
getUniqueNat :: NatM Unique
-getUniqueNat = NatM $ \ (NatM_State us delta imports pic) ->
+getUniqueNat = NatM $ \ (NatM_State us delta imports pic dflags) ->
case splitUniqSupply us of
- (us1,us2) -> (uniqFromSupply us1, (NatM_State us2 delta imports pic))
+ (us1,us2) -> (uniqFromSupply us1, (NatM_State us2 delta imports pic dflags))
+
+
+getDynFlagsNat :: NatM DynFlags
+getDynFlagsNat = NatM $ \ (NatM_State us delta imports pic dflags) ->
+ (dflags, (NatM_State us delta imports pic dflags))
getDeltaNat :: NatM Int
getDeltaNat = NatM $ \ st -> (natm_delta st, st)
setDeltaNat :: Int -> NatM ()
-setDeltaNat delta = NatM $ \ (NatM_State us _ imports pic) ->
- ((), NatM_State us delta imports pic)
+setDeltaNat delta = NatM $ \ (NatM_State us _ imports pic dflags) ->
+ ((), NatM_State us delta imports pic dflags)
addImportNat :: CLabel -> NatM ()
-addImportNat imp = NatM $ \ (NatM_State us delta imports pic) ->
- ((), NatM_State us delta (imp:imports) pic)
+addImportNat imp = NatM $ \ (NatM_State us delta imports pic dflags) ->
+ ((), NatM_State us delta (imp:imports) pic dflags)
getBlockIdNat :: NatM BlockId
getBlockIdNat = do u <- getUniqueNat; return (BlockId u)
import qualified Outputable
import Panic ( panic )
+import DynFlags
-- The most important function here is cmmMakeDynamicReference.
deriving(Eq)
cmmMakeDynamicReference
- :: Monad m => (CLabel -> m ()) -- a monad & a function
+ :: Monad m => DynFlags
+ -> (CLabel -> m ()) -- a monad & a function
-- used for recording imported symbols
-> ReferenceKind -- whether this is the target of a jump
-> CLabel -- the label
-> m CmmExpr
-cmmMakeDynamicReference addImport referenceKind lbl
+cmmMakeDynamicReference dflags addImport referenceKind lbl
| Just _ <- dynamicLinkerLabelInfo lbl
= return $ CmmLit $ CmmLabel lbl -- already processed it, pass through
- | otherwise = case howToAccessLabel referenceKind lbl of
+ | otherwise = case howToAccessLabel dflags referenceKind lbl of
AccessViaStub -> do
let stub = mkDynamicLinkerLabel CodeStub lbl
addImport stub
| AccessViaSymbolPtr
| AccessDirectly
-howToAccessLabel :: ReferenceKind -> CLabel -> LabelAccessStyle
+howToAccessLabel :: DynFlags -> ReferenceKind -> CLabel -> LabelAccessStyle
#if mingw32_TARGET_OS
-- Windows
-- are imported from a DLL via an __imp_* label.
-- There are no stubs for imported code.
-howToAccessLabel _ lbl | labelDynamic lbl = AccessViaSymbolPtr
- | otherwise = AccessDirectly
+howToAccessLabel dflags _ lbl | labelDynamic (thisPackage dflags) lbl = AccessViaSymbolPtr
+ | otherwise = AccessDirectly
#elif darwin_TARGET_OS
-- Mach-O (Darwin, Mac OS X)
--
-- It is always possible to access something indirectly,
-- even when it's not necessary.
-howToAccessLabel DataReference lbl
+howToAccessLabel dflags DataReference lbl
-- data access to a dynamic library goes via a symbol pointer
- | labelDynamic lbl = AccessViaSymbolPtr
+ | labelDynamic (thisPackage dflags) lbl = AccessViaSymbolPtr
#if !x86_64_TARGET_ARCH
-- when generating PIC code, all cross-module data references must
-- dyld code stubs don't work for tailcalls because the
-- stack alignment is only right for regular calls.
-- Therefore, we have to go via a symbol pointer:
-howToAccessLabel JumpReference lbl
- | labelDynamic lbl
+howToAccessLabel dflags JumpReference lbl
+ | labelDynamic (thisPackage dflags) lbl
= AccessViaSymbolPtr
#endif
-howToAccessLabel _ lbl
+howToAccessLabel dflags _ lbl
#if !x86_64_TARGET_ARCH
-- Code stubs are the usual method of choice for imported code;
-- not needed on x86_64 because Apple's new linker, ld64, generates
-- them automatically.
- | labelDynamic lbl
+ | labelDynamic (thisPackage dflags) lbl
= AccessViaStub
#endif
| otherwise
#elif linux_TARGET_OS && powerpc64_TARGET_ARCH
-- ELF PPC64 (powerpc64-linux), AIX, MacOS 9, BeOS/PPC
-howToAccessLabel DataReference lbl = AccessViaSymbolPtr
-howToAccessLabel _ lbl = AccessDirectly -- actually, .label instead of label
+howToAccessLabel _ DataReference lbl = AccessViaSymbolPtr
+howToAccessLabel _ _ lbl = AccessDirectly -- actually, .label instead of label
#elif linux_TARGET_OS
-- ELF (Linux)
-- from position independent code. It is also required from the main program
-- when dynamic libraries containing Haskell code are used.
-howToAccessLabel _ lbl
+howToAccessLabel _ _ lbl
-- no PIC -> the dynamic linker does everything for us;
-- if we don't dynamically link to Haskell code,
-- it actually manages to do so without messing thins up.
| not opt_PIC && opt_Static = AccessDirectly
-howToAccessLabel DataReference lbl
+howToAccessLabel dflags DataReference lbl
-- A dynamic label needs to be accessed via a symbol pointer.
- | labelDynamic lbl = AccessViaSymbolPtr
+ | labelDynamic (thisPackage dflags) lbl = AccessViaSymbolPtr
#if powerpc_TARGET_ARCH
-- For PowerPC32 -fPIC, we have to access even static data
-- via a symbol pointer (see below for an explanation why
-- (AccessDirectly, because we get an implicit symbol stub)
-- and calling functions from PIC code on non-i386 platforms (via a symbol stub)
-howToAccessLabel CallReference lbl
- | labelDynamic lbl && not opt_PIC
+howToAccessLabel dflags CallReference lbl
+ | labelDynamic (thisPackage dflags) lbl && not opt_PIC
= AccessDirectly
#if !i386_TARGET_ARCH
- | labelDynamic lbl && opt_PIC
+ | labelDynamic (thisPackage dflags) lbl && opt_PIC
= AccessViaStub
#endif
-howToAccessLabel _ lbl
- | labelDynamic lbl = AccessViaSymbolPtr
+howToAccessLabel dflags _ lbl
+ | labelDynamic (thisPackage dflags) lbl = AccessViaSymbolPtr
| otherwise = AccessDirectly
#else
--
-- all other platforms
--
-howToAccessLabel _ _
+howToAccessLabel _ _ _
| not opt_PIC = AccessDirectly
| otherwise = panic "howToAccessLabel: PIC not defined for this platform"
#endif
projects / ghc-hetmet.git / commitdiff