import ClosureInfo ( mkLFImported, mkLFArgument, LambdaFormInfo )
import BitSet ( mkBS, emptyBS )
import PrimRep ( isFollowableRep, getPrimRepSize )
-import Id ( Id, idPrimRep, idType, isDataConWrapId )
+import Id ( Id, idPrimRep, idType )
import Type ( typePrimRep )
import VarEnv
import VarSet ( varSetElems )
I {\em think} all looking-up is done through @getCAddrMode(s)@.
\begin{code}
-getCAddrModeAndInfo :: Id -> FCode (CAddrMode, LambdaFormInfo)
+getCAddrModeAndInfo :: Id -> FCode (Id, CAddrMode, LambdaFormInfo)
getCAddrModeAndInfo id
- | not (isLocalName name) || isDataConWrapId id
- -- Why the isDataConWrapId? Because CoreToStg changes a call to
- -- a nullary constructor worker fn to a call to its wrapper,
- -- which may not be defined until later
-
- {- -- OLD: the unpack stuff isn't injected now Jan 2000
- Why the "isWiredInName"?
- Imagine you are compiling PrelBase.hs (a module that
- supplies some of the wired-in values). What can
- happen is that the compiler will inject calls to
- (e.g.) GHCbase.unpackPS, where-ever it likes -- it
- assumes those values are ubiquitously available.
- The main point is: it may inject calls to them earlier
- in GHCbase.hs than the actual definition...
- -}
- = returnFC (global_amode, mkLFImported id)
+ | not (isLocalName name)
+ = returnFC (id, global_amode, mkLFImported id)
+ -- deals with imported or locally defined but externally visible ids
+ -- (CoreTidy makes all these into global names).
| otherwise = -- *might* be a nested defn: in any case, it's something whose
-- definition we will know about...
- lookupBindC id `thenFC` \ (MkCgIdInfo _ volatile_loc stable_loc lf_info) ->
+ lookupBindC id `thenFC` \ (MkCgIdInfo id' volatile_loc stable_loc lf_info) ->
idInfoPiecesToAmode kind volatile_loc stable_loc `thenFC` \ amode ->
- returnFC (amode, lf_info)
+ returnFC (id', amode, lf_info)
where
name = getName id
global_amode = CLbl (mkClosureLabel name) kind
getCAddrMode :: Id -> FCode CAddrMode
getCAddrMode name
- = getCAddrModeAndInfo name `thenFC` \ (amode, _) ->
+ = getCAddrModeAndInfo name `thenFC` \ (_, amode, _) ->
returnFC amode
\end{code}
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgCase.lhs,v 1.50 2000/11/15 14:37:08 simonpj Exp $
+% $Id: CgCase.lhs,v 1.51 2000/12/06 13:19:49 simonmar Exp $
%
%********************************************************
%* *
import CgUpdate ( reserveSeqFrame )
import CgBindery ( getVolatileRegs, getArgAmodes,
bindNewToReg, bindNewToTemp,
- bindNewPrimToAmode,
- rebindToStack, getCAddrMode,
- getCAddrModeAndInfo, getCAddrModeIfVolatile,
+ bindNewPrimToAmode, getCAddrModeAndInfo,
+ rebindToStack, getCAddrMode, getCAddrModeIfVolatile,
buildContLivenessMask, nukeDeadBindings,
)
import CgCon ( bindConArgs, bindUnboxedTupleComponents )
\begin{code}
cgCase (StgApp fun args)
- live_in_whole_case live_in_alts bndr srt alts -- @(StgAlgAlts _ _ _)
- -- SLPJ: Surely PrimAlts is ok too?
- =
- getCAddrModeAndInfo fun `thenFC` \ (fun_amode, lf_info) ->
- getArgAmodes args `thenFC` \ arg_amodes ->
+ live_in_whole_case live_in_alts bndr srt alts
+ = getCAddrModeAndInfo fun `thenFC` \ (fun', fun_amode, lf_info) ->
+ getArgAmodes args `thenFC` \ arg_amodes ->
- -- Squish the environment
+ -- Squish the environment
nukeDeadBindings live_in_alts `thenC`
saveVolatileVarsAndRegs live_in_alts
`thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
`thenFC` \ scrut_eob_info ->
setEndOfBlockInfo (maybeReserveSeqFrame alts scrut_eob_info) $
- tailCallFun fun fun_amode lf_info arg_amodes save_assts
+ tailCallFun fun' fun_amode lf_info arg_amodes save_assts
\end{code}
Note about return addresses: we *always* push a return address, even
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgClosure.lhs,v 1.43 2000/11/06 08:15:21 simonpj Exp $
+% $Id: CgClosure.lhs,v 1.44 2000/12/06 13:19:49 simonmar Exp $
%
\section[CgClosure]{Code generation for closures}
import ClosureInfo -- lots and lots of stuff
import CmdLineOpts ( opt_GranMacros, opt_SccProfilingOn, opt_DoTickyProfiling )
import CostCentre
-import Id ( Id, idName, idType, idPrimRep )
-import Name ( Name, isLocalName )
+import Id ( Id, idName, idType, idPrimRep, setIdName )
+import Name ( Name, isLocalName, globaliseName )
import Module ( Module, pprModule )
import ListSetOps ( minusList )
import PrimRep ( PrimRep(..) )
import PprType ( showTypeCategory )
import Util ( isIn )
-import CmdLineOpts ( opt_SccProfilingOn )
+import CmdLineOpts ( opt_SccProfilingOn, opt_EnsureSplittableC )
import Outputable
import Name ( nameOccName )
-> FCode (Id, CgIdInfo)
cgTopRhsClosure id ccs binder_info args body lf_info
- = -- LAY OUT THE OBJECT
+ =
+ -- LAY OUT THE OBJECT
let
- closure_info = layOutStaticNoFVClosure name lf_info
+ name = idName id
+ closure_info = layOutStaticNoFVClosure name lf_info
+ closure_label = mkClosureLabel name
+ cg_id_info = stableAmodeIdInfo id (CLbl closure_label PtrRep) lf_info
in
-- BUILD THE OBJECT (IF NECESSARY)
) `thenC`
returnFC (id, cg_id_info)
- where
- name = idName id
- closure_label = mkClosureLabel name
- cg_id_info = stableAmodeIdInfo id (CLbl closure_label PtrRep) lf_info
+
\end{code}
%********************************************************
then fvs `minusList` [binder]
else fvs
in
- mapFCs getCAddrModeAndInfo reduced_fvs `thenFC` \ amodes_and_info ->
+ mapFCs getCAddrModeAndInfo reduced_fvs `thenFC` \ fvs_w_amodes_and_info ->
let
- fvs_w_amodes_and_info = reduced_fvs `zip` amodes_and_info
-
closure_info :: ClosureInfo
- bind_details :: [((Id, (CAddrMode, LambdaFormInfo)), VirtualHeapOffset)]
+ bind_details :: [((Id, CAddrMode, LambdaFormInfo), VirtualHeapOffset)]
(closure_info, bind_details)
= layOutDynClosure (idName binder) get_kind fvs_w_amodes_and_info lf_info
- bind_fv ((id, (_, lf_info)), offset) = bindNewToNode id offset lf_info
+ bind_fv ((id, _, lf_info), offset) = bindNewToNode id offset lf_info
- amodes_w_offsets = [(amode,offset) | ((_, (amode,_)), offset) <- bind_details]
+ amodes_w_offsets = [(amode,offset) | ((_,amode,_), offset) <- bind_details]
- get_kind (id, amode_and_info) = idPrimRep id
+ get_kind (id, _, _) = idPrimRep id
in
-- BUILD ITS INFO TABLE AND CODE
forkClosureBody (
-> [StgArg] -- Args
-> FCode (Id, CgIdInfo)
cgTopRhsCon id con args
- = ASSERT(not dynamic_con_or_args) -- checks for litlit args too
+ = ASSERT(not (isDllConApp con args)) -- checks for litlit args too
+ let
+ name = idName id
+ closure_label = mkClosureLabel name
+ lf_info = mkConLFInfo con
+ cg_id_info = stableAmodeIdInfo id (CLbl closure_label PtrRep) lf_info
+ in
+
(
-- LAY IT OUT
getArgAmodes args `thenFC` \ amodes ->
absC (CStaticClosure
closure_label -- Labelled with the name on lhs of defn
closure_info -- Closure is static
- top_ccc
+ (mkCCostCentreStack dontCareCCS) -- because it's static data
(map fst amodes_w_offsets)) -- Sorted into ptrs first, then nonptrs
) `thenC`
-- RETURN
returnFC (id, stableAmodeIdInfo id (CLbl closure_label PtrRep) lf_info)
- where
- lf_info = mkConLFInfo con
- closure_label = mkClosureLabel name
- name = idName id
-
- top_ccc = mkCCostCentreStack dontCareCCS -- because it's static data
-
- -- stuff needed by the assert pred only.
- dynamic_con_or_args = isDllConApp con args
\end{code}
%************************************************************************
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgTailCall.lhs,v 1.28 2000/11/06 08:15:21 simonpj Exp $
+% $Id: CgTailCall.lhs,v 1.29 2000/12/06 13:19:49 simonmar Exp $
%
%********************************************************
%* *
import CLabel ( mkUpdInfoLabel, mkRtsPrimOpLabel,
mkBlackHoleInfoTableLabel )
import ClosureInfo ( nodeMustPointToIt,
- getEntryConvention, EntryConvention(..),
- LambdaFormInfo
+ getEntryConvention, EntryConvention(..), LambdaFormInfo
)
import CmdLineOpts ( opt_DoSemiTagging )
import Id ( Id, idType, idName )
\end{code}
\begin{code}
-performTailCall :: Id -- Function
- -> [StgArg] -- Args
- -> Code
-
+performTailCall :: Id -> [StgArg] -> Code
performTailCall fun args
- = -- Get all the info we have about the function and args and go on to
- -- the business end
- getCAddrModeAndInfo fun `thenFC` \ (fun_amode, lf_info) ->
- getArgAmodes args `thenFC` \ arg_amodes ->
-
- tailCallFun
- fun fun_amode lf_info arg_amodes
- AbsCNop {- No pending assignments -}
-
-
--- generating code for a tail call to a function (or closure)
-
-tailCallFun :: Id -> CAddrMode -- Function and its amode
- -> LambdaFormInfo -- Info about the function
- -> [CAddrMode] -- Arguments
+ = getCAddrModeAndInfo fun `thenFC` \ (fun', fun_amode, lf_info) ->
+ getArgAmodes args `thenFC` \ arg_amodes ->
+ tailCallFun fun' fun_amode lf_info arg_amodes AbsCNop{- No pending assignments -}
+\end{code}
- -> AbstractC -- Pending simultaneous assignments
- -- *** GUARANTEED to contain only stack
- -- assignments.
+Generating code for a tail call to a function (or closure)
+\begin{code}
+tailCallFun
+ :: Id -- Function
+ -> CAddrMode
+ -> LambdaFormInfo
+ -> [CAddrMode] -- Arguments
+ -> AbstractC -- Pending simultaneous assignments
+ -- *** GUARANTEED to contain only stack
+ -- assignments.
-- In ptic, we don't need to look in
-- here to discover all live regs
-
- -> Code
+ -> Code
tailCallFun fun fun_amode lf_info arg_amodes pending_assts
= nodeMustPointToIt lf_info `thenFC` \ node_points ->
+ -- we use the name of fun', the Id from the environment, rather than
+ -- fun from the STG tree, in case it is a top-level name that we globalised
+ -- (see cgTopRhsClosure).
getEntryConvention (idName fun) lf_info
(map getAmodeRep arg_amodes) `thenFC` \ entry_conv ->
let
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: ClosureInfo.lhs,v 1.43 2000/07/14 08:14:53 simonpj Exp $
+% $Id: ClosureInfo.lhs,v 1.44 2000/12/06 13:19:49 simonmar Exp $
%
\section[ClosureInfo]{Data structures which describe closures}
-> StdEntry (mkReturnPtLabel (nameUnique name))
LFLetNoEscape arity
- -> ASSERT(arity == length arg_kinds)
+ -> if (arity /= length arg_kinds) then pprPanic "let-no-escape: " (ppr name <+> ppr arity) else
DirectEntry (mkReturnPtLabel (nameUnique name)) arity arg_regs
where
(arg_regs, _) = assignRegs [] arg_kinds
import PprAbsC ( dumpRealC )
import AbsCUtils ( mkAbstractCs, flattenAbsC )
-import CgBindery ( CgIdInfo, addBindC, addBindsC )
+import CgBindery ( CgIdInfo, addBindC, addBindsC, getCAddrModeAndInfo )
import CgClosure ( cgTopRhsClosure )
import CgCon ( cgTopRhsCon )
import CgConTbls ( genStaticConBits )
import CmdLineOpts ( DynFlags, DynFlag(..),
opt_SccProfilingOn, opt_EnsureSplittableC )
import CostCentre ( CostCentre, CostCentreStack )
-import Id ( Id, idName )
+import Id ( Id, idName, setIdName )
+import Name ( globaliseName )
import Module ( Module )
import PrimRep ( PrimRep(..) )
import TyCon ( TyCon, isDataTyCon )
; fl_uniqs <- mkSplitUniqSupply 'f'
; let
datatype_stuff = genStaticConBits cinfo data_tycons
- code_stuff = initC cinfo (cgTopBindings maybe_split stg_binds)
+ code_stuff = initC cinfo (mapCs cgTopBinding stg_binds)
init_stuff = mkModuleInit fe_binders mod_name imported_modules
cost_centre_info
- abstractC = mkAbstractCs [ maybe_split,
+ abstractC = mkAbstractCs [ maybeSplitCode,
init_stuff,
code_stuff,
datatype_stuff]
where
data_tycons = filter isDataTyCon tycons
- maybe_split = if opt_EnsureSplittableC
- then CSplitMarker
- else AbsCNop
cinfo = MkCompInfo mod_name
\end{code}
%* *
%************************************************************************
-@cgTopBindings@ is only used for top-level bindings, since they need
+@cgTopBinding@ is only used for top-level bindings, since they need
to be allocated statically (not in the heap) and need to be labelled.
No unboxed bindings can happen at top level.
variable.
\begin{code}
-cgTopBindings :: AbstractC -> [(StgBinding,[Id])] -> Code
-
-cgTopBindings split bindings = mapCs (cgTopBinding split) bindings
-
-cgTopBinding :: AbstractC -> (StgBinding,[Id]) -> Code
-
-cgTopBinding split ((StgNonRec name rhs), srt)
- = absC split `thenC`
- absC (mkSRT srt_label srt) `thenC`
+cgTopBinding :: (StgBinding,[Id]) -> Code
+cgTopBinding (StgNonRec id rhs, srt)
+ = absC maybeSplitCode `thenC`
+ maybeGlobaliseId id `thenFC` \ id' ->
+ let
+ srt_label = mkSRTLabel (idName id')
+ in
+ mkSRT srt_label srt [] `thenC`
setSRTLabel srt_label (
- cgTopRhs name rhs `thenFC` \ (name, info) ->
- addBindC name info
+ cgTopRhs id' rhs `thenFC` \ (id, info) ->
+ addBindC id info
)
- where
- srt_label = mkSRTLabel (idName name)
-cgTopBinding split ((StgRec pairs@((name,rhs):_)), srt)
- = absC split `thenC`
- absC (mkSRT srt_label srt) `thenC`
+cgTopBinding (StgRec pairs, srt)
+ = absC maybeSplitCode `thenC`
+ let
+ (bndrs, rhss) = unzip pairs
+ in
+ mapFCs maybeGlobaliseId bndrs `thenFC` \ bndrs'@(id:_) ->
+ let
+ srt_label = mkSRTLabel (idName id)
+ pairs' = zip bndrs' rhss
+ in
+ mkSRT srt_label srt bndrs' `thenC`
setSRTLabel srt_label (
- fixC (\ new_binds -> addBindsC new_binds `thenC`
- mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs
- ) `thenFC` \ new_binds ->
- addBindsC new_binds
+ fixC (\ new_binds ->
+ addBindsC new_binds `thenC`
+ mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs'
+ ) `thenFC` \ new_binds -> nopC
)
- where
- srt_label = mkSRTLabel (idName name)
-mkSRT :: CLabel -> [Id] -> AbstractC
-mkSRT lbl [] = AbsCNop
-mkSRT lbl ids = CSRT lbl (map (mkClosureLabel . idName) ids)
+mkSRT :: CLabel -> [Id] -> [Id] -> Code
+mkSRT lbl [] these = nopC
+mkSRT lbl ids these
+ = mapFCs remap ids `thenFC` \ ids ->
+ absC (CSRT lbl (map (mkClosureLabel . idName) ids))
+ where
+ -- sigh, better map all the ids against the environment in case they've
+ -- been globalised (see maybeGlobaliseId below).
+ remap id = case filter (==id) these of
+ [] -> getCAddrModeAndInfo id
+ `thenFC` \ (id, _, _) -> returnFC id
+ (id':_) -> returnFC id'
+
+-- if we're splitting the object, we need to globalise all the top-level names
+-- (and then make sure we only use the globalised one in any C label we use
+-- which refers to this name).
+maybeGlobaliseId :: Id -> FCode Id
+maybeGlobaliseId id
+ = moduleName `thenFC` \ mod ->
+ let
+ name = idName id
+
+ -- globalise the name for -split-objs, if necessary
+ real_name | opt_EnsureSplittableC = globaliseName name mod
+ | otherwise = name
+
+ id' = setIdName id real_name
+ in
+ returnFC id'
+
+maybeSplitCode
+ | opt_EnsureSplittableC = CSplitMarker
+ | otherwise = AbsCNop
-- Urgh! I tried moving the forkStatics call from the rhss of cgTopRhs
-- to enclose the listFCs in cgTopBinding, but that tickled the
-- the Id is passed along for setting up a binding...
cgTopRhs bndr (StgRhsCon cc con args)
- = forkStatics (cgTopRhsCon bndr con args)
+ = maybeGlobaliseId bndr `thenFC` \ bndr' ->
+ forkStatics (cgTopRhsCon bndr con args)
cgTopRhs bndr (StgRhsClosure cc bi srt fvs upd_flag args body)
= ASSERT(null fvs) -- There should be no free variables
let lf_info =
mkClosureLFInfo bndr TopLevel [{-no fvs-}] upd_flag args srt_label srt
in
- forkStatics (cgTopRhsClosure bndr cc bi args body lf_info)
+ maybeGlobaliseId bndr `thenFC` \ bndr' ->
+ forkStatics (cgTopRhsClosure bndr' cc bi args body lf_info)
\end{code}
projects / ghc-hetmet.git / commitdiff