This BIG PATCH contains most of the work for the New Coercion Representation

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

diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs
index 42379b4..0405716 100644 (file)
--- a/compiler/coreSyn/CorePrep.lhs
+++ b/compiler/coreSyn/CorePrep.lhs
@@ -37,6 +37,7 @@ import OrdList
 import ErrUtils
 import DynFlags
 import Util
 import ErrUtils
 import DynFlags
 import Util

+import Pair

 import Outputable
 import MonadUtils
 import FastString
 import Outputable
 import MonadUtils
 import FastString

@@ -78,9 +79,9 @@ The goal of this pass is to prepare for code generation.
     weaker guarantee of no clashes which the simplifier provides.
     And that is what the code generator needs.
 
     weaker guarantee of no clashes which the simplifier provides.
     And that is what the code generator needs.
 

-    We don't clone TyVars. The code gen doesn't need that, 
+    We don't clone TyVars or CoVars. The code gen doesn't need that, 

     and doing so would be tiresome because then we'd need
     and doing so would be tiresome because then we'd need

-    to substitute in types.
+    to substitute in types and coercions.

 
 
 7.  Give each dynamic CCall occurrence a fresh unique; this is
 
 
 7.  Give each dynamic CCall occurrence a fresh unique; this is

@@ -104,19 +105,21 @@ Invariants
 Here is the syntax of the Core produced by CorePrep:
 
     Trivial expressions 
 Here is the syntax of the Core produced by CorePrep:
 
     Trivial expressions 

-       triv ::= lit |  var  | triv ty  |  /\a. triv  |  triv |> co
+       triv ::= lit |  var  
+              | triv ty  |  /\a. triv 
+              | truv co  |  /\c. triv  |  triv |> co

 
     Applications
 
     Applications

-       app ::= lit  |  var  |  app triv  |  app ty  |  app |> co
+       app ::= lit  |  var  |  app triv  |  app ty  | app co | app |> co

 
     Expressions
        body ::= app  
               | let(rec) x = rhs in body     -- Boxed only
               | case body of pat -> body
 
     Expressions
        body ::= app  
               | let(rec) x = rhs in body     -- Boxed only
               | case body of pat -> body

-             | /\a. body
+             | /\a. body | /\c. body 

               | body |> co
 
               | body |> co
 

-    Right hand sides (only place where lambdas can occur)
+    Right hand sides (only place where value lambdas can occur)

        rhs ::= /\a.rhs  |  \x.rhs  |  body
 
 We define a synonym for each of these non-terminals.  Functions
        rhs ::= /\a.rhs  |  \x.rhs  |  body
 
 We define a synonym for each of these non-terminals.  Functions

@@ -440,9 +443,10 @@ cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
 -- For example
 --     f (g x)   ===>   ([v = g x], f v)
 
 -- For example
 --     f (g x)   ===>   ([v = g x], f v)
 

-cpeRhsE _env expr@(Type _) = return (emptyFloats, expr)
-cpeRhsE _env expr@(Lit _)  = return (emptyFloats, expr)
-cpeRhsE env expr@(Var {})  = cpeApp env expr
+cpeRhsE _env expr@(Type {})     = return (emptyFloats, expr)
+cpeRhsE _env expr@(Coercion {}) = return (emptyFloats, expr)
+cpeRhsE _env expr@(Lit {})      = return (emptyFloats, expr)
+cpeRhsE env expr@(Var {})       = cpeApp env expr

 
 cpeRhsE env (Var f `App` _ `App` arg)
   | f `hasKey` lazyIdKey         -- Replace (lazy a) by a
 
 cpeRhsE env (Var f `App` _ `App` arg)
   | f `hasKey` lazyIdKey         -- Replace (lazy a) by a

@@ -528,7 +532,7 @@ rhsToBody (Cast e co)
 rhsToBody expr@(Lam {})
   | Just no_lam_result <- tryEtaReducePrep bndrs body
   = return (emptyFloats, no_lam_result)
 rhsToBody expr@(Lam {})
   | Just no_lam_result <- tryEtaReducePrep bndrs body
   = return (emptyFloats, no_lam_result)

