From 0e82126ed0bd2d16a1925d8a8a6c5eb6d7762ac5 Mon Sep 17 00:00:00 2001 From: "benl@ouroborus.net" Date: Tue, 31 Aug 2010 10:07:24 +0000 Subject: [PATCH] Finish breaking up VectBuiltIn and VectMonad, and add comments --- compiler/ghc.cabal.in | 11 +- compiler/vectorise/VectBuiltIn.hs | 584 -------------------- compiler/vectorise/VectMonad.hs | 499 ----------------- compiler/vectorise/VectType.hs | 3 +- compiler/vectorise/VectUtils.hs | 5 +- compiler/vectorise/VectVar.hs | 2 +- compiler/vectorise/Vectorise.hs | 3 +- compiler/vectorise/Vectorise/Builtins.hs | 78 +++ .../vectorise/Vectorise/Builtins/Initialise.hs | 314 +++++++++++ compiler/vectorise/Vectorise/Builtins/Prelude.hs | 236 ++++++++ compiler/vectorise/Vectorise/Monad.hs | 146 +++++ compiler/vectorise/Vectorise/Monad/Base.hs | 146 +++++ compiler/vectorise/Vectorise/Monad/Global.hs | 140 +++++ compiler/vectorise/Vectorise/Monad/InstEnv.hs | 80 +++ compiler/vectorise/Vectorise/Monad/Local.hs | 100 ++++ compiler/vectorise/Vectorise/Monad/Naming.hs | 91 +++ 16 files changed, 1348 insertions(+), 1090 deletions(-) delete mode 100644 compiler/vectorise/VectBuiltIn.hs delete mode 100644 compiler/vectorise/VectMonad.hs create mode 100644 compiler/vectorise/Vectorise/Builtins.hs create mode 100644 compiler/vectorise/Vectorise/Builtins/Initialise.hs create mode 100644 compiler/vectorise/Vectorise/Builtins/Prelude.hs create mode 100644 compiler/vectorise/Vectorise/Monad.hs create mode 100644 compiler/vectorise/Vectorise/Monad/Base.hs create mode 100644 compiler/vectorise/Vectorise/Monad/Global.hs create mode 100644 compiler/vectorise/Vectorise/Monad/InstEnv.hs create mode 100644 compiler/vectorise/Vectorise/Monad/Local.hs create mode 100644 compiler/vectorise/Vectorise/Monad/Naming.hs diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index f8eac7b..741f4c7 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -454,15 +454,22 @@ Library 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 diff --git a/compiler/vectorise/VectBuiltIn.hs b/compiler/vectorise/VectBuiltIn.hs deleted file mode 100644 index 360d17b..0000000 --- a/compiler/vectorise/VectBuiltIn.hs +++ /dev/null @@ -1,584 +0,0 @@ - --- | 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) - diff --git a/compiler/vectorise/VectMonad.hs b/compiler/vectorise/VectMonad.hs deleted file mode 100644 index e24ed0e..0000000 --- a/compiler/vectorise/VectMonad.hs +++ /dev/null @@ -1,499 +0,0 @@ -{-# 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 - diff --git a/compiler/vectorise/VectType.hs b/compiler/vectorise/VectType.hs index 5d8f2a8..0004def 100644 --- a/compiler/vectorise/VectType.hs +++ b/compiler/vectorise/VectType.hs @@ -6,10 +6,11 @@ module VectType ( vectTyCon, vectAndLiftType, vectType, vectTypeEnv, 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 diff --git a/compiler/vectorise/VectUtils.hs b/compiler/vectorise/VectUtils.hs index 37dbecb..d823690 100644 --- a/compiler/vectorise/VectUtils.hs +++ b/compiler/vectorise/VectUtils.hs @@ -21,9 +21,10 @@ module VectUtils ( buildClosure, buildClosures, mkClosureApp ) where -import VectMonad +import Vectorise.Monad import Vectorise.Env import Vectorise.Vect +import Vectorise.Builtins import MkCore ( mkCoreTup, mkWildCase ) import CoreSyn @@ -101,7 +102,7 @@ mkBuiltinTyConApps get_tc tys ty 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] diff --git a/compiler/vectorise/VectVar.hs b/compiler/vectorise/VectVar.hs index 1c40ed9..768960e 100644 --- a/compiler/vectorise/VectVar.hs +++ b/compiler/vectorise/VectVar.hs @@ -11,8 +11,8 @@ module VectVar ( vectLiteral ) where import VectUtils -import VectMonad import VectType +import Vectorise.Monad import Vectorise.Env import Vectorise.Vect import CoreSyn diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs index aad5144..d9da183 100644 --- a/compiler/vectorise/Vectorise.hs +++ b/compiler/vectorise/Vectorise.hs @@ -3,12 +3,13 @@ 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(..) ) diff --git a/compiler/vectorise/Vectorise/Builtins.hs b/compiler/vectorise/Vectorise/Builtins.hs new file mode 100644 index 0000000..47dfa7b --- /dev/null +++ b/compiler/vectorise/Vectorise/Builtins.hs @@ -0,0 +1,78 @@ + +-- | 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 diff --git a/compiler/vectorise/Vectorise/Builtins/Initialise.hs b/compiler/vectorise/Vectorise/Builtins/Initialise.hs new file mode 100644 index 0000000..413980a --- /dev/null +++ b/compiler/vectorise/Vectorise/Builtins/Initialise.hs @@ -0,0 +1,314 @@ + + +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) + + diff --git a/compiler/vectorise/Vectorise/Builtins/Prelude.hs b/compiler/vectorise/Vectorise/Builtins/Prelude.hs new file mode 100644 index 0000000..b578f30 --- /dev/null +++ b/compiler/vectorise/Vectorise/Builtins/Prelude.hs @@ -0,0 +1,236 @@ + +-- | 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" + ] diff --git a/compiler/vectorise/Vectorise/Monad.hs b/compiler/vectorise/Vectorise/Monad.hs new file mode 100644 index 0000000..42c1435 --- /dev/null +++ b/compiler/vectorise/Vectorise/Monad.hs @@ -0,0 +1,146 @@ + +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 + diff --git a/compiler/vectorise/Vectorise/Monad/Base.hs b/compiler/vectorise/Vectorise/Monad/Base.hs new file mode 100644 index 0000000..98da3fe --- /dev/null +++ b/compiler/vectorise/Vectorise/Monad/Base.hs @@ -0,0 +1,146 @@ + +-- | 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" + diff --git a/compiler/vectorise/Vectorise/Monad/Global.hs b/compiler/vectorise/Vectorise/Monad/Global.hs new file mode 100644 index 0000000..4bd6c77 --- /dev/null +++ b/compiler/vectorise/Vectorise/Monad/Global.hs @@ -0,0 +1,140 @@ + +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) + + diff --git a/compiler/vectorise/Vectorise/Monad/InstEnv.hs b/compiler/vectorise/Vectorise/Monad/InstEnv.hs new file mode 100644 index 0000000..7bfdc23 --- /dev/null +++ b/compiler/vectorise/Vectorise/Monad/InstEnv.hs @@ -0,0 +1,80 @@ + +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) + } diff --git a/compiler/vectorise/Vectorise/Monad/Local.hs b/compiler/vectorise/Vectorise/Monad/Local.hs new file mode 100644 index 0000000..7d8b493 --- /dev/null +++ b/compiler/vectorise/Vectorise/Monad/Local.hs @@ -0,0 +1,100 @@ + +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) + + diff --git a/compiler/vectorise/Vectorise/Monad/Naming.hs b/compiler/vectorise/Vectorise/Monad/Naming.hs new file mode 100644 index 0000000..7a59dbe --- /dev/null +++ b/compiler/vectorise/Vectorise/Monad/Naming.hs @@ -0,0 +1,91 @@ + +-- | 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 + -- 1.7.10.4