X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreTidy.lhs;h=245474841e28161e717c1c00dead7957888c3c81;hb=26b8a5b3feab9d556c92f495a6775acf8cf9f3ec;hp=9873779c074e00f1e808bd2ae4ed6b7b893db0e0;hpb=b302643c51ba129d50d9de26612ba2b9dc60f4e9;p=ghc-hetmet.git

diff --git a/ghc/compiler/coreSyn/CoreTidy.lhs b/ghc/compiler/coreSyn/CoreTidy.lhs
index 9873779..2454748 100644
--- a/ghc/compiler/coreSyn/CoreTidy.lhs
+++ b/ghc/compiler/coreSyn/CoreTidy.lhs
@@ -14,7 +14,7 @@ module CoreTidy (
 import CmdLineOpts	( DynFlags, DynFlag(..), opt_OmitInterfacePragmas )
 import CoreSyn
 import CoreUnfold	( noUnfolding, mkTopUnfolding, okToUnfoldInHiFile )
-import CoreUtils	( exprArity, exprIsBottom )
+import CoreUtils	( exprArity )
 import CoreFVs		( ruleSomeFreeVars, exprSomeFreeVars )
 import CoreLint		( showPass, endPass )
 import VarEnv
@@ -22,11 +22,11 @@ import VarSet
 import Var		( Id, Var )
 import Id		( idType, idInfo, idName, isExportedId,
 			  idCafInfo, mkId, isLocalId, isImplicitId,
-			  idFlavour, modifyIdInfo
+			  idFlavour, modifyIdInfo, idArity
 			) 
 import IdInfo		{- loads of stuff -}
 import Name		( getOccName, nameOccName, globaliseName, setNameOcc, 
-		  	  localiseName, mkLocalName, isGlobalName
+		  	  localiseName, mkLocalName, isGlobalName, isDllName
 			)
 import OccName		( TidyOccEnv, initTidyOccEnv, tidyOccName )
 import Type		( tidyTopType, tidyType, tidyTyVar )
@@ -37,6 +37,8 @@ import HscTypes		( PersistentCompilerState( pcs_PRS ),
 			  NameSupply( nsNames ), OrigNameCache
 			)
 import UniqSupply
+import DataCon		( dataConName )
+import Literal		( isLitLitLit )
 import FiniteMap	( lookupFM, addToFM )
 import Maybes		( maybeToBool, orElse )
 import ErrUtils		( showPass )
@@ -94,10 +96,19 @@ binder
     that all Ids are unique, rather than the weaker guarantee of
     no clashes which the simplifier provides.
 
-  - Give the Id its final IdInfo; in ptic, 
+  - Give each dynamic CCall occurrence a fresh unique; this is
+    rather like the cloning step above.
+
+  - Give the Id its UTTERLY FINAL IdInfo; in ptic, 
 	* Its flavour becomes ConstantId, reflecting the fact that
 	  from now on we regard it as a constant, not local, Id
+
   	* its unfolding, if it should have one
+	
+	* its arity, computed from the number of visible lambdas
+
+	* its CAF info, computed from what is free in its RHS
+
 		
 Finally, substitute these new top-level binders consistently
 throughout, including in unfoldings.  We also tidy binders in
@@ -354,16 +365,15 @@ tidyTopBinder mod ext_ids tidy_env rhs caf_info
 tidyIdInfo us tidy_env is_external unfold_info arity_info caf_info id
   | opt_OmitInterfacePragmas || not is_external
 	-- No IdInfo if the Id isn't external, or if we don't have -O
-  = mkIdInfo new_flavour 
+  = mkIdInfo new_flavour caf_info
 	`setStrictnessInfo` strictnessInfo core_idinfo
 	`setArityInfo`	    ArityExactly arity_info
-	`setCafInfo`        caf_info
 	-- Keep strictness, arity and CAF info; it's used by the code generator
 
   | otherwise
   =  let (rules', _) = initUs us (tidyRules tidy_env (specInfo core_idinfo))
      in
-     mkIdInfo new_flavour
+     mkIdInfo new_flavour caf_info
 	`setCprInfo`	    cprInfo core_idinfo
 	`setStrictnessInfo` strictnessInfo core_idinfo
 	`setInlinePragInfo` inlinePragInfo core_idinfo
@@ -371,7 +381,6 @@ tidyIdInfo us tidy_env is_external unfold_info arity_info caf_info id
 	`setWorkerInfo`	    tidyWorker tidy_env arity_info (workerInfo core_idinfo)
 	`setSpecInfo`	    rules'
 	`setArityInfo`	    ArityExactly arity_info
-	`setCafInfo`        caf_info
 		-- this is the final IdInfo, it must agree with the
 		-- code finally generated (i.e. NO more transformations
 		-- after this!).
@@ -647,15 +656,46 @@ cafRefss p (e:es) = cafRefs p e `fastOr` cafRefss p es
 -- in an SRT or not.
 
 isCAF :: CoreExpr -> Bool
-   -- special case for expressions which are always bottom,
-   -- such as 'error "..."'.  We don't need to record it as
-   -- a CAF, since it can only be entered once.
-isCAF e 
-  | not_function && is_bottom = False
-  | not_function && updatable = True
-  | otherwise		      = False
+isCAF e = not (rhsIsNonUpd e)
+  {- ToDo: check type for onceness, i.e. non-updatable thunks? -}
+
+rhsIsNonUpd :: CoreExpr -> Bool	-- True => Value-lambda, constructor, PAP
+rhsIsNonUpd (Lam b e)          = isId b || rhsIsNonUpd e
+rhsIsNonUpd (Note (SCC _) e)   = False
+rhsIsNonUpd (Note _ e)         = rhsIsNonUpd e
+rhsIsNonUpd other_expr
+  = go other_expr 0 []
   where
-    not_function = exprArity e == 0
-    is_bottom    = exprIsBottom e
-    updatable    = True {- ToDo: check type for onceness? -}
+    go (Var f) n_args args = idAppIsNonUpd f n_args args
+	
+    go (App f a) n_args args
+	| isTypeArg a = go f n_args args
+	| otherwise   = go f (n_args + 1) (a:args)
+
+    go (Note (SCC _) f) n_args args = False
+    go (Note _ f) n_args args       = go f n_args args
+
+    go other n_args args = False
+
+idAppIsNonUpd :: Id -> Int -> [CoreExpr] -> Bool
+idAppIsNonUpd id n_val_args args
+  = case idFlavour id of
+	DataConId con | not (isDynConApp con args) -> True
+	other -> n_val_args < idArity id
+
+isDynConApp con args = isDllName (dataConName con) || any isDynArg args
+
+	-- Does this argument refer to something in a different DLL,
+	-- or is a LitLit?  Constructor arguments which are in another
+	-- DLL or are LitLits aren't compiled into static constructors
+	-- (see CoreToStg), so we have to take that into account here.
+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
+
+-- We consider partial applications to be non-updatable.  NOTE: this
+-- must match how CoreToStg marks the closure.
 \end{code}