From: Manuel M T Chakravarty <chak@cse.unsw.edu.au>
Date: Fri, 4 Aug 2006 22:05:26 +0000 (+0000)
Subject: Massive patch for the first months work adding System FC to GHC #25
X-Git-Tag: After_FC_branch_merge~157
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=4714e5142548941592b208c34685ce684d1bf3d6

Massive patch for the first months work adding System FC to GHC #25

Broken up massive patch -=chak
Original log message:
This is (sadly) all done in one patch to avoid Darcs bugs.
It's not complete work... more FC stuff to come.  A compiler
using just this patch will fail dismally.
---

diff --git a/compiler/ndpFlatten/Flattening.hs b/compiler/ndpFlatten/Flattening.hs
index 18daaa6..c339c76 100644
--- a/compiler/ndpFlatten/Flattening.hs
+++ b/compiler/ndpFlatten/Flattening.hs
@@ -65,6 +65,7 @@ import FlattenMonad (Flatten, runFlatten, mkBind, extendContext, packContext,
 -- GHC
 import TcType	    ( tcIsForAllTy, tcView )
 import TypeRep	    ( Type(..) )
+import Coercion     ( coercionKind )
 import StaticFlags  (opt_Flatten)
 import Panic        (panic)
 import ErrUtils     (dumpIfSet_dyn)
@@ -448,11 +449,12 @@ lift cExpr@(Case expr b _ alts)  =
                 else extendContext [lb] (liftCaseDataCon b alts)
     letWrapper lExpr b lalts
 
-lift (Note (Coerce t1 t2) expr) =
-  do  
+lift (Cast expr co) =
+  do
     (lexpr, t) <- lift expr
-    let lt1 = liftTy t1
-    return ((Note (Coerce lt1 (liftTy t2)) lexpr), lt1)
+    let lco = liftTy co
+    let (t1, t2) = coercionKind lco
+    return ((Cast expr lco), t2)
 
 lift (Note note expr) =
   do 
diff --git a/compiler/ndpFlatten/NDPCoreUtils.hs b/compiler/ndpFlatten/NDPCoreUtils.hs
index 6e6b94f..9fdca34 100644
--- a/compiler/ndpFlatten/NDPCoreUtils.hs
+++ b/compiler/ndpFlatten/NDPCoreUtils.hs
@@ -171,4 +171,5 @@ substIdEnv env (Case expr b ty alts) =
        (c, bnds, substIdEnv (delVarEnvList env bnds) expr)
 substIdEnv env (Note n expr) =
   Note n (substIdEnv env expr)
+substIdEnv env (Cast e co) = Cast (substIdEnv env e) co
 substIdEnv env e@(Type t) = e
diff --git a/compiler/ndpFlatten/PArrAnal.hs b/compiler/ndpFlatten/PArrAnal.hs
index 2db5622..804162c 100644
--- a/compiler/ndpFlatten/PArrAnal.hs
+++ b/compiler/ndpFlatten/PArrAnal.hs
@@ -87,6 +87,10 @@ arrUsage (Note n expr) =
 arrUsage (Type t) =
   typeArrayUsage  t
 
+-- not quite sure this is right
+arrUsage (Cast expr co) =
+  arrUsage expr 
+
 bindType (b, expr) =
   let
     bT    = varArrayUsage b