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 CmdLineOpts (DynFlag(..))
+import DynFlags (DynFlag(..))
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(..),
(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)
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
(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
- 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
-}
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)
(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
-- 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 (NoteTy n t) = NoteTy n $ liftTy t
liftTy t = mkPArrTy t
-- 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
-- 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
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)