[project @ 2005-11-25 09:46:19 by simonmar]

[ghc-hetmet.git] / ghc / compiler / ndpFlatten / Flattening.hs

diff --git a/ghc/compiler/ndpFlatten/Flattening.hs b/ghc/compiler/ndpFlatten/Flattening.hs
index ccced5a..18daaa6 100644 (file)
--- a/ghc/compiler/ndpFlatten/Flattening.hs
+++ b/ghc/compiler/ndpFlatten/Flattening.hs
@@ -63,16 +63,17 @@ import FlattenMonad (Flatten, runFlatten, mkBind, extendContext, packContext,
                     mk'indexOfP,mk'eq,mk'neq) 
 
 -- GHC
                     mk'indexOfP,mk'eq,mk'neq) 
 
 -- GHC

-import CmdLineOpts  (opt_Flatten)
+import TcType      ( tcIsForAllTy, tcView )
+import TypeRep     ( Type(..) )
+import StaticFlags  (opt_Flatten)

 import Panic        (panic)
 import ErrUtils     (dumpIfSet_dyn)
 import UniqSupply   (mkSplitUniqSupply)
 import Panic        (panic)
 import ErrUtils     (dumpIfSet_dyn)
 import UniqSupply   (mkSplitUniqSupply)

-import CmdLineOpts  (DynFlag(..))
+import DynFlags  (DynFlag(..))

 import Literal      (Literal, literalType)
 import Var         (Var(..), idType, isTyVar)
 import Id          (setIdType)
 import DataCon     (DataCon, dataConTag)
 import Literal      (Literal, literalType)
 import Var         (Var(..), idType, isTyVar)
 import Id          (setIdType)
 import DataCon     (DataCon, dataConTag)

-import TypeRep      (Type(..))

 import HscTypes            ( ModGuts(..), ModGuts, HscEnv(..), hscEPS )
 import CoreFVs     (exprFreeVars)
 import CoreSyn     (Expr(..), Bind(..), Alt(..), AltCon(..), Note(..),
 import HscTypes            ( ModGuts(..), ModGuts, HscEnv(..), hscEPS )
 import CoreFVs     (exprFreeVars)
 import CoreSyn     (Expr(..), Bind(..), Alt(..), AltCon(..), Note(..),

@@ -246,7 +247,7 @@ vectorise (App expr arg) =
     (vexpr, vexprTy) <-  vectorise expr
     (varg,  vargTy)  <-  vectorise arg
 
     (vexpr, vexprTy) <-  vectorise expr
     (varg,  vargTy)  <-  vectorise arg
 

-    if (isPolyType vexprTy)
+    if (tcIsForAllTy vexprTy)

       then do
         let resTy =  applyTypeToArg vexprTy varg
         return (App vexpr varg, resTy)
       then do
         let resTy =  applyTypeToArg vexprTy varg
         return (App vexpr varg, resTy)

@@ -256,13 +257,6 @@ vectorise (App expr arg) =
         let resTy    = applyTypeToArg t1 varg   
         return  ((App vexpr' varg), resTy)  -- apply the first component of
                                             -- the vectorized function
         let resTy    = applyTypeToArg t1 varg   
         return  ((App vexpr' varg), resTy)  -- apply the first component of
                                             -- the vectorized function

-  where
-    isPolyType t =  
-        (case t  of
-           (ForAllTy _ _)  -> True
-           (NoteTy _ nt)   -> isPolyType nt
-           _               -> False)
-    

 
 vectorise  e@(Lam b expr)
   | isTyVar b
 
 vectorise  e@(Lam b expr)
   | isTyVar b

@@ -285,11 +279,12 @@ vectorise (Let bind body) =
     (vbody, vbodyTy) <- vectorise body
     return ((Let vbind vbody), vbodyTy)
 
     (vbody, vbodyTy) <- vectorise body
     return ((Let vbind vbody), vbodyTy)
 

-vectorise (Case expr b alts) =
+vectorise (Case expr b ty alts) =

   do 
     (vexpr, vexprTy) <- vectorise expr
     valts <- mapM vectorise' alts
   do 
     (vexpr, vexprTy) <- vectorise expr
     valts <- mapM vectorise' alts

-    return (Case vexpr (setIdType b vexprTy) (map fst valts), snd (head valts))
+    let res_ty = snd (head valts)
+    return (Case vexpr (setIdType b vexprTy) res_ty (map fst valts), res_ty)

   where vectorise' (con, bs, expr) = 
           do 
             (vexpr, vexprTy) <- vectorise expr
   where vectorise' (con, bs, expr) = 
           do 
             (vexpr, vexprTy) <- vectorise expr

@@ -316,6 +311,10 @@ myShowTy (TyConApp _ t) =
 -}
 
 vectoriseTy :: Type -> Type 
 -}
 
 vectoriseTy :: Type -> Type 

+vectoriseTy ty | Just ty' <- tcView ty = vectoriseTy ty'
+       -- Look through notes and synonyms
+       -- NB: This will discard notes and synonyms, of course
+       -- ToDo: retain somehow?

 vectoriseTy t@(TyVarTy v)      =  t
 vectoriseTy t@(AppTy t1 t2)    = 
   AppTy (vectoriseTy t1) (vectoriseTy t2)
 vectoriseTy t@(TyVarTy v)      =  t
 vectoriseTy t@(AppTy t1 t2)    = 
   AppTy (vectoriseTy t1) (vectoriseTy t2)

@@ -326,8 +325,6 @@ vectoriseTy t@(FunTy t1 t2)    =
                      (liftTy t)]
 vectoriseTy  t@(ForAllTy v ty)  = 
   ForAllTy v (vectoriseTy  ty)
                      (liftTy t)]
 vectoriseTy  t@(ForAllTy v ty)  = 
   ForAllTy v (vectoriseTy  ty)

-vectoriseTy t@(NoteTy note ty) =  -- FIXME: is the note still valid after
-  NoteTy note  (vectoriseTy ty)   --   this or should we just throw it away

 vectoriseTy  t =  t
 
 
 vectoriseTy  t =  t
 
 

@@ -335,9 +332,9 @@ vectoriseTy  t =  t
 --    on the *top level* (is this sufficient???)
 
 liftTy:: Type -> Type
 --    on the *top level* (is this sufficient???)
 
 liftTy:: Type -> Type

+liftTy ty | Just ty' <- tcView ty = liftTy ty'

 liftTy (FunTy t1 t2)   = FunTy (liftTy t1) (liftTy t2)
 liftTy (ForAllTy tv t) = ForAllTy tv (liftTy t)
 liftTy (FunTy t1 t2)   = FunTy (liftTy t1) (liftTy t2)
 liftTy (ForAllTy tv t) = ForAllTy tv (liftTy t)

-liftTy (NoteTy n t)    = NoteTy n $ liftTy t

 liftTy  t              = mkPArrTy t
 
 
 liftTy  t              = mkPArrTy t
 
 

@@ -441,7 +438,8 @@ lift (Let (Rec binds) expr2) =
 --        otherwise (a) compute index vector for simpleAlts (for def permute
 --                      later on
 --                  (b) 
 --        otherwise (a) compute index vector for simpleAlts (for def permute
 --                      later on
 --                  (b) 

-lift cExpr@(Case expr b alts)  =
+-- gaw 2004 FIX? 
+lift cExpr@(Case expr b _ alts)  =

   do  
     (lExpr, _) <- lift expr
     lb    <- liftBinderType  b     -- lift alt-expression
   do  
     (lExpr, _) <- lift expr
     lb    <- liftBinderType  b     -- lift alt-expression

@@ -651,8 +649,7 @@ dftbpBinders indexBnds exprBnds =
        return ((fBnd, (newBnd:restBnds)), liftTy ty)
 
     dftbpBinders'  _ _ _ = 
        return ((fBnd, (newBnd:restBnds)), liftTy ty)
 
     dftbpBinders'  _ _ _ = 

-      panic "Flattening.dftbpBinders: index and expression binder lists \ 
-           \have different length!"
+      panic "Flattening.dftbpBinders: index and expression binder lists have different length!"

 
 getExprOfBind:: CoreBind -> CoreExpr
 getExprOfBind (NonRec _ expr) = expr
 
 getExprOfBind:: CoreBind -> CoreExpr
 getExprOfBind (NonRec _ expr) = expr

@@ -754,7 +751,7 @@ mkIndexOfExprDft idType b lits =
 
 -- create a back-permute binder
 --
 
 -- create a back-permute binder
 --

--- * `mkDftBackpermute ty indexArrayVar srcArrayVar dftArrayVar' creates a
+--  * `mkDftBackpermute ty indexArrayVar srcArrayVar dftArrayVar' creates a

 --   Core binding of the form
 --
 --     x = bpermuteDftP indexArrayVar srcArrayVar dftArrayVar
 --   Core binding of the form
 --
 --     x = bpermuteDftP indexArrayVar srcArrayVar dftArrayVar

@@ -803,7 +800,8 @@ showCoreExpr (Let bnds expr) =
   where showBinds (NonRec b e) = showBind (b,e)
         showBinds (Rec bnds)   = concat (map showBind bnds)
         showBind (b,e) = "  b = " ++ (showCoreExpr e)++ "\n"
   where showBinds (NonRec b e) = showBind (b,e)
         showBinds (Rec bnds)   = concat (map showBind bnds)
         showBind (b,e) = "  b = " ++ (showCoreExpr e)++ "\n"

-showCoreExpr (Case ex b alts) =
+-- gaw 2004 FIX?
+showCoreExpr (Case ex b ty alts) =

   "Case b = " ++ (showCoreExpr ex) ++ " of \n" ++ (showAlts alts)
   where showAlts _ = ""  
 showCoreExpr (Note _ ex) = "Note n " ++ (showCoreExpr ex)
   "Case b = " ++ (showCoreExpr ex) ++ " of \n" ++ (showAlts alts)
   where showAlts _ = ""  
 showCoreExpr (Note _ ex) = "Note n " ++ (showCoreExpr ex)