[project @ 1996-07-19 18:36:04 by partain]

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

diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs
index 5e0031d..66472b7 100644 (file)
--- a/ghc/compiler/deSugar/DsUtils.lhs
+++ b/ghc/compiler/deSugar/DsUtils.lhs
@@ -1,5 +1,5 @@
 %
 %

-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996

 %
 \section[DsUtils]{Utilities for desugaring}
 
 %
 \section[DsUtils]{Utilities for desugaring}
 

@@ -13,45 +13,52 @@ module DsUtils (
 
        combineGRHSMatchResults,
        combineMatchResults,
 
        combineGRHSMatchResults,
        combineMatchResults,

-       dsExprToAtom,
+       dsExprToAtom, SYN_IE(DsCoreArg),

        mkCoAlgCaseMatchResult,
        mkCoAlgCaseMatchResult,

-       mkCoAppDs,
-       mkCoConDs,
+       mkAppDs, mkConDs, mkPrimDs, mkErrorAppDs,

        mkCoLetsMatchResult,
        mkCoPrimCaseMatchResult,
        mkCoLetsMatchResult,
        mkCoPrimCaseMatchResult,

-       mkCoPrimDs,

        mkFailurePair,
        mkGuardedMatchResult,
        mkSelectorBinds,
        mkTupleBind,
        mkTupleExpr,
        mkFailurePair,
        mkGuardedMatchResult,
        mkSelectorBinds,
        mkTupleBind,
        mkTupleExpr,

-       selectMatchVars
+       selectMatchVars,
+       showForErr

     ) where
 
     ) where
 

-import AbsSyn          -- the stuff being desugared
-import PlainCore       -- the output of desugaring;
-                       -- importing this module also gets all the
-                       -- CoreSyn utility functions
-import DsMonad         -- the monadery used in the desugarer
-
-import AbsPrel         ( mkFunTy, stringTy
-                         IF_ATTACK_PRAGMAS(COMMA mkListTy COMMA charTy)
-                       )
-import AbsUniType      ( mkTyVarTy, quantifyTy, mkTupleTyCon,
-                         mkRhoTy, splitDictType, applyTyCon,
-                         getUniDataTyCon, isUnboxedDataType, 
-                         TyVar, TyVarTemplate, TyCon, Arity(..), Class,
-                         UniType, RhoType(..), SigmaType(..)
-                       )
-import Id              ( getIdUniType, getInstantiatedDataConSig,
-                         mkTupleCon, DataCon(..), Id
+IMP_Ubiq()
+IMPORT_DELOOPER(DsLoop)                ( match, matchSimply )
+
+import HsSyn           ( HsExpr(..), OutPat(..), HsLit(..),
+                         Match, HsBinds, Stmt, Qualifier, PolyType, ArithSeqInfo )
+import TcHsSyn         ( SYN_IE(TypecheckedPat) )
+import DsHsSyn         ( outPatType )
+import CoreSyn
+
+import DsMonad
+
+import CoreUtils       ( coreExprType, mkCoreIfThenElse )
+import PprStyle                ( PprStyle(..) )
+import PrelVals                ( iRREFUT_PAT_ERROR_ID, voidId )
+import Pretty          ( ppShow )
+import Id              ( idType, dataConArgTys, mkTupleCon,
+--                       pprId{-ToDo:rm-},
+                         SYN_IE(DataCon), SYN_IE(DictVar), SYN_IE(Id), GenId )
+import Literal         ( Literal(..) )
+import TyCon           ( mkTupleTyCon, isNewTyCon, tyConDataCons )
+import Type            ( mkTyVarTys, mkRhoTy, mkForAllTys, mkFunTy,
+                         mkTheta, isUnboxedType, applyTyCon, getAppTyCon

                        )
                        )

-import Maybes          ( Maybe(..) )
-import Match           ( match, matchSimply )
-import Pretty
-import Unique          ( initUs, UniqueSupply, UniqSM(..) )
-import UniqSet
-import Util
+import TysPrim         ( voidTy )
+import UniqSet         ( mkUniqSet, minusUniqSet, uniqSetToList, SYN_IE(UniqSet) )
+import Util            ( panic, assertPanic{-, pprTrace ToDo:rm-} )
+import Usage           ( SYN_IE(UVar) )
+--import PprCore{-ToDo:rm-}
+--import PprType--ToDo:rm
+--import Pretty--ToDo:rm
+--import TyVar--ToDo:rm
+--import Unique--ToDo:rm

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -65,7 +72,7 @@ The ``equation info'' used by @match@ is relatively complicated and
 worthy of a type synonym and a few handy functions.
 
 \begin{code}
 worthy of a type synonym and a few handy functions.
 
 \begin{code}

-data EquationInfo 
+data EquationInfo

   = EqnInfo
        [TypecheckedPat]    -- the patterns for an eqn
        MatchResult         -- Encapsulates the guards and bindings
   = EqnInfo
        [TypecheckedPat]    -- the patterns for an eqn
        MatchResult         -- Encapsulates the guards and bindings

