X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplify.lhs;h=effd245a2119e6128da5b12635794fb61959e490;hb=e95ee1f718c6915c478005aad8af81705357d6ab;hp=eec45210408370bfe3047898ebd0c0971b94b800;hpb=9a977e72a47a0e0c2a8bbf254f8b85609f0937f9;p=ghc-hetmet.git

diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index eec4521..effd245 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -15,7 +15,8 @@ import SimplEnv
 import SimplUtils
 import FamInstEnv	( FamInstEnv )
 import Id
-import MkId		( mkImpossibleExpr, seqId )
+import MkId		( seqId, realWorldPrimId )
+import MkCore		( mkImpossibleExpr )
 import Var
 import IdInfo
 import Name		( mkSystemVarName, isExternalName )
@@ -36,7 +37,6 @@ import Rules            ( lookupRule, getRules )
 import BasicTypes       ( isMarkedStrict, Arity )
 import CostCentre       ( currentCCS, pushCCisNop )
 import TysPrim          ( realWorldStatePrimTy )
-import PrelInfo         ( realWorldPrimId )
 import BasicTypes       ( TopLevelFlag(..), isTopLevel, RecFlag(..) )
 import MonadUtils	( foldlM, mapAccumLM )
 import Maybes           ( orElse )
@@ -562,7 +562,7 @@ makeTrivialWithInfo top_lvl env info expr
     expr_ty = exprType expr
 
 bindingOk :: TopLevelFlag -> CoreExpr -> Type -> Bool
--- True iff we can have a binding of this expression at this leve
+-- True iff we can have a binding of this expression at this level
 -- Precondition: the type is the type of the expression
 bindingOk top_lvl _ expr_ty
   | isTopLevel top_lvl = not (isUnLiftedType expr_ty) 
@@ -705,8 +705,8 @@ simplUnfolding :: SimplEnv-> TopLevelFlag
 	       -> OccInfo -> OutExpr
 	       -> Unfolding -> SimplM Unfolding
 -- Note [Setting the new unfolding]
-simplUnfolding env _ _ _ _ (DFunUnfolding con ops)
-  = return (DFunUnfolding con ops')
+simplUnfolding env _ _ _ _ (DFunUnfolding ar con ops)
+  = return (DFunUnfolding ar con ops')
   where
     ops' = map (substExpr (text "simplUnfolding") env) ops
 
@@ -877,7 +877,7 @@ simplExprF' env expr@(Lam _ _) cont
     n_params = length bndrs
     (bndrs, body) = collectBinders expr
     zap | n_args >= n_params = \b -> b
-        | otherwise          = \b -> if isTyVar b then b
+        | otherwise          = \b -> if isTyCoVar b then b
                                      else zapLamIdInfo b
         -- NB: we count all the args incl type args
         -- so we must count all the binders (incl type lambdas)
@@ -1081,7 +1081,7 @@ simplNonRecE :: SimplEnv
 	-- First deal with type applications and type lets
 	--   (/\a. e) (Type ty)   and   (let a = Type ty in e)
 simplNonRecE env bndr (Type ty_arg, rhs_se) (bndrs, body) cont
-  = ASSERT( isTyVar bndr )
+  = ASSERT( isTyCoVar bndr )
     do	{ ty_arg' <- simplType (rhs_se `setInScope` env) ty_arg
 	; simplLam (extendTvSubst env bndr ty_arg') bndrs body cont }
 
@@ -1095,7 +1095,7 @@ simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont
                      (StrictBind bndr bndrs body env cont) }
 
   | otherwise
-  = ASSERT( not (isTyVar bndr) )
+  = ASSERT( not (isTyCoVar bndr) )
     do  { (env1, bndr1) <- simplNonRecBndr env bndr
         ; let (env2, bndr2) = addBndrRules env1 bndr bndr1
         ; env3 <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se
@@ -1137,7 +1137,7 @@ simplNote env (CoreNote s) e cont
 simplVar :: SimplEnv -> InVar -> SimplM OutExpr
 -- Look up an InVar in the environment
 simplVar env var
-  | isTyVar var 
+  | isTyCoVar var 
   = return (Type (substTyVar env var))
   | otherwise
   = case substId env var of
@@ -1768,7 +1768,7 @@ simplAlt env _ case_bndr' cont' (DataAlt con, vs, rhs)
         = go vs the_strs
         where
           go [] [] = []
-          go (v:vs') strs | isTyVar v = v : go vs' strs
+          go (v:vs') strs | isTyCoVar v = v : go vs' strs
           go (v:vs') (str:strs)
             | isMarkedStrict str = evald_v  : go vs' strs
             | otherwise          = zapped_v : go vs' strs
@@ -1843,7 +1843,7 @@ knownCon env scrut dc dc_ty_args dc_args bndr bs rhs cont
     bind_args env' [] _  = return env'
 
     bind_args env' (b:bs') (Type ty : args)
-      = ASSERT( isTyVar b )
+      = ASSERT( isTyCoVar b )
         bind_args (extendTvSubst env' b ty) bs' args
 
     bind_args env' (b:bs') (arg : args)
@@ -2030,7 +2030,7 @@ mkDupableAlt env case_bndr (con, bndrs', rhs')
 			  | otherwise		   = bndrs' ++ [case_bndr_w_unf]
 	      
               abstract_over bndr
-                  | isTyVar bndr = True -- Abstract over all type variables just in case
+                  | isTyCoVar bndr = True -- Abstract over all type variables just in case
                   | otherwise    = not (isDeadBinder bndr)
                         -- The deadness info on the new Ids is preserved by simplBinders
 
@@ -2082,12 +2082,22 @@ An alternative plan is this:
 but that is bad if 'c' is *not* later scrutinised.  
 
 So instead we do both: we pass 'c' and 'c#' , and record in c's inlining
-that it's really I# c#, thus
+(an InlineRule) that it's really I# c#, thus
    
    $j = \c# -> \c[=I# c#] -> ...c....
 
 Absence analysis may later discard 'c'.
 
+NB: take great care when doing strictness analysis; 
+    see Note [Lamba-bound unfoldings] in DmdAnal.
+
+Also note that we can still end up passing stuff that isn't used.  Before
+strictness analysis we have
+   let $j x y c{=(x,y)} = (h c, ...)
+   in ...
+After strictness analysis we see that h is strict, we end up with
+   let $j x y c{=(x,y)} = ($wh x y, ...)
+and c is unused.
    
 Note [Duplicated env]
 ~~~~~~~~~~~~~~~~~~~~~