#ifdef GHCI
import RdrHsSyn ( RdrNameHsExpr )
import Rename ( renameExpr )
-import StringBuffer ( stringToStringBuffer, freeStringBuffer )
import Unique ( Uniquable(..) )
import Type ( Type, splitTyConApp_maybe )
import PrelNames ( ioTyConKey )
import HsSyn
-import StringBuffer ( hGetStringBuffer )
+import StringBuffer ( hGetStringBuffer,
+ stringToStringBuffer, freeStringBuffer )
import Parser
import Lex ( PState(..), ParseResult(..) )
import SrcLoc ( mkSrcLoc )
typeEnvClasses, typeEnvTyCons, emptyIfaceTable )
import FiniteMap ( FiniteMap, plusFM, emptyFM, addToFM )
import OccName ( OccName )
-import Name ( Name, nameModule, nameOccName, getName )
-import Name ( emptyNameEnv )
+import Name ( Name, nameModule, nameOccName, getName, isGlobalName,
+ emptyNameEnv )
import Module ( Module, lookupModuleEnvByName )
import Monad ( when )
}
| otherwise
= do {
- hPutStr stderr "compilation IS NOT required";
- when (verbosity dflags /= 1) $ hPutStrLn stderr "";
+ hPutStrLn stderr "compilation IS NOT required";
-- CLOSURE
(pcs_cl, closure_errs, cl_hs_decls)
-- TYPECHECK
maybe_tc_result <- typecheckModule dflags pcs_cl hst
- old_iface alwaysQualify cl_hs_decls;
+ old_iface alwaysQualify cl_hs_decls
+ False{-don't check for Main.main-};
case maybe_tc_result of {
Nothing -> return (HscFail pcs_cl);
Just (pcs_tc, tc_result) -> do {
hscRecomp ghci_mode dflags location maybe_checked_iface hst hit pcs_ch
= do {
; when (verbosity dflags >= 1) $
- hPutStr stderr "compilation IS required";
- -- mode -v1 tries to keep everything on one line
- when (verbosity dflags > 1) $
- hPutStrLn stderr "";
+ hPutStrLn stderr "compilation IS required";
-- what target are we shooting for?
; let toInterp = dopt_HscLang dflags == HscInterpreted
-- RENAME
-------------------
; (pcs_rn, maybe_rn_result)
- <- renameModule dflags hit hst pcs_ch this_mod rdr_module
+ <- _scc_ "Rename"
+ renameModule dflags hit hst pcs_ch this_mod rdr_module
; case maybe_rn_result of {
- Nothing -> return (HscFail pcs_rn);
+ Nothing -> return (HscFail pcs_ch{-was: pcs_rn-});
Just (print_unqualified, (is_exported, new_iface, rn_hs_decls)) -> do {
+ -- In interactive mode, we don't want to discard any top-level entities at
+ -- all (eg. do not inline them away during simplification), and retain them
+ -- all in the TypeEnv so they are available from the command line.
+ --
+ -- isGlobalName separates the user-defined top-level names from those
+ -- introduced by the type checker.
+ ; let dont_discard | ghci_mode == Interactive = isGlobalName
+ | otherwise = is_exported
+
-------------------
-- TYPECHECK
-------------------
- ; maybe_tc_result <- typecheckModule dflags pcs_rn hst new_iface
- print_unqualified rn_hs_decls
+ ; maybe_tc_result
+ <- _scc_ "TypeCheck" typecheckModule dflags pcs_rn hst new_iface
+ print_unqualified rn_hs_decls
+ True{-check for Main.main if necessary-}
; case maybe_tc_result of {
- Nothing -> return (HscFail pcs_rn);
+ Nothing -> return (HscFail pcs_ch{-was: pcs_rn-});
Just (pcs_tc, tc_result) -> do {
; let env_tc = tc_env tc_result
-- DESUGAR
-------------------
; (ds_binds, ds_rules, foreign_stuff)
- <- deSugar dflags pcs_tc hst this_mod print_unqualified tc_result
+ <- _scc_ "DeSugar"
+ deSugar dflags pcs_tc hst this_mod print_unqualified tc_result
-------------------
-- SIMPLIFY, TIDY-CORE
-------------------
-- We grab the the unfoldings at this point.
; (pcs_simpl, tidy_binds, orphan_rules)
- <- simplThenTidy dflags pcs_tc hst this_mod is_exported ds_binds ds_rules
+ <- simplThenTidy dflags pcs_tc hst this_mod dont_discard ds_binds ds_rules
-------------------
-- BUILD THE NEW ModDetails AND ModIface
-------------------
; let new_details = mkModDetails env_tc tidy_binds orphan_rules
- ; final_iface <- mkFinalIface ghci_mode dflags location
+ ; final_iface <- _scc_ "MkFinalIface"
+ mkFinalIface ghci_mode dflags location
maybe_checked_iface new_iface new_details
-------------------
myParseModule dflags src_filename
= do -------------------------- Parser ----------------
showPass dflags "Parser"
- -- _scc_ "Parser"
+ _scc_ "Parser" do
buf <- hGetStringBuffer True{-expand tabs-} src_filename
let glaexts | dopt Opt_GlasgowExts dflags = 1#
| otherwise = 0#
- case parse buf PState{ bol = 0#, atbol = 1#,
- context = [], glasgow_exts = glaexts,
- loc = mkSrcLoc (_PK_ src_filename) 1 } of {
+ case parseModule buf PState{ bol = 0#, atbol = 1#,
+ context = [], glasgow_exts = glaexts,
+ loc = mkSrcLoc (_PK_ src_filename) 1 } of {
PFailed err -> do { hPutStrLn stderr (showSDoc err);
+ freeStringBuffer buf;
return Nothing };
- POk _ (PModule rdr_module@(HsModule mod_name _ _ _ _ _ _)) -> do {
+ POk _ rdr_module@(HsModule mod_name _ _ _ _ _ _) -> do {
dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ;
(ppSourceStats False rdr_module) ;
return (Just rdr_module)
+ -- ToDo: free the string buffer later.
}}
-simplThenTidy dflags pcs hst this_mod is_exported binds rules
+simplThenTidy dflags pcs hst this_mod dont_discard binds rules
= do -- Do main Core-language transformations ---------
-- _scc_ "Core2Core"
(simplified, orphan_rules)
- <- core2core dflags pcs hst is_exported binds rules
+ <- core2core dflags pcs hst dont_discard binds rules
-- Do saturation and convert to A-normal form
-- NOTE: subsequent passes may not transform the syntax, only annotate it
= do
-------------------------- Convert to STG -------------------------------
(stg_binds, cost_centre_info)
- <- myCoreToStg dflags this_mod tidy_binds env_tc
+ <- _scc_ "CoreToStg"
+ myCoreToStg dflags this_mod tidy_binds env_tc
- -------------------------- Code generation -------------------------------
- -- _scc_ "CodeGen"
- abstractC <- codeGen dflags this_mod imported_modules
+ -------------------------- Code generation ------------------------------
+ abstractC <- _scc_ "CodeGen"
+ codeGen dflags this_mod imported_modules
cost_centre_info fe_binders
local_tycons stg_binds
-------------------------- Code output -------------------------------
- -- _scc_ "CodeOutput"
(maybe_stub_h_name, maybe_stub_c_name)
<- codeOutput dflags this_mod local_tycons
tidy_binds stg_binds
--let bcos = byteCodeGen dflags tidy_binds local_tycons local_classes
- -- _scc_ "Core2Stg"
- stg_binds <- coreToStg dflags this_mod tidy_binds
+
+ stg_binds <- _scc_ "Core2Stg" coreToStg dflags this_mod tidy_binds
- -- _scc_ "Stg2Stg"
- (stg_binds2, cost_centre_info) <- stg2stg dflags this_mod stg_binds
+ (stg_binds2, cost_centre_info)
+ <- _scc_ "Core2Stg" stg2stg dflags this_mod stg_binds
return (stg_binds2, cost_centre_info)
where
#ifdef GHCI
hscExpr
:: DynFlags
+ -> Bool -- True <=> wrap in 'print' to get a result of IO type
-> HomeSymbolTable
-> HomeIfaceTable
-> PersistentCompilerState -- IN: persistent compiler state
-> IO ( PersistentCompilerState,
Maybe (UnlinkedBCOExpr, PrintUnqualified, Type) )
-hscExpr dflags hst hit pcs0 this_module expr
+hscExpr dflags wrap_io hst hit pcs0 this_module expr
= do {
maybe_parsed <- hscParseExpr dflags expr;
case maybe_parsed of
-- Typecheck it
maybe_tc_return
- <- typecheckExpr dflags pcs1 hst print_unqual this_module rn_expr;
+ <- typecheckExpr dflags wrap_io pcs1 hst print_unqual this_module rn_expr;
case maybe_tc_return of {
Nothing -> return ({-WAS:pcs1-} pcs0, Nothing);
Just (pcs2, tc_expr, ty) -> do
- -- if it isn't an IO-typed expression,
- -- wrap "print" around it & recompile...
- let { is_IO_type = case splitTyConApp_maybe ty of {
- Just (tycon, _) -> getUnique tycon == ioTyConKey;
- Nothing -> False }
- };
-
- if (not is_IO_type)
- then do (new_pcs, maybe_stuff)
- <- hscExpr dflags hst hit pcs2 this_module
- ("print (" ++ expr ++ ")")
- case maybe_stuff of
- Nothing -> return (new_pcs, maybe_stuff)
- Just (bcos, _, _) ->
- return (new_pcs, Just (bcos, print_unqual, ty))
- else do
-
-- Desugar it
ds_expr <- deSugarExpr dflags pcs2 hst this_module
print_unqual tc_expr;
hscParseExpr dflags str
= do -------------------------- Parser ----------------
showPass dflags "Parser"
- -- _scc_ "Parser"
+ _scc_ "Parser" do
- buf <- stringToStringBuffer ("__expr " ++ str)
+ buf <- stringToStringBuffer str
- -- glaexts is True for now (because of the daft __expr at the front
- -- of the string...)
- let glaexts = 1#
- --let glaexts | dopt Opt_GlasgowExts dflags = 1#
- -- | otherwise = 0#
+ let glaexts | dopt Opt_GlasgowExts dflags = 1#
+ | otherwise = 0#
- case parse buf PState{ bol = 0#, atbol = 1#,
- context = [], glasgow_exts = glaexts,
- loc = mkSrcLoc SLIT("<no file>") 0 } of {
+ case parseExpr buf PState{ bol = 0#, atbol = 1#,
+ context = [], glasgow_exts = glaexts,
+ loc = mkSrcLoc SLIT("<no file>") 0 } of {
- PFailed err -> do { freeStringBuffer buf;
- hPutStrLn stderr (showSDoc err);
+ PFailed err -> do { hPutStrLn stderr (showSDoc err);
+-- Not yet implemented in <4.11 freeStringBuffer buf;
return Nothing };
- POk _ (PExpr rdr_expr) -> do {
+ POk _ rdr_expr -> do {
--ToDo: can't free the string buffer until we've finished this
-- compilation sweep and all the identifiers have gone away.
projects / ghc-hetmet.git / blobdiff