Super-monster patch implementing the new typechecker -- at last

[ghc-hetmet.git] / compiler / deSugar / DsUtils.lhs

diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs
index f565021..4c05f5e 100644 (file)
--- a/compiler/deSugar/DsUtils.lhs
+++ b/compiler/deSugar/DsUtils.lhs
@@ -221,7 +221,7 @@ wrapBinds ((new,old):prs) e = wrapBind new old (wrapBinds prs e)
 wrapBind :: Var -> Var -> CoreExpr -> CoreExpr
 wrapBind new old body  -- Can deal with term variables *or* type variables
   | new==old    = body
-  | isTyVar new = Let (mkTyBind new (mkTyVarTy old)) body
+  | isTyCoVar new = Let (mkTyBind new (mkTyVarTy old)) body
   | otherwise   = Let (NonRec new (Var old))         body
 
 seqVar :: Var -> CoreExpr -> CoreExpr
@@ -419,7 +419,7 @@ But that is bad for two reasons:
 Seq is very, very special!  So we recognise it right here, and desugar to
         case x of _ -> case y of _ -> (# x,y #)
 
-Note [Desugaring seq (2)]  cf Trac #2231
+Note [Desugaring seq (2)]  cf Trac #2273
 ~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider
    let chp = case b of { True -> fst x; False -> 0 }
@@ -447,10 +447,14 @@ should have said explicitly
 
 But that's painful.  So the code here does a little hack to make seq
 more robust: a saturated application of 'seq' is turned *directly* into
-the case expression. So we desugar to:
+the case expression, thus:
+   x  `seq` e2 ==> case x of x -> e2    -- Note shadowing!
+   e1 `seq` e2 ==> case x of _ -> e2
+
+So we desugar our example to:
    let chp = case b of { True -> fst x; False -> 0 }
    case chp of chp { I# -> ...chp... }
-Notice the shadowing of the case binder! And now all is well.
+And now all is well.
 
 The reason it's a hack is because if you define mySeq=seq, the hack
 won't work on mySeq.  
@@ -471,7 +475,7 @@ mkCoreAppDs (Var f `App` Type ty1 `App` Type ty2 `App` arg1) arg2
   where
     case_bndr = case arg1 of
                    Var v1 | isLocalId v1 -> v1        -- Note [Desugaring seq (2) and (3)]
-                   _                     -> mkWildBinder ty1
+                   _                     -> mkWildValBinder ty1
 
 mkCoreAppDs fun arg = mkCoreApp fun arg         -- The rest is done in MkCore
 
@@ -546,8 +550,7 @@ mkSelectorBinds pat val_expr
       error_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID   tuple_ty (ppr pat)
       tuple_expr <- matchSimply val_expr PatBindRhs pat local_tuple error_expr
       tuple_var <- newSysLocalDs tuple_ty
-      let
-          mk_tup_bind binder
+      let mk_tup_bind binder
             = (binder, mkTupleSelector binders binder tuple_var (Var tuple_var))
       return ( (tuple_var, tuple_expr) : map mk_tup_bind binders )
   where
@@ -600,7 +603,7 @@ mkLHsVarPatTup bs  = mkLHsPatTup (map nlVarPat bs)
 mkVanillaTuplePat :: [OutPat Id] -> Boxity -> Pat Id
 -- A vanilla tuple pattern simply gets its type from its sub-patterns
 mkVanillaTuplePat pats box 
-  = TuplePat pats box (mkTupleTy box (length pats) (map hsLPatType pats))
+  = TuplePat pats box (mkTupleTy box (map hsLPatType pats))
 
 -- The Big equivalents for the source tuple expressions
 mkBigLHsVarTup :: [Id] -> LHsExpr Id
@@ -674,23 +677,36 @@ Now @fail.33@ is a function, so it can be let-bound.
 \begin{code}
 mkFailurePair :: CoreExpr      -- Result type of the whole case expression
              -> DsM (CoreBind, -- Binds the newly-created fail variable
-                               -- to either the expression or \ _ -> expression
-                     CoreExpr) -- Either the fail variable, or fail variable
-                               -- applied to unit tuple
+                               -- to \ _ -> expression
+                     CoreExpr) -- Fail variable applied to realWorld#
+-- See Note [Failure thunks and CPR]
 mkFailurePair expr
-  | isUnLiftedType ty = do
-     fail_fun_var <- newFailLocalDs (unitTy `mkFunTy` ty)
-     fail_fun_arg <- newSysLocalDs unitTy
-     return (NonRec fail_fun_var (Lam fail_fun_arg expr),
-             App (Var fail_fun_var) (Var unitDataConId))
-
-  | otherwise = do
-     fail_var <- newFailLocalDs ty
-     return (NonRec fail_var expr, Var fail_var)
+  = do { fail_fun_var <- newFailLocalDs (realWorldStatePrimTy `mkFunTy` ty)
+       ; fail_fun_arg <- newSysLocalDs realWorldStatePrimTy
+       ; return (NonRec fail_fun_var (Lam fail_fun_arg expr),
+                 App (Var fail_fun_var) (Var realWorldPrimId)) }
   where
     ty = exprType expr
 \end{code}
 
+Note [Failure thunks and CPR]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we make a failure point we ensure that it
+does not look like a thunk. Example:
+
+   let fail = \rw -> error "urk"
+   in case x of 
+        [] -> fail realWorld#
+        (y:ys) -> case ys of
+                    [] -> fail realWorld#  
+                    (z:zs) -> (y,z)
+
+Reason: we know that a failure point is always a "join point" and is
+entered at most once.  Adding a dummy 'realWorld' token argument makes
+it clear that sharing is not an issue.  And that in turn makes it more
+CPR-friendly.  This matters a lot: if you don't get it right, you lose
+the tail call property.  For example, see Trac #3403.
+
 \begin{code}
 mkOptTickBox :: Maybe (Int,[Id]) -> CoreExpr -> DsM CoreExpr
 mkOptTickBox Nothing e   = return e