summaryrefslogtreecommitdiff
path: root/ghc/compiler/codeGen
diff options
context:
space:
mode:
Diffstat (limited to 'ghc/compiler/codeGen')
-rw-r--r--ghc/compiler/codeGen/CgBindery.lhs11
-rw-r--r--ghc/compiler/codeGen/CgCase.lhs5
-rw-r--r--ghc/compiler/codeGen/CgClosure.lhs9
-rw-r--r--ghc/compiler/codeGen/CgCon.lhs97
-rw-r--r--ghc/compiler/codeGen/CgExpr.lhs24
-rw-r--r--ghc/compiler/codeGen/CgHeapery.lhs10
-rw-r--r--ghc/compiler/codeGen/CgMonad.lhs26
-rw-r--r--ghc/compiler/codeGen/CgProf.hs4
-rw-r--r--ghc/compiler/codeGen/CgTailCall.lhs5
-rw-r--r--ghc/compiler/codeGen/CgUtils.hs10
-rw-r--r--ghc/compiler/codeGen/ClosureInfo.lhs79
-rw-r--r--ghc/compiler/codeGen/CodeGen.lhs79
12 files changed, 203 insertions, 156 deletions
diff --git a/ghc/compiler/codeGen/CgBindery.lhs b/ghc/compiler/codeGen/CgBindery.lhs
index 5a953500a0..2254ff7df9 100644
--- a/ghc/compiler/codeGen/CgBindery.lhs
+++ b/ghc/compiler/codeGen/CgBindery.lhs
@@ -236,7 +236,12 @@ getCgIdInfo id
Nothing ->
-- Should be imported; make up a CgIdInfo for it
- if isExternalName name then
+ let
+ name = idName id
+ in
+ if isExternalName name then do
+ dflags <- getDynFlags
+ let ext_lbl = CmmLit (CmmLabel (mkClosureLabel dflags name))
return (stableIdInfo id ext_lbl (mkLFImported id))
else
if isVoidArg (idCgRep id) then
@@ -246,9 +251,7 @@ getCgIdInfo id
-- Bug
cgLookupPanic id
}}}}
- where
- name = idName id
- ext_lbl = CmmLit (CmmLabel (mkClosureLabel name))
+
cgLookupPanic :: Id -> FCode a
cgLookupPanic id
diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs
index bdacd27ebd..82bdec31b8 100644
--- a/ghc/compiler/codeGen/CgCase.lhs
+++ b/ghc/compiler/codeGen/CgCase.lhs
@@ -1,7 +1,7 @@
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgCase.lhs,v 1.71 2004/09/30 10:35:36 simonpj Exp $
+% $Id: CgCase.lhs,v 1.72 2004/11/26 16:19:59 simonmar Exp $
%
%********************************************************
%* *
@@ -336,9 +336,10 @@ cgInlinePrimOp primop args bndr (AlgAlt tycon) live_in_alts alts
-- Bind the default binder if necessary
-- (avoiding it avoids the assignment)
-- The deadness info is set by StgVarInfo
+ ; dflags <- getDynFlags
; whenC (not (isDeadBinder bndr))
(do { tmp_reg <- bindNewToTemp bndr
- ; stmtC (CmmAssign tmp_reg (tagToClosure tycon tag_amode)) })
+ ; stmtC (CmmAssign tmp_reg (tagToClosure dflags tycon tag_amode)) })
-- Compile the alts
; (branches, mb_deflt) <- cgAlgAlts NoGC Nothing{-cc_slot-}
diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs
index 0c6ca4b76f..0369b1ba03 100644
--- a/ghc/compiler/codeGen/CgClosure.lhs
+++ b/ghc/compiler/codeGen/CgClosure.lhs
@@ -1,7 +1,7 @@
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgClosure.lhs,v 1.64 2004/09/30 10:35:39 simonpj Exp $
+% $Id: CgClosure.lhs,v 1.65 2004/11/26 16:20:03 simonmar Exp $
%
\section[CgClosure]{Code generation for closures}
@@ -40,8 +40,7 @@ import MachOp ( MachHint(..) )
import Cmm
import CmmUtils ( CmmStmts, mkStmts, oneStmt, plusStmts, noStmts,
mkLblExpr )
-import CLabel ( mkRtsDataLabel, mkClosureLabel, mkRednCountsLabel,
- mkSlowEntryLabel, mkIndStaticInfoLabel )
+import CLabel
import StgSyn
import CmdLineOpts ( opt_DoTickyProfiling )
import CostCentre
@@ -83,7 +82,7 @@ cgTopRhsClosure id ccs binder_info srt upd_flag args body = do
; mod_name <- moduleName
; let descr = closureDescription mod_name name
closure_info = mkClosureInfo True id lf_info 0 0 srt_info descr
- closure_label = mkClosureLabel name
+ closure_label = mkLocalClosureLabel name
cg_id_info = stableIdInfo id (mkLblExpr closure_label) lf_info
closure_rep = mkStaticClosureFields closure_info ccs True []
@@ -366,7 +365,7 @@ mkSlowEntryCode cl_info reg_args
stk_adj_pop = CmmAssign spReg (cmmRegOffW spReg final_stk_offset)
stk_adj_push = CmmAssign spReg (cmmRegOffW spReg (- final_stk_offset))
- jump_to_entry = CmmJump (mkLblExpr (enterIdLabel name)) []
+ jump_to_entry = CmmJump (mkLblExpr (enterLocalIdLabel name)) []
\end{code}
diff --git a/ghc/compiler/codeGen/CgCon.lhs b/ghc/compiler/codeGen/CgCon.lhs
index 7dc5d75b41..9a9f11aa4d 100644
--- a/ghc/compiler/codeGen/CgCon.lhs
+++ b/ghc/compiler/codeGen/CgCon.lhs
@@ -35,7 +35,7 @@ import CgTailCall ( performReturn, emitKnownConReturnCode, returnUnboxedTuple )
import CgProf ( mkCCostCentreStack, ldvEnter, curCCS )
import CgTicky
import CgInfoTbls ( emitClosureCodeAndInfoTable, dataConTagZ )
-import CLabel ( mkClosureLabel, mkRtsDataLabel, mkClosureTblLabel )
+import CLabel
import ClosureInfo ( mkConLFInfo, mkLFArgument )
import CmmUtils ( mkLblExpr )
import Cmm
@@ -70,17 +70,20 @@ cgTopRhsCon :: Id -- Name of thing bound to this RHS
-> [StgArg] -- Args
-> FCode (Id, CgIdInfo)
cgTopRhsCon id con args
- = ASSERT( not (isDllConApp con args) )
- ASSERT( args `lengthIs` dataConRepArity con )
- do { -- LAY IT OUT
+ = do {
+ ; dflags <- getDynFlags
+ ; ASSERT( not (isDllConApp dflags con args) ) return ()
+ ; ASSERT( args `lengthIs` dataConRepArity con ) return ()
+
+ -- LAY IT OUT
; amodes <- getArgAmodes args
; let
name = idName id
lf_info = mkConLFInfo con
- closure_label = mkClosureLabel name
+ closure_label = mkClosureLabel dflags name
caffy = any stgArgHasCafRefs args
- (closure_info, amodes_w_offsets) = layOutStaticConstr con amodes
+ (closure_info, amodes_w_offsets) = layOutStaticConstr dflags con amodes
closure_rep = mkStaticClosureFields
closure_info
dontCareCCS -- Because it's static data
@@ -137,8 +140,9 @@ at all.
\begin{code}
buildDynCon binder cc con []
- = returnFC (stableIdInfo binder
- (mkLblExpr (mkClosureLabel (dataConName con)))
+ = do dflags <- getDynFlags
+ returnFC (stableIdInfo binder
+ (mkLblExpr (mkClosureLabel dflags (dataConName con)))
(mkConLFInfo con))
\end{code}
@@ -191,11 +195,15 @@ Now the general case.
\begin{code}
buildDynCon binder ccs con args
- = do { hp_off <- allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
+ = do {
+ ; dflags <- getDynFlags
+ ; let
+ (closure_info, amodes_w_offsets) = layOutDynConstr dflags con args
+
+ ; hp_off <- allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
; returnFC (heapIdInfo binder hp_off lf_info) }
where
lf_info = mkConLFInfo con
- (closure_info, amodes_w_offsets) = layOutDynConstr con args
use_cc -- cost-centre to stick in the object
| currentOrSubsumedCCS ccs = curCCS
@@ -220,11 +228,13 @@ found a $con$.
\begin{code}
bindConArgs :: DataCon -> [Id] -> Code
bindConArgs con args
- = ASSERT(not (isUnboxedTupleCon con))
- mapCs bind_arg args_w_offsets
- where
- bind_arg (arg, offset) = bindNewToNode arg offset (mkLFArgument arg)
- (_, args_w_offsets) = layOutDynConstr con (addIdReps args)
+ = do dflags <- getDynFlags
+ let
+ bind_arg (arg, offset) = bindNewToNode arg offset (mkLFArgument arg)
+ (_, args_w_offsets) = layOutDynConstr dflags con (addIdReps args)
+ --
+ ASSERT(not (isUnboxedTupleCon con)) return ()
+ mapCs bind_arg args_w_offsets
\end{code}
Unboxed tuples are handled slightly differently - the object is
@@ -385,9 +395,9 @@ cgTyCon tycon
-- to (say) PrelBase_$wTrue_closure, which is defined in code_stuff
; extra <-
if isEnumerationTyCon tycon then do
- tbl <- getCmm (emitRODataLits (mkClosureTblLabel
+ tbl <- getCmm (emitRODataLits (mkLocalClosureTableLabel
(tyConName tycon))
- [ CmmLabel (mkClosureLabel (dataConName con))
+ [ CmmLabel (mkLocalClosureLabel (dataConName con))
| con <- tyConDataCons tycon])
return [tbl]
else
@@ -404,32 +414,41 @@ static closure, for a constructor.
cgDataCon :: DataCon -> Code
cgDataCon data_con
= do { -- Don't need any dynamic closure code for zero-arity constructors
- whenC (not (isNullaryRepDataCon data_con))
+ dflags <- getDynFlags
+
+ ; let
+ -- To allow the debuggers, interpreters, etc to cope with
+ -- static data structures (ie those built at compile
+ -- time), we take care that info-table contains the
+ -- information we need.
+ (static_cl_info, _) =
+ layOutStaticConstr dflags data_con arg_reps
+
+ (dyn_cl_info, arg_things) =
+ layOutDynConstr dflags data_con arg_reps
+
+ emit_info cl_info ticky_code
+ = do { code_blks <- getCgStmts the_code
+ ; emitClosureCodeAndInfoTable cl_info [] code_blks }
+ where
+ the_code = do { ticky_code
+ ; ldvEnter (CmmReg nodeReg)
+ ; body_code }
+
+ arg_reps :: [(CgRep, Type)]
+ arg_reps = [(typeCgRep ty, ty) | ty <- dataConRepArgTys data_con]
+
+ body_code = do {
+ -- NB: We don't set CC when entering data (WDP 94/06)
+ tickyReturnOldCon (length arg_things)
+ ; performReturn (emitKnownConReturnCode data_con) }
+ -- noStmts: Ptr to thing already in Node
+
+ ; whenC (not (isNullaryRepDataCon data_con))
(emit_info dyn_cl_info tickyEnterDynCon)
-- Dynamic-Closure first, to reduce forward references
; emit_info static_cl_info tickyEnterStaticCon }
where
- emit_info cl_info ticky_code
- = do { code_blks <- getCgStmts the_code
- ; emitClosureCodeAndInfoTable cl_info [] code_blks }
- where
- the_code = do { ticky_code
- ; ldvEnter (CmmReg nodeReg)
- ; body_code }
-
- arg_reps :: [(CgRep, Type)]
- arg_reps = [(typeCgRep ty, ty) | ty <- dataConRepArgTys data_con]
-
- -- To allow the debuggers, interpreters, etc to cope with static
- -- data structures (ie those built at compile time), we take care that
- -- info-table contains the information we need.
- (static_cl_info, _) = layOutStaticConstr data_con arg_reps
- (dyn_cl_info, arg_things) = layOutDynConstr data_con arg_reps
-
- body_code = do { -- NB: We don't set CC when entering data (WDP 94/06)
- tickyReturnOldCon (length arg_things)
- ; performReturn (emitKnownConReturnCode data_con) }
- -- noStmts: Ptr to thing already in Node
\end{code}
diff --git a/ghc/compiler/codeGen/CgExpr.lhs b/ghc/compiler/codeGen/CgExpr.lhs
index ff405319c4..459f2c011f 100644
--- a/ghc/compiler/codeGen/CgExpr.lhs
+++ b/ghc/compiler/codeGen/CgExpr.lhs
@@ -1,7 +1,7 @@
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgExpr.lhs,v 1.60 2004/09/30 10:35:43 simonpj Exp $
+% $Id: CgExpr.lhs,v 1.61 2004/11/26 16:20:07 simonmar Exp $
%
%********************************************************
%* *
@@ -152,7 +152,8 @@ cgExpr (StgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty)
do { (_,amode) <- getArgAmode arg
; amode' <- assignTemp amode -- We're going to use it twice,
-- so save in a temp if non-trivial
- ; stmtC (CmmAssign nodeReg (tagToClosure tycon amode'))
+ ; dflags <- getDynFlags
+ ; stmtC (CmmAssign nodeReg (tagToClosure dflags tycon amode'))
; performReturn (emitAlgReturnCode tycon amode') }
where
-- If you're reading this code in the attempt to figure
@@ -184,8 +185,9 @@ cgExpr x@(StgOpApp op@(StgPrimOp primop) args res_ty)
| ReturnsAlg tycon <- result_info, isEnumerationTyCon tycon
-- c.f. cgExpr (...TagToEnumOp...)
= do tag_reg <- newTemp wordRep
+ dflags <- getDynFlags
cgPrimOp [tag_reg] primop args emptyVarSet
- stmtC (CmmAssign nodeReg (tagToClosure tycon (CmmReg tag_reg)))
+ stmtC (CmmAssign nodeReg (tagToClosure dflags tycon (CmmReg tag_reg)))
performReturn (emitAlgReturnCode tycon (CmmReg tag_reg))
where
result_info = getPrimOpResultInfo primop
@@ -280,7 +282,8 @@ cgRhs name (StgRhsCon maybe_cc con args)
; returnFC (name, idinfo) }
cgRhs name (StgRhsClosure cc bi fvs upd_flag srt args body)
- = mkRhsClosure name cc bi srt fvs upd_flag args body
+ = do dflags <- getDynFlags
+ mkRhsClosure dflags name cc bi srt fvs upd_flag args body
\end{code}
mkRhsClosure looks for two special forms of the right-hand side:
@@ -303,7 +306,7 @@ form:
\begin{code}
-mkRhsClosure bndr cc bi srt
+mkRhsClosure dflags bndr cc bi srt
[the_fv] -- Just one free var
upd_flag -- Updatable thunk
[] -- A thunk
@@ -323,9 +326,10 @@ mkRhsClosure bndr cc bi srt
-- will evaluate to.
cgStdRhsClosure bndr cc bi [the_fv] [] body lf_info [StgVarArg the_fv]
where
- lf_info = mkSelectorLFInfo bndr offset_into_int (isUpdatable upd_flag)
- (_, params_w_offsets) = layOutDynConstr con (addIdReps params)
- -- Just want the layout
+ lf_info = mkSelectorLFInfo bndr offset_into_int
+ (isUpdatable upd_flag)
+ (_, params_w_offsets) = layOutDynConstr dflags con (addIdReps params)
+ -- Just want the layout
maybe_offset = assocMaybe params_w_offsets selectee
Just the_offset = maybe_offset
offset_into_int = the_offset - fixedHdrSize
@@ -348,7 +352,7 @@ We only generate an Ap thunk if all the free variables are pointers,
for semi-obvious reasons.
\begin{code}
-mkRhsClosure bndr cc bi srt
+mkRhsClosure dflags bndr cc bi srt
fvs
upd_flag
[] -- No args; a thunk
@@ -373,7 +377,7 @@ mkRhsClosure bndr cc bi srt
The default case
~~~~~~~~~~~~~~~~
\begin{code}
-mkRhsClosure bndr cc bi srt fvs upd_flag args body
+mkRhsClosure dflags bndr cc bi srt fvs upd_flag args body
= cgRhsClosure bndr cc bi srt fvs upd_flag args body
\end{code}
diff --git a/ghc/compiler/codeGen/CgHeapery.lhs b/ghc/compiler/codeGen/CgHeapery.lhs
index 5e6c122f7c..58fbe947ac 100644
--- a/ghc/compiler/codeGen/CgHeapery.lhs
+++ b/ghc/compiler/codeGen/CgHeapery.lhs
@@ -1,7 +1,7 @@
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgHeapery.lhs,v 1.41 2004/09/30 10:35:45 simonpj Exp $
+% $Id: CgHeapery.lhs,v 1.42 2004/11/26 16:20:09 simonmar Exp $
%
\section[CgHeapery]{Heap management functions}
@@ -54,6 +54,7 @@ import TyCon ( tyConPrimRep )
import CostCentre ( CostCentreStack )
import Util ( mapAccumL, filterOut )
import Constants ( wORD_SIZE )
+import CmdLineOpts ( DynFlags )
import Outputable
import GLAEXTS
@@ -125,7 +126,8 @@ getHpRelOffset virtual_offset
\begin{code}
layOutDynConstr, layOutStaticConstr
- :: DataCon
+ :: DynFlags
+ -> DataCon
-> [(CgRep,a)]
-> (ClosureInfo,
[(a,VirtualHpOffset)])
@@ -133,8 +135,8 @@ layOutDynConstr, layOutStaticConstr
layOutDynConstr = layOutConstr False
layOutStaticConstr = layOutConstr True
-layOutConstr is_static data_con args
- = (mkConInfo is_static data_con tot_wds ptr_wds,
+layOutConstr is_static dflags data_con args
+ = (mkConInfo dflags is_static data_con tot_wds ptr_wds,
things_w_offsets)
where
(tot_wds, -- #ptr_wds + #nonptr_wds
diff --git a/ghc/compiler/codeGen/CgMonad.lhs b/ghc/compiler/codeGen/CgMonad.lhs
index f6b209672a..d9d0801a03 100644
--- a/ghc/compiler/codeGen/CgMonad.lhs
+++ b/ghc/compiler/codeGen/CgMonad.lhs
@@ -1,7 +1,7 @@
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgMonad.lhs,v 1.41 2004/09/10 14:53:47 simonmar Exp $
+% $Id: CgMonad.lhs,v 1.42 2004/11/26 16:20:10 simonmar Exp $
%
\section[CgMonad]{The code generation monad}
@@ -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,
+ getState, setState, getInfoDown, getDynFlags,
-- more localised access to monad state
getStkUsage, setStkUsage,
@@ -61,6 +61,7 @@ module CgMonad (
import {-# SOURCE #-} CgBindery ( CgBindings, nukeVolatileBinds )
+import CmdLineOpts ( DynFlags )
import Cmm
import CmmUtils ( CmmStmts, isNopStmt )
import CLabel
@@ -75,6 +76,8 @@ import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply, uniqFromSupp
import FastString
import Outputable
+import Control.Monad ( liftM )
+
infixr 9 `thenC` -- Right-associative!
infixr 9 `thenFC`
\end{code}
@@ -92,6 +95,7 @@ along.
\begin{code}
data CgInfoDownwards -- information only passed *downwards* by the monad
= MkCgInfoDown {
+ cgd_dflags :: DynFlags,
cgd_mod :: Module, -- Module being compiled
cgd_statics :: CgBindings, -- [Id -> info] : static environment
cgd_srt :: CLabel, -- label of the current SRT
@@ -99,9 +103,10 @@ data CgInfoDownwards -- information only passed *downwards* by the monad
cgd_eob :: EndOfBlockInfo -- Info for stuff to do at end of basic block:
}
-initCgInfoDown :: Module -> CgInfoDownwards
-initCgInfoDown mod
- = MkCgInfoDown { cgd_mod = mod,
+initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards
+initCgInfoDown dflags mod
+ = MkCgInfoDown { cgd_dflags = dflags,
+ cgd_mod = mod,
cgd_statics = emptyVarEnv,
cgd_srt = error "initC: srt",
cgd_ticky = mkTopTickyCtrLabel,
@@ -370,11 +375,11 @@ instance Monad FCode where
The Abstract~C is not in the environment so as to improve strictness.
\begin{code}
-initC :: Module -> FCode a -> IO a
+initC :: DynFlags -> Module -> FCode a -> IO a
-initC mod (FCode code)
+initC dflags mod (FCode code)
= do { uniqs <- mkSplitUniqSupply 'c'
- ; case code (initCgInfoDown mod) (initCgState uniqs) of
+ ; case code (initCgInfoDown dflags mod) (initCgState uniqs) of
(res, _) -> return res
}
@@ -499,6 +504,9 @@ newUnique = do
getInfoDown :: FCode CgInfoDownwards
getInfoDown = FCode $ \info_down state -> (info_down,state)
+getDynFlags :: FCode DynFlags
+getDynFlags = liftM cgd_dflags getInfoDown
+
withInfoDown :: FCode a -> CgInfoDownwards -> FCode a
withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state
@@ -646,7 +654,7 @@ forkEvalHelp :: EndOfBlockInfo -- For the body
a) -- Result of the FCode
-- A disturbingly complicated function
forkEvalHelp body_eob_info env_code body_code
- = do { info_down@(MkCgInfoDown cg_info statics srt ticky _) <- getInfoDown
+ = do { info_down <- getInfoDown
; us <- newUniqSupply
; state <- getState
; let { info_down_for_body = info_down {cgd_eob = body_eob_info}
diff --git a/ghc/compiler/codeGen/CgProf.hs b/ghc/compiler/codeGen/CgProf.hs
index 84061e41ed..d54718f495 100644
--- a/ghc/compiler/codeGen/CgProf.hs
+++ b/ghc/compiler/codeGen/CgProf.hs
@@ -43,7 +43,7 @@ import MachOp
import CmmUtils ( zeroCLit, mkIntCLit, mkLblExpr )
import CLabel ( mkCCLabel, mkCCSLabel, mkRtsDataLabel )
-import Module ( moduleNameUserString )
+import Module ( moduleUserString )
import Id ( Id )
import CostCentre
import StgSyn ( GenStgExpr(..), StgExpr )
@@ -291,7 +291,7 @@ emitCostCentreDecl
-> Code
emitCostCentreDecl cc = do
{ label <- mkStringCLit (costCentreUserName cc)
- ; modl <- mkStringCLit (moduleNameUserString (cc_mod cc))
+ ; modl <- mkStringCLit (moduleUserString (cc_mod cc))
; let
lits = [ zero, -- StgInt ccID,
label, -- char *label,
diff --git a/ghc/compiler/codeGen/CgTailCall.lhs b/ghc/compiler/codeGen/CgTailCall.lhs
index 98c075d31d..0b77823560 100644
--- a/ghc/compiler/codeGen/CgTailCall.lhs
+++ b/ghc/compiler/codeGen/CgTailCall.lhs
@@ -1,7 +1,7 @@
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgTailCall.lhs,v 1.40 2004/09/30 10:35:50 simonpj Exp $
+% $Id: CgTailCall.lhs,v 1.41 2004/11/26 16:20:12 simonmar Exp $
%
%********************************************************
%* *
@@ -118,8 +118,9 @@ performTailCall fun_info arg_amodes pending_assts
opt_node_asst | nodeMustPointToIt lf_info = node_asst
| otherwise = noStmts
; EndOfBlockInfo sp _ <- getEndOfBlockInfo
+ ; dflags <- getDynFlags
- ; case (getCallMethod fun_name lf_info (length arg_amodes)) of
+ ; case (getCallMethod dflags fun_name lf_info (length arg_amodes)) of
-- Node must always point to things we enter
EnterIt -> do
diff --git a/ghc/compiler/codeGen/CgUtils.hs b/ghc/compiler/codeGen/CgUtils.hs
index 9727fec38f..a8e9c39ae8 100644
--- a/ghc/compiler/codeGen/CgUtils.hs
+++ b/ghc/compiler/codeGen/CgUtils.hs
@@ -52,10 +52,11 @@ import CLabel ( CLabel, mkStringLitLabel )
import Digraph ( SCC(..), stronglyConnComp )
import ListSetOps ( assocDefault )
import Util ( filterOut, sortLe )
-import Char ( ord )
+import CmdLineOpts ( DynFlags )
import FastString ( LitString, FastString, unpackFS )
import Outputable
+import Char ( ord )
import DATA_BITS
import Maybe ( isNothing )
@@ -211,10 +212,11 @@ addToMemE rep ptr n
--
-------------------------------------------------------------------------
-tagToClosure :: TyCon -> CmmExpr -> CmmExpr
-tagToClosure tycon tag
+tagToClosure :: DynFlags -> TyCon -> CmmExpr -> CmmExpr
+tagToClosure dflags tycon tag
= CmmLoad (cmmOffsetExprW closure_tbl tag) wordRep
- where closure_tbl = CmmLit (CmmLabel (mkClosureTblLabel (tyConName tycon)))
+ where closure_tbl = CmmLit (CmmLabel lbl)
+ lbl = mkClosureTableLabel dflags (tyConName tycon)
-------------------------------------------------------------------------
--
diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs
index 147039b344..f1b2540526 100644
--- a/ghc/compiler/codeGen/ClosureInfo.lhs
+++ b/ghc/compiler/codeGen/ClosureInfo.lhs
@@ -33,7 +33,7 @@ module ClosureInfo (
closureSingleEntry, closureReEntrant, isConstrClosure_maybe,
closureFunInfo, isStandardFormThunk, isKnownFun,
- enterIdLabel, enterReturnPtLabel,
+ enterIdLabel, enterLocalIdLabel, enterReturnPtLabel,
nodeMustPointToIt,
CallMethod(..), getCallMethod,
@@ -61,7 +61,8 @@ import SMRep -- all of it
import CLabel
import Constants ( mIN_UPD_SIZE, mIN_SIZE_NonUpdHeapObject )
-import CmdLineOpts ( opt_SccProfilingOn, opt_OmitBlackHoling,
+import Packages ( isDllName )
+import CmdLineOpts ( DynFlags, opt_SccProfilingOn, opt_OmitBlackHoling,
opt_Parallel, opt_DoTickyProfiling,
opt_SMP )
import Id ( Id, idType, idArity, idName )
@@ -114,7 +115,8 @@ data ClosureInfo
-- the constructor's info table), and they don't have an SRT.
| ConInfo {
closureCon :: !DataCon,
- closureSMRep :: !SMRep
+ closureSMRep :: !SMRep,
+ closureDllCon :: !Bool -- is in a separate DLL
}
-- C_SRT is what StgSyn.SRT gets translated to...
@@ -318,13 +320,15 @@ mkClosureInfo is_static id lf_info tot_wds ptr_wds srt_info descr
name = idName id
sm_rep = chooseSMRep is_static lf_info tot_wds ptr_wds
-mkConInfo :: Bool -- Is static
+mkConInfo :: DynFlags
+ -> Bool -- Is static
-> DataCon
-> Int -> Int -- Total and pointer words
-> ClosureInfo
-mkConInfo is_static data_con tot_wds ptr_wds
+mkConInfo dflags is_static data_con tot_wds ptr_wds
= ConInfo { closureSMRep = sm_rep,
- closureCon = data_con }
+ closureCon = data_con,
+ closureDllCon = isDllName dflags (dataConName data_con) }
where
sm_rep = chooseSMRep is_static (mkConLFInfo data_con) tot_wds ptr_wds
\end{code}
@@ -557,29 +561,30 @@ data CallMethod
CLabel -- The code label
Int -- Its arity
-getCallMethod :: Name -- Function being applied
+getCallMethod :: DynFlags
+ -> Name -- Function being applied
-> LambdaFormInfo -- Its info
-> Int -- Number of available arguments
-> CallMethod
-getCallMethod name lf_info n_args
+getCallMethod dflags 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 name (LFReEntrant _ arity _ _) n_args
+getCallMethod dflags 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 name) arity
+ | otherwise = DirectEntry (enterIdLabel dflags name) arity
-getCallMethod name (LFCon con) n_args
+getCallMethod dflags name (LFCon con) n_args
= ASSERT( n_args == 0 )
ReturnCon con
-getCallMethod name (LFThunk _ _ updatable std_form_info is_fun) n_args
+getCallMethod dflags name (LFThunk _ _ updatable std_form_info is_fun) n_args
| is_fun -- Must always "call" a function-typed
= SlowCall -- thing, cannot just enter it [in eval/apply, the entry code
-- is the fast-entry code]
@@ -592,24 +597,24 @@ getCallMethod name (LFThunk _ _ updatable std_form_info is_fun) n_args
| otherwise -- Jump direct to code for single-entry thunks
= ASSERT( n_args == 0 )
- JumpToIt (thunkEntryLabel name std_form_info updatable)
+ JumpToIt (thunkEntryLabel dflags name std_form_info updatable)
-getCallMethod name (LFUnknown True) n_args
+getCallMethod dflags name (LFUnknown True) n_args
= SlowCall -- might be a function
-getCallMethod name (LFUnknown False) n_args
+getCallMethod dflags name (LFUnknown False) n_args
= ASSERT2 ( n_args == 0, ppr name <+> ppr n_args )
EnterIt -- Not a function
-getCallMethod name (LFBlackHole _) n_args
+getCallMethod dflags 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 name (LFLetNoEscape 0) n_args
+getCallMethod dflags name (LFLetNoEscape 0) n_args
= JumpToIt (enterReturnPtLabel (nameUnique name))
-getCallMethod name (LFLetNoEscape arity) n_args
+getCallMethod dflags name (LFLetNoEscape arity) n_args
| n_args == arity = DirectEntry (enterReturnPtLabel (nameUnique name)) arity
| otherwise = pprPanic "let-no-escape: " (ppr name <+> ppr arity)
@@ -810,35 +815,33 @@ infoTableLabelFromCI (ClosureInfo { closureName = name,
LFThunk _ _ upd_flag (ApThunk arity) _ ->
mkApInfoTableLabel upd_flag arity
- LFThunk{} -> mkInfoTableLabel name
+ LFThunk{} -> mkLocalInfoTableLabel name
- LFReEntrant _ _ _ _ -> mkInfoTableLabel name
+ LFReEntrant _ _ _ _ -> mkLocalInfoTableLabel name
other -> panic "infoTableLabelFromCI"
-infoTableLabelFromCI (ConInfo { closureCon = con, closureSMRep = rep })
- = mkConInfoPtr con rep
-
-
-mkConInfoPtr :: DataCon -> SMRep -> CLabel
-mkConInfoPtr con rep
- | isStaticRep rep = mkStaticInfoTableLabel name
- | otherwise = mkConInfoTableLabel name
+infoTableLabelFromCI (ConInfo { closureCon = con,
+ closureSMRep = rep,
+ closureDllCon = dll })
+ | isStaticRep rep = mkStaticInfoTableLabel name dll
+ | otherwise = mkConInfoTableLabel name dll
where
name = dataConName con
-closureLabelFromCI (ClosureInfo { closureName = nm }) = mkClosureLabel nm
+-- ClosureInfo for a closure (as opposed to a constructor) is always local
+closureLabelFromCI (ClosureInfo { closureName = nm }) = mkLocalClosureLabel nm
closureLabelFromCI _ = panic "closureLabelFromCI"
-- thunkEntryLabel is a local help function, not exported. It's used from both
-- entryLabelFromCI and getCallMethod.
-thunkEntryLabel thunk_id (ApThunk arity) is_updatable
+thunkEntryLabel dflags thunk_id (ApThunk arity) is_updatable
= enterApLabel is_updatable arity
-thunkEntryLabel thunk_id (SelectorThunk offset) upd_flag
+thunkEntryLabel dflags thunk_id (SelectorThunk offset) upd_flag
= enterSelectorLabel upd_flag offset
-thunkEntryLabel thunk_id _ is_updatable
- = enterIdLabel thunk_id
+thunkEntryLabel dflags thunk_id _ is_updatable
+ = enterIdLabel dflags thunk_id
enterApLabel is_updatable arity
| tablesNextToCode = mkApInfoTableLabel is_updatable arity
@@ -848,9 +851,13 @@ enterSelectorLabel upd_flag offset
| tablesNextToCode = mkSelectorInfoLabel upd_flag offset
| otherwise = mkSelectorEntryLabel upd_flag offset
-enterIdLabel id
- | tablesNextToCode = mkInfoTableLabel id
- | otherwise = mkEntryLabel id
+enterIdLabel dflags id
+ | tablesNextToCode = mkInfoTableLabel dflags id
+ | otherwise = mkEntryLabel dflags id
+
+enterLocalIdLabel id
+ | tablesNextToCode = mkLocalInfoTableLabel id
+ | otherwise = mkLocalEntryLabel id
enterReturnPtLabel name
| tablesNextToCode = mkReturnInfoLabel name
diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs
index 7ee581a45f..056fb1ef50 100644
--- a/ghc/compiler/codeGen/CodeGen.lhs
+++ b/ghc/compiler/codeGen/CodeGen.lhs
@@ -33,15 +33,14 @@ import CgClosure ( cgTopRhsClosure )
import CgCon ( cgTopRhsCon, cgTyCon )
import CgUtils ( cmmRegOffW, emitRODataLits, cmmNeWord, emitRtsCall )
-import CLabel ( mkSRTLabel, mkClosureLabel, moduleRegdLabel,
- mkPlainModuleInitLabel, mkModuleInitLabel )
+import CLabel
import Cmm
import CmmUtils ( zeroCLit, mkIntCLit, mkLblExpr )
import PprCmm ( pprCmms )
import MachOp ( wordRep, MachHint(..) )
import StgSyn
-import PrelNames ( gHC_PRIM, rOOT_MAIN, mAIN_Name, pREL_TOP_HANDLER )
+import PrelNames ( gHC_PRIM, rOOT_MAIN, mAIN, pREL_TOP_HANDLER )
import CmdLineOpts ( DynFlags, DynFlag(..), opt_EnsureSplittableC,
opt_SccProfilingOn )
@@ -51,10 +50,9 @@ import Id ( Id, idName, setIdName )
import Name ( nameSrcLoc, nameOccName, nameUnique, isInternalName, mkExternalName )
import OccName ( mkLocalOcc )
import TyCon ( isDataTyCon )
-import Module ( Module, mkModuleName )
+import Module ( Module, mkModule )
import ErrUtils ( dumpIfSet_dyn, showPass )
import Panic ( assertPanic )
-import qualified Module ( moduleName )
#ifdef DEBUG
import Outputable
@@ -86,14 +84,14 @@ codeGen dflags this_mod type_env foreign_stubs imported_mods
-- Why?
-- ; mapM_ (\x -> seq x (return ())) data_tycons
- ; code_stuff <- initC this_mod $ do
- { cmm_binds <- mapM (getCmm . cgTopBinding) stg_binds
- ; cmm_tycons <- mapM cgTyCon data_tycons
- ; cmm_init <- getCmm (mkModuleInit way cost_centre_info
- this_mod mb_main_mod
- foreign_stubs imported_mods)
- ; return (cmm_binds ++ concat cmm_tycons ++ [cmm_init])
- }
+ ; 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
+ this_mod mb_main_mod
+ foreign_stubs imported_mods)
+ ; return (cmm_binds ++ concat cmm_tycons ++ [cmm_init])
+ }
-- Put datatype_stuff after code_stuff, because the
-- datatype closure table (for enumeration types) to
-- (say) PrelBase_True_closure, which is defined in
@@ -149,14 +147,15 @@ We initialise the module tree by keeping a work-stack,
\begin{code}
mkModuleInit
- :: String -- the "way"
+ :: DynFlags
+ -> String -- the "way"
-> CollectedCCs -- cost centre info
-> Module
-> Maybe String -- Just m ==> we have flag: -main-is Foo.baz
-> ForeignStubs
-> [Module]
-> Code
-mkModuleInit way cost_centre_info this_mod mb_main_mod foreign_stubs imported_mods
+mkModuleInit dflags way cost_centre_info this_mod mb_main_mod foreign_stubs imported_mods
= do {
-- Allocate the static boolean that records if this
@@ -184,31 +183,31 @@ mkModuleInit way cost_centre_info this_mod mb_main_mod foreign_stubs imported_mo
; emitSimpleProc plain_init_lbl jump_to_init
-- When compiling the module in which the 'main' function lives,
- -- (that is, Module.moduleName this_mod == main_mod_name)
+ -- (that is, this_mod == main_mod)
-- we inject an extra stg_init procedure for stg_init_ZCMain, for the
-- RTS to invoke. We must consult the -main-is flag in case the
-- user specified a different function to Main.main
- ; whenC (Module.moduleName this_mod == main_mod_name)
+ ; whenC (this_mod == main_mod)
(emitSimpleProc plain_main_init_lbl jump_to_init)
}
where
- plain_init_lbl = mkPlainModuleInitLabel this_mod
- real_init_lbl = mkModuleInitLabel this_mod way
- plain_main_init_lbl = mkPlainModuleInitLabel rOOT_MAIN
+ plain_init_lbl = mkPlainModuleInitLabel dflags this_mod
+ real_init_lbl = mkModuleInitLabel dflags this_mod way
+ plain_main_init_lbl = mkPlainModuleInitLabel dflags rOOT_MAIN
jump_to_init = stmtC (CmmJump (mkLblExpr real_init_lbl) [])
mod_reg_val = CmmLoad (mkLblExpr moduleRegdLabel) wordRep
- main_mod_name = case mb_main_mod of
- Just mod_name -> mkModuleName mod_name
- Nothing -> mAIN_Name
+ main_mod = case mb_main_mod of
+ Just mod_name -> mkModule mod_name
+ Nothing -> mAIN
-- Main refers to GHC.TopHandler.runIO, so make sure we call the
-- init function for GHC.TopHandler.
extra_imported_mods
- | Module.moduleName this_mod == main_mod_name = [pREL_TOP_HANDLER]
- | otherwise = []
+ | this_mod == main_mod = [pREL_TOP_HANDLER]
+ | otherwise = []
mod_init_code = do
{ -- Set mod_reg to 1 to record that we've been here
@@ -217,18 +216,19 @@ mkModuleInit way cost_centre_info this_mod mb_main_mod foreign_stubs imported_mo
-- Now do local stuff
; registerForeignExports foreign_stubs
; initCostCentres cost_centre_info
- ; mapCs (registerModuleImport way) (imported_mods++extra_imported_mods)
+ ; mapCs (registerModuleImport dflags way)
+ (imported_mods++extra_imported_mods)
}
-----------------------
-registerModuleImport :: String -> Module -> Code
-registerModuleImport way mod
+registerModuleImport :: DynFlags -> String -> Module -> Code
+registerModuleImport dflags 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 mod way)) ]
+ , CmmStore (CmmReg spReg) (mkLblExpr (mkModuleInitLabel dflags mod way)) ]
-----------------------
registerForeignExports :: ForeignStubs -> Code
@@ -239,7 +239,8 @@ registerForeignExports (ForeignStubs _ _ _ fe_bndrs)
where
mk_export_register bndr
= emitRtsCall SLIT("getStablePtr")
- [ (CmmLit (CmmLabel (mkClosureLabel (idName bndr))), PtrHint) ]
+ [ (CmmLit (CmmLabel (mkLocalClosureLabel (idName bndr))),
+ PtrHint) ]
\end{code}
@@ -280,32 +281,32 @@ style, with the increasing static environment being plumbed as a state
variable.
\begin{code}
-cgTopBinding :: (StgBinding,[(Id,[Id])]) -> Code
-cgTopBinding (StgNonRec id rhs, srts)
+cgTopBinding :: DynFlags -> (StgBinding,[(Id,[Id])]) -> Code
+cgTopBinding dflags (StgNonRec id rhs, srts)
= do { id' <- maybeExternaliseId id
- ; mapM_ (mkSRT [id']) srts
+ ; mapM_ (mkSRT dflags [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
}
-cgTopBinding (StgRec pairs, srts)
+cgTopBinding dflags (StgRec pairs, srts)
= do { let (bndrs, rhss) = unzip pairs
; bndrs' <- mapFCs maybeExternaliseId bndrs
; let pairs' = zip bndrs' rhss
- ; mapM_ (mkSRT bndrs') srts
+ ; mapM_ (mkSRT dflags bndrs') srts
; new_binds <- fixC (\ new_binds -> do
{ addBindsC new_binds
; mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs' })
; nopC }
-mkSRT :: [Id] -> (Id,[Id]) -> Code
-mkSRT these (id,[]) = nopC
-mkSRT these (id,ids)
+mkSRT :: DynFlags -> [Id] -> (Id,[Id]) -> Code
+mkSRT dflags these (id,[]) = nopC
+mkSRT dflags these (id,ids)
= do { ids <- mapFCs remap ids
; id <- remap id
; emitRODataLits (mkSRTLabel (idName id))
- (map (CmmLabel . mkClosureLabel . idName) ids)
+ (map (CmmLabel . mkClosureLabel dflags . idName) ids)
}
where
-- Sigh, better map all the ids against the environment in
View Lorry Controller Status