summaryrefslogtreecommitdiff
path: root/compiler/main
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/main')
-rw-r--r--compiler/main/DynFlags.hs2
-rw-r--r--compiler/main/HscMain.hs72
-rw-r--r--compiler/main/HscStats.lhs13
-rw-r--r--compiler/main/HscTypes.lhs8
-rw-r--r--compiler/main/InteractiveEval.hs21
-rw-r--r--compiler/main/Packages.lhs2
6 files changed, 54 insertions, 64 deletions
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index ac4df37ac8..747b0b8f71 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -1717,9 +1717,9 @@ package_flags = [
, Flag "ignore-package" (HasArg ignorePackage)
, Flag "syslib" (HasArg (\s -> do exposePackage s
deprecate "Use -package instead"))
+ , Flag "distrust-all-packages" (NoArg (setDynFlag Opt_DistrustAllPackages))
, Flag "trust" (HasArg trustPackage)
, Flag "distrust" (HasArg distrustPackage)
- , Flag "distrust-all-packages" (NoArg (setDynFlag Opt_DistrustAllPackages))
]
type TurnOnFlag = Bool -- True <=> we are turning the flag on
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index fc53d9d544..1fe9077046 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -84,6 +84,8 @@ import DsMeta ( templateHaskellNames )
import VarSet
import VarEnv ( emptyTidyEnv )
import Panic
+
+import GHC.Exts
#endif
import Id
@@ -1351,72 +1353,58 @@ myCoreToStg dflags this_mod prepd_binds = do
%********************************************************************* -}
{-
-When the UnlinkedBCOExpr is linked you get an HValue of type
- IO [HValue]
-When you run it you get a list of HValues that should be
-the same length as the list of names; add them to the ClosureEnv.
-
-A naked expression returns a singleton Name [it].
-
- What you type The IO [HValue] that hscStmt returns
- ------------- ------------------------------------
- let pat = expr ==> let pat = expr in return [coerce HVal x, coerce HVal y, ...]
- bindings: [x,y,...]
-
- pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
- bindings: [x,y,...]
-
- expr (of IO type) ==> expr >>= \ v -> return [v]
- [NB: result not printed] bindings: [it]
-
+When the UnlinkedBCOExpr is linked you get an HValue of type *IO [HValue]* When
+you run it you get a list of HValues that should be the same length as the list
+of names; add them to the ClosureEnv.
- expr (of non-IO type,
- result showable) ==> let v = expr in print v >> return [v]
- bindings: [it]
-
- expr (of non-IO type,
- result not showable) ==> error
+A naked expression returns a singleton Name [it]. The stmt is lifted into the
+IO monad as explained in Note [Interactively-bound Ids in GHCi] in TcRnDriver
-}
#ifdef GHCI
-- | Compile a stmt all the way to an HValue, but don't run it
-hscStmt :: HscEnv
- -> String -- ^ The statement
- -> IO (Maybe ([Id], HValue)) -- ^ 'Nothing' <==> empty statement
- -- (or comment only), but no parse error
+--
+-- We return Nothing to indicate an empty statement (or comment only), not a
+-- parse error.
+hscStmt :: HscEnv -> String -> IO (Maybe ([Id], IO [HValue]))
hscStmt hsc_env stmt = hscStmtWithLocation hsc_env stmt "<interactive>" 1
-- | Compile a stmt all the way to an HValue, but don't run it
+--
+-- We return Nothing to indicate an empty statement (or comment only), not a
+-- parse error.
hscStmtWithLocation :: HscEnv
-> String -- ^ The statement
-> String -- ^ The source
-> Int -- ^ Starting line
- -> IO (Maybe ([Id], HValue)) -- ^ 'Nothing' <==> empty statement
- -- (or comment only), but no parse error
+ -> IO (Maybe ([Id], IO [HValue]))
hscStmtWithLocation hsc_env stmt source linenumber = runHsc hsc_env $ do
maybe_stmt <- hscParseStmtWithLocation source linenumber stmt
case maybe_stmt of
Nothing -> return Nothing
- -- The real stuff
Just parsed_stmt -> do
- -- Rename and typecheck it
- let icontext = hsc_IC hsc_env
- (ids, tc_expr) <- ioMsgMaybe $
- tcRnStmt hsc_env icontext parsed_stmt
+ let icntxt = hsc_IC hsc_env
+ rdr_env = ic_rn_gbl_env icntxt
+ type_env = mkTypeEnvWithImplicits (ic_tythings icntxt)
+ src_span = srcLocSpan interactiveSrcLoc
+
+ -- Rename and typecheck it
+ -- Here we lift the stmt into the IO monad, see Note
+ -- [Interactively-bound Ids in GHCi] in TcRnDriver
+ (ids, tc_expr) <- ioMsgMaybe $ tcRnStmt hsc_env icntxt parsed_stmt
+
-- Desugar it
- let rdr_env = ic_rn_gbl_env icontext
- type_env = mkTypeEnvWithImplicits (ic_tythings icontext)
ds_expr <- ioMsgMaybe $
deSugarExpr hsc_env iNTERACTIVE rdr_env type_env tc_expr
handleWarnings
-- Then code-gen, and link it
- let src_span = srcLocSpan interactiveSrcLoc
hsc_env <- getHscEnv
hval <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr
+ let hval_io = unsafeCoerce# hval :: IO [HValue]
- return $ Just (ids, hval)
+ return $ Just (ids, hval_io)
-- | Compile a decls
hscDecls :: HscEnv
@@ -1442,8 +1430,8 @@ hscDeclsWithLocation hsc_env str source linenumber = runHsc hsc_env $ do
-- We grab the whole environment because of the overlapping that may have
-- been done. See the notes at the definition of InteractiveContext
-- (ic_instances) for more details.
- let finsts = famInstEnvElts $ tcg_fam_inst_env tc_gblenv
- insts = instEnvElts $ tcg_inst_env tc_gblenv
+ let finsts = tcg_fam_insts tc_gblenv
+ insts = tcg_insts tc_gblenv
{- Desugar it -}
-- We use a basically null location for iNTERACTIVE
@@ -1560,7 +1548,7 @@ hscParseThingWithLocation source linenumber parser str
liftIO $ showPass dflags "Parser"
let buf = stringToStringBuffer str
- loc = mkRealSrcLoc (fsLit source) linenumber 1
+ loc = mkRealSrcLoc (fsLit source) linenumber 1
case unP parser (mkPState dflags buf loc) of
PFailed span err -> do
diff --git a/compiler/main/HscStats.lhs b/compiler/main/HscStats.lhs
index f89903f75c..168e49af4a 100644
--- a/compiler/main/HscStats.lhs
+++ b/compiler/main/HscStats.lhs
@@ -52,7 +52,6 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
("DataDecls ", data_ds),
("NewTypeDecls ", newt_ds),
("TypeFamilyDecls ", type_fam_ds),
- ("FamilyInstDecls ", fam_inst_ds),
("DataConstrs ", data_constrs),
("DataDerivings ", data_derivs),
("ClassDecls ", class_ds),
@@ -89,7 +88,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
-- in class decls. ToDo
tycl_decls = [d | TyClD d <- decls]
- (class_ds, type_ds, data_ds, newt_ds, type_fam_ds, fam_inst_ds) =
+ (class_ds, type_ds, data_ds, newt_ds, type_fam_ds) =
countTyClDecls tycl_decls
inst_decls = [d | InstD d <- decls]
@@ -153,7 +152,9 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
(classops, addpr (foldr add2 (0,0) (map (count_bind.unLoc) (bagToList (tcdMeths decl)))))
class_info _ = (0,0)
- inst_info (InstDecl _ inst_meths inst_sigs ats)
+ inst_info (FamInstDecl d) = case countATDecl d of
+ (tyd, dtd) -> (0,0,0,tyd,dtd)
+ inst_info (ClsInstDecl _ inst_meths inst_sigs ats)
= case count_sigs (map unLoc inst_sigs) of
(_,_,ss,is,_) ->
case foldr add2 (0, 0) (map (countATDecl . unLoc) ats) of
@@ -162,9 +163,9 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
(map (count_bind.unLoc) (bagToList inst_meths))),
ss, is, tyDecl, dtDecl)
where
- countATDecl (TyData {}) = (0, 1)
- countATDecl (TySynonym {}) = (1, 0)
- countATDecl d = pprPanic "countATDecl: Unhandled decl"
+ countATDecl (TyData {}) = (0, 1)
+ countATDecl (TySynonym {}) = (1, 0)
+ countATDecl d = pprPanic "countATDecl: Unhandled decl"
(ppr d)
addpr :: (Int,Int) -> Int
diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs
index 3224acf0fe..9840b407ce 100644
--- a/compiler/main/HscTypes.lhs
+++ b/compiler/main/HscTypes.lhs
@@ -931,7 +931,8 @@ data InteractiveContext
ic_tythings :: [TyThing],
-- ^ TyThings defined by the user, in reverse order of
- -- definition.
+ -- definition. At a breakpoint, this list includes the
+ -- local variables in scope at that point
ic_sys_vars :: [Id],
-- ^ Variables defined automatically by the system (e.g.
@@ -1386,8 +1387,9 @@ lookupType dflags hpt pte name
lookupNameEnv (md_types (hm_details hm)) name
| otherwise
= lookupNameEnv pte name
- where mod = ASSERT( isExternalName name ) nameModule name
- this_pkg = thisPackage dflags
+ where
+ mod = ASSERT2( isExternalName name, ppr name ) nameModule name
+ this_pkg = thisPackage dflags
-- | As 'lookupType', but with a marginally easier-to-use interface
-- if you have a 'HscEnv'
diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index eee5c00255..cdc2ca501a 100644
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -198,17 +198,18 @@ runStmtWithLocation source linenumber expr step =
let dflags' = wopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds
hsc_env' = hsc_env{ hsc_dflags = dflags' }
+ -- compile to value (IO [HValue]), don't run
r <- liftIO $ hscStmtWithLocation hsc_env' expr source linenumber
case r of
- Nothing -> return (RunOk []) -- empty statement / comment
+ -- empty statement / comment
+ Nothing -> return (RunOk [])
Just (tyThings, hval) -> do
status <-
withVirtualCWD $
withBreakAction (isStep step) dflags' breakMVar statusMVar $ do
- let thing_to_run = unsafeCoerce# hval :: IO [HValue]
- liftIO $ sandboxIO dflags' statusMVar thing_to_run
+ liftIO $ sandboxIO dflags' statusMVar hval
let ic = hsc_IC hsc_env
bindings = (ic_tythings ic, ic_rn_gbl_env ic)
@@ -942,20 +943,18 @@ typeKind normalise str = withSession $ \hsc_env -> do
liftIO $ hscKcType hsc_env normalise str
-----------------------------------------------------------------------------
--- cmCompileExpr: compile an expression and deliver an HValue
+-- Compile an expression, run it and deliver the resulting HValue
compileExpr :: GhcMonad m => String -> m HValue
compileExpr expr = withSession $ \hsc_env -> do
Just (ids, hval) <- liftIO $ hscStmt hsc_env ("let __cmCompileExpr = "++expr)
- -- Run it!
- hvals <- liftIO (unsafeCoerce# hval :: IO [HValue])
-
+ hvals <- liftIO hval
case (ids,hvals) of
([_],[hv]) -> return hv
- _ -> panic "compileExpr"
+ _ -> panic "compileExpr"
-- -----------------------------------------------------------------------------
--- Compile an expression into a dynamic
+-- Compile an expression, run it and return the result as a dynamic
dynCompileExpr :: GhcMonad m => String -> m Dynamic
dynCompileExpr expr = do
@@ -977,8 +976,8 @@ dynCompileExpr expr = do
setContext iis
vals <- liftIO (unsafeCoerce# hvals :: IO [Dynamic])
case (ids,vals) of
- (_:[], v:[]) -> return v
- _ -> panic "dynCompileExpr"
+ (_:[], v:[]) -> return v
+ _ -> panic "dynCompileExpr"
-----------------------------------------------------------------------------
-- show a module and it's source/object filenames
diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs
index d1fbe2f253..1d6ad4a472 100644
--- a/compiler/main/Packages.lhs
+++ b/compiler/main/Packages.lhs
@@ -272,7 +272,7 @@ setBatchPackageFlags dflags pkgs = (maybeDistrustAll . maybeHideAll) pkgs
| otherwise = pkgs'
hide pkg = pkg{ exposed = False }
- distrust pkg = pkg{ exposed = False }
+ distrust pkg = pkg{ trusted = False }
-- TODO: This code is duplicated in utils/ghc-pkg/Main.hs
mungePackagePaths :: FilePath -> FilePath -> PackageConfig -> PackageConfig
View Lorry Controller Status