@@ -75,9 +82,9 @@ data EquationInfo
 data MatchResult
   = MatchResult
        CanItFail
 data MatchResult
   = MatchResult
        CanItFail

-       UniType         -- Type of argument expression
+       Type            -- Type of argument expression

 
 

-       (PlainCoreExpr -> PlainCoreExpr)
+       (CoreExpr -> CoreExpr)

                        -- Takes a expression to plug in at the
                        -- failure point(s). The expression should
                        -- be duplicatable!
                        -- Takes a expression to plug in at the
                        -- failure point(s). The expression should
                        -- be duplicatable!

@@ -93,11 +100,11 @@ orFail CantFail CantFail = CantFail
 orFail _        _       = CanFail
 
 
 orFail _        _       = CanFail
 
 

-mkCoLetsMatchResult :: [PlainCoreBinding] -> MatchResult -> MatchResult
-mkCoLetsMatchResult binds (MatchResult can_it_fail ty body_fn cxt) 
+mkCoLetsMatchResult :: [CoreBinding] -> MatchResult -> MatchResult
+mkCoLetsMatchResult binds (MatchResult can_it_fail ty body_fn cxt)

   = MatchResult can_it_fail ty (\body -> mkCoLetsAny binds (body_fn body)) cxt
 
   = MatchResult can_it_fail ty (\body -> mkCoLetsAny binds (body_fn body)) cxt
 

-mkGuardedMatchResult :: PlainCoreExpr -> MatchResult -> DsM MatchResult
+mkGuardedMatchResult :: CoreExpr -> MatchResult -> DsM MatchResult

 mkGuardedMatchResult pred_expr (MatchResult can_it_fail ty body_fn cxt)
   = returnDs (MatchResult CanFail
                          ty
 mkGuardedMatchResult pred_expr (MatchResult can_it_fail ty body_fn cxt)
   = returnDs (MatchResult CanFail
                          ty

@@ -106,10 +113,10 @@ mkGuardedMatchResult pred_expr (MatchResult can_it_fail ty body_fn cxt)
     )
 
 mkCoPrimCaseMatchResult :: Id                          -- Scrutinee
     )
 
 mkCoPrimCaseMatchResult :: Id                          -- Scrutinee

-                   -> [(BasicLit, MatchResult)]        -- Alternatives    
+                   -> [(Literal, MatchResult)] -- Alternatives

                    -> DsM MatchResult
 mkCoPrimCaseMatchResult var alts
                    -> DsM MatchResult
 mkCoPrimCaseMatchResult var alts

