Commit 0bfe5c05 authored by chak@cse.unsw.edu.au.'s avatar chak@cse.unsw.edu.au.
Browse files

GHC is now independent of the DPH library structure

* if -XParallelArrays is given, the symbols for the desugarer are
  taken from 'Data.Array.Parallel' (from whichever package is
  exposed and has the module — the home package is fine, too)
* if -fvectorise is given, the symbols for the vectoriser are
  taken from 'Data.Array.Parallel.Prim' (as above)

(There is one wired in symbol left, namely the data constructor
'base:GHC.PArr.[::]. It'll die another day.)
parent 55991bf6
......@@ -365,11 +365,11 @@ dsExpr (ExplicitList elt_ty xs)
-- singletonP x1 +:+ ... +:+ singletonP xn
--
dsExpr (ExplicitPArr ty []) = do
emptyP <- dsLookupDPHId emptyPName
emptyP <- dsDPHBuiltin emptyPVar
return (Var emptyP `App` Type ty)
dsExpr (ExplicitPArr ty xs) = do
singletonP <- dsLookupDPHId singletonPName
appP <- dsLookupDPHId appPName
singletonP <- dsDPHBuiltin singletonPVar
appP <- dsDPHBuiltin appPVar
xs' <- mapM dsLExpr xs
return . foldr1 (binary appP) $ map (unary singletonP) xs'
where
......
......@@ -484,7 +484,7 @@ dsPArrComp (ParStmt qss _ _ _ : quals) = dePArrParComp qss quals
-- <<[:e' | qs:]>> p (filterP (\x -> case x of {p -> True; _ -> False}) e)
--
dsPArrComp (BindStmt p e _ _ : qs) = do
filterP <- dsLookupDPHId filterPName
filterP <- dsDPHBuiltin filterPVar
ce <- dsLExpr e
let ety'ce = parrElemType ce
false = Var falseDataConId
......@@ -496,7 +496,7 @@ dsPArrComp (BindStmt p e _ _ : qs) = do
dePArrComp qs p gen
dsPArrComp qs = do -- no ParStmt in `qs'
sglP <- dsLookupDPHId singletonPName
sglP <- dsDPHBuiltin singletonPVar
let unitArray = mkApps (Var sglP) [Type unitTy, mkCoreTup []]
dePArrComp qs (noLoc $ WildPat unitTy) unitArray
......@@ -516,7 +516,7 @@ dePArrComp [] _ _ = panic "dePArrComp"
--
dePArrComp (LastStmt e' _ : quals) pa cea
= ASSERT( null quals )
do { mapP <- dsLookupDPHId mapPName
do { mapP <- dsDPHBuiltin mapPVar
; let ty = parrElemType cea
; (clam, ty'e') <- deLambda ty pa e'
; return $ mkApps (Var mapP) [Type ty, Type ty'e', clam, cea] }
......@@ -524,7 +524,7 @@ dePArrComp (LastStmt e' _ : quals) pa cea
-- <<[:e' | b, qs:]>> pa ea = <<[:e' | qs:]>> pa (filterP (\pa -> b) ea)
--
dePArrComp (ExprStmt b _ _ _ : qs) pa cea = do
filterP <- dsLookupDPHId filterPName
filterP <- dsDPHBuiltin filterPVar
let ty = parrElemType cea
(clam,_) <- deLambda ty pa b
dePArrComp qs pa (mkApps (Var filterP) [Type ty, clam, cea])
......@@ -543,8 +543,8 @@ dePArrComp (ExprStmt b _ _ _ : qs) pa cea = do
-- <<[:e' | qs:]>> (pa, p) (crossMapP ea ef)
--
dePArrComp (BindStmt p e _ _ : qs) pa cea = do
filterP <- dsLookupDPHId filterPName
crossMapP <- dsLookupDPHId crossMapPName
filterP <- dsDPHBuiltin filterPVar
crossMapP <- dsDPHBuiltin crossMapPVar
ce <- dsLExpr e
let ety'cea = parrElemType cea
ety'ce = parrElemType ce
......@@ -568,7 +568,7 @@ dePArrComp (BindStmt p e _ _ : qs) pa cea = do
-- {x_1, ..., x_n} = DV (ds) -- Defined Variables
--
dePArrComp (LetStmt ds : qs) pa cea = do
mapP <- dsLookupDPHId mapPName
mapP <- dsDPHBuiltin mapPVar
let xs = collectLocalBinders ds
ty'cea = parrElemType cea
v <- newSysLocalDs ty'cea
......@@ -615,7 +615,7 @@ dePArrParComp qss quals = do
---
parStmts [] pa cea = return (pa, cea)
parStmts ((qs, xs):qss) pa cea = do -- subsequent statements (zip'ed)
zipP <- dsLookupDPHId zipPName
zipP <- dsDPHBuiltin zipPVar
let pa' = mkLHsPatTup [pa, mkLHsVarPatTup xs]
ty'cea = parrElemType cea
res_expr = mkLHsVarTuple xs
......
......@@ -21,9 +21,9 @@ module DsMonad (
newUnique,
UniqSupply, newUniqueSupply,
getDOptsDs, getGhcModeDs, doptDs, woptDs,
dsLookupGlobal, dsLookupGlobalId, dsLookupDPHId, dsLookupTyCon, dsLookupDataCon,
dsLookupGlobal, dsLookupGlobalId, dsDPHBuiltin, dsLookupTyCon, dsLookupDataCon,
assertDAPPLoaded, lookupDAPPRdrEnv,
PArrBuiltin(..), dsLookupDPHRdrEnv, dsInitPArrBuiltin,
DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
......@@ -41,6 +41,7 @@ import CoreSyn
import HsSyn
import TcIface
import LoadIface
import Finder
import PrelNames
import Avail
import RdrName
......@@ -60,7 +61,6 @@ import DynFlags
import ErrUtils
import FastString
import Maybes
import Control.Monad
import Data.IORef
\end{code}
......@@ -131,16 +131,38 @@ type DsWarning = (SrcSpan, SDoc)
-- and we'll do the print_unqual stuff later on to turn it
-- into a Doc.
data DsGblEnv = DsGblEnv {
ds_mod :: Module, -- For SCC profiling
ds_unqual :: PrintUnqualified,
ds_msgs :: IORef Messages, -- Warning messages
ds_if_env :: (IfGblEnv, IfLclEnv), -- Used for looking up global,
-- If '-XParallelArrays' is given, the desugarer populates this table with the corresponding
-- variables found in 'Data.Array.Parallel'.
--
data PArrBuiltin
= PArrBuiltin
{ lengthPVar :: Var -- ^ lengthP
, replicatePVar :: Var -- ^ replicateP
, singletonPVar :: Var -- ^ singletonP
, mapPVar :: Var -- ^ mapP
, filterPVar :: Var -- ^ filterP
, zipPVar :: Var -- ^ zipP
, crossMapPVar :: Var -- ^ crossMapP
, indexPVar :: Var -- ^ (!:)
, emptyPVar :: Var -- ^ emptyP
, appPVar :: Var -- ^ (+:+)
, enumFromToPVar :: Var -- ^ enumFromToP
, enumFromThenToPVar :: Var -- ^ enumFromThenToP
}
data DsGblEnv
= DsGblEnv
{ ds_mod :: Module -- For SCC profiling
, ds_unqual :: PrintUnqualified
, ds_msgs :: IORef Messages -- Warning messages
, ds_if_env :: (IfGblEnv, IfLclEnv) -- Used for looking up global,
-- possibly-imported things
ds_dph_env :: GlobalRdrEnv -- exported entities of 'Data.Array.Parallel.Prim' iff
-- '-fdph-*' flag was given (i.e., 'DynFlags.DPHBackend /=
-- DPHNone'); otherwise, empty
}
, ds_dph_env :: GlobalRdrEnv -- exported entities of 'Data.Array.Parallel.Prim'
-- iff '-fvectorise' flag was given as well as
-- exported entities of 'Data.Array.Parallel' iff
-- '-XParallelArrays' was given; otherwise, empty
, ds_parr_bi :: PArrBuiltin -- desugarar names for '-XParallelArrays'
}
data DsLclEnv = DsLclEnv {
ds_meta :: DsMetaEnv, -- Template Haskell bindings
......@@ -171,8 +193,9 @@ initDs hsc_env mod rdr_env type_env thing_inside
(ds_gbl_env, ds_lcl_env) = mkDsEnvs dflags mod rdr_env type_env msg_var
; either_res <- initTcRnIf 'd' hsc_env ds_gbl_env ds_lcl_env $
loadDAPP dflags $
tryM thing_inside -- Catch exceptions (= errors during desugaring)
loadDAP dflags $
initDPHBuiltins $
tryM thing_inside -- Catch exceptions (= errors during desugaring)
-- Display any errors and warnings
-- Note: if -Werror is used, we don't signal an error here.
......@@ -190,22 +213,50 @@ initDs hsc_env mod rdr_env type_env thing_inside
}
where
-- Extend the global environment with a 'GlobalRdrEnv' containing the exported entities of
-- 'Data.Array.Parallel.Prim' if '-fdph-*' specified.
loadDAPP dflags thing_inside
| Just pkg <- dphPackageMaybe dflags
= do { rdr_env <- loadModule sdoc (dATA_ARRAY_PARALLEL_PRIM pkg)
; updGblEnv (\env -> env {ds_dph_env = rdr_env}) thing_inside
-- * 'Data.Array.Parallel' iff '-XParallalArrays' specified (see also 'checkLoadDAP').
-- * 'Data.Array.Parallel.Prim' iff '-fvectorise' specified.
loadDAP dflags thing_inside
= do { dapEnv <- loadOneModule dATA_ARRAY_PARALLEL_NAME checkLoadDAP paErr
; dappEnv <- loadOneModule dATA_ARRAY_PARALLEL_PRIM_NAME (doptM Opt_Vectorise) veErr
; updGblEnv (\env -> env {ds_dph_env = dapEnv `plusOccEnv` dappEnv }) thing_inside
}
| otherwise
= do { ifXOptM Opt_ParallelArrays (liftIO $ fatalErrorMsg dflags $ ptext selectBackendErrPA)
; ifDOptM Opt_Vectorise (liftIO $ fatalErrorMsg dflags $ ptext selectBackendErrVect)
; thing_inside
where
loadOneModule :: ModuleName -- the module to load
-> DsM Bool -- under which condition
-> Message -- error message if module not found
-> DsM GlobalRdrEnv -- empty if condition 'False'
loadOneModule modname check err
= do { doLoad <- check
; if not doLoad
then return emptyGlobalRdrEnv
else do {
; result <- liftIO $ findImportedModule hsc_env modname Nothing
; case result of
Found _ mod -> loadModule err mod
_ -> do { liftIO $ fatalErrorMsg dflags err
; panic "DsMonad.initDs: failed to load module"
}
} }
paErr = ptext $ sLit "To use -XParallelArrays, you must specify a DPH backend package"
veErr = ptext $ sLit "To use -fvectorise, you must specify a DPH backend package"
initDPHBuiltins thing_inside
= do { -- If '-XParallelArrays' given, we populate the builtin table for desugaring those
; doInitBuiltins <- checkLoadDAP
; if doInitBuiltins
then dsInitPArrBuiltin thing_inside
else thing_inside
}
sdoc = ptext (sLit "Internal Data Parallel Haskell interface 'Data.Array.Parallel.Prim'")
selectBackendErrVect = sLit "To use -fvectorise select a DPH backend with -fdph-par or -fdph-seq"
selectBackendErrPA = sLit "To use -XParallelArrays select a DPH backend with -fdph-par or -fdph-seq"
checkLoadDAP = do { paEnabled <- xoptM Opt_ParallelArrays
; return $ paEnabled &&
mod /= gHC_PARR' &&
moduleName mod /= dATA_ARRAY_PARALLEL_NAME
}
-- do not load 'Data.Array.Parallel' iff compiling 'base:GHC.PArr' or a
-- module called 'dATA_ARRAY_PARALLEL_NAME'; see also the comments at the top
-- of 'base:GHC.PArr' and 'Data.Array.Parallel' in the DPH libraries
initDsTc :: DsM a -> TcM a
initDsTc thing_inside
......@@ -228,23 +279,26 @@ mkDsEnvs dflags mod rdr_env type_env msg_var
, ds_unqual = mkPrintUnqualified dflags rdr_env
, ds_msgs = msg_var
, ds_dph_env = emptyGlobalRdrEnv
, ds_parr_bi = panic "DsMonad: uninitialised ds_parr_bi"
}
lcl_env = DsLclEnv { ds_meta = emptyNameEnv
, ds_loc = noSrcSpan
}
in (gbl_env, lcl_env)
-- Attempt to load the given module and return its exported entities if successful; otherwise, return an
-- empty environment. See "Note [Loading Data.Array.Parallel.Prim]".
-- Attempt to load the given module and return its exported entities if successful.
--
loadModule :: SDoc -> Module -> DsM GlobalRdrEnv
loadModule doc mod
= do { env <- getGblEnv
= do { env <- getGblEnv
; dflags <- getDOpts
; setEnvs (ds_if_env env) $ do
{ iface <- loadInterface doc mod ImportBySystem
; case iface of
Failed _err -> return $ mkGlobalRdrEnv []
Succeeded iface -> return $ mkGlobalRdrEnv . gresFromAvails prov . mi_exports $ iface
; case iface of
Failed err -> do { liftIO $ fatalErrorMsg dflags (err $$ doc)
; panic "DsMonad.loadModule: failed to load"
}
Succeeded iface -> return $ mkGlobalRdrEnv . gresFromAvails prov . mi_exports $ iface
} }
where
prov = Imported [ImpSpec { is_decl = imp_spec, is_item = ImpAll }]
......@@ -253,15 +307,6 @@ loadModule doc mod
name = moduleName mod
\end{code}
Note [Loading Data.Array.Parallel.Prim]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We generally attempt to load the interface of 'Data.Array.Parallel.Prim' when a DPH backend is selected.
However, while compiling packages containing a DPH backend, we will start out compiling the modules
'Data.Array.Parallel.Prim' depends on — i.e., when compiling these modules, the interface won't exist yet.
This is fine, as these modules do not use the vectoriser, but we need to ensure that GHC doesn't barf when
the interface is missing. Instead of an error message, we just put an empty 'GlobalRdrEnv' into the
'DsM' state.
%************************************************************************
%* *
......@@ -355,18 +400,11 @@ dsLookupGlobalId :: Name -> DsM Id
dsLookupGlobalId name
= tyThingId <$> dsLookupGlobal name
-- Looking up a global DPH 'Id' is like 'dsLookupGlobalId', but the package, in which the looked
-- up name is located, varies with the active DPH backend.
-- |Get a name from "Data.Array.Parallel" for the desugarer, from the 'ds_parr_bi' component of the
-- global desugerar environment.
--
dsLookupDPHId :: (PackageId -> Name) -> DsM Id
dsLookupDPHId nameInPkg
= do { dflags <- getDOpts
; case dphPackageMaybe dflags of
Just pkg -> tyThingId <$> dsLookupGlobal (nameInPkg pkg)
Nothing -> failWithDs $ ptext err
}
where
err = sLit "To use -XParallelArrays select a DPH backend with -fdph-par or -fdph-seq"
dsDPHBuiltin :: (PArrBuiltin -> a) -> DsM a
dsDPHBuiltin sel = (sel . ds_parr_bi) <$> getGblEnv
dsLookupTyCon :: Name -> DsM TyCon
dsLookupTyCon name
......@@ -378,28 +416,61 @@ dsLookupDataCon name
\end{code}
\begin{code}
-- Complain if 'Data.Array.Parallel.Prim' wasn't loaded (and we are about to use it).
--
-- See "Note [Loading Data.Array.Parallel.Prim]".
-- Look up a name exported by 'Data.Array.Parallel.Prim' or 'Data.Array.Parallel.Prim'.
--
assertDAPPLoaded :: DsM ()
assertDAPPLoaded
= do { env <- ds_dph_env <$> getGblEnv
; when (null $ occEnvElts env) $
panic "'Data.Array.Parallel.Prim' not available; maybe missing dependency in DPH package"
}
-- Look up a name exported by 'Data.Array.Parallel.Prim'.
--
lookupDAPPRdrEnv :: OccName -> DsM Name
lookupDAPPRdrEnv occ
dsLookupDPHRdrEnv :: OccName -> DsM Name
dsLookupDPHRdrEnv occ
= do { env <- ds_dph_env <$> getGblEnv
; let gres = lookupGlobalRdrEnv env occ
; case gres of
[] -> pprPanic "Name not found in 'Data.Array.Parallel.Prim':" (ppr occ)
[] -> pprPanic nameNotFound (ppr occ)
[gre] -> return $ gre_name gre
_ -> pprPanic "Multiple definitions in 'Data.Array.Parallel.Prim':" (ppr occ)
_ -> pprPanic multipleNames (ppr occ)
}
where
nameNotFound = "Name not found in 'Data.Array.Parallel' or 'Data.Array.Parallel.Prim':"
multipleNames = "Multiple definitions in 'Data.Array.Parallel' and 'Data.Array.Parallel.Prim':"
-- Populate 'ds_parr_bi' from 'ds_dph_env'.
--
dsInitPArrBuiltin :: DsM a -> DsM a
dsInitPArrBuiltin thing_inside
= do { lengthPVar <- externalVar (fsLit "lengthP")
; replicatePVar <- externalVar (fsLit "replicateP")
; singletonPVar <- externalVar (fsLit "singletonP")
; mapPVar <- externalVar (fsLit "mapP")
; filterPVar <- externalVar (fsLit "filterP")
; zipPVar <- externalVar (fsLit "zipP")
; crossMapPVar <- externalVar (fsLit "crossMapP")
; indexPVar <- externalVar (fsLit "!:")
; emptyPVar <- externalVar (fsLit "emptyP")
; appPVar <- externalVar (fsLit "+:+")
-- ; enumFromToPVar <- externalVar (fsLit "enumFromToP")
-- ; enumFromThenToPVar <- externalVar (fsLit "enumFromThenToP")
; enumFromToPVar <- return arithErr
; enumFromThenToPVar <- return arithErr
; updGblEnv (\env -> env {ds_parr_bi = PArrBuiltin
{ lengthPVar = lengthPVar
, replicatePVar = replicatePVar
, singletonPVar = singletonPVar
, mapPVar = mapPVar
, filterPVar = filterPVar
, zipPVar = zipPVar
, crossMapPVar = crossMapPVar
, indexPVar = indexPVar
, emptyPVar = emptyPVar
, appPVar = appPVar
, enumFromToPVar = enumFromToPVar
, enumFromThenToPVar = enumFromThenToPVar
} })
thing_inside
}
where
externalVar :: FastString -> DsM Var
externalVar fs = dsLookupDPHRdrEnv (mkVarOccFS fs) >>= dsLookupGlobalId
arithErr = panic "Arithmetic sequences have to wait until we support type classes"
\end{code}
\begin{code}
......
......@@ -389,7 +389,7 @@ mkCoAlgCaseMatchResult var ty match_alts
isPArrFakeAlts [] = panic "DsUtils: unexpectedly found an empty list of PArr fake alternatives"
--
mk_parrCase fail = do
lengthP <- dsLookupDPHId lengthPName
lengthP <- dsDPHBuiltin lengthPVar
alt <- unboxAlt
return (mkWildCase (len lengthP) intTy ty [alt])
where
......@@ -401,7 +401,7 @@ mkCoAlgCaseMatchResult var ty match_alts
--
unboxAlt = do
l <- newSysLocalDs intPrimTy
indexP <- dsLookupDPHId indexPName
indexP <- dsDPHBuiltin indexPVar
alts <- mapM (mkAlt indexP) sorted_alts
return (DataAlt intDataCon, [l], mkWildCase (Var l) intPrimTy ty (dft : alts))
where
......
......@@ -727,8 +727,8 @@ mkPackageState dflags pkgs0 preload0 this_package = do
flags = reverse (packageFlags dflags) ++ dphPackage
-- expose the appropriate DPH backend library
dphPackage = case dphBackend dflags of
DPHPar -> [ExposePackage "dph-prim-par", ExposePackage "dph-par"]
DPHSeq -> [ExposePackage "dph-prim-seq", ExposePackage "dph-seq"]
DPHPar -> [ExposePackage "dph-par"]
DPHSeq -> [ExposePackage "dph-seq"]
DPHThis -> []
DPHNone -> []
......
......@@ -156,7 +156,6 @@ basicKnownKeyNames :: [Name]
basicKnownKeyNames
= genericTyConNames
++ typeableClassNames
++ dphKnownKeyNames dphSeqPackageId ++ dphKnownKeyNames dphParPackageId
++ [ -- Type constructors (synonyms especially)
ioTyConName, ioDataConName,
runMainIOName,
......@@ -306,20 +305,6 @@ genericTyConNames = [
d1TyConName, c1TyConName, s1TyConName, noSelTyConName,
repTyConName, rep1TyConName
]
-- Know names from the DPH package which vary depending on the selected DPH backend.
--
dphKnownKeyNames :: PackageId -> [Name]
dphKnownKeyNames dphPkg
= map ($ dphPkg)
[
-- Parallel array operations
nullPName, lengthPName, replicatePName, singletonPName, mapPName,
filterPName, zipPName, crossMapPName, indexPName,
toPName, emptyPName, appPName,
enumFromToPName, enumFromThenToPName
]
\end{code}
......@@ -399,12 +384,6 @@ rANDOM = mkBaseModule (fsLit "System.Random")
gHC_EXTS = mkBaseModule (fsLit "GHC.Exts")
cONTROL_EXCEPTION_BASE = mkBaseModule (fsLit "Control.Exception.Base")
dATA_ARRAY_PARALLEL_PRIM :: PackageId -> Module
dATA_ARRAY_PARALLEL_PRIM pkg = mkModule pkg (mkModuleNameFS (fsLit "Data.Array.Parallel.Prim"))
gHC_PARR :: PackageId -> Module
gHC_PARR pkg = mkModule pkg (mkModuleNameFS (fsLit "Data.Array.Parallel"))
gHC_PARR' :: Module
gHC_PARR' = mkBaseModule (fsLit "GHC.PArr")
......@@ -423,6 +402,10 @@ pRELUDE_NAME, mAIN_NAME :: ModuleName
pRELUDE_NAME = mkModuleNameFS (fsLit "Prelude")
mAIN_NAME = mkModuleNameFS (fsLit "Main")
dATA_ARRAY_PARALLEL_NAME, dATA_ARRAY_PARALLEL_PRIM_NAME :: ModuleName
dATA_ARRAY_PARALLEL_NAME = mkModuleNameFS (fsLit "Data.Array.Parallel")
dATA_ARRAY_PARALLEL_PRIM_NAME = mkModuleNameFS (fsLit "Data.Array.Parallel.Prim")
mkPrimModule :: FastString -> Module
mkPrimModule m = mkModule primPackageId (mkModuleNameFS m)
......@@ -964,26 +947,6 @@ datatypeClassName = clsQual gHC_GENERICS (fsLit "Datatype") datatypeClassKey
constructorClassName = clsQual gHC_GENERICS (fsLit "Constructor") constructorClassKey
selectorClassName = clsQual gHC_GENERICS (fsLit "Selector") selectorClassKey
-- parallel array types and functions
enumFromToPName, enumFromThenToPName, nullPName, lengthPName,
singletonPName, replicatePName, mapPName, filterPName,
zipPName, crossMapPName, indexPName, toPName,
emptyPName, appPName :: PackageId -> Name
enumFromToPName pkg = varQual (gHC_PARR pkg) (fsLit "enumFromToP") enumFromToPIdKey
enumFromThenToPName pkg = varQual (gHC_PARR pkg) (fsLit "enumFromThenToP") enumFromThenToPIdKey
nullPName pkg = varQual (gHC_PARR pkg) (fsLit "nullP") nullPIdKey
lengthPName pkg = varQual (gHC_PARR pkg) (fsLit "lengthP") lengthPIdKey
singletonPName pkg = varQual (gHC_PARR pkg) (fsLit "singletonP") singletonPIdKey
replicatePName pkg = varQual (gHC_PARR pkg) (fsLit "replicateP") replicatePIdKey
mapPName pkg = varQual (gHC_PARR pkg) (fsLit "mapP") mapPIdKey
filterPName pkg = varQual (gHC_PARR pkg) (fsLit "filterP") filterPIdKey
zipPName pkg = varQual (gHC_PARR pkg) (fsLit "zipP") zipPIdKey
crossMapPName pkg = varQual (gHC_PARR pkg) (fsLit "crossMapP") crossMapPIdKey
indexPName pkg = varQual (gHC_PARR pkg) (fsLit "!:") indexPIdKey
toPName pkg = varQual (gHC_PARR pkg) (fsLit "toP") toPIdKey
emptyPName pkg = varQual (gHC_PARR pkg) (fsLit "emptyP") emptyPIdKey
appPName pkg = varQual (gHC_PARR pkg) (fsLit "+:+") appPIdKey
-- IO things
ioTyConName, ioDataConName, thenIOName, bindIOName, returnIOName,
failIOName :: Name
......@@ -1539,25 +1502,6 @@ dollarIdKey = mkPreludeMiscIdUnique 123
coercionTokenIdKey :: Unique
coercionTokenIdKey = mkPreludeMiscIdUnique 124
-- Parallel array functions
singletonPIdKey, nullPIdKey, lengthPIdKey, replicatePIdKey, mapPIdKey,
filterPIdKey, zipPIdKey, crossMapPIdKey, indexPIdKey, toPIdKey,
enumFromToPIdKey, enumFromThenToPIdKey, emptyPIdKey, appPIdKey :: Unique
singletonPIdKey = mkPreludeMiscIdUnique 130
nullPIdKey = mkPreludeMiscIdUnique 131
lengthPIdKey = mkPreludeMiscIdUnique 132
replicatePIdKey = mkPreludeMiscIdUnique 133
mapPIdKey = mkPreludeMiscIdUnique 134
filterPIdKey = mkPreludeMiscIdUnique 135
zipPIdKey = mkPreludeMiscIdUnique 136
crossMapPIdKey = mkPreludeMiscIdUnique 137
indexPIdKey = mkPreludeMiscIdUnique 138
toPIdKey = mkPreludeMiscIdUnique 139
enumFromToPIdKey = mkPreludeMiscIdUnique 140
enumFromThenToPIdKey = mkPreludeMiscIdUnique 141
emptyPIdKey = mkPreludeMiscIdUnique 142
appPIdKey = mkPreludeMiscIdUnique 143
-- dotnet interop
unmarshalObjectIdKey, marshalObjectIdKey, marshalStringIdKey,
unmarshalStringIdKey, checkDotnetResNameIdKey :: Unique
......
......@@ -39,6 +39,7 @@ import TcHsType
import TcPat
import TcMType
import TcType
import DsMonad hiding (Splice)
import Id
import DataCon
import Name
......@@ -52,7 +53,6 @@ import TysWiredIn
import TysPrim( intPrimTy )
import PrimOp( tagToEnumKey )
import PrelNames
import Module
import DynFlags
import SrcLoc
import Util
......@@ -749,8 +749,9 @@ tcExpr (PArrSeq _ seq@(FromTo expr1 expr2)) res_ty
= do { (coi, elt_ty) <- matchExpectedPArrTy res_ty
; expr1' <- tcPolyExpr expr1 elt_ty
; expr2' <- tcPolyExpr expr2 elt_ty
; enumFromToP <- initDsTc $ dsDPHBuiltin enumFromToPVar
; enum_from_to <- newMethodFromName (PArrSeqOrigin seq)
(enumFromToPName basePackageId) elt_ty -- !!!FIXME: chak
(idName enumFromToP) elt_ty
; return $ mkHsWrapCo coi
(PArrSeq enum_from_to (FromTo expr1' expr2')) }
......@@ -759,13 +760,14 @@ tcExpr (PArrSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
; expr1' <- tcPolyExpr expr1 elt_ty
; expr2' <- tcPolyExpr expr2 elt_ty
; expr3' <- tcPolyExpr expr3 elt_ty
; enumFromThenToP <- initDsTc $ dsDPHBuiltin enumFromThenToPVar
; eft <- newMethodFromName (PArrSeqOrigin seq)
(enumFromThenToPName basePackageId) elt_ty -- !!!FIXME: chak
(idName enumFromThenToP) elt_ty -- !!!FIXME: chak
; return $ mkHsWrapCo coi
(PArrSeq eft (FromThenTo expr1' expr2' expr3')) }
tcExpr (PArrSeq _ _) _
= panic "TcExpr.tcMonoExpr: Infinite parallel array!"
= panic "TcExpr.tcExpr: Infinite parallel array!"
-- the parser shouldn't have generated it and the renamer shouldn't have
-- let it through
\end{code}
......
......@@ -30,9 +30,7 @@ import Data.Array
--
initBuiltins :: DsM Builtins
initBuiltins
= do { assertDAPPLoaded -- complain if 'Data.Array.Parallel.Prim' is not available
-- 'PArray': desugared array type
= 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)
......@@ -206,19 +204,19 @@ initBuiltinTyCons bi
-- Lookup a variable given its name and the module that contains it.
--
externalVar :: FastString -> DsM Var
externalVar fs = lookupDAPPRdrEnv (mkVarOccFS fs) >>= dsLookupGlobalId
externalVar fs = dsLookupDPHRdrEnv (mkVarOccFS fs) >>= dsLookupGlobalId
-- Like `externalVar` but wrap the `Var` in a `CoreExpr`.
--
externalFun :: FastString -> DsM CoreExpr
externalFun fs = liftM Var $ externalVar fs
externalFun fs = Var <$> externalVar fs
-- Lookup a 'TyCon' in 'Data.Array.Parallel.Prim', given its name.
--
externalTyCon :: FastString -> DsM TyCon
externalTyCon fs = lookupDAPPRdrEnv (mkTcOccFS fs) >>= dsLookupTyCon
externalTyCon fs = dsLookupDPHRdrEnv (mkTcOccFS fs) >>= dsLookupTyCon
-- Lookup some `Type` given its name and the module that contains it.
-- Lookup some `Type` in 'Data.Array.Parallel.Prim', given its name.
--
externalType :: FastString -> DsM Type
externalType fs
......@@ -229,7 +227,7 @@ externalType fs
--
externalClass :: FastString -> DsM Class
externalClass fs
= do { tycon <- lookupDAPPRdrEnv (mkClsOccFS fs) >>= dsLookupTyCon
= do { tycon <- dsLookupDPHRdrEnv (mkClsOccFS fs) >>= dsLookupTyCon
; case tyConClass_maybe tycon of
Nothing -> pprPanic "Vectorise.Builtins.Initialise" $
ptext (sLit "Data.Array.Parallel.Prim.") <>
......
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