Skip to content

GitLab

Commit 7aa8104d authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Merge remote-tracking branch 'origin/master'

parents bcff115a 979785c4
Expand all Hide whitespace changes
Inline Side-by-side
compiler/main/GHC.hs
View file @ 7aa8104d
......@@ -122,6 +122,11 @@ module GHC (
#endif
lookupName,
#ifdef GHCI
-- ** EXPERIMENTAL
setGHCiMonad,
#endif
-- * Abstract syntax elements
-- ** Packages
......@@ -1330,6 +1335,21 @@ isModuleTrusted :: GhcMonad m => Module -> m Bool
isModuleTrusted m = withSession $ \hsc_env ->
liftIO $ hscCheckSafe hsc_env m noSrcSpan
-- | EXPERIMENTAL: DO NOT USE.
--
-- Set the monad GHCi lifts user statements into.
--
-- Checks that a type (in string form) is an instance of the
-- @GHC.GHCi.GHCiSandboxIO@ type class. Sets it to be the GHCi monad if it is,
-- throws an error otherwise.
{-# WARNING setGHCiMonad "This is experimental! Don't use." #-}
setGHCiMonad :: GhcMonad m => String -> m ()
setGHCiMonad name = withSession $ \hsc_env -> do
ty <- liftIO $ hscIsGHCiMonad hsc_env name
modifySession $ \s ->
let ic = (hsc_IC s) { ic_monad = ty }
in s { hsc_IC = ic }
getHistorySpan :: GhcMonad m => History -> m SrcSpan
getHistorySpan h = withSession $ \hsc_env ->
return $ InteractiveEval.getHistorySpan hsc_env h
......
compiler/main/HscMain.hs
View file @ 7aa8104d
......@@ -62,6 +62,7 @@ module HscMain
, hscTcRnGetInfo
, hscCheckSafe
#ifdef GHCI
, hscIsGHCiMonad
, hscGetModuleInterface
, hscRnImportDecls
, hscTcRnLookupRdrName
......@@ -311,6 +312,11 @@ hscTcRnGetInfo hsc_env0 name = runInteractiveHsc hsc_env0 $ do
ioMsgMaybe' $ tcRnGetInfo hsc_env name
#ifdef GHCI
hscIsGHCiMonad :: HscEnv -> String -> IO Name
hscIsGHCiMonad hsc_env name =
let icntxt = hsc_IC hsc_env
in runHsc hsc_env $ ioMsgMaybe $ isGHCiMonad hsc_env icntxt name
hscGetModuleInterface :: HscEnv -> Module -> IO ModIface
hscGetModuleInterface hsc_env0 mod = runInteractiveHsc hsc_env0 $ do
hsc_env <- getHscEnv
......
compiler/main/HscTypes.lhs
View file @ 7aa8104d
......@@ -136,7 +136,7 @@ import Annotations
import Class
import TyCon
import DataCon
import PrelNames ( gHC_PRIM )
import PrelNames ( gHC_PRIM, ioTyConName )
import Packages hiding ( Version(..) )
import DynFlags
import DriverPhases
......@@ -910,6 +910,9 @@ data InteractiveContext
-- ^ The 'DynFlags' used to evaluate interative expressions
-- and statements.
ic_monad :: Name,
-- ^ The monad that GHCi is executing in
ic_imports :: [InteractiveImport],
-- ^ The GHCi context is extended with these imports
--
......@@ -973,6 +976,8 @@ hscDeclsWithLocation) and save them in ic_sys_vars.
emptyInteractiveContext :: DynFlags -> InteractiveContext
emptyInteractiveContext dflags
= InteractiveContext { ic_dflags = dflags,
-- IO monad by default
ic_monad = ioTyConName,
ic_imports = [],
ic_rn_gbl_env = emptyGlobalRdrEnv,
ic_tythings = [],
......
compiler/prelude/PrelNames.lhs
View file @ 7aa8104d
......@@ -306,6 +306,9 @@ basicKnownKeyNames
, guardMName
, liftMName
, mzipName
-- GHCi Sandbox
, ghciIoClassName, ghciStepIoMName
]
genericTyConNames :: [Name]
......@@ -334,7 +337,7 @@ pRELUDE = mkBaseModule_ pRELUDE_NAME
gHC_PRIM, gHC_TYPES, gHC_GENERICS,
gHC_MAGIC,
gHC_CLASSES, gHC_BASE, gHC_ENUM, gHC_CSTRING,
gHC_CLASSES, gHC_BASE, gHC_ENUM, gHC_GHCI, gHC_CSTRING,
gHC_SHOW, gHC_READ, gHC_NUM, gHC_INTEGER_TYPE, gHC_LIST,
gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_STRING, dATA_FOLDABLE, dATA_TRAVERSABLE,
gHC_CONC, gHC_IO, gHC_IO_Exception,
......@@ -353,6 +356,7 @@ gHC_CLASSES = mkPrimModule (fsLit "GHC.Classes")
gHC_BASE = mkBaseModule (fsLit "GHC.Base")
gHC_ENUM = mkBaseModule (fsLit "GHC.Enum")
gHC_GHCI = mkBaseModule (fsLit "GHC.GHCi")
gHC_SHOW = mkBaseModule (fsLit "GHC.Show")
gHC_READ = mkBaseModule (fsLit "GHC.Read")
gHC_NUM = mkBaseModule (fsLit "GHC.Num")
......@@ -971,6 +975,11 @@ datatypeClassName = clsQual gHC_GENERICS (fsLit "Datatype") datatypeClassKey
constructorClassName = clsQual gHC_GENERICS (fsLit "Constructor") constructorClassKey
selectorClassName = clsQual gHC_GENERICS (fsLit "Selector") selectorClassKey
-- GHCi things
ghciIoClassName, ghciStepIoMName :: Name
ghciIoClassName = clsQual gHC_GHCI (fsLit "GHCiSandboxIO") ghciIoClassKey
ghciStepIoMName = methName gHC_GHCI (fsLit "ghciStepIO") ghciStepIoMClassOpKey
-- IO things
ioTyConName, ioDataConName, thenIOName, bindIOName, returnIOName,
failIOName :: Name
......@@ -1179,6 +1188,9 @@ selectorClassKey = mkPreludeClassUnique 41
singIClassNameKey, typeNatLeqClassNameKey :: Unique
singIClassNameKey = mkPreludeClassUnique 42
typeNatLeqClassNameKey = mkPreludeClassUnique 43
ghciIoClassKey :: Unique
ghciIoClassKey = mkPreludeClassUnique 44
\end{code}
%************************************************************************
......@@ -1647,6 +1659,10 @@ guardMIdKey = mkPreludeMiscIdUnique 194
liftMIdKey = mkPreludeMiscIdUnique 195
mzipIdKey = mkPreludeMiscIdUnique 196
-- GHCi
ghciStepIoMClassOpKey :: Unique
ghciStepIoMClassOpKey = mkPreludeMiscIdUnique 197
---------------- Template Haskell -------------------
-- USES IdUniques 200-499
......
compiler/typecheck/TcRnDriver.lhs
View file @ 7aa8104d
......@@ -12,6 +12,7 @@ module TcRnDriver (
tcRnLookupRdrName,
getModuleInterface,
tcRnDeclsi,
isGHCiMonad,
#endif
tcRnLookupName,
tcRnGetInfo,
......@@ -24,6 +25,7 @@ module TcRnDriver (
import {-# SOURCE #-} TcSplice ( tcSpliceDecls )
#endif
import TypeRep
import DynFlags
import StaticFlags
import HsSyn
......@@ -1285,6 +1287,7 @@ tcUserStmt :: LStmt RdrName -> TcM PlanResult
tcUserStmt (L loc (ExprStmt expr _ _ _))
= do { (rn_expr, fvs) <- checkNoErrs (rnLExpr expr)
-- Don't try to typecheck if the renamer fails!
; ghciStep <- getGhciStepIO
; uniq <- newUnique
; let fresh_it = itName uniq loc
matches = [mkMatch [] rn_expr emptyLocalBinds]
......@@ -1294,13 +1297,15 @@ tcUserStmt (L loc (ExprStmt expr _ _ _))
-- free variables, and they in turn may have free type variables
-- (if we are at a breakpoint, say). We must put those free vars
-- [let it = expr]
let_stmt = L loc $ LetStmt $ HsValBinds $
ValBindsOut [(NonRecursive,unitBag the_bind)] []
-- [it <- e]
bind_stmt = L loc $ BindStmt (L loc (VarPat fresh_it)) rn_expr
bind_stmt = L loc $ BindStmt (L loc (VarPat fresh_it))
(nlHsApp ghciStep rn_expr)
(HsVar bindIOName) noSyntaxExpr
-- [; print it]
print_it = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar fresh_it))
(HsVar thenIOName) noSyntaxExpr placeHolderType
......@@ -1318,7 +1323,7 @@ tcUserStmt (L loc (ExprStmt expr _ _ _))
-- Plan A
do { stuff@([it_id], _) <- tcGhciStmts [bind_stmt, print_it]
; it_ty <- zonkTcType (idType it_id)
; when (isUnitTy it_ty) failM
; when (isUnitTy $ it_ty) failM
; return stuff },
-- Plan B; a naked bind statment
......@@ -1342,20 +1347,26 @@ tcUserStmt rdr_stmt@(L loc _)
; traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs])
; rnDump (ppr rn_stmt) ;
; ghciStep <- getGhciStepIO
; let gi_stmt
| (L loc (BindStmt pat expr op1 op2)) <- rn_stmt
= L loc $ BindStmt pat (nlHsApp ghciStep expr) op1 op2
| otherwise = rn_stmt
; opt_pr_flag <- doptM Opt_PrintBindResult
; let print_result_plan
| opt_pr_flag -- The flag says "print result"
, [v] <- collectLStmtBinders rn_stmt -- One binder
= [mk_print_result_plan rn_stmt v]
, [v] <- collectLStmtBinders gi_stmt -- One binder
= [mk_print_result_plan gi_stmt v]
| otherwise = []
-- The plans are:
-- [stmt; print v] if one binder and not v::()
-- [stmt] otherwise
; runPlans (print_result_plan ++ [tcGhciStmts [rn_stmt]]) }
; runPlans (print_result_plan ++ [tcGhciStmts [gi_stmt]]) }
where
mk_print_result_plan rn_stmt v
= do { stuff@([v_id], _) <- tcGhciStmts [rn_stmt, print_v]
mk_print_result_plan stmt v
= do { stuff@([v_id], _) <- tcGhciStmts [stmt, print_v]
; v_ty <- zonkTcType (idType v_id)
; when (isUnitTy v_ty || not (isTauTy v_ty)) failM
; return stuff }
......@@ -1410,6 +1421,40 @@ tcGhciStmts stmts
return (ids, mkHsDictLet (EvBinds const_binds) $
noLoc (HsDo GhciStmt stmts io_ret_ty))
}
-- | Generate a typed ghciStepIO expression (ghciStep :: Ty a -> IO a)
getGhciStepIO :: TcM (LHsExpr Name)
getGhciStepIO = do
ghciTy <- getGHCiMonad
fresh_a <- newUnique
let a_tv = mkTcTyVarName fresh_a (fsLit "a")
ghciM = nlHsAppTy (nlHsTyVar ghciTy) (nlHsTyVar a_tv)
ioM = nlHsAppTy (nlHsTyVar ioTyConName) (nlHsTyVar a_tv)
stepTy = noLoc $ HsForAllTy Implicit
([noLoc $ UserTyVar a_tv])
(noLoc [])
(nlHsFunTy ghciM ioM)
step = noLoc $ ExprWithTySig (nlHsVar ghciStepIoMName) stepTy
return step
isGHCiMonad :: HscEnv -> InteractiveContext -> String -> IO (Messages, Maybe Name)
isGHCiMonad hsc_env ictxt ty
= initTcPrintErrors hsc_env iNTERACTIVE $
setInteractiveContext hsc_env ictxt $ do
rdrEnv <- getGlobalRdrEnv
let occIO = lookupOccEnv rdrEnv (mkOccName tcName ty)
case occIO of
Just [n] -> do
let name = gre_name n
ghciClass <- tcLookupClass ghciIoClassName
userTyCon <- tcLookupTyCon name
let userTy = TyConApp userTyCon []
_ <- tcLookupInstance ghciClass [userTy]
return name
Just _ -> failWithTc $ text "Ambigous type!"
Nothing -> failWithTc $ text ("Can't find type:" ++ ty)
\end{code}
tcRnExpr just finds the type of an expression
......
compiler/typecheck/TcRnMonad.lhs
View file @ 7aa8104d
......@@ -486,6 +486,9 @@ setModule mod thing_inside = updGblEnv (\env -> env { tcg_mod = mod }) thing_ins
getIsGHCi :: TcRn Bool
getIsGHCi = do { mod <- getModule; return (mod == iNTERACTIVE) }
getGHCiMonad :: TcRn Name
getGHCiMonad = do { hsc <- getTopEnv; return (ic_monad $ hsc_IC hsc) }
tcIsHsBoot :: TcRn Bool
tcIsHsBoot = do { env <- getGblEnv; return (isHsBoot (tcg_src env)) }
......
compiler/vectorise/Vectorise/Builtins/Base.hs
View file @ 7aa8104d
......@@ -57,7 +57,7 @@ mAX_DPH_COMBINE :: Int
mAX_DPH_COMBINE = 2
mAX_DPH_SCALAR_ARGS :: Int
mAX_DPH_SCALAR_ARGS = 3
mAX_DPH_SCALAR_ARGS = 8
-- Types from 'GHC.Prim' supported by DPH
--
......
compiler/vectorise/Vectorise/Builtins/Initialise.hs
View file @ 7aa8104d
......@@ -95,7 +95,7 @@ initBuiltins
; applyVar <- externalVar (fsLit "$:")
; liftedApplyVar <- externalVar (fsLit "liftedApply")
; closures <- mapM externalVar (numbered "closure" 1 mAX_DPH_SCALAR_ARGS)
; let closureCtrFuns = listArray (1, mAX_DPH_COMBINE) closures
; let closureCtrFuns = listArray (1, mAX_DPH_SCALAR_ARGS) closures
-- Types and functions for selectors
; sel_tys <- mapM externalType (numbered "Sel" 2 mAX_DPH_SUM)
......
compiler/vectorise/Vectorise/Env.hs
View file @ 7aa8104d
......@@ -30,6 +30,9 @@ import NameSet
import Name
import NameEnv
import FastString
import TysPrim
import TysWiredIn
import Data.Maybe
......@@ -158,11 +161,13 @@ initGlobalEnv info vectDecls instEnvs famInstEnvs
-- single variable to be able to obtain the type without
-- inference — see also 'TcBinds.tcVect'
scalar_vars = [var | Vect var Nothing <- vectDecls] ++
[var | VectInst var <- vectDecls]
[var | VectInst var <- vectDecls] ++
[dataConWrapId doubleDataCon, dataConWrapId floatDataCon, dataConWrapId intDataCon] -- TODO: fix this hack
novects = [var | NoVect var <- vectDecls]
scalar_tycons = [tyConName tycon | VectType True tycon Nothing <- vectDecls] ++
[tyConName tycon | VectType _ tycon (Just tycon') <- vectDecls
, tycon == tycon']
, tycon == tycon'] ++
map tyConName [doublePrimTyCon, intPrimTyCon, floatPrimTyCon] -- TODO: fix this hack
-- - for 'VectType True tycon Nothing', we checked that the type does not
-- contain arrays (or type variables that could be instatiated to arrays)
-- - for 'VectType _ tycon (Just tycon')', where the two tycons are the same,
......
compiler/vectorise/Vectorise/Exp.hs
View file @ 7aa8104d
This diff is collapsed.
rts/Linker.c
View file @ 7aa8104d
......@@ -1060,7 +1060,8 @@ typedef struct _RtsSymbolVal {
SymI_NeedsProto(__muldi3) \
SymI_NeedsProto(__ashldi3) \
SymI_NeedsProto(__ashrdi3) \
SymI_NeedsProto(__lshrdi3)
SymI_NeedsProto(__lshrdi3) \
SymI_NeedsProto(__fixunsdfdi)
#else
#define RTS_LIBGCC_SYMBOLS
#endif
......
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