Commit db91c0de authored by chak@cse.unsw.edu.au.'s avatar chak@cse.unsw.edu.au.

Move vectorisation of (->) & [::] into the library

- (->), [::], & PArray are now vectorised via pragmas (and related clean up)
- Repeatedly vectorising a variable or type constructor now raises an error
parent 774ad4b0
......@@ -8,7 +8,6 @@ module Vectorise.Builtins (
Builtins(..),
-- * Wrapped selectors
parray_PrimTyCon,
selTy, selsTy,
selReplicate,
selTags,
......@@ -26,7 +25,7 @@ module Vectorise.Builtins (
closureCtrFun,
-- * Initialisation
initBuiltins, initBuiltinVars, initBuiltinTyCons
initBuiltins, initBuiltinVars,
) where
import Vectorise.Builtins.Base
......
......@@ -13,7 +13,6 @@ module Vectorise.Builtins.Base (
Builtins(..),
-- * Projections
parray_PrimTyCon,
selTy, selsTy,
selReplicate,
selTags,
......@@ -71,9 +70,7 @@ aLL_DPH_PRIM_TYCONS = map tyConName [intPrimTyCon, {- floatPrimTyCon, -} doubleP
--
data Builtins
= Builtins
{ parrayTyCon :: TyCon -- ^ PArray
, parray_PrimTyCons :: NameEnv TyCon -- ^ PArray_Int# etc.
, pdataTyCon :: TyCon -- ^ PData
{ pdataTyCon :: TyCon -- ^ PData
, pdatasTyCon :: TyCon -- ^ PDatas
, prClass :: Class -- ^ PR
, prTyCon :: TyCon -- ^ PR
......@@ -119,9 +116,6 @@ data Builtins
-- We use these wrappers instead of indexing the `Builtin` structure directly
-- because they give nicer panic messages if the indexed thing cannot be found.
parray_PrimTyCon :: TyCon -> Builtins -> TyCon
parray_PrimTyCon tc bi = lookupEnvBuiltin "parray_PrimTyCon" (parray_PrimTyCons bi) (tyConName tc)
selTy :: Int -> Builtins -> Type
selTy = indexBuiltin "selTy" selTys
......
......@@ -2,7 +2,7 @@
module Vectorise.Builtins.Initialise (
-- * Initialisation
initBuiltins, initBuiltinVars, initBuiltinTyCons
initBuiltins, initBuiltinVars
) where
import Vectorise.Builtins.Base
......@@ -30,12 +30,7 @@ import Data.Array
--
initBuiltins :: DsM Builtins
initBuiltins
= do { -- 'PArray': desugared array type
; parrayTyCon <- externalTyCon (fsLit "PArray")
; parray_tcs <- mapM externalTyCon (suffixed "PArray" aLL_DPH_PRIM_TYCONS)
; let parray_PrimTyCons = mkNameEnv (zip aLL_DPH_PRIM_TYCONS parray_tcs)
-- 'PData': type family mapping array element types to array representation types
= do { -- 'PData': type family mapping array element types to array representation types
-- Not all backends use `PDatas`.
; pdataTyCon <- externalTyCon (fsLit "PData")
; pdatasTyCon <- externalTyCon (fsLit "PDatas")
......@@ -80,7 +75,8 @@ initBuiltins
; scalar_map <- externalVar (fsLit "scalar_map")
; scalar_zip2 <- externalVar (fsLit "scalar_zipWith")
; scalar_zips <- mapM externalVar (numbered "scalar_zipWith" 3 mAX_DPH_SCALAR_ARGS)
; let scalarZips = listArray (1, mAX_DPH_SCALAR_ARGS) (scalar_map : scalar_zip2 : scalar_zips)
; let scalarZips = listArray (1, mAX_DPH_SCALAR_ARGS)
(scalar_map : scalar_zip2 : scalar_zips)
-- Types and functions for generic type representations
; voidTyCon <- externalTyCon (fsLit "Void")
......@@ -119,9 +115,7 @@ initBuiltins
; liftingContext <- liftM (\u -> mkSysLocal (fsLit "lc") u intPrimTy) newUnique
; return $ Builtins
{ parrayTyCon = parrayTyCon
, parray_PrimTyCons = parray_PrimTyCons
, pdataTyCon = pdataTyCon
{ pdataTyCon = pdataTyCon
, pdatasTyCon = pdatasTyCon
, preprTyCon = preprTyCon
, prClass = prClass
......@@ -196,20 +190,6 @@ initBuiltinVars (Builtins { })
where
mk_tup n name = (tupleCon BoxedTuple n, name)
-- |Get a list of names to `TyCon`s in the mock prelude.
--
initBuiltinTyCons :: Builtins -> DsM [(Name, TyCon)]
-- FIXME: * must be replaced by VECTORISE pragmas!!!
-- * then we can remove 'parrayTyCon' from the Builtins as well
initBuiltinTyCons bi
= do
return $ (tyConName funTyCon, closureTyCon bi)
: (parrTyConName, parrayTyCon bi)
-- FIXME: temporary
: (tyConName $ parrayTyCon bi, parrayTyCon bi)
: []
-- Auxilliary look up functions -----------------------------------------------
......
......@@ -10,7 +10,6 @@ module Vectorise.Env (
initGlobalEnv,
extendImportedVarsEnv,
extendFamEnv,
extendTyConsEnv,
setPAFunsEnv,
setPRFunsEnv,
modVectInfo
......@@ -182,12 +181,6 @@ extendFamEnv new genv
= genv { global_fam_inst_env = (g_fam_inst, extendFamInstEnvList l_fam_inst new) }
where (g_fam_inst, l_fam_inst) = global_fam_inst_env genv
-- |Extend the list of type constructors in an environment.
--
extendTyConsEnv :: [(Name, TyCon)] -> GlobalEnv -> GlobalEnv
extendTyConsEnv ps genv
= genv { global_tycons = extendNameEnvList (global_tycons genv) ps }
-- |Set the list of PA functions in an environment.
--
setPAFunsEnv :: [(Name, Var)] -> GlobalEnv -> GlobalEnv
......
......@@ -80,7 +80,6 @@ initV hsc_env guts info thing_inside
= do { -- set up tables of builtin entities
; builtins <- initBuiltins
; builtin_vars <- initBuiltinVars builtins
; builtin_tycons <- initBuiltinTyCons builtins
-- set up class and type family envrionments
; eps <- liftIO $ hscEPS hsc_env
......@@ -91,7 +90,6 @@ initV hsc_env guts info thing_inside
-- construct the initial global environment
; let genv = extendImportedVarsEnv builtin_vars
. extendTyConsEnv builtin_tycons
. setPAFunsEnv builtin_pas
. setPRFunsEnv builtin_prs
$ initGlobalEnv info (mg_vect_decls guts) instEnvs famInstEnvs
......
......@@ -39,8 +39,11 @@ import TyCon
import DataCon
import NameEnv
import NameSet
import Name
import VarEnv
import VarSet
import Var as Var
import FastString
import Outputable
......@@ -70,8 +73,22 @@ defGlobalVar :: Var -> Var -> VM ()
defGlobalVar v v'
= do { traceVt "add global var mapping:" (ppr v <+> text "-->" <+> ppr v')
; updGEnv $ \env -> env { global_vars = extendVarEnv (global_vars env) v v' }
-- check for duplicate vectorisation
; currentDef <- readGEnv $ \env -> lookupVarEnv (global_vars env) v
; case currentDef of
Just old_v' -> cantVectorise "Variable is already vectorised:" $
ppr v <+> moduleOf v old_v'
Nothing -> return ()
; updGEnv $ \env -> env { global_vars = extendVarEnv (global_vars env) v v' }
}
where
moduleOf var var' | var == var'
= ptext (sLit "vectorises to itself")
| Just mod <- nameModule_maybe (Var.varName var')
= ptext (sLit "in module") <+> ppr mod
| otherwise
= ptext (sLit "in the current module")
-- Vectorisation declarations -------------------------------------------------
......@@ -120,8 +137,26 @@ lookupTyCon 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' }
defTyCon tc tc'
= do { traceVt "add global tycon mapping:" (ppr tc <+> text "-->" <+> ppr tc')
-- check for duplicate vectorisation
; currentDef <- readGEnv $ \env -> lookupNameEnv (global_tycons env) (tyConName tc)
; case currentDef of
Just old_tc' -> cantVectorise "Type constructor or class is already vectorised:" $
ppr tc <+> moduleOf tc old_tc'
Nothing -> return ()
; updGEnv $ \env ->
env { global_tycons = extendNameEnv (global_tycons env) (tyConName tc) tc' }
}
where
moduleOf tc tc' | tc == tc'
= ptext (sLit "vectorises to itself")
| Just mod <- nameModule_maybe (tyConName tc')
= ptext (sLit "in module") <+> ppr mod
| otherwise
= ptext (sLit "in the current module")
-- |Get the set of all vectorised type constructors.
--
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment