-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
module Vectorise( vectorise )
where
-#include "HsVersions.h"
-
import VectMonad
import VectUtils
import VectType
import TyCon
import Type
import FamInstEnv ( extendFamInstEnvList )
-import InstEnv ( extendInstEnvList )
import Var
import VarEnv
import VarSet
-import Name ( Name, mkSysTvName, getName )
-import NameEnv
import Id
-import MkId ( unwrapFamInstScrut )
import OccName
-import Module ( Module )
-import DsMonad hiding (mapAndUnzipM)
-import DsUtils ( mkCoreTup, mkCoreTupTy )
+import DsMonad
-import Literal ( Literal )
-import PrelNames
+import Literal ( Literal, mkMachInt )
import TysWiredIn
-import TysPrim ( intPrimTy )
-import BasicTypes ( Boxity(..) )
import Outputable
import FastString
-import Control.Monad ( liftM, liftM2, zipWithM, mapAndUnzipM )
+import Control.Monad ( liftM, liftM2, zipWithM )
import Data.List ( sortBy, unzip4 )
vectorise :: HscEnv -> UniqSupply -> RuleBase -> ModGuts
vectModule guts
= do
(types', fam_insts, tc_binds) <- vectTypeEnv (mg_types guts)
-
+
let fam_inst_env' = extendFamInstEnvList (mg_fam_inst_env guts) fam_insts
updGEnv (setFamInstEnv fam_inst_env')
-
+
-- dicts <- mapM buildPADict pa_insts
-- workers <- mapM vectDataConWorkers pa_insts
binds' <- mapM vectTopBind (mg_binds guts)
var' <- cloneId mkVectOcc var vty
defGlobalVar var var'
return var'
-
+
vectTopRhs :: Var -> CoreExpr -> VM CoreExpr
vectTopRhs var expr
= do
vectBndr :: Var -> VM VVar
vectBndr v
= do
- vty <- vectType (idType v)
- lty <- mkPArrayType vty
+ (vty, lty) <- vectAndLiftType (idType v)
let vv = v `Id.setIdType` vty
lv = v `Id.setIdType` lty
updLEnv (mapTo vv lv)
x <- p
return (vv, x)
-vectBndrIn' :: Var -> (VVar -> VM a) -> VM (VVar, a)
-vectBndrIn' v p
- = localV
- $ do
- vv <- vectBndr v
- x <- p vv
- return (vv, x)
-
vectBndrsIn :: [Var] -> VM a -> VM ([VVar], a)
vectBndrsIn vs p
= localV
return (Lit lit, lexpr)
vectPolyExpr :: CoreExprWithFVs -> VM VExpr
+vectPolyExpr (_, AnnNote note expr)
+ = liftM (vNote note) $ vectPolyExpr expr
vectPolyExpr expr
= polyAbstract tvs $ \abstract ->
do
mono' <- vectExpr mono
return $ mapVect abstract mono'
where
- (tvs, mono) = collectAnnTypeBinders expr
-
+ (tvs, mono) = collectAnnTypeBinders expr
+
vectExpr :: CoreExprWithFVs -> VM VExpr
vectExpr (_, AnnType ty)
= liftM vType (vectType ty)
where
(fn, tys) = collectAnnTypeArgs e
+vectExpr (_, AnnApp (_, AnnVar v) (_, AnnLit lit))
+ | Just con <- isDataConId_maybe v
+ , is_special_con con
+ = do
+ let vexpr = App (Var v) (Lit lit)
+ lexpr <- liftPA vexpr
+ return (vexpr, lexpr)
+ where
+ is_special_con con = con `elem` [intDataCon, floatDataCon, doubleDataCon]
+
+
vectExpr (_, AnnApp fn arg)
= do
arg_ty' <- vectType arg_ty
where
scrut_ty = exprType (deAnnotate scrut)
-vectExpr (_, AnnCase expr bndr ty alts)
+vectExpr (_, AnnCase _ _ _ _)
= panic "vectExpr: case"
vectExpr (_, AnnLet (AnnNonRec bndr rhs) body)
where
(bs,body) = collectAnnValBinders e
+vectExpr e = pprPanic "vectExpr" (ppr $ deAnnotate e)
+
vectLam :: VarSet -> [Var] -> CoreExprWithFVs -> VM VExpr
vectLam fvs bs body
= do
(vbndrs, vbody) <- vectBndrsIn (vs ++ bs)
(vectExpr body)
return $ vLams lc vbndrs vbody
-
+
vectTyAppExpr :: CoreExprWithFVs -> [Type] -> VM VExpr
vectTyAppExpr (_, AnnVar v) tys = vectPolyVar v tys
-vectTyAppExpr e tys = pprPanic "vectTyAppExpr" (ppr $ deAnnotate e)
-
-type CoreAltWithFVs = AnnAlt Id VarSet
+vectTyAppExpr e _ = pprPanic "vectTyAppExpr" (ppr $ deAnnotate e)
-- We convert
--
-- When lifting, we have to do it this way because v must have the type
-- [:V(T):] but the scrutinee must be cast to the representation type. We also
-- have to handle the case where v is a wild var correctly.
---
+--
-- FIXME: this is too lazy
-vectAlgCase tycon ty_args scrut bndr ty [(DEFAULT, [], body)]
+vectAlgCase :: TyCon -> [Type] -> CoreExprWithFVs -> Var -> Type
+ -> [(AltCon, [Var], CoreExprWithFVs)]
+ -> VM VExpr
+vectAlgCase _tycon _ty_args scrut bndr ty [(DEFAULT, [], body)]
= do
- vscrut <- vectExpr scrut
- vty <- vectType ty
- lty <- mkPArrayType vty
+ vscrut <- vectExpr scrut
+ (vty, lty) <- vectAndLiftType ty
(vbndr, vbody) <- vectBndrIn bndr (vectExpr body)
return $ vCaseDEFAULT vscrut vbndr vty lty vbody
-vectAlgCase tycon ty_args scrut bndr ty [(DataAlt dc, bndrs, body)]
+vectAlgCase _tycon _ty_args scrut bndr ty [(DataAlt _, [], body)]
= do
- vect_tc <- maybeV (lookupTyCon tycon)
- vty <- vectType ty
- lty <- mkPArrayType vty
- vexpr <- vectExpr scrut
+ vscrut <- vectExpr scrut
+ (vty, lty) <- vectAndLiftType ty
+ (vbndr, vbody) <- vectBndrIn bndr (vectExpr body)
+ return $ vCaseDEFAULT vscrut vbndr vty lty vbody
+
+vectAlgCase tycon _ty_args scrut bndr ty [(DataAlt dc, bndrs, body)]
+ = do
+ vect_tc <- maybeV (lookupTyCon tycon)
+ (vty, lty) <- vectAndLiftType ty
+ vexpr <- vectExpr scrut
(vbndr, (vbndrs, vbody)) <- vect_scrut_bndr
. vectBndrsIn bndrs
$ vectExpr body
- (vscrut, arr_tc, arg_tys) <- mkVScrut (vVar vbndr)
+ (vscrut, arr_tc, _arg_tys) <- mkVScrut (vVar vbndr)
vect_dc <- maybeV (lookupDataCon dc)
let [arr_dc] = tyConDataCons arr_tc
repr <- mkRepr vect_tc
return . vLet (vNonRec vbndr vexpr)
$ vCaseProd vscrut vty lty vect_dc arr_dc shape_bndrs vbndrs vbody
where
- vect_scrut_bndr | isDeadBinder bndr = vectBndrNewIn bndr FSLIT("scrut")
+ vect_scrut_bndr | isDeadBinder bndr = vectBndrNewIn bndr (fsLit "scrut")
| otherwise = vectBndrIn bndr
-vectAlgCase tycon ty_args scrut bndr ty alts
+vectAlgCase tycon _ty_args scrut bndr ty alts
= do
- vect_tc <- maybeV (lookupTyCon tycon)
- vty <- vectType ty
- lty <- mkPArrayType vty
-
+ vect_tc <- maybeV (lookupTyCon tycon)
+ (vty, lty) <- vectAndLiftType ty
repr <- mkRepr vect_tc
shape_bndrs <- arrShapeVars repr
(len, sel, indices) <- arrSelector repr (map Var shape_bndrs)
- (vbndr, valts) <- vect_scrut_bndr $ mapM (proc_alt sel lty) alts'
+ (vbndr, valts) <- vect_scrut_bndr $ mapM (proc_alt sel vty lty) alts'
let (vect_dcs, vect_bndrss, lift_bndrss, vbodies) = unzip4 valts
vexpr <- vectExpr scrut
- (vscrut, arr_tc, arg_tys) <- mkVScrut (vVar vbndr)
+ (vscrut, arr_tc, _arg_tys) <- mkVScrut (vVar vbndr)
let [arr_dc] = tyConDataCons arr_tc
let (vect_scrut, lift_scrut) = vscrut
return . vLet (vNonRec vbndr vexpr)
$ (vect_case, lift_case)
where
- vect_scrut_bndr | isDeadBinder bndr = vectBndrNewIn bndr FSLIT("scrut")
+ vect_scrut_bndr | isDeadBinder bndr = vectBndrNewIn bndr (fsLit "scrut")
| otherwise = vectBndrIn bndr
alts' = sortBy (\(alt1, _, _) (alt2, _, _) -> cmp alt1 alt2) alts
cmp DEFAULT DEFAULT = EQ
cmp DEFAULT _ = LT
cmp _ DEFAULT = GT
+ cmp _ _ = panic "vectAlgCase/cmp"
- proc_alt sel lty (DataAlt dc, bndrs, body)
+ proc_alt sel vty lty (DataAlt dc, bndrs, body)
= do
vect_dc <- maybeV (lookupDataCon dc)
let tag = mkDataConTag vect_dc
fvs = freeVarsOf body `delVarSetList` bndrs
(vect_bndrs, lift_bndrs, vbody)
<- vect_alt_bndrs bndrs
- $ \len -> packLiftingContext len sel tag fvs lty
+ $ \len -> packLiftingContext len sel tag fvs vty lty
$ vectExpr body
return (vect_dc, vect_bndrs, lift_bndrs, vbody)
+ proc_alt _ _ _ _ = panic "vectAlgCase/proc_alt"
vect_alt_bndrs [] p
= do
void_tc <- builtin voidTyCon
let void_ty = mkTyConApp void_tc []
arr_ty <- mkPArrayType void_ty
- bndr <- newLocalVar FSLIT("voids") arr_ty
+ bndr <- newLocalVar (fsLit "voids") arr_ty
len <- lengthPA void_ty (Var bndr)
e <- p len
return ([], [bndr], e)
mk_vect_alt vect_dc bndrs body = (DataAlt vect_dc, bndrs, body)
-packLiftingContext :: CoreExpr -> CoreExpr -> CoreExpr -> VarSet -> Type -> VM VExpr -> VM VExpr
-packLiftingContext len shape tag fvs res_ty p
+packLiftingContext :: CoreExpr -> CoreExpr -> CoreExpr -> VarSet
+ -> Type -> Type -> VM VExpr -> VM VExpr
+packLiftingContext len shape tag fvs vty lty p
= do
select <- builtin selectPAIntPrimVar
let sel_expr = mkApps (Var select) [shape, tag]
- sel_var <- newLocalVar FSLIT("sel#") (exprType sel_expr)
+ sel_var <- newLocalVar (fsLit "sel#") (exprType sel_expr)
lc_var <- builtin liftingContext
localV $
do
. filter isLocalId
$ varSetElems fvs
(vexpr, lexpr) <- p
+ empty <- emptyPA vty
return (vexpr, Let (NonRec sel_var sel_expr)
- $ Case len lc_var res_ty [(DEFAULT, [], lexpr)])
+ $ Case len lc_var lty
+ [(DEFAULT, [], mkLets (concat bnds) lexpr),
+ (LitAlt (mkMachInt 0), [], empty)])
packFreeVar :: CoreExpr -> CoreExpr -> Var -> VM [CoreBind]
packFreeVar len sel v
projects / ghc-hetmet.git / blobdiff