X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FstgSyn%2FCoreToStg.lhs;h=04da56d59be7b7bfe38257895493edb5c594b3ca;hb=3af411e913102d8ec1234f32abe99374f077e3f7;hp=59135df3fdf963ba9bfbd06d93e2b3131ae7f672;hpb=f05b6981de4c1f76279e17a59d3c42e83ee8d244;p=ghc-hetmet.git

diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs
index 59135df..04da56d 100644
--- a/ghc/compiler/stgSyn/CoreToStg.lhs
+++ b/ghc/compiler/stgSyn/CoreToStg.lhs
@@ -19,7 +19,7 @@ import Type
 import TyCon		( isAlgTyCon )
 import Literal
 import Id
-import Var		( Var, globalIdDetails )
+import Var		( Var, globalIdDetails, varType )
 import IdInfo
 import DataCon
 import CostCentre	( noCCS )
@@ -27,12 +27,11 @@ import VarSet
 import VarEnv
 import DataCon		( dataConWrapId )
 import IdInfo		( OccInfo(..) )
-import TysPrim		( foreignObjPrimTyCon )
 import Maybes		( maybeToBool )
 import Name		( getOccName, isExternallyVisibleName, isDllName )
 import OccName		( occNameUserString )
 import BasicTypes       ( TopLevelFlag(..), isNotTopLevel, Arity )
-import CmdLineOpts	( DynFlags, opt_KeepStgTypes )
+import CmdLineOpts	( DynFlags, opt_RuntimeTypes )
 import FastTypes	hiding ( fastOr )
 import Outputable
 
@@ -468,20 +467,6 @@ coreToStgExpr (Let bind body)
     returnLne (new_let, fvs, escs)
 \end{code}
 
-If we've got a case containing a _ccall_GC_ primop, we need to
-ensure that the arguments are kept live for the duration of the
-call. This only an issue
-
-\begin{code}
-isForeignObjArg :: Id -> Bool
-isForeignObjArg x = isId x && isForeignObjPrimTy (idType x)
-
-isForeignObjPrimTy ty
-   = case splitTyConApp_maybe ty of
-	Just (tycon, _) -> tycon == foreignObjPrimTyCon
-	Nothing		-> False
-\end{code}
-
 \begin{code}
 mkStgAlgAlts ty alts deflt
  =  case alts of
@@ -520,22 +505,35 @@ coreToStgApp maybe_thunk_body f args
     lookupVarLne f		`thenLne` \ how_bound ->
 
     let
-	n_args		 = length args
+	n_val_args	 = valArgCount args
 	not_letrec_bound = not (isLetBound how_bound)
-	fun_fvs	 	 = singletonFVInfo f how_bound fun_occ
-
+	fun_fvs	 	 
+          = let fvs = singletonFVInfo f how_bound fun_occ in
+            -- e.g. (f :: a -> int) (x :: a) 
+            -- Here the free variables are "f", "x" AND the type variable "a"
+            -- coreToStgArgs will deal with the arguments recursively
+            if opt_RuntimeTypes then
+	      fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType (varType f))
+	    else fvs
+
+	-- Mostly, the arity info of a function is in the fn's IdInfo
+	-- But new bindings introduced by CoreSat may not have no
+	-- arity info; it would do us no good anyway.  For example:
+	--	let f = \ab -> e in f
+	-- No point in having correct arity info for f!
+	-- Hence the hasArity stuff below.
 	f_arity = case how_bound of 
 			LetBound _ _ arity -> arity
 			_                  -> 0
 
 	fun_occ 
-	 | not_letrec_bound		    = noBinderInfo	-- Uninteresting variable
-	 | f_arity > 0 && f_arity <= n_args = stgSatOcc		-- Saturated or over-saturated function call
-	 | otherwise			    = stgUnsatOcc	-- Unsaturated function or thunk
+	 | not_letrec_bound		        = noBinderInfo	-- Uninteresting variable
+	 | f_arity > 0 && f_arity <= n_val_args = stgSatOcc	-- Saturated or over-saturated function call
+	 | otherwise			        = stgUnsatOcc	-- Unsaturated function or thunk
 
 	fun_escs
