X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FstgSyn%2FCoreToStg.lhs;h=199a9a0abad86dcc37cd457be9af6c28064b61a0;hb=dc7d7a2f55bfd830755aa7040f93f07f3e72ac1e;hp=63cd22e3be83c3515087ddbb7eb3da2fb71db199;hpb=0554dc08d9e05e812d264a682679b798fce1ff78;p=ghc-hetmet.git

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}