Put liftStringName into the known-key names

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

diff --git a/compiler/coreSyn/MkCore.lhs b/compiler/coreSyn/MkCore.lhs
index c7e88be..7714b58 100644 (file)
--- a/compiler/coreSyn/MkCore.lhs
+++ b/compiler/coreSyn/MkCore.lhs
@@ -18,8 +18,7 @@ module MkCore (
         mkChunkified,
         
         -- * Constructing small tuples
-        mkCoreVarTup, mkCoreVarTupTy,
-        mkCoreTup, mkCoreTupTy,
+        mkCoreVarTup, mkCoreVarTupTy, mkCoreTup, 
         
         -- * Constructing big tuples
         mkBigCoreVarTup, mkBigCoreVarTupTy,
@@ -50,16 +49,15 @@ import TysWiredIn
 import PrelNames
 
 import Type
-import TypeRep
 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 )
@@ -95,20 +93,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
 
@@ -338,7 +339,7 @@ mkCoreVarTup ids = mkCoreTup (map Var ids)
 
 -- | Bulid the type of a small tuple that holds the specified variables
 mkCoreVarTupTy :: [Id] -> Type
-mkCoreVarTupTy ids = mkCoreTupTy (map idType ids)
+mkCoreVarTupTy ids = mkBoxedTupleTy (map idType ids)
 
 -- | Build a small tuple holding the specified expressions
 mkCoreTup :: [CoreExpr] -> CoreExpr
@@ -347,12 +348,6 @@ mkCoreTup [c] = c
 mkCoreTup cs  = mkConApp (tupleCon Boxed (length cs))
                          (map (Type . exprType) cs ++ cs)
 
--- | Build the type of a small tuple that holds the specified type of thing
-mkCoreTupTy :: [Type] -> Type
-mkCoreTupTy [ty] = ty
-mkCoreTupTy tys  = mkTupleTy Boxed (length tys) tys
-
-
 -- | Build a big tuple holding the specified variables
 mkBigCoreVarTup :: [Id] -> CoreExpr
 mkBigCoreVarTup ids = mkBigCoreTup (map Var ids)
@@ -367,7 +362,7 @@ mkBigCoreTup = mkChunkified mkCoreTup
 
 -- | Build the type of a big tuple that holds the specified type of thing
 mkBigCoreTupTy :: [Type] -> Type
-mkBigCoreTupTy = mkChunkified mkCoreTupTy
+mkBigCoreTupTy = mkChunkified mkBoxedTupleTy
 \end{code}
 
 %************************************************************************
@@ -411,7 +406,7 @@ mkTupleSelector vars the_var scrut_var scrut
     mk_tup_sel vars_s the_var = mkSmallTupleSelector group the_var tpl_v $
                                 mk_tup_sel (chunkify tpl_vs) tpl_v
         where
-          tpl_tys = [mkCoreTupTy (map idType gp) | gp <- vars_s]
+          tpl_tys = [mkBoxedTupleTy (map idType gp) | gp <- vars_s]
           tpl_vs  = mkTemplateLocals tpl_tys
           [(tpl_v, group)] = [(tpl,gp) | (tpl,gp) <- zipEqual "mkTupleSelector" tpl_vs vars_s,
                                          the_var `elem` gp ]
@@ -472,7 +467,7 @@ mkTupleCase uniqs vars body scrut_var scrut
     one_tuple_case chunk_vars (us, vs, body)
       = let (us1, us2) = splitUniqSupply us
             scrut_var = mkSysLocal (fsLit "ds") (uniqFromSupply us1)
-              (mkCoreTupTy (map idType chunk_vars))
+              (mkBoxedTupleTy (map idType chunk_vars))
             body' = mkSmallTupleCase chunk_vars body scrut_var (Var scrut_var)
         in (us2, scrut_var:vs, body')
 \end{code}