+{-# 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 FastString
import Control.Monad ( liftM, liftM2, zipWithM, mapAndUnzipM )
-builtin_PAs :: [(Name, Module, FastString)]
-builtin_PAs = [
- (closureTyConName, nDP_CLOSURE, FSLIT("dPA_Clo"))
- , mk intTyConName FSLIT("dPA_Int")
- ]
- ++ tups
- where
- mk name fs = (name, nDP_INSTANCES, fs)
-
- tups = mk_tup 0 : map mk_tup [2..3]
- mk_tup n = (getName $ tupleTyCon Boxed n, nDP_INSTANCES,
- mkFastString $ "dPA_" ++ show n)
-
vectorise :: HscEnv -> UniqSupply -> RuleBase -> ModGuts
-> IO (SimplCount, ModGuts)
vectorise hsc_env _ _ guts
vectModule :: ModGuts -> VM ModGuts
vectModule guts
= do
- defTyConBuiltinPAs builtin_PAs
(types', fam_insts, tc_binds) <- vectTypeEnv (mg_types guts)
let fam_inst_env' = extendFamInstEnvList (mg_fam_inst_env guts) fam_insts
vectExpr (_, AnnApp fn arg)
= do
- fn' <- vectExpr fn
- arg' <- vectExpr arg
- mkClosureApp fn' arg'
+ arg_ty' <- vectType arg_ty
+ res_ty' <- vectType res_ty
+ fn' <- vectExpr fn
+ arg' <- vectExpr arg
+ mkClosureApp arg_ty' res_ty' fn' arg'
+ where
+ (arg_ty, res_ty) = splitFunTy . exprType $ deAnnotate fn
vectExpr (_, AnnCase scrut bndr ty alts)
| isAlgType scrut_ty