Add extra WARN test

[ghc-hetmet.git] / compiler / simplCore / Simplify.lhs

diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index 866b2d4..f27bb43 100644 (file)
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -21,7 +21,7 @@ import Coercion
 import FamInstEnv       ( topNormaliseType )
 import DataCon          ( dataConRepStrictness, dataConUnivTyVars )
 import CoreSyn
-import NewDemand        ( isStrictDmd )
+import NewDemand        ( isStrictDmd, splitStrictSig )
 import PprCore          ( pprParendExpr, pprCoreExpr )
 import CoreUnfold       ( mkUnfolding, callSiteInline, CallCtxt(..) )
 import CoreUtils
@@ -511,6 +511,13 @@ makeTrivial env expr
   = do  { var <- newId (fsLit "a") (exprType expr)
         ; env' <- completeNonRecX env False var var expr
         ; return (env', substExpr env' (Var var)) }
+       -- The substitution is needed becase we're constructing a new binding
+       --     a = rhs
+       -- And if rhs is of form (rhs1 |> co), then we might get
+       --     a1 = rhs1
+       --     a = a1 |> co
+       -- and now a's RHS is trivial and can be substituted out, and that
+       -- is what completeNonRecX will do
 \end{code}
 
 
@@ -566,7 +573,10 @@ completeBind env top_lvl old_bndr new_bndr new_rhs
     old_info    = idInfo old_bndr
     occ_info    = occInfo old_info
     wkr                = substWorker env (workerInfo old_info)
-    omit_unfolding = isNonRuleLoopBreaker occ_info || not (activeInline env old_bndr)
+    omit_unfolding = isNonRuleLoopBreaker occ_info 
+                  --       or not (activeInline env old_bndr)
+                  -- Do *not* trim the unfolding in SimplGently, else
+                  -- the specialiser can't see it!
 
 -----------------
 addPolyBind :: TopLevelFlag -> SimplEnv -> OutBind -> SimplEnv
@@ -602,13 +612,20 @@ addNonRecWithUnf :: SimplEnv
                  -> SimplEnv
 -- Add suitable IdInfo to the Id, add the binding to the floats, and extend the in-scope set
 addNonRecWithUnf env new_bndr rhs unfolding wkr
-  = final_id `seq`      -- This seq forces the Id, and hence its IdInfo,
+  = ASSERT( isId new_bndr )
+    WARN( new_arity < old_arity || new_arity < dmd_arity, 
+          (ppr final_id <+> ppr old_arity <+> ppr new_arity <+> ppr dmd_arity) $$ ppr rhs )
+    final_id `seq`      -- This seq forces the Id, and hence its IdInfo,
                        -- and hence any inner substitutions
     addNonRec env final_id rhs
        -- The addNonRec adds it to the in-scope set too
   where
+       dmd_arity = length $ fst $ splitStrictSig $ idNewStrictness new_bndr
+       old_arity = idArity new_bndr
+
         --      Arity info
-        new_bndr_info = idInfo new_bndr `setArityInfo` exprArity rhs
+       new_arity = exprArity rhs
+        new_bndr_info = idInfo new_bndr `setArityInfo` new_arity
 
         --      Unfolding info
         -- Add the unfolding *only* for non-loop-breakers
@@ -819,10 +836,10 @@ simplCast env body co0 cont0
 
        add_coerce co1 (s1, _k2) (CoerceIt co2 cont)
          | (_l1, t1) <- coercionKind co2
-                --      coerce T1 S1 (coerce S1 K1 e)
+               --      e |> (g1 :: S1~L) |> (g2 :: L~T1)
                 -- ==>
-                --      e,                      if T1=K1
-                --      coerce T1 K1 e,         otherwise
+                --      e,                       if T1=T2
+                --      e |> (g1 . g2 :: T1~T2)  otherwise
                 --
                 -- For example, in the initial form of a worker
                 -- we may find  (coerce T (coerce S (\x.e))) y
@@ -832,7 +849,7 @@ simplCast env body co0 cont0
          | otherwise           = CoerceIt (mkTransCoercion co1 co2) cont
 
        add_coerce co (s1s2, _t1t2) (ApplyTo dup (Type arg_ty) arg_se cont)
-                -- (f `cast` g) ty  --->   (f ty) `cast` (g @ ty)
+                -- (f |> g) ty  --->   (f ty) |> (g @ ty)
                 -- This implements the PushT rule from the paper
          | Just (tyvar,_) <- splitForAllTy_maybe s1s2
          , not (isCoVar tyvar)
@@ -845,12 +862,12 @@ simplCast env body co0 cont0
        add_coerce co (s1s2, _t1t2) (ApplyTo dup arg arg_se cont)
          | not (isTypeArg arg)  -- This implements the Push rule from the paper
          , isFunTy s1s2   -- t1t2 must be a function type, becuase it's applied
-                -- co : s1s2 :=: t1t2
-                --      (coerce (T1->T2) (S1->S2) F) E
+                --      (e |> (g :: s1s2 ~ t1->t2)) f
                 -- ===>
-                --      coerce T2 S2 (F (coerce S1 T1 E))
+                --      (e (f |> (arg g :: t1~s1))
+               --      |> (res g :: s2->t2)
                 --
-                -- t1t2 must be a function type, T1->T2, because it's applied
+                -- t1t2 must be a function type, t1->t2, because it's applied
                 -- to something but s1s2 might conceivably not be
                 --
                 -- When we build the ApplyTo we can't mix the out-types
@@ -861,9 +878,9 @@ simplCast env body co0 cont0
                 -- Example of use: Trac #995
          = ApplyTo dup new_arg (zapSubstEnv env) (addCoerce co2 cont)
          where
-           -- we split coercion t1->t2 :=: s1->s2 into t1 :=: s1 and
-           -- t2 :=: s2 with left and right on the curried form:
-           --    (->) t1 t2 :=: (->) s1 s2
+           -- we split coercion t1->t2 ~ s1->s2 into t1 ~ s1 and
+           -- t2 ~ s2 with left and right on the curried form:
+           --    (->) t1 t2 ~ (->) s1 s2
            [co1, co2] = decomposeCo 2 co
            new_arg    = mkCoerce (mkSymCoercion co1) arg'
            arg'       = substExpr (arg_se `setInScope` env) arg
@@ -934,7 +951,8 @@ simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont
                      (StrictBind bndr bndrs body env cont) }
 
   | otherwise
-  = do  { (env1, bndr1) <- simplNonRecBndr env bndr
+  = ASSERT( not (isTyVar bndr) )
+    do  { (env1, bndr1) <- simplNonRecBndr env bndr
         ; let (env2, bndr2) = addBndrRules env1 bndr bndr1
         ; env3 <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se
         ; simplLam env3 bndrs body cont }