import CoreSyn
import CoreUtils
import CoreFVs
+import SimplMonad ( SimplCount, zeroSimplCount )
+import Rules ( RuleBase )
import DataCon
import TyCon
import Type
import Var
import VarEnv
import VarSet
-import Name ( mkSysTvName )
+import Name ( mkSysTvName, getName )
import NameEnv
import Id
import MkId ( unwrapFamInstScrut )
+import OccName
import DsMonad hiding (mapAndUnzipM)
import DsUtils ( mkCoreTup, mkCoreTupTy )
import PrelNames
import TysWiredIn
+import TysPrim ( intPrimTy )
import BasicTypes ( Boxity(..) )
import Outputable
import Control.Monad ( liftM, liftM2, mapAndUnzipM, zipWithM_ )
import Data.Maybe ( maybeToList )
-vectorise :: HscEnv -> ModGuts -> IO ModGuts
-vectorise hsc_env guts
- | not (Opt_Vectorise `dopt` dflags) = return guts
- | otherwise
+vectorise :: HscEnv -> UniqSupply -> RuleBase -> ModGuts
+ -> IO (SimplCount, ModGuts)
+vectorise 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 $ guts' { mg_vect_info = info' }
+ return (zeroSimplCount dflags, guts' { mg_vect_info = info' })
where
dflags = hsc_dflags hsc_env
vectModule :: ModGuts -> VM ModGuts
-vectModule guts = return guts
+vectModule guts
+ = do
+ binds' <- mapM vectTopBind (mg_binds guts)
+ return $ guts { mg_binds = binds' }
+
+vectTopBind :: CoreBind -> VM CoreBind
+vectTopBind b@(NonRec var expr)
+ = do
+ var' <- vectTopBinder var
+ expr' <- vectTopRhs expr
+ hs <- takeHoisted
+ return . Rec $ (var, expr) : (var', expr') : hs
+ `orElseV`
+ return b
+
+vectTopBind b@(Rec bs)
+ = do
+ vars' <- mapM vectTopBinder vars
+ exprs' <- mapM vectTopRhs exprs
+ hs <- takeHoisted
+ return . Rec $ bs ++ zip vars' exprs' ++ hs
+ `orElseV`
+ return b
+ where
+ (vars, exprs) = unzip bs
+
+vectTopBinder :: Var -> VM Var
+vectTopBinder var
+ = do
+ vty <- vectType (idType var)
+ name <- cloneName mkVectOcc (getName var)
+ let var' | isExportedId var = Id.mkExportedLocalId name vty
+ | otherwise = Id.mkLocalId name vty
+ defGlobalVar var var'
+ return var'
+
+vectTopRhs :: CoreExpr -> VM CoreExpr
+vectTopRhs = liftM fst . closedV . vectPolyExpr (panic "Empty lifting context") . freeVars
-- ----------------------------------------------------------------------------
-- Bindings
mkClosureMonoFns :: CEnvInfo -> Var -> CoreExprWithFVs -> VM (CoreExpr, CoreExpr)
mkClosureMonoFns info arg body
= do
- lc_bndr <- newLocalVar FSLIT("lc") intTy
+ lc_bndr <- newLocalVar FSLIT("lc") intPrimTy
(varg : vbndrs, larg : lbndrs, (vbody, lbody))
<- vectBndrsIn (arg : cenv_vars info)
(vectExpr (Var lc_bndr) body)
return . Let (NonRec lbndr lenv)
$ Case (mkApps (Var lengthPA) [Type vty, (Var lbndr)])
lc_bndr
- intTy
+ (exprType lbody)
[(DEFAULT, [], lbody)]
bind_lenv lenv lbody lc_bndr lbndrs
- = return
- $ Case (unwrapFamInstScrut (cenv_repr_tycon info)
- (cenv_repr_tyargs info)
- lenv)
- (mkWildId lty)
+ = let scrut = unwrapFamInstScrut (cenv_repr_tycon info)
+ (cenv_repr_tyargs info)
+ lenv
+ lbndrs' | null lbndrs = [mkWildId unitTy]
+ | otherwise = lbndrs
+ in
+ return
+ $ Case scrut
+ (mkWildId (exprType scrut))
(exprType lbody)
- [(DataAlt (cenv_repr_datacon info), lc_bndr : lbndrs, lbody)]
+ [(DataAlt (cenv_repr_datacon info), lc_bndr : lbndrs', lbody)]
vectTyAppExpr :: CoreExpr -> CoreExprWithFVs -> [Type] -> VM (CoreExpr, CoreExpr)
vectTyAppExpr lc (_, AnnVar v) tys = vectPolyVar lc v tys
Nothing -> pprTrace "ccTyCon:" (ppr tc) $ return tc
vectType :: Type -> VM Type
-vectType ty | Just ty' <- coreView ty = vectType ty
+vectType ty | Just ty' <- coreView ty = vectType ty'
vectType (TyVarTy tv) = return $ TyVarTy tv
vectType (AppTy ty1 ty2) = liftM2 AppTy (vectType ty1) (vectType ty2)
vectType (TyConApp tc tys) = liftM2 TyConApp (vectTyCon tc) (mapM vectType tys)