-{-# 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 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, liftIO )
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 DsMonad
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
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
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
$ vectExpr rhs
vectExpr e@(fvs, AnnLam bndr _)
- | not (isId bndr) = pprPanic "vectExpr" (ppr $ deAnnotate e)
- | otherwise = vectLam fvs bs body
+ | isId bndr = vectLam fvs bs body
where
(bs,body) = collectAnnValBinders e
-vectExpr e = pprPanic "vectExpr" (ppr $ deAnnotate e)
+vectExpr e = cantVectorise "Can't vectorise expression" (ppr $ deAnnotate e)
vectLam :: VarSet -> [Var] -> CoreExprWithFVs -> VM VExpr
vectLam fvs bs body
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 <- 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, [], body)]
+vectAlgCase _tycon _ty_args scrut bndr ty [(DataAlt _, [], 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 dc, bndrs, body)]
= do
- vect_tc <- maybeV (lookupTyCon tycon)
- vty <- vectType ty
- lty <- mkPArrayType vty
- vexpr <- vectExpr scrut
+ 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)
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)]
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 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
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)
= 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
(vexpr, lexpr) <- p
empty <- emptyPA vty
return (vexpr, Let (NonRec sel_var sel_expr)
- . mkLets (concat bnds)
$ Case len lc_var lty
- [(DEFAULT, [], lexpr),
+ [(DEFAULT, [], mkLets (concat bnds) lexpr),
(LitAlt (mkMachInt 0), [], empty)])
packFreeVar :: CoreExpr -> CoreExpr -> Var -> VM [CoreBind]
projects / ghc-hetmet.git / blobdiff