-  | all isTyCoVar bndrs                -- Type lambdas are ok
+  | all isTyVar bndrs          -- Type lambdas are ok

   = return (emptyFloats, expr)
   | otherwise                  -- Some value lambdas
   = do { fn <- newVar (exprType expr)
   = return (emptyFloats, expr)
   | otherwise                  -- Some value lambdas
   = do { fn <- newVar (exprType expr)

@@ -579,6 +583,10 @@ cpeApp env expr
       = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun depth
            ; return (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss) }
 
       = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun depth
            ; return (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss) }
 

+    collect_args (App fun arg@(Coercion arg_co)) depth
+      = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun depth
+           ; return (App fun' arg, hd, applyCo fun_ty arg_co, floats, ss) }
+

     collect_args (App fun arg) depth
       = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun (depth+1)
           ; let
     collect_args (App fun arg) depth
       = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun (depth+1)
           ; let

@@ -608,7 +616,7 @@ cpeApp env expr
                -- partial application might be seq'd
 
     collect_args (Cast fun co) depth
                -- partial application might be seq'd
 
     collect_args (Cast fun co) depth

-      = do { let (_ty1,ty2) = coercionKind co
+      = do { let Pair _ty1 ty2 = coercionKind co

            ; (fun', hd, _, floats, ss) <- collect_args fun depth
            ; return (Cast fun' co, hd, ty2, floats, ss) }
           
            ; (fun', hd, _, floats, ss) <- collect_args fun depth
            ; return (Cast fun' co, hd, ty2, floats, ss) }
           

@@ -751,11 +759,12 @@ cpe_ExprIsTrivial :: CoreExpr -> Bool
 -- Version that doesn't consider an scc annotation to be trivial.
 cpe_ExprIsTrivial (Var _)                  = True
 cpe_ExprIsTrivial (Type _)                 = True
 -- Version that doesn't consider an scc annotation to be trivial.
 cpe_ExprIsTrivial (Var _)                  = True
 cpe_ExprIsTrivial (Type _)                 = True

+cpe_ExprIsTrivial (Coercion _)             = True

 cpe_ExprIsTrivial (Lit _)                  = True
 cpe_ExprIsTrivial (App e arg)              = isTypeArg arg && cpe_ExprIsTrivial e
 cpe_ExprIsTrivial (Note n e)               = notSccNote n  && cpe_ExprIsTrivial e
 cpe_ExprIsTrivial (Cast e _)               = cpe_ExprIsTrivial e
 cpe_ExprIsTrivial (Lit _)                  = True
 cpe_ExprIsTrivial (App e arg)              = isTypeArg arg && cpe_ExprIsTrivial e
 cpe_ExprIsTrivial (Note n e)               = notSccNote n  && cpe_ExprIsTrivial e
 cpe_ExprIsTrivial (Cast e _)               = cpe_ExprIsTrivial e

-cpe_ExprIsTrivial (Lam b body) | isTyCoVar b = cpe_ExprIsTrivial body
+cpe_ExprIsTrivial (Lam b body) | isTyVar b = cpe_ExprIsTrivial body

 cpe_ExprIsTrivial _                        = False
 \end{code}
 
 cpe_ExprIsTrivial _                        = False
 \end{code}
 

@@ -1070,7 +1079,7 @@ cloneBndrs env bs = mapAccumLM cloneBndr env bs
 
 cloneBndr  :: CorePrepEnv -> Var -> UniqSM (CorePrepEnv, Var)
 cloneBndr env bndr
 
 cloneBndr  :: CorePrepEnv -> Var -> UniqSM (CorePrepEnv, Var)
 cloneBndr env bndr

-  | isLocalId bndr
+  | isLocalId bndr, not (isCoVar bndr)

   = do bndr' <- setVarUnique bndr <$> getUniqueM
        
        -- We are going to OccAnal soon, so drop (now-useless) rules/unfoldings
   = do bndr' <- setVarUnique bndr <$> getUniqueM
        
        -- We are going to OccAnal soon, so drop (now-useless) rules/unfoldings

@@ -1082,7 +1091,7 @@ cloneBndr env bndr
 
   | otherwise  -- Top level things, which we don't want
                -- to clone, have become GlobalIds by now
 
   | otherwise  -- Top level things, which we don't want
                -- to clone, have become GlobalIds by now

-               -- And we don't clone tyvars
+               -- And we don't clone tyvars, or coercion variables

   = return (env, bndr)
   
 
   = return (env, bndr)