-  = newSysLocalDs (getIdUniType var)   `thenDs` \ wild ->
+  = newSysLocalDs (idType var) `thenDs` \ wild ->

     returnDs (MatchResult CanFail
                          ty1
                          (mk_case alts wild)
     returnDs (MatchResult CanFail
                          ty1
                          (mk_case alts wild)

@@ -118,52 +125,71 @@ mkCoPrimCaseMatchResult var alts
     ((_,MatchResult _ ty1 _ cxt1) : _) = alts
 
     mk_case alts wild fail_expr
     ((_,MatchResult _ ty1 _ cxt1) : _) = alts
 
     mk_case alts wild fail_expr

-      = CoCase (CoVar var) (CoPrimAlts final_alts (CoBindDefault wild fail_expr))
+      = Case (Var var) (PrimAlts final_alts (BindDefault wild fail_expr))

       where
       where

-       final_alts = [ (lit, body_fn fail_expr) 
+       final_alts = [ (lit, body_fn fail_expr)

                     | (lit, MatchResult _ _ body_fn _) <- alts
                     ]
 
 
 mkCoAlgCaseMatchResult :: Id                           -- Scrutinee
                     | (lit, MatchResult _ _ body_fn _) <- alts
                     ]
 
 
 mkCoAlgCaseMatchResult :: Id                           -- Scrutinee

-                   -> [(DataCon, [Id], MatchResult)]   -- Alternatives    
+                   -> [(DataCon, [Id], MatchResult)]   -- Alternatives

                    -> DsM MatchResult
                    -> DsM MatchResult

+

 mkCoAlgCaseMatchResult var alts
 mkCoAlgCaseMatchResult var alts

+  | isNewTyCon tycon           -- newtype case; use a let
+  = ASSERT( newtype_sanity )
+    returnDs (mkCoLetsMatchResult [coercion_bind] match_result)
+
+  | otherwise                  -- datatype case  

   =        -- Find all the constructors in the type which aren't
            -- explicitly mentioned in the alternatives:
     case un_mentioned_constructors of
        [] ->   -- All constructors mentioned, so no default needed
   =        -- Find all the constructors in the type which aren't
            -- explicitly mentioned in the alternatives:
     case un_mentioned_constructors of
        [] ->   -- All constructors mentioned, so no default needed

-               returnDs (MatchResult can_any_alt_fail 
-                                     ty1 
-                                     (mk_case alts (\ignore -> CoNoDefault)) 
+               returnDs (MatchResult can_any_alt_fail
+                                     ty1
+                                     (mk_case alts (\ignore -> NoDefault))

                                      cxt1)
 
        [con] ->     -- Just one constructor missing, so add a case for it
                                      cxt1)
 
        [con] ->     -- Just one constructor missing, so add a case for it

-                    -- We need to build new locals for the args of the constructor, 
+                    -- We need to build new locals for the args of the constructor,

                     -- and figuring out their types is somewhat tiresome.
                let
                     -- and figuring out their types is somewhat tiresome.
                let

-                       (_,arg_tys,_) = getInstantiatedDataConSig con tycon_arg_tys
+                       arg_tys = dataConArgTys con tycon_arg_tys

                in
                newSysLocalsDs arg_tys  `thenDs` \ arg_ids ->
                in
                newSysLocalsDs arg_tys  `thenDs` \ arg_ids ->

-    
+

                     -- Now we are ready to construct the new alternative
                let
                        new_alt = (con, arg_ids, MatchResult CanFail ty1 id NoMatchContext)
                in
                returnDs (MatchResult CanFail
                     -- Now we are ready to construct the new alternative
                let
                        new_alt = (con, arg_ids, MatchResult CanFail ty1 id NoMatchContext)
                in
                returnDs (MatchResult CanFail

-                                     ty1 
-                                     (mk_case (new_alt:alts) (\ignore -> CoNoDefault)) 
+                                     ty1
+                                     (mk_case (new_alt:alts) (\ignore -> NoDefault))

                                      cxt1)
 
        other ->      -- Many constructors missing, so use a default case
                newSysLocalDs scrut_ty          `thenDs` \ wild ->
                returnDs (MatchResult CanFail
                                      cxt1)
 
        other ->      -- Many constructors missing, so use a default case
                newSysLocalDs scrut_ty          `thenDs` \ wild ->
                returnDs (MatchResult CanFail

-                                     ty1 
-                                     (mk_case alts (\fail_expr -> CoBindDefault wild fail_expr))
+                                     ty1
+                                     (mk_case alts (\fail_expr -> BindDefault wild fail_expr))

                                      cxt1)
   where
                                      cxt1)
   where

-    scrut_ty = getIdUniType var
-    (tycon, tycon_arg_tys, data_cons) = getUniDataTyCon scrut_ty
+       -- Common stuff
+    scrut_ty = idType var
+    (tycon, tycon_arg_tys) = --pprTrace "CoAlgCase:" (pprType PprDebug scrut_ty) $ 
+                            getAppTyCon scrut_ty
+
+       -- Stuff for newtype
+    (con_id, arg_ids, match_result) = head alts
+    arg_id                         = head arg_ids
+    coercion_bind                  = NonRec arg_id (Coerce (CoerceOut con_id) 
+                                                           (idType arg_id)
+                                                           (Var var))
+    newtype_sanity                 = null (tail alts) && null (tail arg_ids)
+
+       -- Stuff for data types
+    data_cons = tyConDataCons tycon

 
     un_mentioned_constructors
       = uniqSetToList (mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- alts] )
 
     un_mentioned_constructors
       = uniqSetToList (mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- alts] )

@@ -173,24 +199,24 @@ mkCoAlgCaseMatchResult var alts
     can_any_alt_fail = foldr1 orFail [can_it_fail | MatchResult can_it_fail _ _ _ <- match_results]
 
     mk_case alts deflt_fn fail_expr
     can_any_alt_fail = foldr1 orFail [can_it_fail | MatchResult can_it_fail _ _ _ <- match_results]
 
     mk_case alts deflt_fn fail_expr

-      = CoCase (CoVar var) (CoAlgAlts final_alts (deflt_fn fail_expr))
+      = Case (Var var) (AlgAlts final_alts (deflt_fn fail_expr))

       where
       where

-       final_alts = [ (con, args, body_fn fail_expr) 
+       final_alts = [ (con, args, body_fn fail_expr)

                     | (con, args, MatchResult _ _ body_fn _) <- alts
                     ]
 
 
 combineMatchResults :: MatchResult -> MatchResult -> DsM MatchResult
 combineMatchResults (MatchResult CanFail      ty1 body_fn1 cxt1)
                     | (con, args, MatchResult _ _ body_fn _) <- alts
                     ]
 
 
 combineMatchResults :: MatchResult -> MatchResult -> DsM MatchResult
 combineMatchResults (MatchResult CanFail      ty1 body_fn1 cxt1)

-                   (MatchResult can_it_fail2 ty2 body_fn2 cxt2) 
+                   (MatchResult can_it_fail2 ty2 body_fn2 cxt2)

   = mkFailurePair ty1          `thenDs` \ (bind_fn, duplicatable_expr) ->
     let
   = mkFailurePair ty1          `thenDs` \ (bind_fn, duplicatable_expr) ->
     let

