-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
module VectUtils (
collectAnnTypeBinders, collectAnnTypeArgs, isAnnTypeArg,
collectAnnValBinders,
mkClosureApp
) where
-#include "HsVersions.h"
-
import VectCore
import VectMonad
-import DsUtils
+import MkCore
import CoreSyn
import CoreUtils
import Coercion
import TyCon
import DataCon
import Var
-import Id ( mkWildId )
import MkId ( unwrapFamInstScrut )
-import Name ( Name )
-import PrelNames
import TysWiredIn
-import TysPrim ( intPrimTy )
import BasicTypes ( Boxity(..) )
import Literal ( Literal, mkMachInt )
import Outputable
import FastString
-import Data.List ( zipWith4 )
-import Control.Monad ( liftM, liftM2, zipWithM_ )
+import Control.Monad
+
collectAnnTypeArgs :: AnnExpr b ann -> (AnnExpr b ann, [Type])
collectAnnTypeArgs expr = go expr []
go bs e = (reverse bs, e)
isAnnTypeArg :: AnnExpr b ann -> Bool
-isAnnTypeArg (_, AnnType t) = True
+isAnnTypeArg (_, AnnType _) = True
isAnnTypeArg _ = False
dataConTagZ :: DataCon -> Int
where
mk tc ty1 ty2 = mkTyConApp tc [ty1,ty2]
+{-
mkBuiltinTyConApps1 :: (Builtins -> TyCon) -> Type -> [Type] -> VM Type
-mkBuiltinTyConApps1 get_tc dft [] = return dft
-mkBuiltinTyConApps1 get_tc dft tys
+mkBuiltinTyConApps1 _ dft [] = return dft
+mkBuiltinTyConApps1 get_tc _ tys
= do
tc <- builtin get_tc
case tys of
mkClosureType :: Type -> Type -> VM Type
mkClosureType arg_ty res_ty = mkBuiltinTyConApp closureTyCon [arg_ty, res_ty]
+-}
mkClosureTypes :: [Type] -> Type -> VM Type
mkClosureTypes = mkBuiltinTyConApps closureTyCon
mkPArrayType ty
| Just tycon <- splitPrimTyCon ty
= do
- arr <- traceMaybeV "mkPArrayType" (ppr tycon)
- $ lookupPrimPArray tycon
- return $ mkTyConApp arr []
+ r <- lookupPrimPArray tycon
+ case r of
+ Just arr -> return $ mkTyConApp arr []
+ Nothing -> cantVectorise "Primitive tycon not vectorised" (ppr tycon)
mkPArrayType ty = mkBuiltinTyConApp parrayTyCon [ty]
mkBuiltinCo :: (Builtins -> TyCon) -> VM Coercion
prDFunOfTyCon :: TyCon -> VM CoreExpr
prDFunOfTyCon tycon
- = liftM Var (traceMaybeV "prDictOfTyCon" (ppr tycon) (lookupTyConPR tycon))
+ = liftM Var
+ . maybeCantVectoriseM "No PR dictionary for tycon" (ppr tycon)
+ $ lookupTyConPR tycon
paDictArgType :: TyVar -> VM (Maybe Type)
paDictArgType tv = go (TyVarTy tv) (tyVarKind tv)
go ty k | Just k' <- kindView k = go ty k'
go ty (FunTy k1 k2)
= do
- tv <- newTyVar FSLIT("a") k1
+ tv <- newTyVar (fsLit "a") k1
mty1 <- go (TyVarTy tv) k1
case mty1 of
Just ty1 -> do
| isLiftedTypeKind k
= liftM Just (mkPADictType ty)
- go ty k = return Nothing
+ go _ _ = return Nothing
paDictOfType :: Type -> VM CoreExpr
paDictOfType ty = paDictOfTyApp ty_fn ty_args
paDFunApply dfun ty_args
paDictOfTyApp (TyConApp tc _) ty_args
= do
- dfun <- traceMaybeV "paDictOfTyApp" (ppr tc) (lookupTyConPA tc)
+ dfun <- maybeCantVectoriseM "No PA dictionary for tycon" (ppr tc)
+ $ lookupTyConPA tc
paDFunApply (Var dfun) ty_args
-paDictOfTyApp ty ty_args = pprPanic "paDictOfTyApp" (ppr ty)
+paDictOfTyApp ty _
+ = cantVectorise "Can't construct PA dictionary for type" (ppr ty)
paDFunType :: TyCon -> VM Type
paDFunType tc
type PAMethod = (Builtins -> Var, String)
+pa_length, pa_replicate, pa_empty, pa_pack :: (Builtins -> Var, String)
pa_length = (lengthPAVar, "lengthPA")
pa_replicate = (replicatePAVar, "replicatePA")
pa_empty = (emptyPAVar, "emptyPA")
pa_pack = (packPAVar, "packPA")
paMethod :: PAMethod -> Type -> VM CoreExpr
-paMethod (method, name) ty
+paMethod (_method, name) ty
| Just tycon <- splitPrimTyCon ty
- = do
- fn <- traceMaybeV "paMethod" (ppr tycon <+> text name)
- $ lookupPrimMethod tycon name
- return (Var fn)
+ = liftM Var
+ . maybeCantVectoriseM "No PA method" (text name <+> text "for" <+> ppr tycon)
+ $ lookupPrimMethod tycon name
-paMethod (method, name) ty
+paMethod (method, _name) ty
= do
fn <- builtin method
dict <- paDictOfType ty
emptyPA = paMethod pa_empty
packPA :: Type -> CoreExpr -> CoreExpr -> CoreExpr -> VM CoreExpr
-packPA ty xs len sel = liftM (`mkApps` [len, sel])
+packPA ty xs len sel = liftM (`mkApps` [xs, len, sel])
(paMethod pa_pack ty)
combinePA :: Type -> CoreExpr -> CoreExpr -> CoreExpr -> [CoreExpr]
mk_dict_var tv = do
r <- paDictArgType tv
case r of
- Just ty -> liftM Just (newLocalVar FSLIT("dPA") ty)
+ Just ty -> liftM Just (newLocalVar (fsLit "dPA") ty)
Nothing -> return Nothing
mk_lams mdicts = mkLams (tvs ++ [dict | Just dict <- mdicts])
setGEnv $ env { global_bindings = [] }
return $ global_bindings env
+{-
+boxExpr :: Type -> VExpr -> VM VExpr
+boxExpr ty (vexpr, lexpr)
+ | Just (tycon, []) <- splitTyConApp_maybe ty
+ , isUnLiftedTyCon tycon
+ = do
+ r <- lookupBoxedTyCon tycon
+ case r of
+ Just tycon' -> let [dc] = tyConDataCons tycon'
+ in
+ return (mkConApp dc [vexpr], lexpr)
+ Nothing -> return (vexpr, lexpr)
+-}
+
mkClosure :: Type -> Type -> Type -> VExpr -> VExpr -> VM VExpr
mkClosure arg_ty res_ty env_ty (vfn,lfn) (venv,lenv)
= do
Var lapply `mkTyApps` [arg_ty, res_ty] `mkApps` [lclo, larg])
buildClosures :: [TyVar] -> [VVar] -> [Type] -> Type -> VM VExpr -> VM VExpr
-buildClosures tvs vars [] res_ty mk_body
+buildClosures _ _ [] _ mk_body
= mk_body
buildClosures tvs vars [arg_ty] res_ty mk_body
= buildClosure tvs vars arg_ty res_ty mk_body
buildClosures tvs vars (arg_ty : arg_tys) res_ty mk_body
= do
res_ty' <- mkClosureTypes arg_tys res_ty
- arg <- newLocalVVar FSLIT("x") arg_ty
+ arg <- newLocalVVar (fsLit "x") arg_ty
buildClosure tvs vars arg_ty res_ty'
. hoistPolyVExpr tvs
$ do
buildClosure tvs vars arg_ty res_ty mk_body
= do
(env_ty, env, bind) <- buildEnv vars
- env_bndr <- newLocalVVar FSLIT("env") env_ty
- arg_bndr <- newLocalVVar FSLIT("arg") arg_ty
+ env_bndr <- newLocalVVar (fsLit "env") env_ty
+ arg_bndr <- newLocalVVar (fsLit "arg") arg_ty
fn <- hoistPolyVExpr tvs
$ do
return (vbody', lbody'))
where
(vs,ls) = unzip vvs
- tys = map idType vs
+ tys = map varType vs
mkVectEnv :: [Type] -> [Var] -> (Type, CoreExpr, CoreExpr -> CoreExpr -> CoreExpr)
-mkVectEnv [] [] = (unitTy, Var unitDataConId, \env body -> body)
+mkVectEnv [] [] = (unitTy, Var unitDataConId, \_ body -> body)
mkVectEnv [ty] [v] = (ty, Var v, \env body -> Let (NonRec v env) body)
mkVectEnv tys vs = (ty, mkCoreTup (map Var vs),
- \env body -> Case env (mkWildId ty) (exprType body)
+ \env body -> mkWildCase env ty (exprType body)
[(DataAlt (tupleCon Boxed (length vs)), vs, body)])
where
ty = mkCoreTupTy tys
mkLiftEnv lc tys vs
= do
(env_tc, env_tyargs) <- parrayReprTyCon vty
+
+ bndrs <- if null vs then do
+ v <- newDummyVar unitTy
+ return [v]
+ else return vs
let [env_con] = tyConDataCons env_tc
env = Var (dataConWrapId env_con)
`mkTyApps` env_tyargs
- `mkVarApps` (lc : vs)
+ `mkApps` (Var lc : args)
bind env body = let scrut = unwrapFamInstScrut env_tc env_tyargs env
in
- return $ Case scrut (mkWildId (exprType scrut))
+ return $ mkWildCase scrut (exprType scrut)
(exprType body)
[(DataAlt env_con, lc : bndrs, body)]
return (env, bind)
where
vty = mkCoreTupTy tys
- bndrs | null vs = [mkWildId unitTy]
- | otherwise = vs
+ args | null vs = [Var unitDataConId]
+ | otherwise = map Var vs
projects / ghc-hetmet.git / blobdiff