-- friends
import NDPCoreUtils (tupleTyArgs, funTyArgs, parrElemTy, isDefault,
-- friends
import NDPCoreUtils (tupleTyArgs, funTyArgs, parrElemTy, isDefault,
- isLit, mkPArrTy, mkTuple, isSimpleExpr, boolTy, substIdEnv)
+ isLit, mkPArrTy, mkTuple, isSimpleExpr, substIdEnv)
import FlattenMonad (Flatten, runFlatten, mkBind, extendContext, packContext,
liftVar, liftConst, intersectWithContext, mk'fst,
mk'lengthP, mk'replicateP, mk'mapP, mk'bpermuteDftP,
mk'indexOfP,mk'eq,mk'neq)
-- GHC
import FlattenMonad (Flatten, runFlatten, mkBind, extendContext, packContext,
liftVar, liftConst, intersectWithContext, mk'fst,
mk'lengthP, mk'replicateP, mk'mapP, mk'bpermuteDftP,
mk'indexOfP,mk'eq,mk'neq)
-- GHC
-import CmdLineOpts (opt_Flatten)
+import TcType ( tcIsForAllTy, tcView )
+import TypeRep ( Type(..) )
+import StaticFlags (opt_Flatten)
-import TypeRep (Type(..))
-import Type (isTypeKind)
-import HscTypes (PersistentCompilerState, ModGuts(..),
- ModGuts, HscEnv(..) )
+import HscTypes ( ModGuts(..), ModGuts, HscEnv(..), hscEPS )
import CoreFVs (exprFreeVars)
import CoreSyn (Expr(..), Bind(..), Alt(..), AltCon(..), Note(..),
CoreBndr, CoreExpr, CoreBind, mkLams, mkLets,
import CoreFVs (exprFreeVars)
import CoreSyn (Expr(..), Bind(..), Alt(..), AltCon(..), Note(..),
CoreBndr, CoreExpr, CoreBind, mkLams, mkLets,
do
(varg, argTy) <- vectorise arg
(vexpr, vexprTy) <- vectorise expr
do
(varg, argTy) <- vectorise arg
(vexpr, vexprTy) <- vectorise expr
return ((App (Lam vb vexpr) varg),
applyTypeToArg (mkPiType vb vexprTy) varg)
return ((App (Lam vb vexpr) varg),
applyTypeToArg (mkPiType vb vexprTy) varg)
(vexpr, vexprTy) <- vectorise expr
(varg, vargTy) <- vectorise arg
(vexpr, vexprTy) <- vectorise expr
(varg, vargTy) <- vectorise arg
then do
let resTy = applyTypeToArg vexprTy varg
return (App vexpr varg, resTy)
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
let resTy = applyTypeToArg t1 varg
return ((App vexpr' varg), resTy) -- apply the first component of
-- the vectorized function
(vexpr, vexprTy) <- vectorise expr -- don't vectorise 'b'!
return ((Lam b vexpr), mkPiType b vexprTy)
| otherwise =
do
(vexpr, vexprTy) <- vectorise expr
(vexpr, vexprTy) <- vectorise expr -- don't vectorise 'b'!
return ((Lam b vexpr), mkPiType b vexprTy)
| otherwise =
do
(vexpr, vexprTy) <- vectorise expr
let ve = Lam vb vexpr
(lexpr, lexprTy) <- lift e
let veTy = mkPiType vb vexprTy
let ve = Lam vb vexpr
(lexpr, lexprTy) <- lift e
let veTy = mkPiType vb vexprTy
(vbody, vbodyTy) <- vectorise body
return ((Let vbind vbody), vbodyTy)
(vbody, vbodyTy) <- vectorise body
return ((Let vbind vbody), vbodyTy)
do
(vexpr, vexprTy) <- vectorise expr
valts <- mapM vectorise' alts
do
(vexpr, vexprTy) <- vectorise expr
valts <- mapM vectorise' alts
where vectorise' (con, bs, expr) =
do
(vexpr, vexprTy) <- vectorise expr
where vectorise' (con, bs, expr) =
do
(vexpr, vexprTy) <- vectorise expr
+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)
-- lift type, don't change name (incl unique) nor IdInfo. IdInfo looks ok,
-- but I'm not entirely sure about some fields (e.g., strictness info)
liftBinderType:: CoreBndr -> Flatten CoreBndr
-- lift type, don't change name (incl unique) nor IdInfo. IdInfo looks ok,
-- but I'm not entirely sure about some fields (e.g., strictness info)
liftBinderType:: CoreBndr -> Flatten CoreBndr
-- lift: lifts an expression (a -> [:a:])
-- If the expression is a simple expression, it is treated like a constant
-- lift: lifts an expression (a -> [:a:])
-- If the expression is a simple expression, it is treated like a constant
do
(lexpr, lexprTy) <- lift expr -- don't lift b!
return (Lam b lexpr, mkPiType b lexprTy)
do
(lexpr, lexprTy) <- lift expr -- don't lift b!
return (Lam b lexpr, mkPiType b lexprTy)
(bb, bbind) <- mkBind FSLIT("is") indexExpr
lbnds <- mapM liftBinderType bnds
((lExpr, _), bnds') <- packContext bb (extendContext lbnds (lift expr))
(bb, bbind) <- mkBind FSLIT("is") indexExpr
lbnds <- mapM liftBinderType bnds
((lExpr, _), bnds') <- packContext bb (extendContext lbnds (lift expr))
liftCaseDataConDefault b (_, _, def) alts =
do
let dconIds = map (\(DataAlt d, _, _) -> dataConTag d) alts
liftCaseDataConDefault b (_, _, def) alts =
do
let dconIds = map (\(DataAlt d, _, _) -> dataConTag d) alts
(bb, bbind) <- mkBind FSLIT("is") indexExpr
((lDef, _), bnds) <- packContext bb (lift def)
(_, vbind) <- mkBind FSLIT("r") lDef
(bb, bbind) <- mkBind FSLIT("is") indexExpr
((lDef, _), bnds) <- packContext bb (lift def)
(_, vbind) <- mkBind FSLIT("r") lDef
liftCaseLitDefault b (_, _, def) alts =
do
let lits = map (\(LitAlt l, _, _) -> l) alts
liftCaseLitDefault b (_, _, def) alts =
do
let lits = map (\(LitAlt l, _, _) -> l) alts
(bb, bbind) <- mkBind FSLIT("is") indexExpr
((lDef, _), bnds) <- packContext bb (lift def)
(_, vbind) <- mkBind FSLIT("r") lDef
(bb, bbind) <- mkBind FSLIT("is") indexExpr
((lDef, _), bnds) <- packContext bb (lift def)
(_, vbind) <- mkBind FSLIT("r") lDef
Flatten (CoreBind, CoreBind, [CoreBind])
liftSingleCaseLit b lit expr =
do
Flatten (CoreBind, CoreBind, [CoreBind])
liftSingleCaseLit b lit expr =
do
(bb, bbind) <- mkBind FSLIT("is") indexExpr
((lExpr, t), bnds) <- packContext bb (lift expr) -- (b)
(_, vbind) <- mkBind FSLIT("r") lExpr
(bb, bbind) <- mkBind FSLIT("is") indexExpr
((lExpr, t), bnds) <- packContext bb (lift expr) -- (b)
(_, vbind) <- mkBind FSLIT("r") lExpr
let iVar = getVarOfBind i
let eVar = getVarOfBind e
let cVar = getVarOfBind cBind
let iVar = getVarOfBind i
let eVar = getVarOfBind e
let cVar = getVarOfBind cBind
newBnd <- mkDftBackpermute ty iVar eVar cVar
((fBnd, restBnds), _) <- dftbpBinders' is es newBnd
return ((fBnd, (newBnd:restBnds)), liftTy ty)
dftbpBinders' _ _ _ =
newBnd <- mkDftBackpermute ty iVar eVar cVar
((fBnd, restBnds), _) <- dftbpBinders' is es newBnd
return ((fBnd, (newBnd:restBnds)), liftTy ty)
dftbpBinders' _ _ _ =
lamExpr = mkLams (b:bndVars) expr -- FIXME: should be tuple
-- here
let (t1, t2) = funTyArgs . exprType $ lamExpr
lamExpr = mkLams (b:bndVars) expr -- FIXME: should be tuple
-- here
let (t1, t2) = funTyArgs . exprType $ lamExpr
-- indexOf (mapP (\x -> x == lit) b) b
--
mkIndexOfExpr:: Type -> CoreBndr -> Literal -> Flatten CoreExpr
-- indexOf (mapP (\x -> x == lit) b) b
--
mkIndexOfExpr:: Type -> CoreBndr -> Literal -> Flatten CoreExpr
-- there is FlattenMonad.mk'indexOfP as well as
-- CoreSyn.mkApps and CoreSyn.mkLam, all of which should help here
-- there is FlattenMonad.mk'indexOfP as well as
-- CoreSyn.mkApps and CoreSyn.mkLam, all of which should help here
-- indexOfP (\x -> x != dconId_1 && ....) b)
--
mkIndexOfExprDConDft:: Type -> CoreBndr -> [Int] -> Flatten CoreExpr
-- indexOfP (\x -> x != dconId_1 && ....) b)
--
mkIndexOfExprDConDft:: Type -> CoreBndr -> [Int] -> Flatten CoreExpr
-- mkIndexOfExprDef b [lit1, lit2,...] ->
-- indexOf (\x -> not (x == lit1 || x == lit2 ....) b
mkIndexOfExprDft:: Type -> CoreBndr -> [Literal] -> Flatten CoreExpr
-- mkIndexOfExprDef b [lit1, lit2,...] ->
-- indexOf (\x -> not (x == lit1 || x == lit2 ....) b
mkIndexOfExprDft:: Type -> CoreBndr -> [Literal] -> Flatten CoreExpr
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"
"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)