-       new_body_fn1 = \body1 -> CoLet (bind_fn body1) (body_fn1 duplicatable_expr)
+       new_body_fn1 = \body1 -> Let (bind_fn body1) (body_fn1 duplicatable_expr)

        new_body_fn2 = \body2 -> new_body_fn1 (body_fn2 body2)
     in
     returnDs (MatchResult can_it_fail2 ty1 new_body_fn2 cxt1)
 
        new_body_fn2 = \body2 -> new_body_fn1 (body_fn2 body2)
     in
     returnDs (MatchResult can_it_fail2 ty1 new_body_fn2 cxt1)
 

-combineMatchResults match_result1@(MatchResult CantFail ty body_fn1 cxt1) 
+combineMatchResults match_result1@(MatchResult CantFail ty body_fn1 cxt1)

                                  match_result2
   = returnDs match_result1
 
                                  match_result2
   = returnDs match_result1
 

@@ -199,7 +225,7 @@ combineMatchResults match_result1@(MatchResult CantFail ty body_fn1 cxt1)
 -- need to let-bind to avoid code duplication
 combineGRHSMatchResults :: MatchResult -> MatchResult -> DsM MatchResult
 combineGRHSMatchResults (MatchResult CanFail     ty1 body_fn1 cxt1)
 -- need to let-bind to avoid code duplication
 combineGRHSMatchResults :: MatchResult -> MatchResult -> DsM MatchResult
 combineGRHSMatchResults (MatchResult CanFail     ty1 body_fn1 cxt1)

-                       (MatchResult can_it_fail ty2 body_fn2 cxt2) 
+                       (MatchResult can_it_fail ty2 body_fn2 cxt2)

   = returnDs (MatchResult can_it_fail ty1 (\ body -> body_fn1 (body_fn2 body)) cxt1)
 
 combineGRHSMatchResults match_result1 match_result2
   = returnDs (MatchResult can_it_fail ty1 (\ body -> body_fn1 (body_fn2 body)) cxt1)
 
 combineGRHSMatchResults match_result1 match_result2

@@ -214,58 +240,84 @@ combineGRHSMatchResults match_result1 match_result2
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}

-dsExprToAtom :: PlainCoreExpr                          -- The argument expression
-            -> (PlainCoreAtom -> DsM PlainCoreExpr)    -- Something taking the argument *atom*,
-                                                       -- and delivering an expression E
-            -> DsM PlainCoreExpr                       -- Either E or let x=arg-expr in E
-
-dsExprToAtom (CoVar v) continue_with = continue_with (CoVarAtom v)
-dsExprToAtom (CoLit v) continue_with = continue_with (CoLitAtom v)
-
-dsExprToAtom arg_expr continue_with
-  = newSysLocalDs ty                   `thenDs` \ arg_id ->
-    continue_with (CoVarAtom arg_id)   `thenDs` \ body   ->
-    if isUnboxedDataType ty
-    then returnDs (CoCase arg_expr (CoPrimAlts [] (CoBindDefault arg_id body)))
-    else returnDs (CoLet (CoNonRec arg_id arg_expr) body)
-  where
-    ty = typeOfCoreExpr arg_expr
+dsExprToAtom :: DsCoreArg                  -- The argument expression
+            -> (CoreArg -> DsM CoreExpr)   -- Something taking the argument *atom*,
+                                           -- and delivering an expression E
+            -> DsM CoreExpr                -- Either E or let x=arg-expr in E

 
 

-dsExprsToAtoms :: [PlainCoreExpr]
-              -> ([PlainCoreAtom] -> DsM PlainCoreExpr)
-              -> DsM PlainCoreExpr
+dsExprToAtom (UsageArg u) continue_with = continue_with (UsageArg u)
+dsExprToAtom (TyArg    t) continue_with = continue_with (TyArg    t)
+dsExprToAtom (LitArg   l) continue_with = continue_with (LitArg   l)

 
 

-dsExprsToAtoms [] continue_with
-  = continue_with []
+dsExprToAtom (VarArg (Var v)) continue_with = continue_with (VarArg v)
+dsExprToAtom (VarArg (Lit v)) continue_with = continue_with (LitArg v)
+
+dsExprToAtom (VarArg arg_expr) continue_with
+  = let
+       ty = coreExprType arg_expr
+    in
+    newSysLocalDs ty                   `thenDs` \ arg_id ->
+    continue_with (VarArg arg_id)      `thenDs` \ body   ->
+    returnDs (
+       if isUnboxedType ty
+       then Case arg_expr (PrimAlts [] (BindDefault arg_id body))
+       else Let (NonRec arg_id arg_expr) body
+    )
+
+dsExprsToAtoms :: [DsCoreArg]
+              -> ([CoreArg] -> DsM CoreExpr)
+              -> DsM CoreExpr
+
+dsExprsToAtoms [] continue_with = continue_with []

 
 dsExprsToAtoms (arg:args) continue_with
 
 dsExprsToAtoms (arg:args) continue_with

