From dc7d7a2f55bfd830755aa7040f93f07f3e72ac1e Mon Sep 17 00:00:00 2001 From: sof Date: Tue, 2 Mar 1999 14:34:38 +0000 Subject: [PATCH] [project @ 1999-03-02 14:34:33 by sof] - import list tweaks - moved the code that decides that a StgCon really shouldn't be mapped to a static constructor but an updateable thunk if it contains lit-lits from the codegen into the CoreToStg translation. Added an extra case to this code to deal with StgCon's that contain references to values that reside in a DLL, where we also have to opt for an updateable thunk instead of a static constructor. Only applies when compiling on/for Win32 platforms. --- ghc/compiler/codeGen/CgClosure.lhs | 5 +- ghc/compiler/codeGen/CgCon.lhs | 94 +++++++++++----------------------- ghc/compiler/codeGen/CgMonad.lhs | 4 +- ghc/compiler/codeGen/CodeGen.lhs | 2 +- ghc/compiler/simplStg/LambdaLift.lhs | 3 +- ghc/compiler/simplStg/SRT.lhs | 12 +++-- ghc/compiler/simplStg/SimplStg.lhs | 2 +- ghc/compiler/stgSyn/CoreToStg.lhs | 66 +++++++++++++++++++++++- 8 files changed, 110 insertions(+), 78 deletions(-) diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs index 6721172..c1ddff2 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.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} @@ -47,7 +47,8 @@ import ClosureInfo -- lots and lots of stuff 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 ) diff --git a/ghc/compiler/codeGen/CgCon.lhs b/ghc/compiler/codeGen/CgCon.lhs index 0a9a76d..35dcdc2 100644 --- a/ghc/compiler/codeGen/CgCon.lhs +++ b/ghc/compiler/codeGen/CgCon.lhs @@ -45,12 +45,14 @@ import DataCon ( DataCon, dataConName, dataConTag, dataConTyCon, 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} %************************************************************************ @@ -65,69 +67,9 @@ cgTopRhsCon :: Id -- Name of thing bound to this RHS -> [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 -> @@ -152,6 +94,30 @@ cgTopRhsCon id con args all_zero_size_args 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} %************************************************************************ diff --git a/ghc/compiler/codeGen/CgMonad.lhs b/ghc/compiler/codeGen/CgMonad.lhs index a9b6e41..c3e0295 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.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} @@ -50,7 +50,7 @@ import AbsCSyn 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 diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs index 6bd024d..6d38827 100644 --- a/ghc/compiler/codeGen/CodeGen.lhs +++ b/ghc/compiler/codeGen/CodeGen.lhs @@ -36,7 +36,7 @@ import CmdLineOpts ( opt_SccProfilingOn, opt_EnsureSplittableC, 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 ) diff --git a/ghc/compiler/simplStg/LambdaLift.lhs b/ghc/compiler/simplStg/LambdaLift.lhs index 3340b8a..837293b 100644 --- a/ghc/compiler/simplStg/LambdaLift.lhs +++ b/ghc/compiler/simplStg/LambdaLift.lhs @@ -15,7 +15,8 @@ import Id ( mkUserId, idType, setIdArity, Id ) 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 ) diff --git a/ghc/compiler/simplStg/SRT.lhs b/ghc/compiler/simplStg/SRT.lhs index c699fd3..00c31f5 100644 --- a/ghc/compiler/simplStg/SRT.lhs +++ b/ghc/compiler/simplStg/SRT.lhs @@ -10,7 +10,8 @@ bindings have no CAF references, and record the fact in their IdInfo. module SRT where import Id ( Id, setIdCafInfo, getIdCafInfo, externallyVisibleId, - idAppIsBottom ) + idAppIsBottom + ) import IdInfo ( CafInfo(..) ) import StgSyn @@ -126,7 +127,7 @@ srtTopBind rho (StgNonRec binder rhs) = -- 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) = @@ -391,9 +392,10 @@ mk_caf_info (StgRhsClosure _ _ _ free_vars upd args body) srt | 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) diff --git a/ghc/compiler/simplStg/SimplStg.lhs b/ghc/compiler/simplStg/SimplStg.lhs index abde371..5fd71cb 100644 --- a/ghc/compiler/simplStg/SimplStg.lhs +++ b/ghc/compiler/simplStg/SimplStg.lhs @@ -25,7 +25,7 @@ import CmdLineOpts ( opt_SccGroup, StgToDo(..) ) import Id ( Id ) -import OccName ( Module, moduleString ) +import Module ( Module, moduleString ) import VarEnv import ErrUtils ( doIfSet ) import UniqSupply ( splitUniqSupply, UniqSupply ) diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index 63cd22e..199a9a0 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -21,8 +21,12 @@ import CoreUtils ( coreExprType ) 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(..) ) @@ -146,17 +150,75 @@ exprToRhs (StgLet (StgNonRec var1 rhs) (StgApp var2 [])) -- 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} -- 1.7.10.4