-	 | not_letrec_bound  = emptyVarSet	-- Only letrec-bound escapees are interesting
-	 | f_arity == n_args = emptyVarSet	-- A function *or thunk* with an exactly
+	 | not_letrec_bound      = emptyVarSet	-- Only letrec-bound escapees are interesting
+	 | f_arity == n_val_args = emptyVarSet	-- A function *or thunk* with an exactly
 						-- saturated call doesn't escape
 						-- (let-no-escape applies to 'thunks' too)
 
@@ -552,9 +550,11 @@ coreToStgApp maybe_thunk_body f args
 	--	   continuation, but it does no harm to just union the
 	--	   two regardless.
 
+	res_ty = exprType (mkApps (Var f) args)
 	app = case globalIdDetails f of
-      		DataConId dc -> StgConApp dc args'
-	        PrimOpId op  -> StgPrimApp op args' (exprType (mkApps (Var f) args))
+      		DataConId dc -> StgConApp dc				 args'
+	        PrimOpId op  -> StgOpApp  (StgPrimOp op)		 args' res_ty
+		FCallId call -> StgOpApp  (StgFCallOp call (idUnique f)) args' res_ty
 		_other       -> StgApp f args'
 
     in
@@ -579,7 +579,7 @@ coreToStgArgs []
 
 coreToStgArgs (Type ty : args)	-- Type argument
   = coreToStgArgs args	`thenLne` \ (args', fvs) ->
-    if opt_KeepStgTypes then
+    if opt_RuntimeTypes then
  	returnLne (StgTypeArg ty : args', fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType ty))
     else
     returnLne (args', fvs)
@@ -889,7 +889,7 @@ freeVarsToLiveVars fvs env live_in_cont
   = returnLne (lvs, cafs) env live_in_cont
   where
     (lvs_cont, cafs_cont) = live_in_cont -- not a strict pattern match!
-    (local, global) = partition isLocalId (allFVs fvs)
+    (local, global) = partition isLocalId (allFreeIds fvs)
 
     (lvs_from_fvs, caf_extras) = unzip (map do_one local)
 
@@ -907,7 +907,7 @@ freeVarsToLiveVars fvs env live_in_cont
 	      Nothing -> pprPanic "lookupLiveVarsForSet/do_one:" (ppr v)
 
     is_caf_one v
-	 = case lookupVarEnv env v of
+      = case lookupVarEnv env v of
 		Just (LetBound TopLevelHasCafs (lvs,_) _) ->
 		    ASSERT( isEmptyVarSet lvs ) True
 	        Just (LetBound _ _ _) -> False
@@ -970,7 +970,7 @@ minusFVBinders :: [Id] -> FreeVarsInfo -> FreeVarsInfo
 minusFVBinders vs fv = foldr minusFVBinder fv vs
 
 minusFVBinder :: Id -> FreeVarsInfo -> FreeVarsInfo
-minusFVBinder v fv | isId v && opt_KeepStgTypes
+minusFVBinder v fv | isId v && opt_RuntimeTypes
 		   = (fv `delVarEnv` v) `unionFVInfo` 
 		     tyvarFVInfo (tyVarsOfType (idType v))
 		   | otherwise = fv `delVarEnv` v
@@ -989,13 +989,15 @@ lookupFVInfo fvs id
 			Nothing         -> noBinderInfo
 			Just (_,_,info) -> info
 
-allFVs :: FreeVarsInfo -> [Id]	-- Non-top-level things only
-allFVs fvs = [id | (id,_,_) <- rngVarEnv fvs]
+allFreeIds :: FreeVarsInfo -> [Id]	-- Non-top-level things only
+allFreeIds fvs = [id | (id,_,_) <- rngVarEnv fvs, isId id]
 
-getFVs :: FreeVarsInfo -> [Id]	-- Non-top-level things only
+-- Non-top-level things only, both type variables and ids (type variables
+-- only if opt_RuntimeTypes.
+getFVs :: FreeVarsInfo -> [Var]	
 getFVs fvs = [id | (id,NotTopLevelBound,_) <- rngVarEnv fvs]
 
-getFVSet :: FreeVarsInfo -> IdSet
+getFVSet :: FreeVarsInfo -> VarSet
 getFVSet fvs = mkVarSet (getFVs fvs)
 
 plusFVInfo (id1,top1,info1) (id2,top2,info2)
@@ -1007,7 +1009,7 @@ Misc.
 \begin{code}
 filterStgBinders :: [Var] -> [Var]
 filterStgBinders bndrs
-  | opt_KeepStgTypes = bndrs
+  | opt_RuntimeTypes = bndrs
   | otherwise	     = filter isId bndrs
 \end{code}
 
@@ -1116,7 +1118,12 @@ rhsIsNonUpd :: CoreExpr -> Bool
   -- 
   --    c) don't look through unfolding of f in (f x).  I'm suspicious of this one
 
-rhsIsNonUpd (Lam b e)          = isId b || rhsIsNonUpd e
+-- This function has to line up with what the update flag
+-- for the StgRhs gets set to in mkStgRhs (above)
+--
+-- When opt_RuntimeTypes is on, we keep type lambdas and treat
+-- them as making the RHS re-entrant (non-updatable).
+rhsIsNonUpd (Lam b e)          = isRuntimeVar b || rhsIsNonUpd e
 rhsIsNonUpd (Note (SCC _) e)   = False
 rhsIsNonUpd (Note _ e)         = rhsIsNonUpd e
 rhsIsNonUpd other_expr
@@ -1135,11 +1142,11 @@ rhsIsNonUpd other_expr
 
 idAppIsNonUpd :: Id -> Int -> [CoreExpr] -> Bool
 idAppIsNonUpd id n_val_args args
-  | Just con <- isDataConId_maybe id = not (isDynConApp con args)
+  | Just con <- isDataConId_maybe id = not (isCrossDllConApp con args)
   | otherwise 			     = n_val_args < idArity id
 
-isDynConApp :: DataCon -> [CoreExpr] -> Bool
-isDynConApp con args = isDllName (dataConName con) || any isDynArg args
+isCrossDllConApp :: DataCon -> [CoreExpr] -> Bool
+isCrossDllConApp con args = isDllName (dataConName con) || any isCrossDllArg args
 -- Top-level constructor applications can usually be allocated 
 -- statically, but they can't if 
 -- 	a) the constructor, or any of the arguments, come from another DLL
@@ -1150,10 +1157,12 @@ isDynConApp con args = isDllName (dataConName con) || any isDynArg args
 -- All this should match the decision in (see CoreToStg.coreToStgRhs)
 
 
-isDynArg :: CoreExpr -> Bool
-isDynArg (Var v)    = isDllName (idName v)
-isDynArg (Note _ e) = isDynArg e
-isDynArg (Lit lit)  = isLitLitLit lit
-isDynArg (App e _)  = isDynArg e	-- must be a type app
-isDynArg (Lam _ e)  = isDynArg e	-- must be a type lam
+isCrossDllArg :: CoreExpr -> Bool
+-- True if somewhere in the expression there's a cross-DLL reference
+isCrossDllArg (Type _)    = False
+isCrossDllArg (Var v)     = isDllName (idName v)
+isCrossDllArg (Note _ e)  = isCrossDllArg e
+isCrossDllArg (Lit lit)   = isLitLitLit lit
+isCrossDllArg (App e1 e2) = isCrossDllArg e1 || isCrossDllArg e2	-- must be a type app
+isCrossDllArg (Lam v e)   = isCrossDllArg e	-- must be a type lam
 \end{code}