-{-# 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 VectMonad (
Scope(..),
VM,
- noV, tryV, maybeV, traceMaybeV, orElseV, fixV, localV, closedV, initV,
+ noV, traceNoV, tryV, maybeV, traceMaybeV, orElseV, fixV, localV, closedV,
+ initV, cantVectorise, maybeCantVectorise, maybeCantVectoriseM,
liftDs,
cloneName, cloneId, cloneVar,
newExportedVar, newLocalVar, newDummyVar, newTyVar,
- Builtins(..), sumTyCon, prodTyCon, combinePAVar,
+ Builtins(..), sumTyCon, prodTyCon,
+ combinePAVar,
builtin, builtins,
GlobalEnv(..),
import VectBuiltIn
-import HscTypes
+import HscTypes hiding ( MonadThings(..) )
+import Module ( PackageId )
import CoreSyn
import TyCon
import DataCon
import Type
-import Class
import Var
import VarEnv
import Id
-import OccName
import Name
import NameEnv
-import TysPrim ( intPrimTy )
-import Module
-import IfaceEnv
-import IOEnv ( ioToIOEnv )
+import IOEnv ( liftIO )
import DsMonad
-import PrelNames
import InstEnv
import FamInstEnv
-import Panic
import Outputable
import FastString
import SrcLoc ( noSrcSpan )
-import Control.Monad ( liftM, zipWithM )
+import Control.Monad
data Scope a b = Global a | Local b
setBoxedTyConsEnv ps genv
= genv { global_boxed_tycons = mkNameEnv ps }
+emptyLocalEnv :: LocalEnv
emptyLocalEnv = LocalEnv {
local_vars = emptyVarEnv
, local_tyvars = []
, local_tyvar_pa = emptyVarEnv
- , local_bind_name = FSLIT("fn")
+ , local_bind_name = fsLit "fn"
}
-- FIXME
newtype VM a = VM { runVM :: Builtins -> GlobalEnv -> LocalEnv -> DsM (VResult a) }
instance Monad VM where
- return x = VM $ \bi genv lenv -> return (Yes genv lenv x)
+ return x = VM $ \_ genv lenv -> return (Yes genv lenv x)
VM p >>= f = VM $ \bi genv lenv -> do
r <- p bi genv lenv
case r of
Yes genv' lenv' x -> runVM (f x) bi genv' lenv'
No -> return No
+
+cantVectorise :: String -> SDoc -> a
+cantVectorise s d = pgmError
+ . showSDocDump
+ $ vcat [text "*** Vectorisation error ***",
+ nest 4 $ sep [text s, nest 4 d]]
+
+maybeCantVectorise :: String -> SDoc -> Maybe a -> a
+maybeCantVectorise s d Nothing = cantVectorise s d
+maybeCantVectorise _ _ (Just x) = x
+
+maybeCantVectoriseM :: Monad m => String -> SDoc -> m (Maybe a) -> m a
+maybeCantVectoriseM s d p
+ = do
+ r <- p
+ case r of
+ Just x -> return x
+ Nothing -> cantVectorise s d
+
noV :: VM a
noV = VM $ \_ _ _ -> return No
fixV :: (a -> VM a) -> VM a
fixV f = VM (\bi genv lenv -> fixDs $ \r -> runVM (f (unYes r)) bi genv lenv )
where
+ -- NOTE: It is essential that we are lazy in r above so do not replace
+ -- calls to this function by an explicit case.
unYes (Yes _ _ x) = x
+ unYes No = panic "VectMonad.fixV: no result"
localV :: VM a -> VM a
localV p = do
return x
liftDs :: DsM a -> VM a
-liftDs p = VM $ \bi genv lenv -> do { x <- p; return (Yes genv lenv x) }
+liftDs p = VM $ \_ genv lenv -> do { x <- p; return (Yes genv lenv x) }
+
+liftBuiltinDs :: (Builtins -> DsM a) -> VM a
+liftBuiltinDs p = VM $ \bi genv lenv -> do { x <- p bi; return (Yes genv lenv x)}
builtin :: (Builtins -> a) -> VM a
builtin f = VM $ \bi genv lenv -> return (Yes genv lenv (f bi))
builtins f = VM $ \bi genv lenv -> return (Yes genv lenv (`f` bi))
readGEnv :: (GlobalEnv -> a) -> VM a
-readGEnv f = VM $ \bi genv lenv -> return (Yes genv lenv (f genv))
+readGEnv f = VM $ \_ genv lenv -> return (Yes genv lenv (f genv))
setGEnv :: GlobalEnv -> VM ()
setGEnv genv = VM $ \_ _ lenv -> return (Yes genv lenv ())
updGEnv f = VM $ \_ genv lenv -> return (Yes (f genv) lenv ())
readLEnv :: (LocalEnv -> a) -> VM a
-readLEnv f = VM $ \bi genv lenv -> return (Yes genv lenv (f lenv))
+readLEnv f = VM $ \_ genv lenv -> return (Yes genv lenv (f lenv))
setLEnv :: LocalEnv -> VM ()
setLEnv lenv = VM $ \_ genv _ -> return (Yes genv lenv ())
updLEnv :: (LocalEnv -> LocalEnv) -> VM ()
updLEnv f = VM $ \_ genv lenv -> return (Yes genv (f lenv) ())
+{-
getInstEnv :: VM (InstEnv, InstEnv)
getInstEnv = readGEnv global_inst_env
+-}
getFamInstEnv :: VM FamInstEnvs
getFamInstEnv = readGEnv global_fam_inst_env
return $ mkSysLocal fs u ty
newDummyVar :: Type -> VM Var
-newDummyVar = newLocalVar FSLIT("ds")
+newDummyVar = newLocalVar (fsLit "vv")
newTyVar :: FastString -> Kind -> VM Var
newTyVar fs k
case r of
Just e -> return (Local e)
Nothing -> liftM Global
- $ traceMaybeV "lookupVar" (ppr v)
- (readGEnv $ \env -> lookupVarEnv (global_vars env) v)
+ . maybeCantVectoriseM "Variable not vectorised:" (ppr v)
+ . readGEnv $ \env -> lookupVarEnv (global_vars env) v
lookupTyCon :: TyCon -> VM (Maybe TyCon)
lookupTyCon tc
env { global_datacons = extendNameEnv (global_datacons env) (dataConName dc) dc' }
lookupPrimPArray :: TyCon -> VM (Maybe TyCon)
-lookupPrimPArray = liftDs . primPArray
+lookupPrimPArray = liftBuiltinDs . primPArray
lookupPrimMethod :: TyCon -> String -> VM (Maybe Var)
-lookupPrimMethod tycon = liftDs . primMethod tycon
+lookupPrimMethod tycon = liftBuiltinDs . primMethod tycon
lookupTyConPA :: TyCon -> VM (Maybe Var)
lookupTyConPA tc = readGEnv $ \env -> lookupNameEnv (global_pa_funs env) (tyConName tc)
(ppr $ mkTyConApp tycon tys)
}
-initV :: HscEnv -> ModGuts -> VectInfo -> VM a -> IO (Maybe (VectInfo, a))
-initV hsc_env guts info p
+initV :: PackageId -> HscEnv -> ModGuts -> VectInfo -> VM a -> IO (Maybe (VectInfo, a))
+initV pkg hsc_env guts info p
= do
- Just r <- initDs hsc_env (mg_module guts)
+ -- XXX: ignores error messages and warnings, check that this is
+ -- indeed ok (the use of "Just r" suggests so)
+ (_,Just r) <- initDs hsc_env (mg_module guts)
(mg_rdr_env guts)
(mg_types guts)
go
go =
do
- builtins <- initBuiltins
+ builtins <- initBuiltins pkg
builtin_vars <- initBuiltinVars builtins
builtin_tycons <- initBuiltinTyCons builtins
let builtin_datacons = initBuiltinDataCons builtins
builtin_prs <- initBuiltinPRs builtins
builtin_boxed <- initBuiltinBoxedTyCons builtins
- eps <- ioToIOEnv $ hscEPS hsc_env
+ eps <- liftIO $ hscEPS hsc_env
let famInstEnvs = (eps_fam_inst_env eps, mg_fam_inst_env guts)
instEnvs = (eps_inst_env eps, mg_inst_env guts)