%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgClosure.lhs,v 1.23 1999/01/21 10:31:55 simonm Exp $
+% $Id: CgClosure.lhs,v 1.24 1999/03/02 14:34:36 sof Exp $
%
\section[CgClosure]{Code generation for closures}
import CmdLineOpts ( opt_GranMacros, opt_SccProfilingOn )
import CostCentre
import Id ( Id, idName, idType, idPrimRep )
-import Name ( Name, Module, pprModule )
+import Name ( Name )
+import Module ( Module, pprModule )
import ListSetOps ( minusList )
import PrimRep ( PrimRep(..) )
import PprType ( showTypeCategory )
isUnboxedTupleCon )
import MkId ( mkDataConId )
import Id ( Id, idName, idType, idPrimRep )
-import Const ( Con(..), Literal(..) )
+import Name ( nameModule, isLocallyDefinedName )
+import Module ( isDynamicModule )
+import Const ( Con(..), Literal(..), isLitLitLit )
import PrelInfo ( maybeCharLikeCon, maybeIntLikeCon )
import PrimRep ( PrimRep(..) )
import BasicTypes ( TopLevelFlag(..) )
import Util
-import Panic ( assertPanic )
+import Panic ( assertPanic, trace )
\end{code}
%************************************************************************
-> [StgArg] -- Args
-> Bool -- All zero-size args (see buildDynCon)
-> FCode (Id, CgIdInfo)
-\end{code}
-
-Special Case: Constructors some of whose arguments are of \tr{Double#}
-type, {\em or} which are ``lit lits'' (which are given \tr{Addr#}
-type).
-
-These ones have to be compiled as re-entrant thunks rather than
-closures, because we can't figure out a way to persuade C to allow us
-to initialise a static closure with Doubles! Thus, for \tr{x = 2.0}
-(defaults to Double), we get:
-
-\begin{verbatim}
--- The STG syntax:
- Main.x = MkDouble [2.0##]
-
--- C Code:
-
--- closure:
- SET_STATIC_HDR(Main_x_closure,Main_x_static,CC_DATA,,EXTDATA_RO)
- };
--- its *own* info table:
- STATIC_INFO_TABLE(Main_x,Main_x_entry,,,,EXTFUN,???,":MkDouble","Double");
--- with its *own* entry code:
- STGFUN(Main_x_entry) {
- P_ u1701;
- RetDouble1=2.0;
- u1701=(P_)*SpB;
- SpB=SpB-1;
- JMP_(u1701[0]);
- }
-\end{verbatim}
-
-The above has the down side that each floating-point constant will end
-up with its own info table (rather than sharing the MkFloat/MkDouble
-ones). On the plus side, however, it does return a value (\tr{2.0})
-{\em straight away}.
-
-Here, then is the implementation: just pretend it's a non-updatable
-thunk. That is, instead of
-
- x = D# 3.455#
-
-pretend we've seen
-
- x = [] \n [] -> D# 3.455#
-
-\begin{code}
-top_ccc = mkCCostCentreStack dontCareCCS -- because it's static data
-
-cgTopRhsCon bndr con args all_zero_size_args
- | any isLitLitArg args
- = cgTopRhsClosure bndr dontCareCCS NoStgBinderInfo NoSRT [] body lf_info
- where
- body = StgCon (DataCon con) args rhs_ty
- lf_info = mkClosureLFInfo bndr TopLevel [] ReEntrant []
- rhs_ty = idType bndr
-\end{code}
-
-OK, so now we have the general case.
-
-\begin{code}
cgTopRhsCon id con args all_zero_size_args
- = (
+ = ASSERT(not (any_litlit_args || dynamic_con_or_args))
+ (
-- LAY IT OUT
getArgAmodes args `thenFC` \ amodes ->
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.
+ any_litlit_args = any isLitLitArg args
+ dynamic_con_or_args = dynamic_con || any (isDynamic) args
+
+ dynamic_con = isDynName (dataConName con)
+
+ isDynName nm =
+ not (isLocallyDefinedName nm) &&
+ isDynamicModule (nameModule nm)
+
+ {-
+ Do any of the arguments refer to something in a DLL?
+ -}
+ isDynamic (StgVarArg v) = isDynName (idName v)
+ isDynamic (StgConArg c) =
+ case c of
+ DataCon dc -> isDynName (dataConName dc)
+ Literal l -> isLitLitLit l -- all bets are off if it is.
+ _ -> False
+
+
\end{code}
%************************************************************************
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgMonad.lhs,v 1.17 1999/01/06 11:35:27 simonm Exp $
+% $Id: CgMonad.lhs,v 1.18 1999/03/02 14:34:38 sof Exp $
%
\section[CgMonad]{The code generation monad}
import AbsCUtils ( mkAbsCStmts )
import CmdLineOpts ( opt_SccProfilingOn, opt_DoTickyProfiling )
import CLabel ( CLabel, mkUpdEntryLabel )
-import OccName ( Module )
+import Module ( Module )
import DataCon ( ConTag )
import Id ( Id )
import VarEnv
import CostCentre ( CostCentre, CostCentreStack )
import FiniteMap ( FiniteMap )
import Id ( Id, idName )
-import Name ( Module, moduleString )
+import Module ( Module, moduleString )
import PrimRep ( getPrimRepSize, PrimRep(..) )
import Type ( Type )
import TyCon ( TyCon )
import VarSet
import VarEnv
import IdInfo ( exactArity )
-import Name ( Module, mkTopName )
+import Module ( Module )
+import Name ( mkTopName )
import Type ( splitForAllTys, mkForAllTys, mkFunTys, Type )
import UniqSupply ( uniqFromSupply, splitUniqSupply, UniqSupply )
import Util ( zipEqual )
module SRT where
import Id ( Id, setIdCafInfo, getIdCafInfo, externallyVisibleId,
- idAppIsBottom )
+ idAppIsBottom
+ )
import IdInfo ( CafInfo(..) )
import StgSyn
-- don't output an SRT for the constructor, but just remember
-- whether it had any caf references or not.
- StgRhsCon _ _ _ -> (StgNonRec binder' rhs, [], rho')
+ StgRhsCon _ _ _ -> (StgNonRec binder' rhs, [], rho')
srtTopBind rho (StgRec bs) =
| null srt = NoCafRefs -- function w/ no static references
| otherwise = MayHaveCafRefs -- function w/ some static references
-mk_caf_info (StgRhsCon cc con args) srt
- | null srt = NoCafRefs -- constructor w/ no static references
- | otherwise = MayHaveCafRefs -- otherwise, treat as a CAF
+mk_caf_info rcon@(StgRhsCon cc con args) srt
+ | null srt = NoCafRefs -- constructor w/ no static references
+ | otherwise = MayHaveCafRefs -- otherwise, treat as a CAF
+
isBottomingExpr (StgLet bind expr) = isBottomingExpr expr
isBottomingExpr (StgApp f args) = idAppIsBottom f (length args)
StgToDo(..)
)
import Id ( Id )
-import OccName ( Module, moduleString )
+import Module ( Module, moduleString )
import VarEnv
import ErrUtils ( doIfSet )
import UniqSupply ( splitUniqSupply, UniqSupply )
import SimplUtils ( findDefault )
import CostCentre ( noCCS )
import Id ( Id, mkSysLocal, idType,
- externallyVisibleId, setIdUnique
+ externallyVisibleId, setIdUnique, idName
)
+import DataCon ( DataCon, dataConName, dataConId )
+import Name ( Name, nameModule, isLocallyDefinedName )
+import Module ( isDynamicModule )
+import Const ( Con(..), Literal, isLitLitLit )
import VarEnv
import Const ( Con(..), isWHNFCon, Literal(..) )
import PrimOp ( PrimOp(..) )
-- incoming rhs. Why? Because trivial bindings might conceal
-- what the rhs is actually like.
-exprToRhs (StgCon (DataCon con) args _) = StgRhsCon noCCS con args
+{-
+ We reject the following candidates for 'static constructor'dom:
+
+ - any dcon that takes a lit-lit as an arg.
+ - [Win32 DLLs only]: any dcon that is (or takes as arg)
+ that's living in a DLL.
+
+ These constraints are necessary to ensure that the code
+ generated in the end for the static constructors, which
+ live in the data segment, remain valid - i.e., it has to
+ be constant. For obvious reasons, that's hard to guarantee
+ with lit-lits. The second case of a constructor referring
+ to static closures hiding out in some DLL is an artifact
+ of the way Win32 DLLs handle global DLL variables. A (data)
+ symbol exported from a DLL has to be accessed through a
+ level of indirection at the site of use, so whereas
+
+ extern StgClosure y_closure;
+ extern StgClosure z_closure;
+ x = { ..., &y_closure, &z_closure };
+
+ is legal when the symbols are in scope at link-time, it is
+ not when y_closure is in a DLL. So, any potential static
+ closures that refers to stuff that's residing in a DLL
+ will be put in an (updateable) thunk instead.
+
+ An alternative strategy is to support the generation of
+ constructors (ala C++ static class constructors) which will
+ then be run at load time to fix up static closures.
+-}
+exprToRhs (StgCon (DataCon con) args _)
+ | not is_dynamic &&
+ all (not.is_lit_lit) args = StgRhsCon noCCS con args
+ where
+ is_dynamic = isDynCon con || any (isDynArg) args
+
+ is_lit_lit (StgVarArg _) = False
+ is_lit_lit (StgConArg x) =
+ case x of
+ Literal l -> isLitLitLit l
+ _ -> False
exprToRhs expr
= StgRhsClosure noCCS -- No cost centre (ToDo?)
stgArgOcc -- safe
noSRT -- figure out later
bOGUS_FVs
+
Updatable -- Be pessimistic
[]
expr
+isDynCon :: DataCon -> Bool
+isDynCon con = isDynName (dataConName con)
+
+isDynArg :: StgArg -> Bool
+isDynArg (StgVarArg v) = isDynName (idName v)
+isDynArg (StgConArg con) =
+ case con of
+ DataCon dc -> isDynCon dc
+ Literal l -> isLitLitLit l
+ _ -> False
+
+isDynName :: Name -> Bool
+isDynName nm =
+ not (isLocallyDefinedName nm) &&
+ isDynamicModule (nameModule nm)
+
+
\end{code}
projects / ghc-hetmet.git / commitdiff