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

[ghc-hetmet.git] / compiler / coreSyn / MkCore.lhs

diff --git a/compiler/coreSyn/MkCore.lhs b/compiler/coreSyn/MkCore.lhs
index f7c0f9a..3e0ad62 100644 (file)
--- a/compiler/coreSyn/MkCore.lhs
+++ b/compiler/coreSyn/MkCore.lhs
@@ -4,7 +4,8 @@ module MkCore (
         -- * Constructing normal syntax
         mkCoreLet, mkCoreLets,
         mkCoreApp, mkCoreApps, mkCoreConApps,
-        mkCoreLams, mkWildCase, mkWildBinder, mkIfThenElse,
+        mkCoreLams, mkWildCase, mkIfThenElse,
+        mkWildValBinder, mkWildEvBinder,
         
         -- * Constructing boxed literals
         mkWordExpr, mkWordExprWord,
@@ -38,7 +39,7 @@ module MkCore (
 #include "HsVersions.h"
 
 import Id
-import Var      ( setTyVarUnique )
+import Var      ( EvVar, mkWildCoVar, setTyVarUnique )
 
 import CoreSyn
 import CoreUtils        ( exprType, needsCaseBinding, bindNonRec )
@@ -52,12 +53,12 @@ import Type
 import TysPrim          ( alphaTyVar )
 import DataCon          ( DataCon, dataConWorkId )
 
+import Outputable
 import FastString
 import UniqSupply
 import Unique          ( mkBuiltinUnique )
 import BasicTypes
 import Util             ( notNull, zipEqual )
-import Panic
 import Constants
 
 import Data.Char        ( ord )
@@ -93,20 +94,23 @@ mkCoreApp :: CoreExpr -> CoreExpr -> CoreExpr
 -- Check the invariant that the arg of an App is ok-for-speculation if unlifted
 -- See CoreSyn Note [CoreSyn let/app invariant]
 mkCoreApp fun (Type ty) = App fun (Type ty)
-mkCoreApp fun arg       = mk_val_app fun arg arg_ty res_ty
+mkCoreApp fun arg       = ASSERT2( isFunTy fun_ty, ppr fun $$ ppr arg )
+                          mk_val_app fun arg arg_ty res_ty
                       where
-                        (arg_ty, res_ty) = splitFunTy (exprType fun)
+                        fun_ty = exprType fun
+                        (arg_ty, res_ty) = splitFunTy fun_ty
 
 -- | Construct an expression which represents the application of a number of
 -- expressions to another. The leftmost expression in the list is applied first
 mkCoreApps :: CoreExpr -> [CoreExpr] -> CoreExpr
 -- Slightly more efficient version of (foldl mkCoreApp)
-mkCoreApps fun args
-  = go fun (exprType fun) args
+mkCoreApps orig_fun orig_args
+  = go orig_fun (exprType orig_fun) orig_args
   where
     go fun _      []               = fun
     go fun fun_ty (Type ty : args) = go (App fun (Type ty)) (applyTy fun_ty ty) args
-    go fun fun_ty (arg     : args) = go (mk_val_app fun arg arg_ty res_ty) res_ty args
+    go fun fun_ty (arg     : args) = ASSERT2( isFunTy fun_ty, ppr fun_ty $$ ppr orig_fun $$ ppr orig_args )
+                                     go (mk_val_app fun arg arg_ty res_ty) res_ty args
                                    where
                                      (arg_ty, res_ty) = splitFunTy fun_ty
 
@@ -125,7 +129,7 @@ mk_val_app fun arg arg_ty _        -- See Note [CoreSyn let/app invariant]
 mk_val_app fun arg arg_ty res_ty
   = Case arg arg_id res_ty [(DEFAULT,[],App fun (Var arg_id))]
   where
-    arg_id = mkWildBinder arg_ty    
+    arg_id = mkWildValBinder arg_ty    
        -- Lots of shadowing, but it doesn't matter,
         -- because 'fun ' should not have a free wild-id
        --
@@ -135,19 +139,22 @@ mk_val_app fun arg arg_ty res_ty
        -- is if you take apart this case expression, and pass a 
        -- fragmet of it as the fun part of a 'mk_val_app'.
 
+mkWildEvBinder :: PredType -> EvVar
+mkWildEvBinder pred@(EqPred {}) = mkWildCoVar     (mkPredTy pred)
+mkWildEvBinder pred             = mkWildValBinder (mkPredTy pred)
 
 -- | Make a /wildcard binder/. This is typically used when you need a binder 
 -- that you expect to use only at a *binding* site.  Do not use it at
 -- occurrence sites because it has a single, fixed unique, and it's very
 -- easy to get into difficulties with shadowing.  That's why it is used so little.
-mkWildBinder :: Type -> Id
-mkWildBinder ty = mkSysLocal (fsLit "wild") (mkBuiltinUnique 1) ty
+mkWildValBinder :: Type -> Id
+mkWildValBinder ty = mkSysLocal (fsLit "wild") (mkBuiltinUnique 1) ty
 
 mkWildCase :: CoreExpr -> Type -> Type -> [CoreAlt] -> CoreExpr
 -- Make a case expression whose case binder is unused
 -- The alts should not have any occurrences of WildId
 mkWildCase scrut scrut_ty res_ty alts 
-  = Case scrut (mkWildBinder scrut_ty) res_ty alts
+  = Case scrut (mkWildValBinder scrut_ty) res_ty alts
 
 mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
 mkIfThenElse guard then_expr else_expr