Commit 9f695847 authored by rl@cse.unsw.edu.au's avatar rl@cse.unsw.edu.au
Browse files

Add code for looking up PA methods of primitive TyCons

parent 8e3058a5
......@@ -279,6 +279,7 @@ gLA_EXTS = mkBaseModule FSLIT("GHC.Exts")
nDP_PARRAY = mkNDPModule FSLIT("Data.Array.Parallel.Lifted.PArray")
nDP_REPR = mkNDPModule FSLIT("Data.Array.Parallel.Lifted.Repr")
nDP_CLOSURE = mkNDPModule FSLIT("Data.Array.Parallel.Lifted.Closure")
nDP_PRIM = mkNDPModule FSLIT("Data.Array.Parallel.Lifted.Prim")
nDP_INSTANCES = mkNDPModule FSLIT("Data.Array.Parallel.Lifted.Instances")
nDP_UARR = mkNDPModule FSLIT("Data.Array.Parallel.Unlifted.Flat.UArr")
......
module VectBuiltIn (
Builtins(..), sumTyCon, prodTyCon,
initBuiltins, initBuiltinTyCons, initBuiltinPAs, initBuiltinPRs
initBuiltins, initBuiltinTyCons, initBuiltinPAs, initBuiltinPRs,
primMethod
) where
#include "HsVersions.h"
......@@ -13,11 +15,12 @@ import DataCon ( DataCon )
import TyCon ( TyCon, tyConName, tyConDataCons )
import Var ( Var )
import Id ( mkSysLocal )
import Name ( Name )
import OccName ( mkVarOccFS, mkOccNameFS, tcName )
import Name ( Name, getOccString )
import NameEnv
import OccName
import TypeRep ( funTyCon )
import TysPrim ( intPrimTy )
import TysPrim
import TysWiredIn ( unitTyCon, tupleTyCon, intTyConName )
import PrelNames
import BasicTypes ( Boxity(..) )
......@@ -191,3 +194,15 @@ lookupExternalTyCon mod fs
unitTyConName = tyConName unitTyCon
primMethod :: TyCon -> String -> DsM (Maybe Var)
primMethod tycon method
| Just suffix <- lookupNameEnv prim_ty_cons (tyConName tycon)
= liftM Just
$ dsLookupGlobalId =<< lookupOrig nDP_PRIM (mkVarOcc $ method ++ suffix)
| otherwise = return Nothing
prim_ty_cons = mkNameEnv [mk_prim intPrimTyCon]
where
mk_prim tycon = (tyConName tycon, '_' : getOccString tycon)
......@@ -24,6 +24,7 @@ module VectMonad (
lookupDataCon, defDataCon,
lookupTyConPA, defTyConPA, defTyConPAs,
lookupTyConPR,
lookupPrimMethod,
lookupTyVarPA, defLocalTyVar, defLocalTyVarWithPA, localTyVars,
{-lookupInst,-} lookupFamInst
......@@ -354,6 +355,9 @@ defDataCon :: DataCon -> DataCon -> VM ()
defDataCon dc dc' = updGEnv $ \env ->
env { global_datacons = extendNameEnv (global_datacons env) (dataConName dc) dc' }
lookupPrimMethod :: TyCon -> String -> VM (Maybe Var)
lookupPrimMethod tycon method = liftDs $ primMethod tycon method
lookupTyConPA :: TyCon -> VM (Maybe Var)
lookupTyConPA tc = readGEnv $ \env -> lookupNameEnv (global_pa_funs env) (tyConName tc)
......
......@@ -221,27 +221,45 @@ paDFunApply dfun tys
dicts <- mapM paDictOfType tys
return $ mkApps (mkTyApps dfun tys) dicts
paMethod :: (Builtins -> Var) -> Type -> VM CoreExpr
paMethod method ty
type PAMethod = (Builtins -> Var, String)
pa_length = (lengthPAVar, "lengthPA")
pa_replicate = (replicatePAVar, "replicatePA")
pa_empty = (emptyPAVar, "emptyPA")
paMethod :: PAMethod -> Type -> VM CoreExpr
paMethod (method, name) ty
| Just (tycon, []) <- splitTyConApp_maybe ty
, isPrimTyCon tycon
= do
fn <- traceMaybeV "paMethod" (ppr tycon <+> text name)
$ lookupPrimMethod tycon name
return (Var fn)
paMethod (method, name) ty
= do
fn <- builtin method
dict <- paDictOfType ty
return $ mkApps (Var fn) [Type ty, dict]
mkPR :: Type -> VM CoreExpr
mkPR = paMethod mkPRVar
mkPR ty
= do
fn <- builtin mkPRVar
dict <- paDictOfType ty
return $ mkApps (Var fn) [Type ty, dict]
lengthPA :: CoreExpr -> VM CoreExpr
lengthPA x = liftM (`App` x) (paMethod lengthPAVar ty)
lengthPA x = liftM (`App` x) (paMethod pa_length ty)
where
ty = splitPArrayTy (exprType x)
replicatePA :: CoreExpr -> CoreExpr -> VM CoreExpr
replicatePA len x = liftM (`mkApps` [len,x])
(paMethod replicatePAVar (exprType x))
(paMethod pa_replicate (exprType x))
emptyPA :: Type -> VM CoreExpr
emptyPA = paMethod emptyPAVar
emptyPA = paMethod pa_empty
liftPA :: CoreExpr -> VM CoreExpr
liftPA x
......
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