-{-# 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
import VectType
import VectCore
-import DynFlags
-import HscTypes
+import HscTypes hiding ( MonadThings(..) )
-import CoreLint ( showPass, endPass )
+import Module ( PackageId )
import CoreSyn
import CoreUtils
import CoreFVs
-import SimplMonad ( SimplCount, zeroSimplCount )
-import Rules ( RuleBase )
+import CoreMonad ( CoreM, getHscEnv )
import DataCon
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 Literal ( Literal, mkMachInt )
-import PrelNames
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
- -> IO (SimplCount, ModGuts)
-vectorise hsc_env _ _ guts
+vectorise :: PackageId -> ModGuts -> CoreM ModGuts
+vectorise backend guts = do
+ hsc_env <- getHscEnv
+ liftIO $ vectoriseIO backend hsc_env guts
+
+vectoriseIO :: PackageId -> HscEnv -> ModGuts -> IO ModGuts
+vectoriseIO backend hsc_env guts
= do
- showPass dflags "Vectorisation"
eps <- hscEPS hsc_env
let info = hptVectInfo hsc_env `plusVectInfo` eps_vect_info eps
- Just (info', guts') <- initV hsc_env guts info (vectModule guts)
- endPass dflags "Vectorisation" Opt_D_dump_vect (mg_binds guts')
- return (zeroSimplCount dflags, guts' { mg_vect_info = info' })
- where
- dflags = hsc_dflags hsc_env
+ Just (info', guts') <- initV backend hsc_env guts info (vectModule guts)
+ return (guts' { mg_vect_info = info' })
vectModule :: ModGuts -> VM ModGuts
vectModule guts
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
vectPolyExpr expr
= polyAbstract tvs $ \abstract ->
do
- mono' <- vectExpr mono
+ mono' <- vectFnExpr False mono
return $ mapVect abstract mono'
where
(tvs, mono) = collectAnnTypeBinders expr
where
scrut_ty = exprType (deAnnotate scrut)
-vectExpr (_, AnnCase expr bndr ty alts)
- = panic "vectExpr: case"
-
vectExpr (_, AnnLet (AnnNonRec bndr rhs) body)
= do
vrhs <- localV . inBind bndr $ vectPolyExpr rhs
. inBind bndr
$ vectExpr rhs
-vectExpr e@(fvs, AnnLam bndr _)
- | not (isId bndr) = pprPanic "vectExpr" (ppr $ deAnnotate e)
- | otherwise = vectLam fvs bs body
+vectExpr e@(_, AnnLam bndr _)
+ | isId bndr = vectFnExpr True e
+{-
+onlyIfV (isEmptyVarSet fvs) (vectScalarLam bs $ deAnnotate body)
+ `orElseV` vectLam True fvs bs body
+ where
+ (bs,body) = collectAnnValBinders e
+-}
+
+vectExpr e = cantVectorise "Can't vectorise expression" (ppr $ deAnnotate e)
+
+vectFnExpr :: Bool -> CoreExprWithFVs -> VM VExpr
+vectFnExpr inline e@(fvs, AnnLam bndr _)
+ | isId bndr = onlyIfV (isEmptyVarSet fvs) (vectScalarLam bs $ deAnnotate body)
+ `orElseV` vectLam inline fvs bs body
where
(bs,body) = collectAnnValBinders e
+vectFnExpr _ e = vectExpr e
-vectExpr e = pprPanic "vectExpr" (ppr $ deAnnotate e)
-vectLam :: VarSet -> [Var] -> CoreExprWithFVs -> VM VExpr
-vectLam fvs bs body
+vectScalarLam :: [Var] -> CoreExpr -> VM VExpr
+vectScalarLam args body
+ = do
+ scalars <- globalScalars
+ onlyIfV (all is_scalar_ty arg_tys
+ && is_scalar_ty res_ty
+ && is_scalar (extendVarSetList scalars args) body)
+ $ do
+ fn_var <- hoistExpr (fsLit "fn") (mkLams args body)
+ zipf <- zipScalars arg_tys res_ty
+ clo <- scalarClosure arg_tys res_ty (Var fn_var)
+ (zipf `App` Var fn_var)
+ clo_var <- hoistExpr (fsLit "clo") clo
+ lclo <- liftPA (Var clo_var)
+ return (Var clo_var, lclo)
+ where
+ arg_tys = map idType args
+ res_ty = exprType body
+
+ is_scalar_ty ty | Just (tycon, []) <- splitTyConApp_maybe ty
+ = tycon == intTyCon
+ || tycon == floatTyCon
+ || tycon == doubleTyCon
+
+ | otherwise = False
+
+ is_scalar vs (Var v) = v `elemVarSet` vs
+ is_scalar _ e@(Lit _) = is_scalar_ty $ exprType e
+ is_scalar vs (App e1 e2) = is_scalar vs e1 && is_scalar vs e2
+ is_scalar _ _ = False
+
+vectLam :: Bool -> VarSet -> [Var] -> CoreExprWithFVs -> VM VExpr
+vectLam inline fvs bs body
= do
tyvars <- localTyVars
(vs, vvs) <- readLEnv $ \env ->
lc <- builtin liftingContext
(vbndrs, vbody) <- vectBndrsIn (vs ++ bs)
(vectExpr body)
- return $ vLams lc vbndrs vbody
+ return . maybe_inline $ vLams lc vbndrs vbody
+ where
+ maybe_inline = if inline then vInlineMe else id
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 tys = cantVectorise "Can't vectorise expression"
+ (ppr $ deAnnotate e `mkTyApps` tys)
-- We convert
--
--
-- 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, 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, [], body)]
+vectAlgCase _tycon _ty_args scrut bndr ty [(DataAlt _, [], body)]
= do
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 dc, bndrs, body)]
= do
vect_tc <- maybeV (lookupTyCon tycon)
(vty, lty) <- vectAndLiftType ty
. 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
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, lty) <- vectAndLiftType ty
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
(vect_bodies, lift_bodies) = unzip vbodies
- let vect_case = Case vect_scrut (mkWildId (exprType vect_scrut)) vty
+ vdummy <- newDummyVar (exprType vect_scrut)
+ ldummy <- newDummyVar (exprType lift_scrut)
+ let vect_case = Case vect_scrut vdummy vty
(zipWith3 mk_vect_alt vect_dcs vect_bndrss vect_bodies)
lbody <- combinePA vty len sel indices lift_bodies
- let lift_case = Case lift_scrut (mkWildId (exprType lift_scrut)) lty
+ let lift_case = Case lift_scrut ldummy lty
[(DataAlt arr_dc, shape_bndrs ++ concat lift_bndrss,
lbody)]
cmp DEFAULT DEFAULT = EQ
cmp DEFAULT _ = LT
cmp _ DEFAULT = GT
+ cmp _ _ = panic "vectAlgCase/cmp"
proc_alt sel vty lty (DataAlt dc, bndrs, body)
= do
$ vectExpr body
return (vect_dc, vect_bndrs, lift_bndrs, vbody)
+ proc_alt _ _ _ _ = panic "vectAlgCase/proc_alt"
vect_alt_bndrs [] p
= do
projects / ghc-hetmet.git / blobdiff