[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.

8 files changed, 110 insertions, 78 deletions

diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs
index 6721172474..c1ddff2d3d 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 0a9a76dc7f..35dcdc2610 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 a9b6e41974..c3e029516a 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 6bd024d70e..6d388277fb 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 3340b8a7bd..837293bc54 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 c699fd3ab6..00c31f5f66 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 abde3712bd..5fd71cb470 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 63cd22e3be..199a9a0aba 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}