Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Alex D
GHC
Commits
7aa8104d
Commit
7aa8104d
authored
Apr 25, 2012
by
Simon Peyton Jones
Browse files
Merge remote-tracking branch 'origin/master'
parents
bcff115a
979785c4
Changes
11
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.
Click to expand it.
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
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment