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

Improve import and export of vectorisation information

parent 46fa261e
......@@ -154,7 +154,7 @@ data DsMetaVal
| Splice (HsExpr Id) -- These bindings are introduced by
-- the PendingSplices on a HsBracketOut
initDs :: HscEnv
initDs :: HscEnv
-> Module -> GlobalRdrEnv -> TypeEnv
-> DsM a
-> IO (Messages, Maybe a)
......
......@@ -61,6 +61,7 @@ import HsTypes
import HsDoc
import TyCon
import NameSet
import Name
import {- Kind parts of -} Type
import BasicTypes
import ForeignCall
......@@ -1048,11 +1049,11 @@ data VectDecl name
(Maybe Type) -- 'Nothing' => SCALAR declaration
deriving (Data, Typeable)
lvectDeclName :: Outputable name => LVectDecl name -> name
lvectDeclName (L _ (HsVect (L _ name) _)) = name
lvectDeclName (L _ (HsNoVect (L _ name))) = name
lvectDeclName (L _ (HsVectTypeIn (L _ name) _)) = name
lvectDeclName (L _ (HsVectTypeOut name _)) = pprPanic "HsDecls.HsVectTypeOut" (ppr name)
lvectDeclName :: NamedThing name => LVectDecl name -> Name
lvectDeclName (L _ (HsVect (L _ name) _)) = getName name
lvectDeclName (L _ (HsNoVect (L _ name))) = getName name
lvectDeclName (L _ (HsVectTypeIn (L _ name) _)) = getName name
lvectDeclName (L _ (HsVectTypeOut tycon _)) = getName tycon
instance OutputableBndr name => Outputable (VectDecl name) where
ppr (HsVect v Nothing)
......
......@@ -668,19 +668,18 @@ pprModIface iface
, vcat (map pprUsage (mi_usages iface))
, vcat (map pprIfaceAnnotation (mi_anns iface))
, pprFixities (mi_fixities iface)
, vcat (map pprIfaceDecl (mi_decls iface))
, vcat (map ppr (mi_insts iface))
, vcat (map ppr (mi_fam_insts iface))
, vcat (map ppr (mi_rules iface))
, vcat (map pprIfaceDecl (mi_decls iface))
, vcat (map ppr (mi_insts iface))
, vcat (map ppr (mi_fam_insts iface))
, vcat (map ppr (mi_rules iface))
, pprVectInfo (mi_vect_info iface)
, pprVectInfo (mi_vect_info iface)
, ppr (mi_warns iface)
, pprTrustInfo (mi_trust iface)
, pprTrustPkg (mi_trust_pkg iface)
]
, ppr (mi_warns iface)
, pprTrustInfo (mi_trust iface)
, pprTrustPkg (mi_trust_pkg iface)
]
where
pp_boot | mi_boot iface = ptext (sLit "[boot]")
| otherwise = empty
| otherwise = empty
\end{code}
When printing export lists, we print like this:
......
......@@ -548,12 +548,13 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
-- - export list
-- - orphans
-- - deprecations
-- - XXX vect info?
-- - vect info
mod_hash <- computeFingerprint putNameLiterally
(map fst sorted_decls,
export_hash,
orphan_hash,
mi_warns iface0)
mi_warns iface0,
mi_vect_info iface0)
-- The interface hash depends on:
-- - the ABI hash, plus
......
......@@ -705,57 +705,72 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo
, ifaceVectInfoScalarVars = scalarVars
, ifaceVectInfoScalarTyCons = scalarTyCons
})
= do { vVars <- mapM vectVarMapping vars
; tyConRes1 <- mapM vectTyConMapping tycons
; tyConRes2 <- mapM vectTyConReuseMapping tyconsReuse
= do { let scalarTyConsSet = mkNameSet scalarTyCons
; vVars <- mapM vectVarMapping vars
; tyConRes1 <- mapM vectTyConMapping tycons
; tyConRes2 <- mapM (vectTyConReuseMapping scalarTyConsSet) tyconsReuse
; let (vTyCons, vDataCons, vPAs, vIsos) = unzip4 (tyConRes1 ++ tyConRes2)
; return $ VectInfo
{ vectInfoVar = mkVarEnv vVars
, vectInfoTyCon = mkNameEnv vTyCons
, vectInfoDataCon = mkNameEnv (concat vDataCons)
, vectInfoPADFun = mkNameEnv vPAs
, vectInfoIso = mkNameEnv vIsos
{ vectInfoVar = mkVarEnv vVars
, vectInfoTyCon = mkNameEnv vTyCons
, vectInfoDataCon = mkNameEnv (concat vDataCons)
, vectInfoPADFun = mkNameEnv (catMaybes vPAs)
, vectInfoIso = mkNameEnv (catMaybes vIsos)
, vectInfoScalarVars = mkVarSet (map lookupVar scalarVars)
, vectInfoScalarTyCons = mkNameSet scalarTyCons
, vectInfoScalarTyCons = scalarTyConsSet
}
}
where
vectVarMapping name
= do { vName <- lookupOrig mod (mkVectOcc (nameOccName name))
; let { var = lookupVar name
; vVar = lookupVar vName
}
; var <- forkM (text ("vect var") <+> ppr name) $
tcIfaceExtId name
; vVar <- forkM (text ("vect vVar") <+> ppr vName) $
tcIfaceExtId vName
; return (var, (var, vVar))
}
vectTyConMapping name
= do { vName <- lookupOrig mod (mkVectTyConOcc (nameOccName name))
; paName <- lookupOrig mod (mkPADFunOcc (nameOccName name))
; isoName <- lookupOrig mod (mkVectIsoOcc (nameOccName name))
-- FIXME: we will need to use tcIfaceTyCon/tcIfaceExtId on some of these (but depends
-- on how we exactly define the 'VECTORISE type' pragma to work)
; let { tycon = lookupTyCon name
; vTycon = lookupTyCon vName
; paTycon = lookupVar paName
; isoTycon = lookupVar isoName
}
; vDataCons <- mapM vectDataConMapping (tyConDataCons tycon)
; return ((name, (tycon, vTycon)), -- (T, T_v)
vDataCons, -- list of (Ci, Ci_v)
(vName, (vTycon, paTycon)), -- (T_v, paT)
(name, (tycon, isoTycon))) -- (T, isoT)
; return ( (name, (tycon, vTycon)) -- (T, T_v)
, vDataCons -- list of (Ci, Ci_v)
, Just (vName, (vTycon, paTycon)) -- (T_v, paT)
, Just (name, (tycon, isoTycon)) -- (T, isoT)
)
}
vectTyConReuseMapping name
= do { paName <- lookupOrig mod (mkPADFunOcc (nameOccName name))
; isoName <- lookupOrig mod (mkVectIsoOcc (nameOccName name))
; let { tycon = lookupTyCon name
; paTycon = lookupVar paName
vectTyConReuseMapping scalarNames name
= do { paName <- lookupOrig mod (mkPADFunOcc (nameOccName name))
; isoName <- lookupOrig mod (mkVectIsoOcc (nameOccName name))
; tycon <- forkM (text ("vect reuse tycon") <+> ppr name) $
tcIfaceTyCon (IfaceTc name) -- somewhat naughty for wired in tycons, but ok
; if name `elemNameSet` scalarNames
then do
{ return ( (name, (tycon, tycon)) -- scalar type constructors expose no data...
, [] -- ...constructors and have no PA and ISO vars...
, Nothing -- ...see "Note [Pragmas to vectorise tycons]" in..
, Nothing -- ...'Vectorise.Type.Env'
)
} else do
{ let { paTycon = lookupVar paName
; isoTycon = lookupVar isoName
; vDataCons = [ (dataConName dc, (dc, dc))
| dc <- tyConDataCons tycon]
}
; return ((name, (tycon, tycon)), -- (T, T)
vDataCons, -- list of (Ci, Ci)
(name, (tycon, paTycon)), -- (T, paT)
(name, (tycon, isoTycon))) -- (T, isoT)
}
; return ( (name, (tycon, tycon)) -- (T, T)
, vDataCons -- list of (Ci, Ci)
, Just (name, (tycon, paTycon)) -- (T, paT)
, Just (name, (tycon, isoTycon)) -- (T, isoT)
)
}}
vectDataConMapping datacon
= do { let name = dataConName datacon
; vName <- lookupOrig mod (mkVectDataConOcc (nameOccName name))
......@@ -766,21 +781,21 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo
lookupVar name = case lookupTypeEnv typeEnv name of
Just (AnId var) -> var
Just _ ->
panic "TcIface.tcIfaceVectInfo: not an id"
pprPanic "TcIface.tcIfaceVectInfo: not an id" (ppr name)
Nothing ->
panic "TcIface.tcIfaceVectInfo: unknown name"
pprPanic "TcIface.tcIfaceVectInfo: unknown name of id" (ppr name)
lookupTyCon name = case lookupTypeEnv typeEnv name of
Just (ATyCon tc) -> tc
Just _ ->
panic "TcIface.tcIfaceVectInfo: not a tycon"
pprPanic "TcIface.tcIfaceVectInfo: not a tycon" (ppr name)
Nothing ->
panic "TcIface.tcIfaceVectInfo: unknown name"
pprPanic "TcIface.tcIfaceVectInfo: unknown name of tycon" (ppr name)
lookupDataCon name = case lookupTypeEnv typeEnv name of
Just (ADataCon dc) -> dc
Just _ ->
panic "TcIface.tcIfaceVectInfo: not a datacon"
pprPanic "TcIface.tcIfaceVectInfo: not a datacon" (ppr name)
Nothing ->
panic "TcIface.tcIfaceVectInfo: unknown name"
pprPanic "TcIface.tcIfaceVectInfo: unknown name of datacon" (ppr name)
\end{code}
%************************************************************************
......
......@@ -1816,6 +1816,10 @@ on just the OccName easily in a Core pass.
\begin{code}
-- |Vectorisation information for 'ModGuts', 'ModDetails' and 'ExternalPackageState'; see also
-- documentation at 'Vectorise.Env.GlobalEnv'.
--
-- NB: The following tables may also include 'Var's, 'TyCon's and 'DataCon's from imported modules,
-- which have been subsequently vectorised in the current module.
--
data VectInfo
= VectInfo
{ vectInfoVar :: VarEnv (Var , Var ) -- ^ @(f, f_v)@ keyed on @f@
......
......@@ -331,20 +331,20 @@ tidyProgram hsc_env (ModGuts { mg_module = mod, mg_exports = exports,
-- we want Global, IdInfo-rich (or not) DFunId in the
-- tidy_insts
; tidy_rules = tidyRules tidy_env ext_rules
-- You might worry that the tidy_env contains IdInfo-rich stuff
-- and indeed it does, but if omit_prags is on, ext_rules is
-- empty
; tidy_rules = tidyRules tidy_env ext_rules
-- You might worry that the tidy_env contains IdInfo-rich stuff
-- and indeed it does, but if omit_prags is on, ext_rules is
-- empty
; tidy_vect_info = tidyVectInfo tidy_env vect_info
-- See Note [Injecting implicit bindings]
; all_tidy_binds = implicit_binds ++ tidy_binds
-- See Note [Injecting implicit bindings]
; all_tidy_binds = implicit_binds ++ tidy_binds
; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env)
}
; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env)
}
; endPass dflags CoreTidy all_tidy_binds tidy_rules
; endPass dflags CoreTidy all_tidy_binds tidy_rules
-- If the endPass didn't print the rules, but ddump-rules is on, print now
; dumpIfSet (dopt Opt_D_dump_rules dflags
......
......@@ -686,7 +686,7 @@ tcVect (HsNoVect name)
tcVect (HsVectTypeIn lname@(L _ name) ty)
= addErrCtxt (vectCtxt lname) $
do { tycon <- tcLookupTyCon name
; checkTc (tyConArity tycon /= 0) scalarTyConMustBeNullary
; checkTc (tyConArity tycon == 0) scalarTyConMustBeNullary
; ty' <- fmapMaybeM dsHsType ty
; return $ HsVectTypeOut tycon ty'
......
......@@ -25,7 +25,6 @@ module Vectorise.Builtins (
-- * Initialisation
initBuiltins, initBuiltinVars, initBuiltinTyCons, initBuiltinDataCons,
initBuiltinPAs, initBuiltinPRs,
initBuiltinBoxedTyCons,
-- * Lookup
primMethod,
......
......@@ -3,15 +3,13 @@
module Vectorise.Builtins.Initialise (
-- * Initialisation
initBuiltins, initBuiltinVars, initBuiltinTyCons, initBuiltinDataCons,
initBuiltinPAs, initBuiltinPRs,
initBuiltinBoxedTyCons
initBuiltinPAs, initBuiltinPRs
) where
import Vectorise.Builtins.Base
import Vectorise.Builtins.Modules
import BasicTypes
import PrelNames
import TysPrim
import DsMonad
import IfaceEnv
......@@ -254,9 +252,7 @@ initBuiltinTyCons bi
where
defaultTyCons :: DsM [TyCon]
defaultTyCons
= do word8 <- dsLookupTyCon word8TyConName
return [intTyCon, boolTyCon, floatTyCon, doubleTyCon, word8]
defaultTyCons = return [boolTyCon]
-- |Get a list of names to `DataCon`s in the mock prelude.
--
......@@ -284,18 +280,8 @@ initBuiltinPRs (Builtins { dphModules = mods }) insts
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)]
find i | [Just tc] <- instanceRoughTcs i = (tc, instanceDFunId i)
| otherwise = pprPanic "Invalid DPH instance" (ppr i)
-- Auxilliary look up functions ----------------
......
module Vectorise.Env (
Scope(..),
......@@ -16,7 +15,6 @@ module Vectorise.Env (
extendDataConsEnv,
extendPAFunsEnv,
setPRFunsEnv,
setBoxedTyConsEnv,
modVectInfo
) where
......@@ -116,9 +114,6 @@ data GlobalEnv
, global_pr_funs :: NameEnv Var
-- ^Mapping from TyCons to their PR dfuns.
, global_boxed_tycons :: NameEnv TyCon
-- ^Mapping from unboxed TyCons to their boxed versions.
, global_inst_env :: (InstEnv, InstEnv)
-- ^External package inst-env & home-package inst-env for class instances.
......@@ -144,7 +139,6 @@ initGlobalEnv info vectDecls instEnvs famInstEnvs
, global_datacons = mapNameEnv snd $ vectInfoDataCon info
, global_pa_funs = mapNameEnv snd $ vectInfoPADFun info
, global_pr_funs = emptyNameEnv
, global_boxed_tycons = emptyNameEnv
, global_inst_env = instEnvs
, global_fam_inst_env = famInstEnvs
, global_bindings = []
......@@ -202,29 +196,29 @@ setPRFunsEnv :: [(Name, Var)] -> GlobalEnv -> GlobalEnv
setPRFunsEnv ps genv
= genv { global_pr_funs = mkNameEnv ps }
-- |Set the list of boxed type constructor in an environment.
--
setBoxedTyConsEnv :: [(Name, TyCon)] -> GlobalEnv -> GlobalEnv
setBoxedTyConsEnv ps genv
= genv { global_boxed_tycons = mkNameEnv ps }
-- |Compute vectorisation information that goes into 'ModGuts' (and is stored in interface files).
-- The incoming 'vectInfo' is that from the 'HscEnv' and 'EPS'. The outgoing one contains only the
-- definitions for the currently compiled module.
-- definitions for the currently compiled module; this includes variables, type constructors, and
-- data constructors referenced in VECTORISE pragmas.
--
modVectInfo :: GlobalEnv -> TypeEnv -> VectInfo -> VectInfo
modVectInfo env tyenv info
modVectInfo :: GlobalEnv -> TypeEnv -> [CoreVect]-> VectInfo -> VectInfo
modVectInfo env tyenv vectDecls info
= info
{ vectInfoVar = global_exported_vars env
, vectInfoTyCon = mk_env typeEnvTyCons global_tycons
, vectInfoDataCon = mk_env typeEnvDataCons global_datacons
, vectInfoPADFun = mk_env typeEnvTyCons global_pa_funs
, vectInfoTyCon = mk_env tyCons (global_tycons env)
, vectInfoDataCon = mk_env dataCons (global_datacons env)
, vectInfoPADFun = mk_env tyCons (global_pa_funs env)
, vectInfoScalarVars = global_scalar_vars env `minusVarSet` vectInfoScalarVars info
, vectInfoScalarTyCons = global_scalar_tycons env `minusNameSet` vectInfoScalarTyCons info
}
where
mk_env from_tyenv from_env
= mkNameEnv [(name, (from,to))
| from <- from_tyenv tyenv
, let name = getName from
, Just to <- [lookupNameEnv (from_env env) name]]
vectTypeTyCons = [tycon | VectType tycon _ <- vectDecls]
tyCons = typeEnvTyCons tyenv ++ vectTypeTyCons
dataCons = typeEnvDataCons tyenv ++ concatMap tyConDataCons vectTypeTyCons
-- Produce an entry for every declaration that is mentioned in the domain of the 'inspectedEnv'
mk_env decls inspectedEnv
= mkNameEnv [(name, (decl, to))
| decl <- decls
, let name = getName decl
, Just to <- [lookupNameEnv inspectedEnv name]]
......@@ -45,7 +45,7 @@ import FastString
import Control.Monad
import VarSet
-- | Run a vectorisation computation.
-- |Run a vectorisation computation.
--
initV :: HscEnv
-> ModGuts
......@@ -69,7 +69,6 @@ initV hsc_env guts info thing_inside
; builtin_vars <- initBuiltinVars builtins
; builtin_tycons <- initBuiltinTyCons builtins
; let builtin_datacons = initBuiltinDataCons builtins
; builtin_boxed <- initBuiltinBoxedTyCons builtins
-- set up class and type family envrionments
; eps <- liftIO $ hscEPS hsc_env
......@@ -85,7 +84,6 @@ initV hsc_env guts info thing_inside
. extendDataConsEnv builtin_datacons
. extendPAFunsEnv builtin_pas
. setPRFunsEnv builtin_prs
. setBoxedTyConsEnv builtin_boxed
$ initGlobalEnv info (mg_vect_decls guts) instEnvs famInstEnvs
-- perform vectorisation
......@@ -95,7 +93,7 @@ initV hsc_env guts info thing_inside
No -> return Nothing
} }
new_info genv = modVectInfo genv (mg_types guts) info
new_info genv = modVectInfo genv (mg_types guts) (mg_vect_decls guts) info
selectBackendErr = sLit "To use -fvectorise select a DPH backend with -fdph-par or -fdph-seq"
......
......@@ -15,7 +15,7 @@ module Vectorise.Monad.Global (
globalScalarVars, isGlobalScalar, globalScalarTyCons,
-- * TyCons
lookupTyCon, lookupBoxedTyCon,
lookupTyCon,
defTyCon, globalVectTyCons,
-- * Datacons
......@@ -119,13 +119,6 @@ lookupTyCon 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 ()
......
......@@ -53,7 +53,7 @@ import Data.List
-- (1) Data type constructor 'T' that may be used in vectorised code, where 'T' represents itself,
-- but the representation of 'T' is opaque in vectorised code.
--
-- An example is the treatment of Int'. 'Int's can be used in vectorised code and remain
-- An example is the treatment of 'Int'. 'Int's can be used in vectorised code and remain
-- unchanged by vectorisation. However, the representation of 'Int' by the 'I#' data
-- constructor wrapping an 'Int#' is not exposed in vectorised code. Instead, computations
-- involving the representation need to be confined to scalar code.
......@@ -64,7 +64,8 @@ import Data.List
-- Type constructors declared with {-# VECTORISE SCALAR type T #-} are treated in this manner.
-- (The vectoriser never treats a type constructor automatically in this manner.)
--
-- (2) Data type constructor 'T' that together with its constructors 'Cn' may be used in vectorised
-- (2) [NOT FULLY IMPLEMENTED YET]
-- Data type constructor 'T' that together with its constructors 'Cn' may be used in vectorised
-- code, where 'T' and the 'Cn' represent themselves in vectorised code.
--
-- An example is the treatment of 'Bool'. 'Bool' together with 'False' and 'True' may appear in
......@@ -122,6 +123,10 @@ vectTypeEnv env vectTypeDecls
keep_and_scalar_tcs = keep_tcs ++ localScalarTyCons
; traceVt " declared SCALAR: " $ ppr localScalarTyCons
; traceVt " reuse : " $ ppr keep_tcs
; traceVt " convert : " $ ppr conv_tcs
-- Of those type constructors that we don't need to vectorise, we use the original
-- representation in both unvectorised and vectorised code. For those declared VECTORISE
-- SCALAR, we ignore their represention — see "Note [Pragmas to vectorise tycons]".
......
module Vectorise.Type.TyConDecl
(vectTyConDecls)
where
module Vectorise.Type.TyConDecl (
vectTyConDecls
) where
import Vectorise.Type.Type
import Vectorise.Monad
import BuildTyCl
......@@ -16,14 +17,14 @@ import Util
import Control.Monad
-- | Vectorise some (possibly recursively defined) type constructors.
-- |Vectorise some (possibly recursively defined) type constructors.
--
vectTyConDecls :: [TyCon] -> VM [TyCon]
vectTyConDecls tcs = fixV $ \tcs' ->
do
mapM_ (uncurry defTyCon) (zipLazy tcs tcs')
mapM vectTyConDecl tcs
-- | Vectorise a single type construcrtor.
vectTyConDecl :: TyCon -> VM TyCon
vectTyConDecl tycon
......
-- Apply the vectorisation transformation to types. This is the \mathcal{L}_t scheme in HtM.
module Vectorise.Type.Type (
vectTyCon,
vectAndLiftType,
vectType
) where
module Vectorise.Type.Type
( vectTyCon
, vectAndLiftType
, vectType)
where
import Vectorise.Utils
import Vectorise.Monad
import Vectorise.Builtins
......@@ -15,8 +17,8 @@ import Control.Monad
import Data.List
import Data.Maybe
-- | Vectorise a type constructor.
--
vectTyCon :: TyCon -> VM TyCon
vectTyCon tc
| isFunTyCon tc = builtin closureTyCon
......@@ -24,10 +26,10 @@ vectTyCon tc
| isUnLiftedTyCon tc = return tc
| otherwise
= maybeCantVectoriseM "Tycon not vectorised: " (ppr tc)
$ lookupTyCon tc
$ lookupTyCon tc
-- | Produce the vectorised and lifted versions of a type.
-- |Produce the vectorised and lifted versions of a type.
--
vectAndLiftType :: Type -> VM (Type, Type)
vectAndLiftType ty | Just ty' <- coreView ty = vectAndLiftType ty'
vectAndLiftType ty
......@@ -41,18 +43,17 @@ vectAndLiftType ty
where
(tyvars, mono_ty) = splitForAllTys ty
-- | Vectorise a type.
-- |Vectorise a type.
--
vectType :: Type -> VM Type
vectType ty
| Just ty' <- coreView ty
= vectType ty'
vectType (TyVarTy tv) = return $ TyVarTy tv
vectType (AppTy ty1 ty2) = liftM2 AppTy (vectType ty1) (vectType ty2)
vectType (TyConApp tc tys) = liftM2 TyConApp (vectTyCon tc) (mapM vectType tys)
vectType (FunTy ty1 ty2) = liftM2 TyConApp (builtin closureTyCon)
(mapM vectAndBoxType [ty1,ty2])
| Just ty' <- coreView ty
= vectType ty'
vectType (TyVarTy tv) = return $ TyVarTy tv
vectType (AppTy ty1 ty2) = liftM2 AppTy (vectType ty1) (vectType ty2)
vectType (TyConApp tc tys) = liftM2 TyConApp (vectTyCon tc) (mapM vectType tys)
vectType (FunTy ty1 ty2) = liftM2 TyConApp (builtin closureTyCon) (mapM vectType [ty1,ty2])
-- For each quantified var we need to add a PA dictionary out the front of the type.
-- So forall a. C a => a -> a
......@@ -82,28 +83,7 @@ vectType ty@(ForAllTy _ _)
vectType ty = cantVectorise "Can't vectorise type" (ppr ty)
-- | Add quantified vars and dictionary parameters to the front of a type.
-- |Add quantified vars and dictionary parameters to the front of a type.
--
abstractType :: [TyVar] -> [Type] -> Type -> Type
abstractType tyvars dicts = mkForAllTys tyvars . mkFunTys dicts
-- | Create the boxed version of a vectorised type.
vectAndBoxType :: Type -> VM Type
vectAndBoxType ty = vectType ty >>= boxType
-- | Create the boxed version of a type.
boxType :: Type -> VM Type
boxType ty
| Just (tycon, []) <- splitTyConApp_maybe ty
, isUnLiftedTyCon tycon
= do
r <- lookupBoxedTyCon tycon
case r of
Just tycon' -> return $ mkTyConApp tycon' []
Nothing -> return ty
| otherwise = return ty
module Vectorise.Utils (
module Vectorise.Utils.Base,
module Vectorise.Utils.Closure,
......@@ -21,8 +20,8 @@ module Vectorise.Utils (
-- * Naming
newLocalVar
)
where
) where
import Vectorise.Utils.Base
import Vectorise.Utils.Closure
import Vectorise.Utils.Hoisting
......@@ -37,6 +36,7 @@ import Control.Monad
-- Annotated Exprs ------------------------------------------------------------
collectAnnTypeArgs :: AnnExpr b ann -> (AnnExpr b ann, [Type])
collectAnnTypeArgs expr = go expr []
where
......@@ -69,58 +69,52 @@ isAnnTypeArg _ = False
-- in dph-common/D.A.P.Lifted/PArray.hs
--
-- | An empty array of the given type.
-- |An empty array of the given type.
--
emptyPD :: Type -> VM CoreExpr
emptyPD = paMethod emptyPDVar "emptyPD"
-- | Produce an array containing copies of a given element.
replicatePD
:: CoreExpr -- ^ Number of copies in the resulting array.
-> CoreExpr -- ^ Value to replicate.
-> VM CoreExpr
-- |Produce an array containing copies of a given element.
--
replicatePD :: CoreExpr -- ^ Number of copies in the resulting array.
-> CoreExpr -- ^ Value to replicate.
-> VM CoreExpr