UniqFM
UniqSet
Util
- VectBuiltIn
- VectMonad
VectType
VectUtils
VectVar
Vectorise.Env
Vectorise.Vect
Vectorise.Builtins.Base
+ Vectorise.Builtins.Initialise
Vectorise.Builtins.Modules
+ Vectorise.Builtins.Prelude
+ Vectorise.Builtins
+ Vectorise.Monad.Base
+ Vectorise.Monad.Naming
+ Vectorise.Monad.Local
+ Vectorise.Monad.Global
+ Vectorise.Monad.InstEnv
+ Vectorise.Monad
Vectorise
-- We only need to expose more modules as some of the ncg code is used
+++ /dev/null
-
--- | The vectoriser rewrites user code to use builtin types and functions exported by the DPH library.
--- We track the names of those things in the `Builtis` type, and provide selection functions
--- to help extract their names.
-module VectBuiltIn (
- Builtins(..),
-
- -- * Projections
- sumTyCon, prodTyCon, prodDataCon,
- selTy,selReplicate, selPick, selTags, selElements,
- combinePDVar, scalarZip, closureCtrFun,
-
- -- * Initialisation
- initBuiltins, initBuiltinVars, initBuiltinTyCons, initBuiltinDataCons,
- initBuiltinPAs, initBuiltinPRs,
- initBuiltinBoxedTyCons, initBuiltinScalars,
-
- primMethod, primPArray
-) where
-
-import Vectorise.Builtins.Modules
-import Vectorise.Builtins.Base
-
-import DsMonad
-import IfaceEnv ( lookupOrig )
-import InstEnv
-
-import Module
-import DataCon ( DataCon, dataConName, dataConWorkId )
-import TyCon ( TyCon, tyConName, tyConDataCons )
-import Class ( Class, classTyCon )
-import CoreSyn ( CoreExpr, Expr(..) )
-import Var ( Var )
-import Id ( mkSysLocal )
-import Name ( Name, getOccString )
-import NameEnv
-import OccName
-
-import TypeRep ( funTyCon )
-import Type ( Type, mkTyConApp )
-import TysPrim
-import TysWiredIn ( unitDataCon,
- tupleCon,
- intTyCon,
- doubleTyCon,
- boolTyCon, trueDataCon, falseDataCon,
- parrTyConName )
-import PrelNames ( word8TyConName, gHC_PARR, gHC_CLASSES )
-import BasicTypes ( Boxity(..) )
-
-import FastString
-import Outputable
-
-import Data.Array
-import Control.Monad ( liftM, zipWithM )
-import Data.List ( unzip4 )
-
-
-
-
--- Initialisation -------------------------------------------------------------
--- | Create the initial map of builtin types and functions.
-initBuiltins
- :: PackageId -- ^ package id the builtins are in, eg dph-common
- -> DsM Builtins
-
-initBuiltins pkg
- = do
- mapM_ load dph_Orphans
-
- -- From dph-common:Data.Array.Parallel.Lifted.PArray
- parrayTyCon <- externalTyCon dph_PArray (fsLit "PArray")
- let [parrayDataCon] = tyConDataCons parrayTyCon
- pdataTyCon <- externalTyCon dph_PArray (fsLit "PData")
- paTyCon <- externalClassTyCon dph_PArray (fsLit "PA")
- let [paDataCon] = tyConDataCons paTyCon
- preprTyCon <- externalTyCon dph_PArray (fsLit "PRepr")
- prTyCon <- externalClassTyCon dph_PArray (fsLit "PR")
- let [prDataCon] = tyConDataCons prTyCon
-
- -- wher
- closureTyCon <- externalTyCon dph_Closure (fsLit ":->")
-
- -- From dph-common:Data.Array.Parallel.Lifted.Repr
- voidTyCon <- externalTyCon dph_Repr (fsLit "Void")
- wrapTyCon <- externalTyCon dph_Repr (fsLit "Wrap")
-
- -- From dph-common:Data.Array.Parallel.Lifted.Unboxed
- sel_tys <- mapM (externalType dph_Unboxed)
- (numbered "Sel" 2 mAX_DPH_SUM)
-
- sel_replicates <- mapM (externalFun dph_Unboxed)
- (numbered_hash "replicateSel" 2 mAX_DPH_SUM)
-
- sel_picks <- mapM (externalFun dph_Unboxed)
- (numbered_hash "pickSel" 2 mAX_DPH_SUM)
-
- sel_tags <- mapM (externalFun dph_Unboxed)
- (numbered "tagsSel" 2 mAX_DPH_SUM)
-
- sel_els <- mapM mk_elements
- [(i,j) | i <- [2..mAX_DPH_SUM], j <- [0..i-1]]
-
- sum_tcs <- mapM (externalTyCon dph_Repr)
- (numbered "Sum" 2 mAX_DPH_SUM)
-
- let selTys = listArray (2, mAX_DPH_SUM) sel_tys
- selReplicates = listArray (2, mAX_DPH_SUM) sel_replicates
- selPicks = listArray (2, mAX_DPH_SUM) sel_picks
- selTagss = listArray (2, mAX_DPH_SUM) sel_tags
- selEls = array ((2,0), (mAX_DPH_SUM, mAX_DPH_SUM)) sel_els
- sumTyCons = listArray (2, mAX_DPH_SUM) sum_tcs
-
-
- voidVar <- externalVar dph_Repr (fsLit "void")
- pvoidVar <- externalVar dph_Repr (fsLit "pvoid")
- fromVoidVar <- externalVar dph_Repr (fsLit "fromVoid")
- punitVar <- externalVar dph_Repr (fsLit "punit")
- closureVar <- externalVar dph_Closure (fsLit "closure")
- applyVar <- externalVar dph_Closure (fsLit "$:")
- liftedClosureVar <- externalVar dph_Closure (fsLit "liftedClosure")
- liftedApplyVar <- externalVar dph_Closure (fsLit "liftedApply")
- replicatePDVar <- externalVar dph_PArray (fsLit "replicatePD")
- emptyPDVar <- externalVar dph_PArray (fsLit "emptyPD")
- packByTagPDVar <- externalVar dph_PArray (fsLit "packByTagPD")
-
- combines <- mapM (externalVar dph_PArray)
- [mkFastString ("combine" ++ show i ++ "PD")
- | i <- [2..mAX_DPH_COMBINE]]
- let combinePDVars = listArray (2, mAX_DPH_COMBINE) combines
-
- scalarClass <- externalClass dph_PArray (fsLit "Scalar")
- scalar_map <- externalVar dph_Scalar (fsLit "scalar_map")
- scalar_zip2 <- externalVar dph_Scalar (fsLit "scalar_zipWith")
- scalar_zips <- mapM (externalVar dph_Scalar)
- (numbered "scalar_zipWith" 3 mAX_DPH_SCALAR_ARGS)
- let scalarZips = listArray (1, mAX_DPH_SCALAR_ARGS)
- (scalar_map : scalar_zip2 : scalar_zips)
- closures <- mapM (externalVar dph_Closure)
- (numbered "closure" 1 mAX_DPH_SCALAR_ARGS)
- let closureCtrFuns = listArray (1, mAX_DPH_COMBINE) closures
-
- liftingContext <- liftM (\u -> mkSysLocal (fsLit "lc") u intPrimTy)
- newUnique
-
- return $ Builtins {
- dphModules = modules
- , parrayTyCon = parrayTyCon
- , parrayDataCon = parrayDataCon
- , pdataTyCon = pdataTyCon
- , paTyCon = paTyCon
- , paDataCon = paDataCon
- , preprTyCon = preprTyCon
- , prTyCon = prTyCon
- , prDataCon = prDataCon
- , voidTyCon = voidTyCon
- , wrapTyCon = wrapTyCon
- , selTys = selTys
- , selReplicates = selReplicates
- , selPicks = selPicks
- , selTagss = selTagss
- , selEls = selEls
- , sumTyCons = sumTyCons
- , closureTyCon = closureTyCon
- , voidVar = voidVar
- , pvoidVar = pvoidVar
- , fromVoidVar = fromVoidVar
- , punitVar = punitVar
- , closureVar = closureVar
- , applyVar = applyVar
- , liftedClosureVar = liftedClosureVar
- , liftedApplyVar = liftedApplyVar
- , replicatePDVar = replicatePDVar
- , emptyPDVar = emptyPDVar
- , packByTagPDVar = packByTagPDVar
- , combinePDVars = combinePDVars
- , scalarClass = scalarClass
- , scalarZips = scalarZips
- , closureCtrFuns = closureCtrFuns
- , liftingContext = liftingContext
- }
- where
- modules@(Modules {
- dph_PArray = dph_PArray
- , dph_Repr = dph_Repr
- , dph_Closure = dph_Closure
- , dph_Scalar = dph_Scalar
- , dph_Unboxed = dph_Unboxed
- })
- = dph_Modules pkg
-
- load get_mod = dsLoadModule doc mod
- where
- mod = get_mod modules
- doc = ppr mod <+> ptext (sLit "is a DPH module")
-
- -- Make a list of numbered strings in some range, eg foo3, foo4, foo5
- numbered :: String -> Int -> Int -> [FastString]
- numbered pfx m n = [mkFastString (pfx ++ show i) | i <- [m..n]]
-
- numbered_hash :: String -> Int -> Int -> [FastString]
- numbered_hash pfx m n = [mkFastString (pfx ++ show i ++ "#") | i <- [m..n]]
-
- mk_elements :: (Int, Int) -> DsM ((Int, Int), CoreExpr)
- mk_elements (i,j)
- = do
- v <- externalVar dph_Unboxed
- $ mkFastString ("elementsSel" ++ show i ++ "_" ++ show j ++ "#")
- return ((i,j), Var v)
-
-
--- | Get the mapping of names in the Prelude to names in the DPH library.
-initBuiltinVars :: Builtins -> DsM [(Var, Var)]
-initBuiltinVars (Builtins { dphModules = mods })
- = do
- uvars <- zipWithM externalVar umods ufs
- vvars <- zipWithM externalVar vmods vfs
- cvars <- zipWithM externalVar cmods cfs
- return $ [(v,v) | v <- map dataConWorkId defaultDataConWorkers]
- ++ zip (map dataConWorkId cons) cvars
- ++ zip uvars vvars
- where
- (umods, ufs, vmods, vfs) = unzip4 (preludeVars mods)
- (cons, cmods, cfs) = unzip3 (preludeDataCons mods)
-
-defaultDataConWorkers :: [DataCon]
-defaultDataConWorkers = [trueDataCon, falseDataCon, unitDataCon]
-
-preludeDataCons :: Modules -> [(DataCon, Module, FastString)]
-preludeDataCons (Modules { dph_Prelude_Tuple = dph_Prelude_Tuple })
- = [mk_tup n dph_Prelude_Tuple (mkFastString $ "tup" ++ show n) | n <- [2..3]]
- where
- mk_tup n mod name = (tupleCon Boxed n, mod, name)
-
-
--- | Mapping of prelude functions to vectorised versions.
--- Functions like filterP currently have a working but naive version in GHC.PArr
--- During vectorisation we replace these by calls to filterPA, which are
--- defined in dph-common Data.Array.Parallel.Lifted.Combinators
---
--- As renamer only sees the GHC.PArr functions, if you want to add a new function
--- to the vectoriser there has to be a definition for it in GHC.PArr, even though
--- it will never be used at runtime.
---
-preludeVars :: Modules -> [(Module, FastString, Module, FastString)]
-preludeVars (Modules { dph_Combinators = dph_Combinators
- , dph_PArray = dph_PArray
- , dph_Prelude_Int = dph_Prelude_Int
- , dph_Prelude_Word8 = dph_Prelude_Word8
- , dph_Prelude_Double = dph_Prelude_Double
- , dph_Prelude_Bool = dph_Prelude_Bool
- , dph_Prelude_PArr = dph_Prelude_PArr
- })
-
- -- Functions that work on whole PArrays, defined in GHC.PArr
- = [ mk gHC_PARR (fsLit "mapP") dph_Combinators (fsLit "mapPA")
- , mk gHC_PARR (fsLit "zipWithP") dph_Combinators (fsLit "zipWithPA")
- , mk gHC_PARR (fsLit "zipP") dph_Combinators (fsLit "zipPA")
- , mk gHC_PARR (fsLit "unzipP") dph_Combinators (fsLit "unzipPA")
- , mk gHC_PARR (fsLit "filterP") dph_Combinators (fsLit "filterPA")
- , mk gHC_PARR (fsLit "lengthP") dph_Combinators (fsLit "lengthPA")
- , mk gHC_PARR (fsLit "replicateP") dph_Combinators (fsLit "replicatePA")
- , mk gHC_PARR (fsLit "!:") dph_Combinators (fsLit "indexPA")
- , mk gHC_PARR (fsLit "sliceP") dph_Combinators (fsLit "slicePA")
- , mk gHC_PARR (fsLit "crossMapP") dph_Combinators (fsLit "crossMapPA")
- , mk gHC_PARR (fsLit "singletonP") dph_Combinators (fsLit "singletonPA")
- , mk gHC_PARR (fsLit "concatP") dph_Combinators (fsLit "concatPA")
- , mk gHC_PARR (fsLit "+:+") dph_Combinators (fsLit "appPA")
- , mk gHC_PARR (fsLit "emptyP") dph_PArray (fsLit "emptyPA")
-
- -- Map scalar functions to versions using closures.
- , mk' dph_Prelude_Int "div" "divV"
- , mk' dph_Prelude_Int "mod" "modV"
- , mk' dph_Prelude_Int "sqrt" "sqrtV"
- , mk' dph_Prelude_Int "enumFromToP" "enumFromToPA"
- -- , mk' dph_Prelude_Int "upToP" "upToPA"
- ]
- ++ vars_Ord dph_Prelude_Int
- ++ vars_Num dph_Prelude_Int
-
- ++ vars_Ord dph_Prelude_Word8
- ++ vars_Num dph_Prelude_Word8
- ++
- [ mk' dph_Prelude_Word8 "div" "divV"
- , mk' dph_Prelude_Word8 "mod" "modV"
- , mk' dph_Prelude_Word8 "fromInt" "fromIntV"
- , mk' dph_Prelude_Word8 "toInt" "toIntV"
- ]
-
- ++ vars_Ord dph_Prelude_Double
- ++ vars_Num dph_Prelude_Double
- ++ vars_Fractional dph_Prelude_Double
- ++ vars_Floating dph_Prelude_Double
- ++ vars_RealFrac dph_Prelude_Double
- ++
- [ mk dph_Prelude_Bool (fsLit "andP") dph_Prelude_Bool (fsLit "andPA")
- , mk dph_Prelude_Bool (fsLit "orP") dph_Prelude_Bool (fsLit "orPA")
-
- , mk gHC_CLASSES (fsLit "not") dph_Prelude_Bool (fsLit "notV")
- , mk gHC_CLASSES (fsLit "&&") dph_Prelude_Bool (fsLit "andV")
- , mk gHC_CLASSES (fsLit "||") dph_Prelude_Bool (fsLit "orV")
-
- -- FIXME: temporary
- , mk dph_Prelude_PArr (fsLit "fromPArrayP") dph_Prelude_PArr (fsLit "fromPArrayPA")
- , mk dph_Prelude_PArr (fsLit "toPArrayP") dph_Prelude_PArr (fsLit "toPArrayPA")
- , mk dph_Prelude_PArr (fsLit "fromNestedPArrayP") dph_Prelude_PArr (fsLit "fromNestedPArrayPA")
- , mk dph_Prelude_PArr (fsLit "combineP") dph_Combinators (fsLit "combine2PA")
- , mk dph_Prelude_PArr (fsLit "updateP") dph_Combinators (fsLit "updatePA")
- , mk dph_Prelude_PArr (fsLit "bpermuteP") dph_Combinators (fsLit "bpermutePA")
- , mk dph_Prelude_PArr (fsLit "indexedP") dph_Combinators (fsLit "indexedPA")
- ]
- where
- mk = (,,,)
- mk' mod v v' = mk mod (fsLit v) mod (fsLit v')
-
- vars_Ord mod
- = [ mk' mod "==" "eqV"
- , mk' mod "/=" "neqV"
- , mk' mod "<=" "leV"
- , mk' mod "<" "ltV"
- , mk' mod ">=" "geV"
- , mk' mod ">" "gtV"
- , mk' mod "min" "minV"
- , mk' mod "max" "maxV"
- , mk' mod "minimumP" "minimumPA"
- , mk' mod "maximumP" "maximumPA"
- , mk' mod "minIndexP" "minIndexPA"
- , mk' mod "maxIndexP" "maxIndexPA"
- ]
-
- vars_Num mod
- = [ mk' mod "+" "plusV"
- , mk' mod "-" "minusV"
- , mk' mod "*" "multV"
- , mk' mod "negate" "negateV"
- , mk' mod "abs" "absV"
- , mk' mod "sumP" "sumPA"
- , mk' mod "productP" "productPA"
- ]
-
- vars_Fractional mod
- = [ mk' mod "/" "divideV"
- , mk' mod "recip" "recipV"
- ]
-
- vars_Floating mod
- = [ mk' mod "pi" "pi"
- , mk' mod "exp" "expV"
- , mk' mod "sqrt" "sqrtV"
- , mk' mod "log" "logV"
- , mk' mod "sin" "sinV"
- , mk' mod "tan" "tanV"
- , mk' mod "cos" "cosV"
- , mk' mod "asin" "asinV"
- , mk' mod "atan" "atanV"
- , mk' mod "acos" "acosV"
- , mk' mod "sinh" "sinhV"
- , mk' mod "tanh" "tanhV"
- , mk' mod "cosh" "coshV"
- , mk' mod "asinh" "asinhV"
- , mk' mod "atanh" "atanhV"
- , mk' mod "acosh" "acoshV"
- , mk' mod "**" "powV"
- , mk' mod "logBase" "logBaseV"
- ]
-
- vars_RealFrac mod
- = [ mk' mod "fromInt" "fromIntV"
- , mk' mod "truncate" "truncateV"
- , mk' mod "round" "roundV"
- , mk' mod "ceiling" "ceilingV"
- , mk' mod "floor" "floorV"
- ]
-
-
--- | Get a list of names to `TyCon`s in the mock prelude.
-initBuiltinTyCons :: Builtins -> DsM [(Name, TyCon)]
-initBuiltinTyCons bi
- = do
- -- parr <- externalTyCon dph_Prelude_PArr (fsLit "PArr")
- dft_tcs <- defaultTyCons
- return $ (tyConName funTyCon, closureTyCon bi)
- : (parrTyConName, parrayTyCon bi)
-
- -- FIXME: temporary
- : (tyConName $ parrayTyCon bi, parrayTyCon bi)
-
- : [(tyConName tc, tc) | tc <- dft_tcs]
-
-defaultTyCons :: DsM [TyCon]
-defaultTyCons
- = do
- word8 <- dsLookupTyCon word8TyConName
- return [intTyCon, boolTyCon, doubleTyCon, word8]
-
-
--- | Get a list of names to `DataCon`s in the mock prelude.
-initBuiltinDataCons :: Builtins -> [(Name, DataCon)]
-initBuiltinDataCons _ = [(dataConName dc, dc)| dc <- defaultDataCons]
-
-defaultDataCons :: [DataCon]
-defaultDataCons = [trueDataCon, falseDataCon, unitDataCon]
-
-
--- | Get the names of all buildin instance functions for the PA class.
-initBuiltinPAs :: Builtins -> (InstEnv, InstEnv) -> DsM [(Name, Var)]
-initBuiltinPAs (Builtins { dphModules = mods }) insts
- = liftM (initBuiltinDicts insts) (externalClass (dph_PArray mods) (fsLit "PA"))
-
-
--- | Get the names of all builtin instance functions for the PR class.
-initBuiltinPRs :: Builtins -> (InstEnv, InstEnv) -> DsM [(Name, Var)]
-initBuiltinPRs (Builtins { dphModules = mods }) insts
- = liftM (initBuiltinDicts insts) (externalClass (dph_PArray mods) (fsLit "PR"))
-
-
--- | Get the names of all DPH instance functions for this class.
-initBuiltinDicts :: (InstEnv, InstEnv) -> Class -> [(Name, Var)]
-initBuiltinDicts insts cls = map find $ classInstances insts cls
- where
- find i | [Just tc] <- instanceRoughTcs i = (tc, instanceDFunId i)
- | otherwise = pprPanic "Invalid DPH instance" (ppr i)
-
-
--- | Get a list of boxed `TyCons` in the mock prelude. This is Int only.
-initBuiltinBoxedTyCons :: Builtins -> DsM [(Name, TyCon)]
-initBuiltinBoxedTyCons = return . builtinBoxedTyCons
-
-builtinBoxedTyCons :: Builtins -> [(Name, TyCon)]
-builtinBoxedTyCons _
- = [(tyConName intPrimTyCon, intTyCon)]
-
-
--- | Get a list of all scalar functions in the mock prelude.
-initBuiltinScalars :: Builtins -> DsM [Var]
-initBuiltinScalars bi
- = mapM (uncurry externalVar) (preludeScalars $ dphModules bi)
-
-
-preludeScalars :: Modules -> [(Module, FastString)]
-preludeScalars (Modules { dph_Prelude_Int = dph_Prelude_Int
- , dph_Prelude_Word8 = dph_Prelude_Word8
- , dph_Prelude_Double = dph_Prelude_Double
- })
- = [ mk dph_Prelude_Int "div"
- , mk dph_Prelude_Int "mod"
- , mk dph_Prelude_Int "sqrt"
- ]
- ++ scalars_Ord dph_Prelude_Int
- ++ scalars_Num dph_Prelude_Int
-
- ++ scalars_Ord dph_Prelude_Word8
- ++ scalars_Num dph_Prelude_Word8
- ++
- [ mk dph_Prelude_Word8 "div"
- , mk dph_Prelude_Word8 "mod"
- , mk dph_Prelude_Word8 "fromInt"
- , mk dph_Prelude_Word8 "toInt"
- ]
-
- ++ scalars_Ord dph_Prelude_Double
- ++ scalars_Num dph_Prelude_Double
- ++ scalars_Fractional dph_Prelude_Double
- ++ scalars_Floating dph_Prelude_Double
- ++ scalars_RealFrac dph_Prelude_Double
- where
- mk mod s = (mod, fsLit s)
-
- scalars_Ord mod
- = [ mk mod "=="
- , mk mod "/="
- , mk mod "<="
- , mk mod "<"
- , mk mod ">="
- , mk mod ">"
- , mk mod "min"
- , mk mod "max"
- ]
-
- scalars_Num mod
- = [ mk mod "+"
- , mk mod "-"
- , mk mod "*"
- , mk mod "negate"
- , mk mod "abs"
- ]
-
- scalars_Fractional mod
- = [ mk mod "/"
- , mk mod "recip"
- ]
-
- scalars_Floating mod
- = [ mk mod "pi"
- , mk mod "exp"
- , mk mod "sqrt"
- , mk mod "log"
- , mk mod "sin"
- , mk mod "tan"
- , mk mod "cos"
- , mk mod "asin"
- , mk mod "atan"
- , mk mod "acos"
- , mk mod "sinh"
- , mk mod "tanh"
- , mk mod "cosh"
- , mk mod "asinh"
- , mk mod "atanh"
- , mk mod "acosh"
- , mk mod "**"
- , mk mod "logBase"
- ]
-
- scalars_RealFrac mod
- = [ mk mod "fromInt"
- , mk mod "truncate"
- , mk mod "round"
- , mk mod "ceiling"
- , mk mod "floor"
- ]
-
-
--- | Lookup some variable given its name and the module that contains it.
-externalVar :: Module -> FastString -> DsM Var
-externalVar mod fs
- = dsLookupGlobalId =<< lookupOrig mod (mkVarOccFS fs)
-
-
--- | Like `externalVar` but wrap the `Var` in a `CoreExpr`
-externalFun :: Module -> FastString -> DsM CoreExpr
-externalFun mod fs
- = do var <- externalVar mod fs
- return $ Var var
-
-
--- | Lookup some `TyCon` given its name and the module that contains it.
-externalTyCon :: Module -> FastString -> DsM TyCon
-externalTyCon mod fs
- = dsLookupTyCon =<< lookupOrig mod (mkTcOccFS fs)
-
-
--- | Lookup some `Type` given its name and the module that contains it.
-externalType :: Module -> FastString -> DsM Type
-externalType mod fs
- = do tycon <- externalTyCon mod fs
- return $ mkTyConApp tycon []
-
-
--- | Lookup some `Class` given its name and the module that contains it.
-externalClass :: Module -> FastString -> DsM Class
-externalClass mod fs
- = dsLookupClass =<< lookupOrig mod (mkClsOccFS fs)
-
-
--- | Like `externalClass`, but get the TyCon of of the class.
-externalClassTyCon :: Module -> FastString -> DsM TyCon
-externalClassTyCon mod fs = liftM classTyCon (externalClass mod fs)
-
-
--- | Lookup a method function given its name and instance type.
-primMethod :: TyCon -> String -> Builtins -> DsM (Maybe Var)
-primMethod tycon method (Builtins { dphModules = mods })
- | Just suffix <- lookupNameEnv prim_ty_cons (tyConName tycon)
- = liftM Just
- $ dsLookupGlobalId =<< lookupOrig (dph_Unboxed mods)
- (mkVarOcc $ method ++ suffix)
-
- | otherwise = return Nothing
-
--- | Lookup the representation type we use for PArrays that contain a given element type.
-primPArray :: TyCon -> Builtins -> DsM (Maybe TyCon)
-primPArray tycon (Builtins { dphModules = mods })
- | Just suffix <- lookupNameEnv prim_ty_cons (tyConName tycon)
- = liftM Just
- $ dsLookupTyCon =<< lookupOrig (dph_Unboxed mods)
- (mkTcOcc $ "PArray" ++ suffix)
-
- | otherwise = return Nothing
-
-prim_ty_cons :: NameEnv String
-prim_ty_cons = mkNameEnv [mk_prim intPrimTyCon]
- where
- mk_prim tycon = (tyConName tycon, '_' : getOccString tycon)
-
+++ /dev/null
-{-# LANGUAGE NamedFieldPuns #-}
-
--- | The Vectorisation monad.
-module VectMonad (
- VM,
-
- noV, traceNoV, ensureV, traceEnsureV, tryV, maybeV, traceMaybeV, orElseV,
- onlyIfV, fixV, localV, closedV,
- initV, cantVectorise, maybeCantVectorise, maybeCantVectoriseM,
- liftDs,
- cloneName, cloneId, cloneVar,
- newExportedVar, newLocalVar, newLocalVars, newDummyVar, newTyVar,
-
- Builtins(..), sumTyCon, prodTyCon, prodDataCon,
- selTy, selReplicate, selPick, selTags, selElements,
- combinePDVar, scalarZip, closureCtrFun,
- builtin, builtins,
-
- setFamInstEnv,
- readGEnv, setGEnv, updGEnv,
-
- readLEnv, setLEnv, updLEnv,
-
- getBindName, inBind,
-
- lookupVar, defGlobalVar, globalScalars,
- lookupTyCon, defTyCon,
- lookupDataCon, defDataCon,
- lookupTyConPA, defTyConPA, defTyConPAs,
- lookupTyConPR,
- lookupBoxedTyCon,
- lookupPrimMethod, lookupPrimPArray,
- lookupTyVarPA, defLocalTyVar, defLocalTyVarWithPA, localTyVars,
-
- lookupInst, lookupFamInst
-) where
-
-#include "HsVersions.h"
-
-import VectBuiltIn
-import Vectorise.Env
-
-import HscTypes hiding ( MonadThings(..) )
-import Module ( PackageId )
-import CoreSyn
-import Class
-import TyCon
-import DataCon
-import Type
-import Var
-import VarSet
-import VarEnv
-import Id
-import Name
-import NameEnv
-
-import DsMonad
-
-import InstEnv
-import FamInstEnv
-
-import Outputable
-import FastString
-import SrcLoc ( noSrcSpan )
-
-import Control.Monad
-
-
--- The Vectorisation Monad ----------------------------------------------------
-
--- Vectorisation can either succeed with new envionment and a value,
--- or return with failure.
---
-data VResult a = Yes GlobalEnv LocalEnv a | No
-
-newtype VM a = VM { runVM :: Builtins -> GlobalEnv -> LocalEnv -> DsM (VResult a) }
-
-instance Monad VM where
- return x = VM $ \_ genv lenv -> return (Yes genv lenv x)
- VM p >>= f = VM $ \bi genv lenv -> do
- r <- p bi genv lenv
- case r of
- Yes genv' lenv' x -> runVM (f x) bi genv' lenv'
- No -> return No
-
-
--- | Throw an error saying we can't vectorise something
-cantVectorise :: String -> SDoc -> a
-cantVectorise s d = pgmError
- . showSDocDump
- $ vcat [text "*** Vectorisation error ***",
- nest 4 $ sep [text s, nest 4 d]]
-
-maybeCantVectorise :: String -> SDoc -> Maybe a -> a
-maybeCantVectorise s d Nothing = cantVectorise s d
-maybeCantVectorise _ _ (Just x) = x
-
-maybeCantVectoriseM :: Monad m => String -> SDoc -> m (Maybe a) -> m a
-maybeCantVectoriseM s d p
- = do
- r <- p
- case r of
- Just x -> return x
- Nothing -> cantVectorise s d
-
-
--- Control --------------------------------------------------------------------
--- | Return some result saying we've failed.
-noV :: VM a
-noV = VM $ \_ _ _ -> return No
-
-traceNoV :: String -> SDoc -> VM a
-traceNoV s d = pprTrace s d noV
-
-
--- | If True then carry on, otherwise fail.
-ensureV :: Bool -> VM ()
-ensureV False = noV
-ensureV True = return ()
-
-
--- | If True then return the first argument, otherwise fail.
-onlyIfV :: Bool -> VM a -> VM a
-onlyIfV b p = ensureV b >> p
-
-traceEnsureV :: String -> SDoc -> Bool -> VM ()
-traceEnsureV s d False = traceNoV s d
-traceEnsureV _ _ True = return ()
-
-
--- | Try some vectorisation computaton.
--- If it succeeds then return Just the result,
--- otherwise return Nothing.
-tryV :: VM a -> VM (Maybe a)
-tryV (VM p) = VM $ \bi genv lenv ->
- do
- r <- p bi genv lenv
- case r of
- Yes genv' lenv' x -> return (Yes genv' lenv' (Just x))
- No -> return (Yes genv lenv Nothing)
-
-
-maybeV :: VM (Maybe a) -> VM a
-maybeV p = maybe noV return =<< p
-
-traceMaybeV :: String -> SDoc -> VM (Maybe a) -> VM a
-traceMaybeV s d p = maybe (traceNoV s d) return =<< p
-
-orElseV :: VM a -> VM a -> VM a
-orElseV p q = maybe q return =<< tryV p
-
-fixV :: (a -> VM a) -> VM a
-fixV f = VM (\bi genv lenv -> fixDs $ \r -> runVM (f (unYes r)) bi genv lenv )
- where
- -- NOTE: It is essential that we are lazy in r above so do not replace
- -- calls to this function by an explicit case.
- unYes (Yes _ _ x) = x
- unYes No = panic "VectMonad.fixV: no result"
-
-
--- Local Environments ---------------------------------------------------------
--- | Perform a computation in its own local environment.
--- This does not alter the environment of the current state.
-localV :: VM a -> VM a
-localV p = do
- env <- readLEnv id
- x <- p
- setLEnv env
- return x
-
--- | Perform a computation in an empty local environment.
-closedV :: VM a -> VM a
-closedV p = do
- env <- readLEnv id
- setLEnv (emptyLocalEnv { local_bind_name = local_bind_name env })
- x <- p
- setLEnv env
- return x
-
--- Lifting --------------------------------------------------------------------
--- | Lift a desugaring computation into the vectorisation monad.
-liftDs :: DsM a -> VM a
-liftDs p = VM $ \_ genv lenv -> do { x <- p; return (Yes genv lenv x) }
-
-
-
--- Builtins -------------------------------------------------------------------
--- Operations on Builtins
-liftBuiltinDs :: (Builtins -> DsM a) -> VM a
-liftBuiltinDs p = VM $ \bi genv lenv -> do { x <- p bi; return (Yes genv lenv x)}
-
-
--- | Project something from the set of builtins.
-builtin :: (Builtins -> a) -> VM a
-builtin f = VM $ \bi genv lenv -> return (Yes genv lenv (f bi))
-
-builtins :: (a -> Builtins -> b) -> VM (a -> b)
-builtins f = VM $ \bi genv lenv -> return (Yes genv lenv (`f` bi))
-
-
--- Environments ---------------------------------------------------------------
--- | Project something from the global environment.
-readGEnv :: (GlobalEnv -> a) -> VM a
-readGEnv f = VM $ \_ genv lenv -> return (Yes genv lenv (f genv))
-
-setGEnv :: GlobalEnv -> VM ()
-setGEnv genv = VM $ \_ _ lenv -> return (Yes genv lenv ())
-
-updGEnv :: (GlobalEnv -> GlobalEnv) -> VM ()
-updGEnv f = VM $ \_ genv lenv -> return (Yes (f genv) lenv ())
-
-
--- | Project something from the local environment.
-readLEnv :: (LocalEnv -> a) -> VM a
-readLEnv f = VM $ \_ genv lenv -> return (Yes genv lenv (f lenv))
-
--- | Set the local environment.
-setLEnv :: LocalEnv -> VM ()
-setLEnv lenv = VM $ \_ genv _ -> return (Yes genv lenv ())
-
--- | Update the enviroment using a provided function.
-updLEnv :: (LocalEnv -> LocalEnv) -> VM ()
-updLEnv f = VM $ \_ genv lenv -> return (Yes genv (f lenv) ())
-
-
--- InstEnv --------------------------------------------------------------------
-getInstEnv :: VM (InstEnv, InstEnv)
-getInstEnv = readGEnv global_inst_env
-
-getFamInstEnv :: VM FamInstEnvs
-getFamInstEnv = readGEnv global_fam_inst_env
-
-
--- Names ----------------------------------------------------------------------
--- | Get the name of the local binding currently being vectorised.
-getBindName :: VM FastString
-getBindName = readLEnv local_bind_name
-
-inBind :: Id -> VM a -> VM a
-inBind id p
- = do updLEnv $ \env -> env { local_bind_name = occNameFS (getOccName id) }
- p
-
-cloneName :: (OccName -> OccName) -> Name -> VM Name
-cloneName mk_occ name = liftM make (liftDs newUnique)
- where
- occ_name = mk_occ (nameOccName name)
-
- make u | isExternalName name = mkExternalName u (nameModule name)
- occ_name
- (nameSrcSpan name)
- | otherwise = mkSystemName u occ_name
-
-cloneId :: (OccName -> OccName) -> Id -> Type -> VM Id
-cloneId mk_occ id ty
- = do
- name <- cloneName mk_occ (getName id)
- let id' | isExportedId id = Id.mkExportedLocalId name ty
- | otherwise = Id.mkLocalId name ty
- return id'
-
--- Make a fresh instance of this var, with a new unique.
-cloneVar :: Var -> VM Var
-cloneVar var = liftM (setIdUnique var) (liftDs newUnique)
-
-newExportedVar :: OccName -> Type -> VM Var
-newExportedVar occ_name ty
- = do
- mod <- liftDs getModuleDs
- u <- liftDs newUnique
-
- let name = mkExternalName u mod occ_name noSrcSpan
-
- return $ Id.mkExportedLocalId name ty
-
-newLocalVar :: FastString -> Type -> VM Var
-newLocalVar fs ty
- = do
- u <- liftDs newUnique
- return $ mkSysLocal fs u ty
-
-newLocalVars :: FastString -> [Type] -> VM [Var]
-newLocalVars fs = mapM (newLocalVar fs)
-
-newDummyVar :: Type -> VM Var
-newDummyVar = newLocalVar (fsLit "vv")
-
-newTyVar :: FastString -> Kind -> VM Var
-newTyVar fs k
- = do
- u <- liftDs newUnique
- return $ mkTyVar (mkSysTvName u fs) k
-
-
--- | Add a mapping between a global var and its vectorised version to the state.
-defGlobalVar :: Var -> Var -> VM ()
-defGlobalVar v v' = updGEnv $ \env ->
- env { global_vars = extendVarEnv (global_vars env) v v'
- , global_exported_vars = upd (global_exported_vars env)
- }
- where
- upd env | isExportedId v = extendVarEnv env v (v, v')
- | otherwise = env
-
--- Var ------------------------------------------------------------------------
--- | Lookup the vectorised and\/or lifted versions of this variable.
--- If it's in the global environment we get the vectorised version.
--- If it's in the local environment we get both the vectorised and lifted version.
---
-lookupVar :: Var -> VM (Scope Var (Var, Var))
-lookupVar v
- = do r <- readLEnv $ \env -> lookupVarEnv (local_vars env) v
- case r of
- Just e -> return (Local e)
- Nothing -> liftM Global
- . maybeCantVectoriseVarM v
- . readGEnv $ \env -> lookupVarEnv (global_vars env) v
-
-maybeCantVectoriseVarM :: Monad m => Var -> m (Maybe Var) -> m Var
-maybeCantVectoriseVarM v p
- = do r <- p
- case r of
- Just x -> return x
- Nothing -> dumpVar v
-
-dumpVar :: Var -> a
-dumpVar var
- | Just _ <- isClassOpId_maybe var
- = cantVectorise "ClassOpId not vectorised:" (ppr var)
-
- | otherwise
- = cantVectorise "Variable not vectorised:" (ppr var)
-
--------------------------------------------------------------------------------
-globalScalars :: VM VarSet
-globalScalars = readGEnv global_scalars
-
-lookupTyCon :: TyCon -> VM (Maybe TyCon)
-lookupTyCon tc
- | isUnLiftedTyCon tc || isTupleTyCon tc = return (Just tc)
-
- | otherwise = readGEnv $ \env -> lookupNameEnv (global_tycons env) (tyConName tc)
-
-defTyCon :: TyCon -> TyCon -> VM ()
-defTyCon tc tc' = updGEnv $ \env ->
- env { global_tycons = extendNameEnv (global_tycons env) (tyConName tc) tc' }
-
-lookupDataCon :: DataCon -> VM (Maybe DataCon)
-lookupDataCon dc
- | isTupleTyCon (dataConTyCon dc) = return (Just dc)
- | otherwise = readGEnv $ \env -> lookupNameEnv (global_datacons env) (dataConName dc)
-
-defDataCon :: DataCon -> DataCon -> VM ()
-defDataCon dc dc' = updGEnv $ \env ->
- env { global_datacons = extendNameEnv (global_datacons env) (dataConName dc) dc' }
-
-lookupPrimPArray :: TyCon -> VM (Maybe TyCon)
-lookupPrimPArray = liftBuiltinDs . primPArray
-
-lookupPrimMethod :: TyCon -> String -> VM (Maybe Var)
-lookupPrimMethod tycon = liftBuiltinDs . primMethod tycon
-
-lookupTyConPA :: TyCon -> VM (Maybe Var)
-lookupTyConPA tc = readGEnv $ \env -> lookupNameEnv (global_pa_funs env) (tyConName tc)
-
-defTyConPA :: TyCon -> Var -> VM ()
-defTyConPA tc pa = updGEnv $ \env ->
- env { global_pa_funs = extendNameEnv (global_pa_funs env) (tyConName tc) pa }
-
-defTyConPAs :: [(TyCon, Var)] -> VM ()
-defTyConPAs ps = updGEnv $ \env ->
- env { global_pa_funs = extendNameEnvList (global_pa_funs env)
- [(tyConName tc, pa) | (tc, pa) <- ps] }
-
-lookupTyVarPA :: Var -> VM (Maybe CoreExpr)
-lookupTyVarPA tv = readLEnv $ \env -> lookupVarEnv (local_tyvar_pa env) tv
-
-lookupTyConPR :: TyCon -> VM (Maybe Var)
-lookupTyConPR tc = readGEnv $ \env -> lookupNameEnv (global_pr_funs env) (tyConName tc)
-
-lookupBoxedTyCon :: TyCon -> VM (Maybe TyCon)
-lookupBoxedTyCon tc = readGEnv $ \env -> lookupNameEnv (global_boxed_tycons env)
- (tyConName tc)
-
-defLocalTyVar :: TyVar -> VM ()
-defLocalTyVar tv = updLEnv $ \env ->
- env { local_tyvars = tv : local_tyvars env
- , local_tyvar_pa = local_tyvar_pa env `delVarEnv` tv
- }
-
-defLocalTyVarWithPA :: TyVar -> CoreExpr -> VM ()
-defLocalTyVarWithPA tv pa = updLEnv $ \env ->
- env { local_tyvars = tv : local_tyvars env
- , local_tyvar_pa = extendVarEnv (local_tyvar_pa env) tv pa
- }
-
-localTyVars :: VM [TyVar]
-localTyVars = readLEnv (reverse . local_tyvars)
-
--- Look up the dfun of a class instance.
---
--- The match must be unique - ie, match exactly one instance - but the
--- type arguments used for matching may be more specific than those of
--- the class instance declaration. The found class instances must not have
--- any type variables in the instance context that do not appear in the
--- instances head (i.e., no flexi vars); for details for what this means,
--- see the docs at InstEnv.lookupInstEnv.
---
-lookupInst :: Class -> [Type] -> VM (DFunId, [Type])
-lookupInst cls tys
- = do { instEnv <- getInstEnv
- ; case lookupInstEnv instEnv cls tys of
- ([(inst, inst_tys)], _)
- | noFlexiVar -> return (instanceDFunId inst, inst_tys')
- | otherwise -> pprPanic "VectMonad.lookupInst: flexi var: "
- (ppr $ mkTyConApp (classTyCon cls) tys)
- where
- inst_tys' = [ty | Right ty <- inst_tys]
- noFlexiVar = all isRight inst_tys
- _other ->
- pprPanic "VectMonad.lookupInst: not found " (ppr cls <+> ppr tys)
- }
- where
- isRight (Left _) = False
- isRight (Right _) = True
-
--- Look up the representation tycon of a family instance.
---
--- The match must be unique - ie, match exactly one instance - but the
--- type arguments used for matching may be more specific than those of
--- the family instance declaration.
---
--- Return the instance tycon and its type instance. For example, if we have
---
--- lookupFamInst 'T' '[Int]' yields (':R42T', 'Int')
---
--- then we have a coercion (ie, type instance of family instance coercion)
---
--- :Co:R42T Int :: T [Int] ~ :R42T Int
---
--- which implies that :R42T was declared as 'data instance T [a]'.
---
-lookupFamInst :: TyCon -> [Type] -> VM (TyCon, [Type])
-lookupFamInst tycon tys
- = ASSERT( isOpenTyCon tycon )
- do { instEnv <- getFamInstEnv
- ; case lookupFamInstEnv instEnv tycon tys of
- [(fam_inst, rep_tys)] -> return (famInstTyCon fam_inst, rep_tys)
- _other ->
- pprPanic "VectMonad.lookupFamInst: not found: "
- (ppr $ mkTyConApp tycon tys)
- }
-
-
--- | Run a vectorisation computation.
-initV :: PackageId -> HscEnv -> ModGuts -> VectInfo -> VM a -> IO (Maybe (VectInfo, a))
-initV pkg hsc_env guts info p
- = do
- -- XXX: ignores error messages and warnings, check that this is
- -- indeed ok (the use of "Just r" suggests so)
- (_,Just r) <- initDs hsc_env (mg_module guts)
- (mg_rdr_env guts)
- (mg_types guts)
- go
- return r
- where
-
- go =
- do
- builtins <- initBuiltins pkg
- builtin_vars <- initBuiltinVars builtins
- builtin_tycons <- initBuiltinTyCons builtins
- let builtin_datacons = initBuiltinDataCons builtins
- builtin_boxed <- initBuiltinBoxedTyCons builtins
- builtin_scalars <- initBuiltinScalars builtins
-
- eps <- liftIO $ hscEPS hsc_env
- let famInstEnvs = (eps_fam_inst_env eps, mg_fam_inst_env guts)
- instEnvs = (eps_inst_env eps, mg_inst_env guts)
-
- builtin_prs <- initBuiltinPRs builtins instEnvs
- builtin_pas <- initBuiltinPAs builtins instEnvs
-
- let genv = extendImportedVarsEnv builtin_vars
- . extendScalars builtin_scalars
- . extendTyConsEnv builtin_tycons
- . extendDataConsEnv builtin_datacons
- . extendPAFunsEnv builtin_pas
- . setPRFunsEnv builtin_prs
- . setBoxedTyConsEnv builtin_boxed
- $ initGlobalEnv info instEnvs famInstEnvs
-
- r <- runVM p builtins genv emptyLocalEnv
- case r of
- Yes genv _ x -> return $ Just (new_info genv, x)
- No -> return Nothing
-
- new_info genv = updVectInfo genv (mg_types guts) info
-
fromVect )
where
-import VectMonad
import VectUtils
import Vectorise.Env
import Vectorise.Vect
+import Vectorise.Monad
+import Vectorise.Builtins
import HscTypes ( TypeEnv, extendTypeEnvList, typeEnvTyCons )
import BasicTypes
buildClosure, buildClosures,
mkClosureApp
) where
-import VectMonad
+import Vectorise.Monad
import Vectorise.Env
import Vectorise.Vect
+import Vectorise.Builtins
import MkCore ( mkCoreTup, mkWildCase )
import CoreSyn
mk tc ty1 ty2 = mkTyConApp tc [ty1,ty2]
voidType :: VM Type
-voidType = mkBuiltinTyConApp VectMonad.voidTyCon []
+voidType = mkBuiltinTyConApp voidTyCon []
mkWrapType :: Type -> VM Type
mkWrapType ty = mkBuiltinTyConApp wrapTyCon [ty]
vectLiteral
) where
import VectUtils
-import VectMonad
import VectType
+import Vectorise.Monad
import Vectorise.Env
import Vectorise.Vect
import CoreSyn
module Vectorise( vectorise )
where
-import VectMonad
import VectUtils
import VectVar
import VectType
import Vectorise.Vect
import Vectorise.Env
+import Vectorise.Monad
+import Vectorise.Builtins
import HscTypes hiding ( MonadThings(..) )
--- /dev/null
+
+-- | Builtin types and functions used by the vectoriser.
+-- The source program uses functions from GHC.PArr, which the vectoriser rewrites
+-- to use equivalent vectorised versions in the DPH backend packages.
+--
+-- The `Builtins` structure holds the name of all the things in the DPH packages
+-- we will need. We can get specific things using the selectors, which print a
+-- civilized panic message if the specified thing cannot be found.
+--
+module Vectorise.Builtins (
+ -- * Builtins
+ Builtins(..),
+ indexBuiltin,
+
+ -- * Wrapped selectors
+ selTy,
+ selReplicate,
+ selPick,
+ selTags,
+ selElements,
+ sumTyCon,
+ prodTyCon,
+ prodDataCon,
+ combinePDVar,
+ scalarZip,
+ closureCtrFun,
+
+ -- * Initialisation
+ initBuiltins, initBuiltinVars, initBuiltinTyCons, initBuiltinDataCons,
+ initBuiltinPAs, initBuiltinPRs,
+ initBuiltinBoxedTyCons, initBuiltinScalars,
+
+ -- * Lookup
+ primMethod,
+ primPArray
+) where
+import Vectorise.Builtins.Base
+import Vectorise.Builtins.Modules
+import Vectorise.Builtins.Initialise
+
+import TysPrim
+import IfaceEnv
+import TyCon
+import DsMonad
+import NameEnv
+import Name
+import Var
+import Control.Monad
+
+
+-- | Lookup a method function given its name and instance type.
+primMethod :: TyCon -> String -> Builtins -> DsM (Maybe Var)
+primMethod tycon method (Builtins { dphModules = mods })
+ | Just suffix <- lookupNameEnv prim_ty_cons (tyConName tycon)
+ = liftM Just
+ $ dsLookupGlobalId =<< lookupOrig (dph_Unboxed mods)
+ (mkVarOcc $ method ++ suffix)
+
+ | otherwise = return Nothing
+
+-- | Lookup the representation type we use for PArrays that contain a given element type.
+primPArray :: TyCon -> Builtins -> DsM (Maybe TyCon)
+primPArray tycon (Builtins { dphModules = mods })
+ | Just suffix <- lookupNameEnv prim_ty_cons (tyConName tycon)
+ = liftM Just
+ $ dsLookupTyCon =<< lookupOrig (dph_Unboxed mods)
+ (mkTcOcc $ "PArray" ++ suffix)
+
+ | otherwise = return Nothing
+
+prim_ty_cons :: NameEnv String
+prim_ty_cons = mkNameEnv [mk_prim intPrimTyCon]
+ where
+ mk_prim tycon = (tyConName tycon, '_' : getOccString tycon)
+
+
+
+
\ No newline at end of file
--- /dev/null
+
+
+module Vectorise.Builtins.Initialise (
+ -- * Initialisation
+ initBuiltins, initBuiltinVars, initBuiltinTyCons, initBuiltinDataCons,
+ initBuiltinPAs, initBuiltinPRs,
+ initBuiltinBoxedTyCons, initBuiltinScalars,
+) where
+import Vectorise.Builtins.Base
+import Vectorise.Builtins.Modules
+import Vectorise.Builtins.Prelude
+
+import BasicTypes
+import PrelNames
+import TysPrim
+import DsMonad
+import IfaceEnv
+import InstEnv
+import TysWiredIn
+import DataCon
+import TyCon
+import Class
+import CoreSyn
+import Type
+import OccName
+import Name
+import Module
+import Var
+import Id
+import FastString
+import Outputable
+
+import Control.Monad
+import Data.Array
+import Data.List
+
+-- | Create the initial map of builtin types and functions.
+initBuiltins
+ :: PackageId -- ^ package id the builtins are in, eg dph-common
+ -> DsM Builtins
+
+initBuiltins pkg
+ = do mapM_ load dph_Orphans
+
+ -- From dph-common:Data.Array.Parallel.Lifted.PArray
+ parrayTyCon <- externalTyCon dph_PArray (fsLit "PArray")
+ let [parrayDataCon] = tyConDataCons parrayTyCon
+
+ pdataTyCon <- externalTyCon dph_PArray (fsLit "PData")
+ paTyCon <- externalClassTyCon dph_PArray (fsLit "PA")
+ let [paDataCon] = tyConDataCons paTyCon
+
+ preprTyCon <- externalTyCon dph_PArray (fsLit "PRepr")
+ prTyCon <- externalClassTyCon dph_PArray (fsLit "PR")
+ let [prDataCon] = tyConDataCons prTyCon
+
+ closureTyCon <- externalTyCon dph_Closure (fsLit ":->")
+
+ -- From dph-common:Data.Array.Parallel.Lifted.Repr
+ voidTyCon <- externalTyCon dph_Repr (fsLit "Void")
+ wrapTyCon <- externalTyCon dph_Repr (fsLit "Wrap")
+
+ -- From dph-common:Data.Array.Parallel.Lifted.Unboxed
+ sel_tys <- mapM (externalType dph_Unboxed)
+ (numbered "Sel" 2 mAX_DPH_SUM)
+
+ sel_replicates <- mapM (externalFun dph_Unboxed)
+ (numbered_hash "replicateSel" 2 mAX_DPH_SUM)
+
+ sel_picks <- mapM (externalFun dph_Unboxed)
+ (numbered_hash "pickSel" 2 mAX_DPH_SUM)
+
+ sel_tags <- mapM (externalFun dph_Unboxed)
+ (numbered "tagsSel" 2 mAX_DPH_SUM)
+
+ sel_els <- mapM mk_elements
+ [(i,j) | i <- [2..mAX_DPH_SUM], j <- [0..i-1]]
+
+ sum_tcs <- mapM (externalTyCon dph_Repr)
+ (numbered "Sum" 2 mAX_DPH_SUM)
+
+ let selTys = listArray (2, mAX_DPH_SUM) sel_tys
+ selReplicates = listArray (2, mAX_DPH_SUM) sel_replicates
+ selPicks = listArray (2, mAX_DPH_SUM) sel_picks
+ selTagss = listArray (2, mAX_DPH_SUM) sel_tags
+ selEls = array ((2,0), (mAX_DPH_SUM, mAX_DPH_SUM)) sel_els
+ sumTyCons = listArray (2, mAX_DPH_SUM) sum_tcs
+
+
+ voidVar <- externalVar dph_Repr (fsLit "void")
+ pvoidVar <- externalVar dph_Repr (fsLit "pvoid")
+ fromVoidVar <- externalVar dph_Repr (fsLit "fromVoid")
+ punitVar <- externalVar dph_Repr (fsLit "punit")
+ closureVar <- externalVar dph_Closure (fsLit "closure")
+ applyVar <- externalVar dph_Closure (fsLit "$:")
+ liftedClosureVar <- externalVar dph_Closure (fsLit "liftedClosure")
+ liftedApplyVar <- externalVar dph_Closure (fsLit "liftedApply")
+ replicatePDVar <- externalVar dph_PArray (fsLit "replicatePD")
+ emptyPDVar <- externalVar dph_PArray (fsLit "emptyPD")
+ packByTagPDVar <- externalVar dph_PArray (fsLit "packByTagPD")
+
+ combines <- mapM (externalVar dph_PArray)
+ [mkFastString ("combine" ++ show i ++ "PD")
+ | i <- [2..mAX_DPH_COMBINE]]
+ let combinePDVars = listArray (2, mAX_DPH_COMBINE) combines
+
+ scalarClass <- externalClass dph_PArray (fsLit "Scalar")
+ scalar_map <- externalVar dph_Scalar (fsLit "scalar_map")
+ scalar_zip2 <- externalVar dph_Scalar (fsLit "scalar_zipWith")
+ scalar_zips <- mapM (externalVar dph_Scalar)
+ (numbered "scalar_zipWith" 3 mAX_DPH_SCALAR_ARGS)
+
+ let scalarZips = listArray (1, mAX_DPH_SCALAR_ARGS)
+ (scalar_map : scalar_zip2 : scalar_zips)
+
+ closures <- mapM (externalVar dph_Closure)
+ (numbered "closure" 1 mAX_DPH_SCALAR_ARGS)
+
+ let closureCtrFuns = listArray (1, mAX_DPH_COMBINE) closures
+
+ liftingContext <- liftM (\u -> mkSysLocal (fsLit "lc") u intPrimTy)
+ newUnique
+
+ return $ Builtins
+ { dphModules = mods
+ , parrayTyCon = parrayTyCon
+ , parrayDataCon = parrayDataCon
+ , pdataTyCon = pdataTyCon
+ , paTyCon = paTyCon
+ , paDataCon = paDataCon
+ , preprTyCon = preprTyCon
+ , prTyCon = prTyCon
+ , prDataCon = prDataCon
+ , voidTyCon = voidTyCon
+ , wrapTyCon = wrapTyCon
+ , selTys = selTys
+ , selReplicates = selReplicates
+ , selPicks = selPicks
+ , selTagss = selTagss
+ , selEls = selEls
+ , sumTyCons = sumTyCons
+ , closureTyCon = closureTyCon
+ , voidVar = voidVar
+ , pvoidVar = pvoidVar
+ , fromVoidVar = fromVoidVar
+ , punitVar = punitVar
+ , closureVar = closureVar
+ , applyVar = applyVar
+ , liftedClosureVar = liftedClosureVar
+ , liftedApplyVar = liftedApplyVar
+ , replicatePDVar = replicatePDVar
+ , emptyPDVar = emptyPDVar
+ , packByTagPDVar = packByTagPDVar
+ , combinePDVars = combinePDVars
+ , scalarClass = scalarClass
+ , scalarZips = scalarZips
+ , closureCtrFuns = closureCtrFuns
+ , liftingContext = liftingContext
+ }
+ where
+ mods@(Modules {
+ dph_PArray = dph_PArray
+ , dph_Repr = dph_Repr
+ , dph_Closure = dph_Closure
+ , dph_Scalar = dph_Scalar
+ , dph_Unboxed = dph_Unboxed
+ })
+ = dph_Modules pkg
+
+ load get_mod = dsLoadModule doc mod
+ where
+ mod = get_mod mods
+ doc = ppr mod <+> ptext (sLit "is a DPH module")
+
+ -- Make a list of numbered strings in some range, eg foo3, foo4, foo5
+ numbered :: String -> Int -> Int -> [FastString]
+ numbered pfx m n = [mkFastString (pfx ++ show i) | i <- [m..n]]
+
+ numbered_hash :: String -> Int -> Int -> [FastString]
+ numbered_hash pfx m n = [mkFastString (pfx ++ show i ++ "#") | i <- [m..n]]
+
+ mk_elements :: (Int, Int) -> DsM ((Int, Int), CoreExpr)
+ mk_elements (i,j)
+ = do
+ v <- externalVar dph_Unboxed
+ $ mkFastString ("elementsSel" ++ show i ++ "_" ++ show j ++ "#")
+ return ((i,j), Var v)
+
+
+-- | Get the mapping of names in the Prelude to names in the DPH library.
+initBuiltinVars :: Builtins -> DsM [(Var, Var)]
+initBuiltinVars (Builtins { dphModules = mods })
+ = do
+ uvars <- zipWithM externalVar umods ufs
+ vvars <- zipWithM externalVar vmods vfs
+ cvars <- zipWithM externalVar cmods cfs
+ return $ [(v,v) | v <- map dataConWorkId defaultDataConWorkers]
+ ++ zip (map dataConWorkId cons) cvars
+ ++ zip uvars vvars
+ where
+ (umods, ufs, vmods, vfs) = unzip4 (preludeVars mods)
+ (cons, cmods, cfs) = unzip3 (preludeDataCons mods)
+
+ defaultDataConWorkers :: [DataCon]
+ defaultDataConWorkers = [trueDataCon, falseDataCon, unitDataCon]
+
+
+preludeDataCons :: Modules -> [(DataCon, Module, FastString)]
+preludeDataCons (Modules { dph_Prelude_Tuple = dph_Prelude_Tuple })
+ = [mk_tup n dph_Prelude_Tuple (mkFastString $ "tup" ++ show n) | n <- [2..3]]
+ where
+ mk_tup n mod name = (tupleCon Boxed n, mod, name)
+
+
+-- | Get a list of names to `TyCon`s in the mock prelude.
+initBuiltinTyCons :: Builtins -> DsM [(Name, TyCon)]
+initBuiltinTyCons bi
+ = do
+ -- parr <- externalTyCon dph_Prelude_PArr (fsLit "PArr")
+ dft_tcs <- defaultTyCons
+ return $ (tyConName funTyCon, closureTyCon bi)
+ : (parrTyConName, parrayTyCon bi)
+
+ -- FIXME: temporary
+ : (tyConName $ parrayTyCon bi, parrayTyCon bi)
+
+ : [(tyConName tc, tc) | tc <- dft_tcs]
+
+ where defaultTyCons :: DsM [TyCon]
+ defaultTyCons
+ = do word8 <- dsLookupTyCon word8TyConName
+ return [intTyCon, boolTyCon, doubleTyCon, word8]
+
+
+-- | Get a list of names to `DataCon`s in the mock prelude.
+initBuiltinDataCons :: Builtins -> [(Name, DataCon)]
+initBuiltinDataCons _
+ = [(dataConName dc, dc)| dc <- defaultDataCons]
+ where defaultDataCons :: [DataCon]
+ defaultDataCons = [trueDataCon, falseDataCon, unitDataCon]
+
+
+-- | Get the names of all buildin instance functions for the PA class.
+initBuiltinPAs :: Builtins -> (InstEnv, InstEnv) -> DsM [(Name, Var)]
+initBuiltinPAs (Builtins { dphModules = mods }) insts
+ = liftM (initBuiltinDicts insts) (externalClass (dph_PArray mods) (fsLit "PA"))
+
+
+-- | Get the names of all builtin instance functions for the PR class.
+initBuiltinPRs :: Builtins -> (InstEnv, InstEnv) -> DsM [(Name, Var)]
+initBuiltinPRs (Builtins { dphModules = mods }) insts
+ = liftM (initBuiltinDicts insts) (externalClass (dph_PArray mods) (fsLit "PR"))
+
+
+-- | Get the names of all DPH instance functions for this class.
+initBuiltinDicts :: (InstEnv, InstEnv) -> Class -> [(Name, Var)]
+initBuiltinDicts insts cls = map find $ classInstances insts cls
+ where
+ find i | [Just tc] <- instanceRoughTcs i = (tc, instanceDFunId i)
+ | otherwise = pprPanic "Invalid DPH instance" (ppr i)
+
+
+-- | Get a list of boxed `TyCons` in the mock prelude. This is Int only.
+initBuiltinBoxedTyCons :: Builtins -> DsM [(Name, TyCon)]
+initBuiltinBoxedTyCons
+ = return . builtinBoxedTyCons
+ where builtinBoxedTyCons :: Builtins -> [(Name, TyCon)]
+ builtinBoxedTyCons _
+ = [(tyConName intPrimTyCon, intTyCon)]
+
+
+-- | Get a list of all scalar functions in the mock prelude.
+initBuiltinScalars :: Builtins -> DsM [Var]
+initBuiltinScalars bi
+ = mapM (uncurry externalVar) (preludeScalars $ dphModules bi)
+
+
+-- | Lookup some variable given its name and the module that contains it.
+externalVar :: Module -> FastString -> DsM Var
+externalVar mod fs
+ = dsLookupGlobalId =<< lookupOrig mod (mkVarOccFS fs)
+
+
+-- | Like `externalVar` but wrap the `Var` in a `CoreExpr`
+externalFun :: Module -> FastString -> DsM CoreExpr
+externalFun mod fs
+ = do var <- externalVar mod fs
+ return $ Var var
+
+
+-- | Lookup some `TyCon` given its name and the module that contains it.
+externalTyCon :: Module -> FastString -> DsM TyCon
+externalTyCon mod fs
+ = dsLookupTyCon =<< lookupOrig mod (mkTcOccFS fs)
+
+
+-- | Lookup some `Type` given its name and the module that contains it.
+externalType :: Module -> FastString -> DsM Type
+externalType mod fs
+ = do tycon <- externalTyCon mod fs
+ return $ mkTyConApp tycon []
+
+
+-- | Lookup some `Class` given its name and the module that contains it.
+externalClass :: Module -> FastString -> DsM Class
+externalClass mod fs
+ = dsLookupClass =<< lookupOrig mod (mkClsOccFS fs)
+
+
+-- | Like `externalClass`, but get the TyCon of of the class.
+externalClassTyCon :: Module -> FastString -> DsM TyCon
+externalClassTyCon mod fs = liftM classTyCon (externalClass mod fs)
+
+
--- /dev/null
+
+-- | Mapping of prelude functions to vectorised versions.
+-- Functions like filterP currently have a working but naive version in GHC.PArr
+-- During vectorisation we replace these by calls to filterPA, which are
+-- defined in dph-common Data.Array.Parallel.Lifted.Combinators
+--
+-- As renamer only sees the GHC.PArr functions, if you want to add a new function
+-- to the vectoriser there has to be a definition for it in GHC.PArr, even though
+-- it will never be used at runtime.
+--
+module Vectorise.Builtins.Prelude
+ ( preludeVars
+ , preludeScalars)
+where
+import Vectorise.Builtins.Modules
+import PrelNames
+import Module
+import FastString
+
+
+preludeVars
+ :: Modules -- ^ Modules containing the DPH backens
+ -> [( Module, FastString -- Maps the original variable to the one in the DPH
+ , Module, FastString)] -- packages that it should be rewritten to.
+
+preludeVars (Modules { dph_Combinators = dph_Combinators
+ , dph_PArray = dph_PArray
+ , dph_Prelude_Int = dph_Prelude_Int
+ , dph_Prelude_Word8 = dph_Prelude_Word8
+ , dph_Prelude_Double = dph_Prelude_Double
+ , dph_Prelude_Bool = dph_Prelude_Bool
+ , dph_Prelude_PArr = dph_Prelude_PArr
+ })
+
+ -- Functions that work on whole PArrays, defined in GHC.PArr
+ = [ mk gHC_PARR (fsLit "mapP") dph_Combinators (fsLit "mapPA")
+ , mk gHC_PARR (fsLit "zipWithP") dph_Combinators (fsLit "zipWithPA")
+ , mk gHC_PARR (fsLit "zipP") dph_Combinators (fsLit "zipPA")
+ , mk gHC_PARR (fsLit "unzipP") dph_Combinators (fsLit "unzipPA")
+ , mk gHC_PARR (fsLit "filterP") dph_Combinators (fsLit "filterPA")
+ , mk gHC_PARR (fsLit "lengthP") dph_Combinators (fsLit "lengthPA")
+ , mk gHC_PARR (fsLit "replicateP") dph_Combinators (fsLit "replicatePA")
+ , mk gHC_PARR (fsLit "!:") dph_Combinators (fsLit "indexPA")
+ , mk gHC_PARR (fsLit "sliceP") dph_Combinators (fsLit "slicePA")
+ , mk gHC_PARR (fsLit "crossMapP") dph_Combinators (fsLit "crossMapPA")
+ , mk gHC_PARR (fsLit "singletonP") dph_Combinators (fsLit "singletonPA")
+ , mk gHC_PARR (fsLit "concatP") dph_Combinators (fsLit "concatPA")
+ , mk gHC_PARR (fsLit "+:+") dph_Combinators (fsLit "appPA")
+ , mk gHC_PARR (fsLit "emptyP") dph_PArray (fsLit "emptyPA")
+
+ -- Map scalar functions to versions using closures.
+ , mk' dph_Prelude_Int "div" "divV"
+ , mk' dph_Prelude_Int "mod" "modV"
+ , mk' dph_Prelude_Int "sqrt" "sqrtV"
+ , mk' dph_Prelude_Int "enumFromToP" "enumFromToPA"
+ -- , mk' dph_Prelude_Int "upToP" "upToPA"
+ ]
+ ++ vars_Ord dph_Prelude_Int
+ ++ vars_Num dph_Prelude_Int
+
+ ++ vars_Ord dph_Prelude_Word8
+ ++ vars_Num dph_Prelude_Word8
+ ++
+ [ mk' dph_Prelude_Word8 "div" "divV"
+ , mk' dph_Prelude_Word8 "mod" "modV"
+ , mk' dph_Prelude_Word8 "fromInt" "fromIntV"
+ , mk' dph_Prelude_Word8 "toInt" "toIntV"
+ ]
+
+ ++ vars_Ord dph_Prelude_Double
+ ++ vars_Num dph_Prelude_Double
+ ++ vars_Fractional dph_Prelude_Double
+ ++ vars_Floating dph_Prelude_Double
+ ++ vars_RealFrac dph_Prelude_Double
+ ++
+ [ mk dph_Prelude_Bool (fsLit "andP") dph_Prelude_Bool (fsLit "andPA")
+ , mk dph_Prelude_Bool (fsLit "orP") dph_Prelude_Bool (fsLit "orPA")
+
+ , mk gHC_CLASSES (fsLit "not") dph_Prelude_Bool (fsLit "notV")
+ , mk gHC_CLASSES (fsLit "&&") dph_Prelude_Bool (fsLit "andV")
+ , mk gHC_CLASSES (fsLit "||") dph_Prelude_Bool (fsLit "orV")
+
+ -- FIXME: temporary
+ , mk dph_Prelude_PArr (fsLit "fromPArrayP") dph_Prelude_PArr (fsLit "fromPArrayPA")
+ , mk dph_Prelude_PArr (fsLit "toPArrayP") dph_Prelude_PArr (fsLit "toPArrayPA")
+ , mk dph_Prelude_PArr (fsLit "fromNestedPArrayP") dph_Prelude_PArr (fsLit "fromNestedPArrayPA")
+ , mk dph_Prelude_PArr (fsLit "combineP") dph_Combinators (fsLit "combine2PA")
+ , mk dph_Prelude_PArr (fsLit "updateP") dph_Combinators (fsLit "updatePA")
+ , mk dph_Prelude_PArr (fsLit "bpermuteP") dph_Combinators (fsLit "bpermutePA")
+ , mk dph_Prelude_PArr (fsLit "indexedP") dph_Combinators (fsLit "indexedPA")
+ ]
+ where
+ mk = (,,,)
+ mk' mod v v' = mk mod (fsLit v) mod (fsLit v')
+
+ vars_Ord mod
+ = [ mk' mod "==" "eqV"
+ , mk' mod "/=" "neqV"
+ , mk' mod "<=" "leV"
+ , mk' mod "<" "ltV"
+ , mk' mod ">=" "geV"
+ , mk' mod ">" "gtV"
+ , mk' mod "min" "minV"
+ , mk' mod "max" "maxV"
+ , mk' mod "minimumP" "minimumPA"
+ , mk' mod "maximumP" "maximumPA"
+ , mk' mod "minIndexP" "minIndexPA"
+ , mk' mod "maxIndexP" "maxIndexPA"
+ ]
+
+ vars_Num mod
+ = [ mk' mod "+" "plusV"
+ , mk' mod "-" "minusV"
+ , mk' mod "*" "multV"
+ , mk' mod "negate" "negateV"
+ , mk' mod "abs" "absV"
+ , mk' mod "sumP" "sumPA"
+ , mk' mod "productP" "productPA"
+ ]
+
+ vars_Fractional mod
+ = [ mk' mod "/" "divideV"
+ , mk' mod "recip" "recipV"
+ ]
+
+ vars_Floating mod
+ = [ mk' mod "pi" "pi"
+ , mk' mod "exp" "expV"
+ , mk' mod "sqrt" "sqrtV"
+ , mk' mod "log" "logV"
+ , mk' mod "sin" "sinV"
+ , mk' mod "tan" "tanV"
+ , mk' mod "cos" "cosV"
+ , mk' mod "asin" "asinV"
+ , mk' mod "atan" "atanV"
+ , mk' mod "acos" "acosV"
+ , mk' mod "sinh" "sinhV"
+ , mk' mod "tanh" "tanhV"
+ , mk' mod "cosh" "coshV"
+ , mk' mod "asinh" "asinhV"
+ , mk' mod "atanh" "atanhV"
+ , mk' mod "acosh" "acoshV"
+ , mk' mod "**" "powV"
+ , mk' mod "logBase" "logBaseV"
+ ]
+
+ vars_RealFrac mod
+ = [ mk' mod "fromInt" "fromIntV"
+ , mk' mod "truncate" "truncateV"
+ , mk' mod "round" "roundV"
+ , mk' mod "ceiling" "ceilingV"
+ , mk' mod "floor" "floorV"
+ ]
+
+
+preludeScalars :: Modules -> [(Module, FastString)]
+preludeScalars (Modules { dph_Prelude_Int = dph_Prelude_Int
+ , dph_Prelude_Word8 = dph_Prelude_Word8
+ , dph_Prelude_Double = dph_Prelude_Double
+ })
+ = [ mk dph_Prelude_Int "div"
+ , mk dph_Prelude_Int "mod"
+ , mk dph_Prelude_Int "sqrt"
+ ]
+ ++ scalars_Ord dph_Prelude_Int
+ ++ scalars_Num dph_Prelude_Int
+
+ ++ scalars_Ord dph_Prelude_Word8
+ ++ scalars_Num dph_Prelude_Word8
+ ++
+ [ mk dph_Prelude_Word8 "div"
+ , mk dph_Prelude_Word8 "mod"
+ , mk dph_Prelude_Word8 "fromInt"
+ , mk dph_Prelude_Word8 "toInt"
+ ]
+
+ ++ scalars_Ord dph_Prelude_Double
+ ++ scalars_Num dph_Prelude_Double
+ ++ scalars_Fractional dph_Prelude_Double
+ ++ scalars_Floating dph_Prelude_Double
+ ++ scalars_RealFrac dph_Prelude_Double
+ where
+ mk mod s = (mod, fsLit s)
+
+ scalars_Ord mod
+ = [ mk mod "=="
+ , mk mod "/="
+ , mk mod "<="
+ , mk mod "<"
+ , mk mod ">="
+ , mk mod ">"
+ , mk mod "min"
+ , mk mod "max"
+ ]
+
+ scalars_Num mod
+ = [ mk mod "+"
+ , mk mod "-"
+ , mk mod "*"
+ , mk mod "negate"
+ , mk mod "abs"
+ ]
+
+ scalars_Fractional mod
+ = [ mk mod "/"
+ , mk mod "recip"
+ ]
+
+ scalars_Floating mod
+ = [ mk mod "pi"
+ , mk mod "exp"
+ , mk mod "sqrt"
+ , mk mod "log"
+ , mk mod "sin"
+ , mk mod "tan"
+ , mk mod "cos"
+ , mk mod "asin"
+ , mk mod "atan"
+ , mk mod "acos"
+ , mk mod "sinh"
+ , mk mod "tanh"
+ , mk mod "cosh"
+ , mk mod "asinh"
+ , mk mod "atanh"
+ , mk mod "acosh"
+ , mk mod "**"
+ , mk mod "logBase"
+ ]
+
+ scalars_RealFrac mod
+ = [ mk mod "fromInt"
+ , mk mod "truncate"
+ , mk mod "round"
+ , mk mod "ceiling"
+ , mk mod "floor"
+ ]
--- /dev/null
+
+module Vectorise.Monad (
+ module Vectorise.Monad.Base,
+ module Vectorise.Monad.Naming,
+ module Vectorise.Monad.Local,
+ module Vectorise.Monad.Global,
+ module Vectorise.Monad.InstEnv,
+ initV,
+
+ -- * Builtins
+ liftBuiltinDs,
+ builtin,
+ builtins,
+
+ -- * Variables
+ lookupVar,
+ maybeCantVectoriseVarM,
+ dumpVar,
+
+ -- * Primitives
+ lookupPrimPArray,
+ lookupPrimMethod
+)
+where
+import Vectorise.Monad.Base
+import Vectorise.Monad.Naming
+import Vectorise.Monad.Local
+import Vectorise.Monad.Global
+import Vectorise.Monad.InstEnv
+import Vectorise.Builtins
+import Vectorise.Env
+
+import HscTypes hiding ( MonadThings(..) )
+import Module
+import TyCon
+import Var
+import VarEnv
+import Id
+import DsMonad
+import Outputable
+import Control.Monad
+
+
+-- | Run a vectorisation computation.
+initV :: PackageId
+ -> HscEnv
+ -> ModGuts
+ -> VectInfo
+ -> VM a
+ -> IO (Maybe (VectInfo, a))
+
+initV pkg hsc_env guts info p
+ = do
+ -- XXX: ignores error messages and warnings, check that this is
+ -- indeed ok (the use of "Just r" suggests so)
+ (_,Just r) <- initDs hsc_env (mg_module guts)
+ (mg_rdr_env guts)
+ (mg_types guts)
+ go
+ return r
+ where
+ go
+ = do
+ builtins <- initBuiltins pkg
+ builtin_vars <- initBuiltinVars builtins
+ builtin_tycons <- initBuiltinTyCons builtins
+ let builtin_datacons = initBuiltinDataCons builtins
+ builtin_boxed <- initBuiltinBoxedTyCons builtins
+ builtin_scalars <- initBuiltinScalars builtins
+
+ eps <- liftIO $ hscEPS hsc_env
+ let famInstEnvs = (eps_fam_inst_env eps, mg_fam_inst_env guts)
+ instEnvs = (eps_inst_env eps, mg_inst_env guts)
+
+ builtin_prs <- initBuiltinPRs builtins instEnvs
+ builtin_pas <- initBuiltinPAs builtins instEnvs
+
+ let genv = extendImportedVarsEnv builtin_vars
+ . extendScalars builtin_scalars
+ . extendTyConsEnv builtin_tycons
+ . extendDataConsEnv builtin_datacons
+ . extendPAFunsEnv builtin_pas
+ . setPRFunsEnv builtin_prs
+ . setBoxedTyConsEnv builtin_boxed
+ $ initGlobalEnv info instEnvs famInstEnvs
+
+ r <- runVM p builtins genv emptyLocalEnv
+ case r of
+ Yes genv _ x -> return $ Just (new_info genv, x)
+ No -> return Nothing
+
+ new_info genv = updVectInfo genv (mg_types guts) info
+
+
+-- Builtins -------------------------------------------------------------------
+-- | Lift a desugaring computation using the `Builtins` into the vectorisation monad.
+liftBuiltinDs :: (Builtins -> DsM a) -> VM a
+liftBuiltinDs p = VM $ \bi genv lenv -> do { x <- p bi; return (Yes genv lenv x)}
+
+
+-- | Project something from the set of builtins.
+builtin :: (Builtins -> a) -> VM a
+builtin f = VM $ \bi genv lenv -> return (Yes genv lenv (f bi))
+
+
+-- | Lift a function using the `Builtins` into the vectorisation monad.
+builtins :: (a -> Builtins -> b) -> VM (a -> b)
+builtins f = VM $ \bi genv lenv -> return (Yes genv lenv (`f` bi))
+
+
+-- Var ------------------------------------------------------------------------
+-- | Lookup the vectorised and\/or lifted versions of this variable.
+-- If it's in the global environment we get the vectorised version.
+-- If it's in the local environment we get both the vectorised and lifted version.
+lookupVar :: Var -> VM (Scope Var (Var, Var))
+lookupVar v
+ = do r <- readLEnv $ \env -> lookupVarEnv (local_vars env) v
+ case r of
+ Just e -> return (Local e)
+ Nothing -> liftM Global
+ . maybeCantVectoriseVarM v
+ . readGEnv $ \env -> lookupVarEnv (global_vars env) v
+
+maybeCantVectoriseVarM :: Monad m => Var -> m (Maybe Var) -> m Var
+maybeCantVectoriseVarM v p
+ = do r <- p
+ case r of
+ Just x -> return x
+ Nothing -> dumpVar v
+
+dumpVar :: Var -> a
+dumpVar var
+ | Just _ <- isClassOpId_maybe var
+ = cantVectorise "ClassOpId not vectorised:" (ppr var)
+
+ | otherwise
+ = cantVectorise "Variable not vectorised:" (ppr var)
+
+
+-- Primitives -----------------------------------------------------------------
+lookupPrimPArray :: TyCon -> VM (Maybe TyCon)
+lookupPrimPArray = liftBuiltinDs . primPArray
+
+lookupPrimMethod :: TyCon -> String -> VM (Maybe Var)
+lookupPrimMethod tycon = liftBuiltinDs . primMethod tycon
+
--- /dev/null
+
+-- | The Vectorisation monad.
+module Vectorise.Monad.Base (
+ -- * The Vectorisation Monad
+ VResult(..),
+ VM(..),
+
+ -- * Lifting
+ liftDs,
+
+ -- * Error Handling
+ cantVectorise,
+ maybeCantVectorise,
+ maybeCantVectoriseM,
+
+ -- * Control
+ noV, traceNoV,
+ ensureV, traceEnsureV,
+ onlyIfV,
+ tryV,
+ maybeV, traceMaybeV,
+ orElseV,
+ fixV,
+) where
+import Vectorise.Builtins
+import Vectorise.Env
+
+import DsMonad
+import Outputable
+
+
+-- The Vectorisation Monad ----------------------------------------------------
+-- | Vectorisation can either succeed with new envionment and a value,
+-- or return with failure.
+data VResult a
+ = Yes GlobalEnv LocalEnv a | No
+
+newtype VM a
+ = VM { runVM :: Builtins -> GlobalEnv -> LocalEnv -> DsM (VResult a) }
+
+instance Monad VM where
+ return x = VM $ \_ genv lenv -> return (Yes genv lenv x)
+ VM p >>= f = VM $ \bi genv lenv -> do
+ r <- p bi genv lenv
+ case r of
+ Yes genv' lenv' x -> runVM (f x) bi genv' lenv'
+ No -> return No
+
+
+-- Lifting --------------------------------------------------------------------
+-- | Lift a desugaring computation into the vectorisation monad.
+liftDs :: DsM a -> VM a
+liftDs p = VM $ \_ genv lenv -> do { x <- p; return (Yes genv lenv x) }
+
+
+-- Error Handling -------------------------------------------------------------
+-- | Throw a `pgmError` saying we can't vectorise something.
+cantVectorise :: String -> SDoc -> a
+cantVectorise s d = pgmError
+ . showSDocDump
+ $ vcat [text "*** Vectorisation error ***",
+ nest 4 $ sep [text s, nest 4 d]]
+
+
+-- | Like `fromJust`, but `pgmError` on Nothing.
+maybeCantVectorise :: String -> SDoc -> Maybe a -> a
+maybeCantVectorise s d Nothing = cantVectorise s d
+maybeCantVectorise _ _ (Just x) = x
+
+
+-- | Like `maybeCantVectorise` but in a `Monad`.
+maybeCantVectoriseM :: Monad m => String -> SDoc -> m (Maybe a) -> m a
+maybeCantVectoriseM s d p
+ = do
+ r <- p
+ case r of
+ Just x -> return x
+ Nothing -> cantVectorise s d
+
+
+-- Control --------------------------------------------------------------------
+-- | Return some result saying we've failed.
+noV :: VM a
+noV = VM $ \_ _ _ -> return No
+
+
+-- | Like `traceNoV` but also emit some trace message to stderr.
+traceNoV :: String -> SDoc -> VM a
+traceNoV s d = pprTrace s d noV
+
+
+-- | If `True` then carry on, otherwise fail.
+ensureV :: Bool -> VM ()
+ensureV False = noV
+ensureV True = return ()
+
+
+-- | Like `ensureV` but if we fail then emit some trace message to stderr.
+traceEnsureV :: String -> SDoc -> Bool -> VM ()
+traceEnsureV s d False = traceNoV s d
+traceEnsureV _ _ True = return ()
+
+
+-- | If `True` then return the first argument, otherwise fail.
+onlyIfV :: Bool -> VM a -> VM a
+onlyIfV b p = ensureV b >> p
+
+
+-- | Try some vectorisation computaton.
+-- If it succeeds then return `Just` the result,
+-- otherwise return `Nothing`.
+tryV :: VM a -> VM (Maybe a)
+tryV (VM p) = VM $ \bi genv lenv ->
+ do
+ r <- p bi genv lenv
+ case r of
+ Yes genv' lenv' x -> return (Yes genv' lenv' (Just x))
+ No -> return (Yes genv lenv Nothing)
+
+
+-- | If `Just` then return the value, otherwise fail.
+maybeV :: VM (Maybe a) -> VM a
+maybeV p = maybe noV return =<< p
+
+
+-- | Like `maybeV` but emit a message to stderr if we fail.
+traceMaybeV :: String -> SDoc -> VM (Maybe a) -> VM a
+traceMaybeV s d p = maybe (traceNoV s d) return =<< p
+
+
+-- | Try the first computation,
+-- if it succeeds then take the returned value,
+-- if it fails then run the second computation instead.
+orElseV :: VM a -> VM a -> VM a
+orElseV p q = maybe q return =<< tryV p
+
+
+-- | Fixpoint in the vectorisation monad.
+fixV :: (a -> VM a) -> VM a
+fixV f = VM (\bi genv lenv -> fixDs $ \r -> runVM (f (unYes r)) bi genv lenv )
+ where
+ -- NOTE: It is essential that we are lazy in r above so do not replace
+ -- calls to this function by an explicit case.
+ unYes (Yes _ _ x) = x
+ unYes No = panic "Vectorise.Monad.Base.fixV: no result"
+
--- /dev/null
+
+module Vectorise.Monad.Global (
+ readGEnv,
+ setGEnv,
+ updGEnv,
+
+ -- * Vars
+ defGlobalVar,
+
+ -- * Scalars
+ globalScalars,
+
+ -- * TyCons
+ lookupTyCon,
+ lookupBoxedTyCon,
+ defTyCon,
+
+ -- * Datacons
+ lookupDataCon,
+ defDataCon,
+
+ -- * PA Dictionaries
+ lookupTyConPA,
+ defTyConPA,
+ defTyConPAs,
+
+ -- * PR Dictionaries
+ lookupTyConPR
+) where
+import Vectorise.Monad.Base
+import Vectorise.Env
+import TyCon
+import DataCon
+import NameEnv
+import Var
+import VarEnv
+import VarSet
+
+
+-- Global Environment ---------------------------------------------------------
+-- | Project something from the global environment.
+readGEnv :: (GlobalEnv -> a) -> VM a
+readGEnv f = VM $ \_ genv lenv -> return (Yes genv lenv (f genv))
+
+
+-- | Set the value of the global environment.
+setGEnv :: GlobalEnv -> VM ()
+setGEnv genv = VM $ \_ _ lenv -> return (Yes genv lenv ())
+
+
+-- | Update the global environment using the provided function.
+updGEnv :: (GlobalEnv -> GlobalEnv) -> VM ()
+updGEnv f = VM $ \_ genv lenv -> return (Yes (f genv) lenv ())
+
+
+-- Vars -----------------------------------------------------------------------
+-- | Add a mapping between a global var and its vectorised version to the state.
+defGlobalVar :: Var -> Var -> VM ()
+defGlobalVar v v' = updGEnv $ \env ->
+ env { global_vars = extendVarEnv (global_vars env) v v'
+ , global_exported_vars = upd (global_exported_vars env)
+ }
+ where
+ upd env | isExportedId v = extendVarEnv env v (v, v')
+ | otherwise = env
+
+
+-- Scalars --------------------------------------------------------------------
+-- | Get the set of global scalar variables.
+globalScalars :: VM VarSet
+globalScalars
+ = readGEnv global_scalars
+
+
+-- TyCons ---------------------------------------------------------------------
+-- | Lookup the vectorised version of a `TyCon` from the global environment.
+lookupTyCon :: TyCon -> VM (Maybe TyCon)
+lookupTyCon tc
+ | isUnLiftedTyCon tc || isTupleTyCon tc
+ = return (Just tc)
+
+ | otherwise
+ = readGEnv $ \env -> lookupNameEnv (global_tycons env) (tyConName tc)
+
+
+-- | Lookup the vectorised version of a boxed `TyCon` from the global environment.
+lookupBoxedTyCon :: TyCon -> VM (Maybe TyCon)
+lookupBoxedTyCon tc
+ = readGEnv $ \env -> lookupNameEnv (global_boxed_tycons env)
+ (tyConName tc)
+
+
+-- | Add a mapping between plain and vectorised `TyCon`s to the global environment.
+defTyCon :: TyCon -> TyCon -> VM ()
+defTyCon tc tc' = updGEnv $ \env ->
+ env { global_tycons = extendNameEnv (global_tycons env) (tyConName tc) tc' }
+
+
+-- DataCons -------------------------------------------------------------------
+-- | Lookup the vectorised version of a `DataCon` from the global environment.
+lookupDataCon :: DataCon -> VM (Maybe DataCon)
+lookupDataCon dc
+ | isTupleTyCon (dataConTyCon dc)
+ = return (Just dc)
+
+ | otherwise
+ = readGEnv $ \env -> lookupNameEnv (global_datacons env) (dataConName dc)
+
+
+-- | Add the mapping between plain and vectorised `DataCon`s to the global environment.
+defDataCon :: DataCon -> DataCon -> VM ()
+defDataCon dc dc' = updGEnv $ \env ->
+ env { global_datacons = extendNameEnv (global_datacons env) (dataConName dc) dc' }
+
+
+-- PA dictionaries ------------------------------------------------------------
+-- | Lookup a PA `TyCon` from the global environment.
+lookupTyConPA :: TyCon -> VM (Maybe Var)
+lookupTyConPA tc
+ = readGEnv $ \env -> lookupNameEnv (global_pa_funs env) (tyConName tc)
+
+
+-- | Add a mapping between a PA TyCon and is vectorised version to the global environment.
+defTyConPA :: TyCon -> Var -> VM ()
+defTyConPA tc pa = updGEnv $ \env ->
+ env { global_pa_funs = extendNameEnv (global_pa_funs env) (tyConName tc) pa }
+
+
+-- | Add several mapping between PA TyCons and their vectorised versions to the global environment.
+defTyConPAs :: [(TyCon, Var)] -> VM ()
+defTyConPAs ps = updGEnv $ \env ->
+ env { global_pa_funs = extendNameEnvList (global_pa_funs env)
+ [(tyConName tc, pa) | (tc, pa) <- ps] }
+
+
+-- PR Dictionaries ------------------------------------------------------------
+lookupTyConPR :: TyCon -> VM (Maybe Var)
+lookupTyConPR tc = readGEnv $ \env -> lookupNameEnv (global_pr_funs env) (tyConName tc)
+
+
--- /dev/null
+
+module Vectorise.Monad.InstEnv (
+ lookupInst,
+ lookupFamInst
+) where
+import Vectorise.Monad.Global
+import Vectorise.Monad.Base
+import Vectorise.Env
+
+import FamInstEnv
+import InstEnv
+import Class
+import Type
+import TyCon
+import Outputable
+
+
+#include "HsVersions.h"
+
+
+getInstEnv :: VM (InstEnv, InstEnv)
+getInstEnv = readGEnv global_inst_env
+
+getFamInstEnv :: VM FamInstEnvs
+getFamInstEnv = readGEnv global_fam_inst_env
+
+
+-- Look up the dfun of a class instance.
+--
+-- The match must be unique - ie, match exactly one instance - but the
+-- type arguments used for matching may be more specific than those of
+-- the class instance declaration. The found class instances must not have
+-- any type variables in the instance context that do not appear in the
+-- instances head (i.e., no flexi vars); for details for what this means,
+-- see the docs at InstEnv.lookupInstEnv.
+--
+lookupInst :: Class -> [Type] -> VM (DFunId, [Type])
+lookupInst cls tys
+ = do { instEnv <- getInstEnv
+ ; case lookupInstEnv instEnv cls tys of
+ ([(inst, inst_tys)], _)
+ | noFlexiVar -> return (instanceDFunId inst, inst_tys')
+ | otherwise -> pprPanic "VectMonad.lookupInst: flexi var: "
+ (ppr $ mkTyConApp (classTyCon cls) tys)
+ where
+ inst_tys' = [ty | Right ty <- inst_tys]
+ noFlexiVar = all isRight inst_tys
+ _other ->
+ pprPanic "VectMonad.lookupInst: not found " (ppr cls <+> ppr tys)
+ }
+ where
+ isRight (Left _) = False
+ isRight (Right _) = True
+
+-- Look up the representation tycon of a family instance.
+--
+-- The match must be unique - ie, match exactly one instance - but the
+-- type arguments used for matching may be more specific than those of
+-- the family instance declaration.
+--
+-- Return the instance tycon and its type instance. For example, if we have
+--
+-- lookupFamInst 'T' '[Int]' yields (':R42T', 'Int')
+--
+-- then we have a coercion (ie, type instance of family instance coercion)
+--
+-- :Co:R42T Int :: T [Int] ~ :R42T Int
+--
+-- which implies that :R42T was declared as 'data instance T [a]'.
+--
+lookupFamInst :: TyCon -> [Type] -> VM (TyCon, [Type])
+lookupFamInst tycon tys
+ = ASSERT( isOpenTyCon tycon )
+ do { instEnv <- getFamInstEnv
+ ; case lookupFamInstEnv instEnv tycon tys of
+ [(fam_inst, rep_tys)] -> return (famInstTyCon fam_inst, rep_tys)
+ _other ->
+ pprPanic "VectMonad.lookupFamInst: not found: "
+ (ppr $ mkTyConApp tycon tys)
+ }
--- /dev/null
+
+module Vectorise.Monad.Local (
+ readLEnv,
+ setLEnv,
+ updLEnv,
+ localV,
+ closedV,
+ getBindName,
+ inBind,
+ lookupTyVarPA,
+ defLocalTyVar,
+ defLocalTyVarWithPA,
+ localTyVars
+) where
+import Vectorise.Monad.Base
+import Vectorise.Env
+
+import CoreSyn
+import Id
+import OccName
+import Name
+import VarEnv
+import Var
+import FastString
+
+-- Local Environment ----------------------------------------------------------
+-- | Project something from the local environment.
+readLEnv :: (LocalEnv -> a) -> VM a
+readLEnv f = VM $ \_ genv lenv -> return (Yes genv lenv (f lenv))
+
+
+-- | Set the local environment.
+setLEnv :: LocalEnv -> VM ()
+setLEnv lenv = VM $ \_ genv _ -> return (Yes genv lenv ())
+
+
+-- | Update the enviroment using the provided function.
+updLEnv :: (LocalEnv -> LocalEnv) -> VM ()
+updLEnv f = VM $ \_ genv lenv -> return (Yes genv (f lenv) ())
+
+
+-- | Perform a computation in its own local environment.
+-- This does not alter the environment of the current state.
+localV :: VM a -> VM a
+localV p
+ = do env <- readLEnv id
+ x <- p
+ setLEnv env
+ return x
+
+
+-- | Perform a computation in an empty local environment.
+closedV :: VM a -> VM a
+closedV p
+ = do env <- readLEnv id
+ setLEnv (emptyLocalEnv { local_bind_name = local_bind_name env })
+ x <- p
+ setLEnv env
+ return x
+
+
+-- | Get the name of the local binding currently being vectorised.
+getBindName :: VM FastString
+getBindName = readLEnv local_bind_name
+
+
+-- | Run a vectorisation computation in a local environment,
+-- with this id set as the current binding.
+inBind :: Id -> VM a -> VM a
+inBind id p
+ = do updLEnv $ \env -> env { local_bind_name = occNameFS (getOccName id) }
+ p
+
+
+-- | Lookup a PA tyvars from the local environment.
+lookupTyVarPA :: Var -> VM (Maybe CoreExpr)
+lookupTyVarPA tv
+ = readLEnv $ \env -> lookupVarEnv (local_tyvar_pa env) tv
+
+
+-- | Add a tyvar to the local environment.
+defLocalTyVar :: TyVar -> VM ()
+defLocalTyVar tv = updLEnv $ \env ->
+ env { local_tyvars = tv : local_tyvars env
+ , local_tyvar_pa = local_tyvar_pa env `delVarEnv` tv
+ }
+
+-- | Add mapping between a tyvar and pa dictionary to the local environment.
+defLocalTyVarWithPA :: TyVar -> CoreExpr -> VM ()
+defLocalTyVarWithPA tv pa = updLEnv $ \env ->
+ env { local_tyvars = tv : local_tyvars env
+ , local_tyvar_pa = extendVarEnv (local_tyvar_pa env) tv pa
+ }
+
+
+-- | Get the set of tyvars from the local environment.
+localTyVars :: VM [TyVar]
+localTyVars = readLEnv (reverse . local_tyvars)
+
+
--- /dev/null
+
+-- | Computations in the vectorisation monad concerned with naming
+-- and fresh variable generation.
+module Vectorise.Monad.Naming
+ ( cloneName
+ , cloneId
+ , cloneVar
+ , newExportedVar
+ , newLocalVar
+ , newLocalVars
+ , newDummyVar
+ , newTyVar)
+where
+import Vectorise.Monad.Base
+
+import DsMonad
+import Type
+import Var
+import OccName
+import Name
+import SrcLoc
+import Id
+import FastString
+import Control.Monad
+
+
+-- Naming ---------------------------------------------------------------------
+-- | Clone a name, using the provide function to transform its `OccName`.
+cloneName :: (OccName -> OccName) -> Name -> VM Name
+cloneName mk_occ name = liftM make (liftDs newUnique)
+ where
+ occ_name = mk_occ (nameOccName name)
+
+ make u | isExternalName name = mkExternalName u (nameModule name)
+ occ_name
+ (nameSrcSpan name)
+ | otherwise = mkSystemName u occ_name
+
+
+-- | Clone an `Id`, using the provided function to transform its `OccName`.
+cloneId :: (OccName -> OccName) -> Id -> Type -> VM Id
+cloneId mk_occ id ty
+ = do
+ name <- cloneName mk_occ (getName id)
+ let id' | isExportedId id = Id.mkExportedLocalId name ty
+ | otherwise = Id.mkLocalId name ty
+ return id'
+
+
+-- | Make a fresh instance of this var, with a new unique.
+cloneVar :: Var -> VM Var
+cloneVar var = liftM (setIdUnique var) (liftDs newUnique)
+
+
+-- | Make a fresh exported variable with the given type.
+newExportedVar :: OccName -> Type -> VM Var
+newExportedVar occ_name ty
+ = do mod <- liftDs getModuleDs
+ u <- liftDs newUnique
+
+ let name = mkExternalName u mod occ_name noSrcSpan
+
+ return $ Id.mkExportedLocalId name ty
+
+
+-- | Make a fresh local variable with the given type.
+-- The variable's name is formed using the given string as the prefix.
+newLocalVar :: FastString -> Type -> VM Var
+newLocalVar fs ty
+ = do u <- liftDs newUnique
+ return $ mkSysLocal fs u ty
+
+
+-- | Make several fresh local varaiables with the given types.
+-- The variable's names are formed using the given string as the prefix.
+newLocalVars :: FastString -> [Type] -> VM [Var]
+newLocalVars fs = mapM (newLocalVar fs)
+
+
+-- | Make a new local dummy variable.
+newDummyVar :: Type -> VM Var
+newDummyVar = newLocalVar (fsLit "vv")
+
+
+-- | Make a fresh type variable with the given kind.
+-- The variable's name is formed using the given string as the prefix.
+newTyVar :: FastString -> Kind -> VM Var
+newTyVar fs k
+ = do u <- liftDs newUnique
+ return $ mkTyVar (mkSysTvName u fs) k
+
projects / ghc-hetmet.git / commitdiff