-  = dsExprToAtom   arg         (\ arg_atom ->
-    dsExprsToAtoms args (\ arg_atoms ->
+  = dsExprToAtom   arg         $ \ arg_atom  ->
+    dsExprsToAtoms args $ \ arg_atoms ->

     continue_with (arg_atom:arg_atoms)
     continue_with (arg_atom:arg_atoms)

-    ))

 \end{code}
 
 %************************************************************************
 %*                                                                     *
 \end{code}
 
 %************************************************************************
 %*                                                                     *

-\subsection[mkCoAppDs]{Desugarer's versions of some Core functions}
+\subsection{Desugarer's versions of some Core functions}

 %*                                                                     *
 %************************************************************************
 
 %*                                                                     *
 %************************************************************************
 

-Plumb the desugarer's @UniqueSupply@ in/out of the @UniqueSupplyMonad@
-world.

 \begin{code}
 \begin{code}

-mkCoAppDs  :: PlainCoreExpr -> PlainCoreExpr -> DsM PlainCoreExpr
-mkCoConDs  :: Id -> [UniType] -> [PlainCoreExpr] -> DsM PlainCoreExpr
-mkCoPrimDs :: PrimOp -> [UniType] -> [PlainCoreExpr] -> DsM PlainCoreExpr
+type DsCoreArg = GenCoreArg CoreExpr{-NB!-} TyVar UVar
+
+mkAppDs  :: CoreExpr -> [DsCoreArg] -> DsM CoreExpr
+mkConDs  :: Id       -> [DsCoreArg] -> DsM CoreExpr
+mkPrimDs :: PrimOp   -> [DsCoreArg] -> DsM CoreExpr
+
+mkAppDs fun args
+  = dsExprsToAtoms args $ \ atoms ->
+    returnDs (mkGenApp fun atoms)

 
 

-mkCoAppDs fun arg_expr
-  = dsExprToAtom arg_expr (\ arg_atom -> returnDs (CoApp fun arg_atom))
+mkConDs con args
+  = dsExprsToAtoms args $ \ atoms ->
+    returnDs (Con  con atoms)
+
+mkPrimDs op args
+  = dsExprsToAtoms args $ \ atoms ->
+    returnDs (Prim op  atoms)
+\end{code}
+
+\begin{code}
+showForErr :: Outputable a => a -> String              -- Boring but useful
+showForErr thing = ppShow 80 (ppr PprForUser thing)

 
 

-mkCoConDs con tys arg_exprs
-  = dsExprsToAtoms arg_exprs (\ arg_atoms -> returnDs (CoCon con tys arg_atoms))
+mkErrorAppDs :: Id             -- The error function
+            -> Type            -- Type to which it should be applied
+            -> String          -- The error message string to pass
+            -> DsM CoreExpr

 
 

-mkCoPrimDs op tys arg_exprs
-  = dsExprsToAtoms arg_exprs (\ arg_atoms -> returnDs (CoPrim op tys arg_atoms))
+mkErrorAppDs err_id ty msg
+  = getSrcLocDs                        `thenDs` \ (file, line) ->
+    let
+       full_msg = file ++ "|" ++ line ++ "|" ++msg
+       msg_lit  = NoRepStr (_PK_ full_msg)
+    in
+    returnDs (mkApp (Var err_id) [] [ty] [LitArg msg_lit])

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -295,27 +347,20 @@ mkSelectorBinds :: [TyVar]            -- Variables wrt which the pattern is polymorphic
                -> TypecheckedPat   -- The pattern
                -> [(Id,Id)]        -- Monomorphic and polymorphic binders for
                                    -- the pattern
                -> TypecheckedPat   -- The pattern
                -> [(Id,Id)]        -- Monomorphic and polymorphic binders for
                                    -- the pattern

-               -> PlainCoreExpr    -- Expression to which the pattern is bound
-               -> DsM [(Id,PlainCoreExpr)]
+               -> CoreExpr    -- Expression to which the pattern is bound
+               -> DsM [(Id,CoreExpr)]

 
 mkSelectorBinds tyvars pat locals_and_globals val_expr
 
 mkSelectorBinds tyvars pat locals_and_globals val_expr

-  = getSrcLocDs                `thenDs` \ (src_file, src_line) ->
-
-    if is_simple_tuple_pat pat then
+  = if is_simple_tuple_pat pat then

        mkTupleBind tyvars [] locals_and_globals val_expr
     else
        mkTupleBind tyvars [] locals_and_globals val_expr
     else

-       newSysLocalDs stringTy  `thenDs` \ str_var -> -- to hold the string
-       let
-           src_loc_str   = escErrorMsg ('"' : src_file) ++ "%l" ++ src_line
-           error_string  = src_loc_str ++ "%~" --> ": pattern-match failed on an irrefutable pattern"
-           error_msg     = mkErrorCoApp res_ty str_var error_string
-       in
+       mkErrorAppDs iRREFUT_PAT_ERROR_ID res_ty ""     `thenDs` \ error_msg ->

        matchSimply val_expr pat res_ty local_tuple error_msg `thenDs` \ tuple_expr ->
        mkTupleBind tyvars [] locals_and_globals tuple_expr
   where
     locals     = [local | (local, _) <- locals_and_globals]
     local_tuple = mkTupleExpr locals
        matchSimply val_expr pat res_ty local_tuple error_msg `thenDs` \ tuple_expr ->
        mkTupleBind tyvars [] locals_and_globals tuple_expr
   where
     locals     = [local | (local, _) <- locals_and_globals]
     local_tuple = mkTupleExpr locals

-    res_ty      = typeOfCoreExpr local_tuple
+    res_ty      = coreExprType local_tuple

 
     is_simple_tuple_pat (TuplePat ps) = all is_var_pat ps
     is_simple_tuple_pat other         = False
 
     is_simple_tuple_pat (TuplePat ps) = all is_var_pat ps
     is_simple_tuple_pat other         = False

@@ -326,7 +371,7 @@ mkSelectorBinds tyvars pat locals_and_globals val_expr
 
 We're about to match against some patterns.  We want to make some
 @Ids@ to use as match variables.  If a pattern has an @Id@ readily at
 
 We're about to match against some patterns.  We want to make some
 @Ids@ to use as match variables.  If a pattern has an @Id@ readily at

-hand, which should indeed be bound to the pattern as a whole, then use it; 
+hand, which should indeed be bound to the pattern as a whole, then use it;

 otherwise, make one up.
 \begin{code}
 selectMatchVars :: [TypecheckedPat] -> DsM [Id]
 otherwise, make one up.
 \begin{code}
 selectMatchVars :: [TypecheckedPat] -> DsM [Id]

@@ -336,27 +381,23 @@ selectMatchVars pats
     var_from_pat_maybe (VarPat var)    = returnDs var
     var_from_pat_maybe (AsPat var pat) = returnDs var
     var_from_pat_maybe (LazyPat pat)   = var_from_pat_maybe pat
     var_from_pat_maybe (VarPat var)    = returnDs var
     var_from_pat_maybe (AsPat var pat) = returnDs var
     var_from_pat_maybe (LazyPat pat)   = var_from_pat_maybe pat

-
---  var_from_pat_maybe (NPlusKPat n _ _ _ _ _) = returnDs n
--- WRONG!  We don't want to bind n to the pattern as a whole!
-

     var_from_pat_maybe other_pat
     var_from_pat_maybe other_pat

-      = newSysLocalDs (typeOfPat other_pat) -- OK, better make up one...
+      = newSysLocalDs (outPatType other_pat) -- OK, better make up one...

 \end{code}
 
 \begin{code}
 mkTupleBind :: [TyVar]     -- Abstract wrt these...
        -> [DictVar]        -- ... and these
 \end{code}
 
 \begin{code}
 mkTupleBind :: [TyVar]     -- Abstract wrt these...
        -> [DictVar]        -- ... and these

-                           
+

        -> [(Id, Id)]       -- Local, global pairs, equal in number
                            -- to the size of the tuple.  The types
                            -- of the globals is the generalisation of
                            -- the corresp local, wrt the tyvars and dicts
        -> [(Id, Id)]       -- Local, global pairs, equal in number
                            -- to the size of the tuple.  The types
                            -- of the globals is the generalisation of
                            -- the corresp local, wrt the tyvars and dicts

-                               
-       -> PlainCoreExpr    -- Expr whose value is a tuple; the expression
+
+       -> CoreExpr    -- Expr whose value is a tuple; the expression

                            -- may mention the tyvars and dicts
                            -- may mention the tyvars and dicts

-                                       
-       -> DsM [(Id, PlainCoreExpr)]    -- Bindings for the globals
+
+       -> DsM [(Id, CoreExpr)] -- Bindings for the globals

 \end{code}
 
 The general call is
 \end{code}
 
 The general call is

@@ -377,22 +418,24 @@ Otherwise, the result is:
 
 \begin{code}
 mkTupleBind tyvars dicts [(local,global)] tuple_expr
 
 \begin{code}
 mkTupleBind tyvars dicts [(local,global)] tuple_expr

-  = returnDs [(global, mkCoTyLam tyvars (mkCoLam dicts tuple_expr))]
+  = returnDs [(global, mkLam tyvars dicts tuple_expr)]

 \end{code}
 
 The general case:
 
 \begin{code}
 mkTupleBind tyvars dicts local_global_prs tuple_expr
 \end{code}
 
 The general case:
 
 \begin{code}
 mkTupleBind tyvars dicts local_global_prs tuple_expr

-  = newSysLocalDs tuple_var_ty `thenDs` \ tuple_var ->
+  = --pprTrace "mkTupleBind:\n" (ppAboves [ppCat (map (pprId PprShowAll) locals), ppCat (map (pprId PprShowAll) globals), {-ppr PprDebug local_tuple, pprType PprDebug res_ty,-} ppr PprDebug tuple_expr]) $

 
 

-    zipWithDs (mk_selector (CoVar tuple_var))
+    newSysLocalDs tuple_var_ty `thenDs` \ tuple_var ->
+
+    zipWithDs (mk_selector (Var tuple_var))

              local_global_prs
              [(0::Int) .. (length local_global_prs - 1)]
                                `thenDs` \ tup_selectors ->
     returnDs (
              local_global_prs
              [(0::Int) .. (length local_global_prs - 1)]
                                `thenDs` \ tup_selectors ->
     returnDs (

-       (tuple_var, mkCoTyLam tyvars (mkCoLam dicts tuple_expr)) :
-       tup_selectors
+       (tuple_var, mkLam tyvars dicts tuple_expr)
+       : tup_selectors

     )
   where
     locals, globals :: [Id]
     )
   where
     locals, globals :: [Id]

@@ -400,18 +443,18 @@ mkTupleBind tyvars dicts local_global_prs tuple_expr
     globals = [global | (local,global) <- local_global_prs]
 
     no_of_binders = length local_global_prs
     globals = [global | (local,global) <- local_global_prs]
 
     no_of_binders = length local_global_prs

-    tyvar_tys = map mkTyVarTy tyvars
+    tyvar_tys = mkTyVarTys tyvars

 
 

-    tuple_var_ty :: UniType
+    tuple_var_ty :: Type

     tuple_var_ty
     tuple_var_ty

-      = case (quantifyTy tyvars (mkRhoTy theta
-                                 (applyTyCon (mkTupleTyCon no_of_binders) 
-                                             (map getIdUniType locals)))) of
-         (_{-tossed templates-}, ty) -> ty
+      = mkForAllTys tyvars $
+       mkRhoTy theta      $
+       applyTyCon (mkTupleTyCon no_of_binders)
+                  (map idType locals)

       where
       where

-       theta = map (splitDictType . getIdUniType) dicts
+       theta = mkTheta (map idType dicts)

 
 

-    mk_selector :: PlainCoreExpr -> (Id, Id) -> Int -> DsM (Id, PlainCoreExpr)
+    mk_selector :: CoreExpr -> (Id, Id) -> Int -> DsM (Id, CoreExpr)

 
     mk_selector tuple_var_expr (local, global) which_local
       = mapDs duplicateLocalDs locals{-the whole bunch-} `thenDs` \ binders ->
 
     mk_selector tuple_var_expr (local, global) which_local
       = mapDs duplicateLocalDs locals{-the whole bunch-} `thenDs` \ binders ->

@@ -419,37 +462,33 @@ mkTupleBind tyvars dicts local_global_prs tuple_expr
            selected = binders !! which_local
        in
        returnDs (
            selected = binders !! which_local
        in
        returnDs (

-         (global, mkCoTyLam tyvars (
-                   mkCoLam dicts (
-                   mkTupleSelector (mkCoApp_XX (mkCoTyApps tuple_var_expr tyvar_tys) dicts)
-                                   binders selected)))
+           global,
+           mkLam tyvars dicts (
+               mkTupleSelector
+                   (mkValApp (mkTyApp tuple_var_expr tyvar_tys)
+                             (map VarArg dicts))
+                   binders
+                   selected)

        )
        )

-
-mkCoApp_XX :: PlainCoreExpr -> [Id] -> PlainCoreExpr
-mkCoApp_XX expr []      = expr
-mkCoApp_XX expr (id:ids) = mkCoApp_XX (CoApp expr (CoVarAtom id)) ids

 \end{code}
 
 \end{code}
 

-
-
-@mkTupleExpr@ builds a tuple; the inverse to mkTupleSelector.  
-If it has only one element, it is
-the identity function.
-
+@mkTupleExpr@ builds a tuple; the inverse to @mkTupleSelector@.  If it
+has only one element, it is the identity function.

 \begin{code}
 \begin{code}

-mkTupleExpr :: [Id] -> PlainCoreExpr
-
-mkTupleExpr []  = CoCon (mkTupleCon 0) [] []
-mkTupleExpr [id] = CoVar id
-mkTupleExpr ids         = CoCon (mkTupleCon (length ids)) 
-                        (map getIdUniType ids) 
-                        [ CoVarAtom i | i <- ids ]
+mkTupleExpr :: [Id] -> CoreExpr
+
+mkTupleExpr []  = Con (mkTupleCon 0) []
+mkTupleExpr [id] = Var id
+mkTupleExpr ids         = mkCon (mkTupleCon (length ids))
+                        [{-usages-}]
+                        (map idType ids)
+                        [ VarArg i | i <- ids ]

 \end{code}
 
 
 @mkTupleSelector@ builds a selector which scrutises the given
 expression and extracts the one name from the list given.
 \end{code}
 
 
 @mkTupleSelector@ builds a selector which scrutises the given
 expression and extracts the one name from the list given.

-If you want the no-shadowing rule to apply, the caller 
+If you want the no-shadowing rule to apply, the caller

 is responsible for making sure that none of these names
 are in scope.
 
 is responsible for making sure that none of these names
 are in scope.
 

@@ -457,10 +496,10 @@ If there is just one id in the ``tuple'', then the selector is
 just the identity.
 
 \begin{code}
 just the identity.
 
 \begin{code}

-mkTupleSelector :: PlainCoreExpr       -- Scrutinee
+mkTupleSelector :: CoreExpr    -- Scrutinee

                -> [Id]                 -- The tuple args
                -> Id                   -- The selected one
                -> [Id]                 -- The tuple args
                -> Id                   -- The selected one

-               -> PlainCoreExpr
+               -> CoreExpr

 
 mkTupleSelector expr [] the_var = panic "mkTupleSelector"
 
 
 mkTupleSelector expr [] the_var = panic "mkTupleSelector"
 

@@ -468,9 +507,9 @@ mkTupleSelector expr [var] should_be_the_same_var
   = ASSERT(var == should_be_the_same_var)
     expr
 
   = ASSERT(var == should_be_the_same_var)
     expr
 

-mkTupleSelector expr vars the_var 
- = CoCase expr (CoAlgAlts [(mkTupleCon arity, vars, CoVar the_var)]
-                         CoNoDefault)
+mkTupleSelector expr vars the_var
+ = Case expr (AlgAlts [(mkTupleCon arity, vars, Var the_var)]
+                         NoDefault)

  where
    arity = length vars
 \end{code}
  where
    arity = length vars
 \end{code}

@@ -515,42 +554,40 @@ there is every chance that someone will change the let into a case:
 \end{verbatim}
 
 which is of course utterly wrong.  Rather than drop the condition that
 \end{verbatim}
 
 which is of course utterly wrong.  Rather than drop the condition that

-only boxed types can be let-bound, we just turn the fail into a function 
+only boxed types can be let-bound, we just turn the fail into a function

 for the primitive case:
 \begin{verbatim}
 for the primitive case:
 \begin{verbatim}

-       let fail.33 :: () -> Int#
+       let fail.33 :: Void -> Int#

            fail.33 = \_ -> error "Help"
        in
        case x of
                p1 -> ...
            fail.33 = \_ -> error "Help"
        in
        case x of
                p1 -> ...

-               p2 -> fail.33 ()
-               p3 -> fail.33 ()
+               p2 -> fail.33 void
+               p3 -> fail.33 void

                p4 -> ...
 \end{verbatim}
 
 Now fail.33 is a function, so it can be let-bound.
 
 \begin{code}
                p4 -> ...
 \end{verbatim}
 
 Now fail.33 is a function, so it can be let-bound.
 
 \begin{code}

-mkFailurePair :: UniType               -- Result type of the whole case expression
-             -> DsM (PlainCoreExpr -> PlainCoreBinding,
-                                       -- Binds the newly-created fail variable 
-                                       -- to either the expression or \_ -> expression
-                     PlainCoreExpr)    -- Either the fail variable, or fail variable 
-                                       -- applied to unit tuple
+mkFailurePair :: Type          -- Result type of the whole case expression
+             -> DsM (CoreExpr -> CoreBinding,
+                               -- Binds the newly-created fail variable
+                               -- to either the expression or \ _ -> expression
+                     CoreExpr) -- Either the fail variable, or fail variable
+                               -- applied to unit tuple

 mkFailurePair ty
 mkFailurePair ty

-  | isUnboxedDataType ty
-  = newFailLocalDs (mkFunTy unit_ty ty)        `thenDs` \ fail_fun_var ->
-    newSysLocalDs unit_ty              `thenDs` \ fail_fun_arg ->
-    returnDs (\ body -> CoNonRec fail_fun_var (CoLam [fail_fun_arg] body), 
-             CoApp (CoVar fail_fun_var) (CoVarAtom unit_id))
+  | isUnboxedType ty
+  = newFailLocalDs (voidTy `mkFunTy` ty)       `thenDs` \ fail_fun_var ->
+    newSysLocalDs voidTy                       `thenDs` \ fail_fun_arg ->
+    returnDs (\ body ->
+               NonRec fail_fun_var (Lam (ValBinder fail_fun_arg) body),
+             App (Var fail_fun_var) (VarArg voidId))

 
   | otherwise
   = newFailLocalDs ty          `thenDs` \ fail_var ->
 
   | otherwise
   = newFailLocalDs ty          `thenDs` \ fail_var ->

-    returnDs (\ body -> CoNonRec fail_var body, CoVar fail_var)
+    returnDs (\ body -> NonRec fail_var body, Var fail_var)
+\end{code}
+

 
 

-unit_id :: Id  -- out here to avoid CAF (sigh)
-unit_id = mkTupleCon 0

 
 

-unit_ty :: UniType
-unit_ty = getIdUniType unit_id
-\end{code}