projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Fix fwrite$UNIX2003 symbols when cross-compiling for Tiger
[ghc-hetmet.git]
/
compiler
/
vectorise
/
VectMonad.hs
diff --git
a/compiler/vectorise/VectMonad.hs
b/compiler/vectorise/VectMonad.hs
index
5435fbe
..
4ae6c17
100644
(file)
--- a/
compiler/vectorise/VectMonad.hs
+++ b/
compiler/vectorise/VectMonad.hs
@@
-1,20
+1,14
@@
-{-# OPTIONS_GHC -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/WorkingConventions#Warnings
--- for details
-
module VectMonad (
Scope(..),
VM,
noV, tryV, maybeV, traceMaybeV, orElseV, fixV, localV, closedV, initV,
liftDs,
module VectMonad (
Scope(..),
VM,
noV, tryV, maybeV, traceMaybeV, orElseV, fixV, localV, closedV, initV,
liftDs,
- cloneName, cloneId,
+ cloneName, cloneId, cloneVar,
newExportedVar, newLocalVar, newDummyVar, newTyVar,
newExportedVar, newLocalVar, newDummyVar, newTyVar,
- Builtins(..), sumTyCon, prodTyCon,
+ Builtins(..), sumTyCon, prodTyCon, uarrTy, intPrimArrayTy,
+ combinePAVar,
builtin, builtins,
GlobalEnv(..),
builtin, builtins,
GlobalEnv(..),
@@
-31,6
+25,7
@@
module VectMonad (
lookupDataCon, defDataCon,
lookupTyConPA, defTyConPA, defTyConPAs,
lookupTyConPR,
lookupDataCon, defDataCon,
lookupTyConPA, defTyConPA, defTyConPAs,
lookupTyConPR,
+ lookupBoxedTyCon,
lookupPrimMethod, lookupPrimPArray,
lookupTyVarPA, defLocalTyVar, defLocalTyVarWithPA, localTyVars,
lookupPrimMethod, lookupPrimPArray,
lookupTyVarPA, defLocalTyVar, defLocalTyVarWithPA, localTyVars,
@@
-46,30
+41,23
@@
import CoreSyn
import TyCon
import DataCon
import Type
import TyCon
import DataCon
import Type
-import Class
import Var
import VarEnv
import Id
import Var
import VarEnv
import Id
-import OccName
import Name
import NameEnv
import Name
import NameEnv
-import TysPrim ( intPrimTy )
-import Module
-import IfaceEnv
-import IOEnv ( ioToIOEnv )
+import IOEnv ( liftIO )
import DsMonad
import DsMonad
-import PrelNames
import InstEnv
import FamInstEnv
import InstEnv
import FamInstEnv
-import Panic
import Outputable
import FastString
import SrcLoc ( noSrcSpan )
import Outputable
import FastString
import SrcLoc ( noSrcSpan )
-import Control.Monad ( liftM, zipWithM )
+import Control.Monad
data Scope a b = Global a | Local b
data Scope a b = Global a | Local b
@@
-102,6
+90,9
@@
data GlobalEnv = GlobalEnv {
-- Mapping from TyCons to their PR dfuns
, global_pr_funs :: NameEnv Var
-- Mapping from TyCons to their PR dfuns
, global_pr_funs :: NameEnv Var
+ -- Mapping from unboxed TyCons to their boxed versions
+ , global_boxed_tycons :: NameEnv TyCon
+
-- External package inst-env & home-package inst-env for class
-- instances
--
-- External package inst-env & home-package inst-env for class
-- instances
--
@@
-141,12
+132,17
@@
initGlobalEnv info instEnvs famInstEnvs
, global_tycons = mapNameEnv snd $ vectInfoTyCon info
, global_datacons = mapNameEnv snd $ vectInfoDataCon info
, global_pa_funs = mapNameEnv snd $ vectInfoPADFun info
, global_tycons = mapNameEnv snd $ vectInfoTyCon info
, global_datacons = mapNameEnv snd $ vectInfoDataCon info
, global_pa_funs = mapNameEnv snd $ vectInfoPADFun info
- , global_pr_funs = emptyVarEnv
+ , global_pr_funs = emptyNameEnv
+ , global_boxed_tycons = emptyNameEnv
, global_inst_env = instEnvs
, global_fam_inst_env = famInstEnvs
, global_bindings = []
}
, global_inst_env = instEnvs
, global_fam_inst_env = famInstEnvs
, global_bindings = []
}
+extendImportedVarsEnv :: [(Var, Var)] -> GlobalEnv -> GlobalEnv
+extendImportedVarsEnv ps genv
+ = genv { global_vars = extendVarEnvList (global_vars genv) ps }
+
setFamInstEnv :: FamInstEnv -> GlobalEnv -> GlobalEnv
setFamInstEnv l_fam_inst genv
= genv { global_fam_inst_env = (g_fam_inst, l_fam_inst) }
setFamInstEnv :: FamInstEnv -> GlobalEnv -> GlobalEnv
setFamInstEnv l_fam_inst genv
= genv { global_fam_inst_env = (g_fam_inst, l_fam_inst) }
@@
-157,6
+153,10
@@
extendTyConsEnv :: [(Name, TyCon)] -> GlobalEnv -> GlobalEnv
extendTyConsEnv ps genv
= genv { global_tycons = extendNameEnvList (global_tycons genv) ps }
extendTyConsEnv ps genv
= genv { global_tycons = extendNameEnvList (global_tycons genv) ps }
+extendDataConsEnv :: [(Name, DataCon)] -> GlobalEnv -> GlobalEnv
+extendDataConsEnv ps genv
+ = genv { global_datacons = extendNameEnvList (global_datacons genv) ps }
+
extendPAFunsEnv :: [(Name, Var)] -> GlobalEnv -> GlobalEnv
extendPAFunsEnv ps genv
= genv { global_pa_funs = extendNameEnvList (global_pa_funs genv) ps }
extendPAFunsEnv :: [(Name, Var)] -> GlobalEnv -> GlobalEnv
extendPAFunsEnv ps genv
= genv { global_pa_funs = extendNameEnvList (global_pa_funs genv) ps }
@@
-165,11
+165,16
@@
setPRFunsEnv :: [(Name, Var)] -> GlobalEnv -> GlobalEnv
setPRFunsEnv ps genv
= genv { global_pr_funs = mkNameEnv ps }
setPRFunsEnv ps genv
= genv { global_pr_funs = mkNameEnv ps }
+setBoxedTyConsEnv :: [(Name, TyCon)] -> GlobalEnv -> GlobalEnv
+setBoxedTyConsEnv ps genv
+ = genv { global_boxed_tycons = mkNameEnv ps }
+
+emptyLocalEnv :: LocalEnv
emptyLocalEnv = LocalEnv {
local_vars = emptyVarEnv
, local_tyvars = []
, local_tyvar_pa = emptyVarEnv
emptyLocalEnv = LocalEnv {
local_vars = emptyVarEnv
, local_tyvars = []
, local_tyvar_pa = emptyVarEnv
- , local_bind_name = FSLIT("fn")
+ , local_bind_name = fsLit "fn"
}
-- FIXME
}
-- FIXME
@@
-192,7
+197,7
@@
data VResult a = Yes GlobalEnv LocalEnv a | No
newtype VM a = VM { runVM :: Builtins -> GlobalEnv -> LocalEnv -> DsM (VResult a) }
instance Monad VM where
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
VM p >>= f = VM $ \bi genv lenv -> do
r <- p bi genv lenv
case r of
@@
-225,7
+230,10
@@
orElseV p q = maybe q return =<< tryV p
fixV :: (a -> VM a) -> VM a
fixV f = VM (\bi genv lenv -> fixDs $ \r -> runVM (f (unYes r)) bi genv lenv )
where
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 (Yes _ _ x) = x
+ unYes No = panic "VectMonad.fixV: no result"
localV :: VM a -> VM a
localV p = do
localV :: VM a -> VM a
localV p = do
@@
-243,7
+251,7
@@
closedV p = do
return x
liftDs :: DsM a -> VM a
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) }
builtin :: (Builtins -> a) -> VM a
builtin f = VM $ \bi genv lenv -> return (Yes genv lenv (f bi))
builtin :: (Builtins -> a) -> VM a
builtin f = VM $ \bi genv lenv -> return (Yes genv lenv (f bi))
@@
-252,7
+260,7
@@
builtins :: (a -> Builtins -> b) -> VM (a -> b)
builtins f = VM $ \bi genv lenv -> return (Yes genv lenv (`f` bi))
readGEnv :: (GlobalEnv -> a) -> VM a
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 ())
setGEnv :: GlobalEnv -> VM ()
setGEnv genv = VM $ \_ _ lenv -> return (Yes genv lenv ())
@@
-261,7
+269,7
@@
updGEnv :: (GlobalEnv -> GlobalEnv) -> VM ()
updGEnv f = VM $ \_ genv lenv -> return (Yes (f genv) lenv ())
readLEnv :: (LocalEnv -> a) -> VM a
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 ())
setLEnv :: LocalEnv -> VM ()
setLEnv lenv = VM $ \_ genv _ -> return (Yes genv lenv ())
@@
-269,8
+277,10
@@
setLEnv lenv = VM $ \_ genv _ -> return (Yes genv lenv ())
updLEnv :: (LocalEnv -> LocalEnv) -> VM ()
updLEnv f = VM $ \_ genv lenv -> return (Yes genv (f lenv) ())
updLEnv :: (LocalEnv -> LocalEnv) -> VM ()
updLEnv f = VM $ \_ genv lenv -> return (Yes genv (f lenv) ())
+{-
getInstEnv :: VM (InstEnv, InstEnv)
getInstEnv = readGEnv global_inst_env
getInstEnv :: VM (InstEnv, InstEnv)
getInstEnv = readGEnv global_inst_env
+-}
getFamInstEnv :: VM FamInstEnvs
getFamInstEnv = readGEnv global_fam_inst_env
getFamInstEnv :: VM FamInstEnvs
getFamInstEnv = readGEnv global_fam_inst_env
@@
-301,6
+311,9
@@
cloneId mk_occ id ty
| otherwise = Id.mkLocalId name ty
return id'
| otherwise = Id.mkLocalId name ty
return id'
+cloneVar :: Var -> VM Var
+cloneVar var = liftM (setIdUnique var) (liftDs newUnique)
+
newExportedVar :: OccName -> Type -> VM Var
newExportedVar occ_name ty
= do
newExportedVar :: OccName -> Type -> VM Var
newExportedVar occ_name ty
= do
@@
-318,7
+331,7
@@
newLocalVar fs ty
return $ mkSysLocal fs u ty
newDummyVar :: Type -> VM Var
return $ mkSysLocal fs u ty
newDummyVar :: Type -> VM Var
-newDummyVar = newLocalVar FSLIT("ds")
+newDummyVar = newLocalVar (fsLit "ds")
newTyVar :: FastString -> Kind -> VM Var
newTyVar fs k
newTyVar :: FastString -> Kind -> VM Var
newTyVar fs k
@@
-356,7
+369,9
@@
defTyCon tc tc' = updGEnv $ \env ->
env { global_tycons = extendNameEnv (global_tycons env) (tyConName tc) tc' }
lookupDataCon :: DataCon -> VM (Maybe DataCon)
env { global_tycons = extendNameEnv (global_tycons env) (tyConName tc) tc' }
lookupDataCon :: DataCon -> VM (Maybe DataCon)
-lookupDataCon dc = readGEnv $ \env -> lookupNameEnv (global_datacons env) (dataConName dc)
+lookupDataCon dc
+ | isTupleTyCon (dataConTyCon dc) = return (Just dc)
+ | otherwise = readGEnv $ \env -> lookupNameEnv (global_datacons env) (dataConName dc)
defDataCon :: DataCon -> DataCon -> VM ()
defDataCon dc dc' = updGEnv $ \env ->
defDataCon :: DataCon -> DataCon -> VM ()
defDataCon dc dc' = updGEnv $ \env ->
@@
-386,6
+401,10
@@
lookupTyVarPA tv = readLEnv $ \env -> lookupVarEnv (local_tyvar_pa env) tv
lookupTyConPR :: TyCon -> VM (Maybe Var)
lookupTyConPR tc = readGEnv $ \env -> lookupNameEnv (global_pr_funs env) (tyConName tc)
lookupTyConPR :: TyCon -> VM (Maybe Var)
lookupTyConPR tc = readGEnv $ \env -> lookupNameEnv (global_pr_funs env) (tyConName tc)
+lookupBoxedTyCon :: TyCon -> VM (Maybe TyCon)
+lookupBoxedTyCon tc = readGEnv $ \env -> lookupNameEnv (global_boxed_tycons env)
+ (tyConName tc)
+
defLocalTyVar :: TyVar -> VM ()
defLocalTyVar tv = updLEnv $ \env ->
env { local_tyvars = tv : local_tyvars env
defLocalTyVar :: TyVar -> VM ()
defLocalTyVar tv = updLEnv $ \env ->
env { local_tyvars = tv : local_tyvars env
@@
-469,17
+488,23
@@
initV hsc_env guts info p
go =
do
builtins <- initBuiltins
go =
do
builtins <- initBuiltins
- let builtin_tycons = initBuiltinTyCons builtins
+ builtin_vars <- initBuiltinVars builtins
+ builtin_tycons <- initBuiltinTyCons builtins
+ let builtin_datacons = initBuiltinDataCons builtins
builtin_pas <- initBuiltinPAs builtins
builtin_prs <- initBuiltinPRs builtins
builtin_pas <- initBuiltinPAs 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)
let famInstEnvs = (eps_fam_inst_env eps, mg_fam_inst_env guts)
instEnvs = (eps_inst_env eps, mg_inst_env guts)
- let genv = extendTyConsEnv builtin_tycons
+ let genv = extendImportedVarsEnv builtin_vars
+ . extendTyConsEnv builtin_tycons
+ . extendDataConsEnv builtin_datacons
. extendPAFunsEnv builtin_pas
. setPRFunsEnv builtin_prs
. extendPAFunsEnv builtin_pas
. setPRFunsEnv builtin_prs
+ . setBoxedTyConsEnv builtin_boxed
$ initGlobalEnv info instEnvs famInstEnvs
r <- runVM p builtins genv emptyLocalEnv
$ initGlobalEnv info instEnvs famInstEnvs
r <- runVM p builtins genv emptyLocalEnv