import Type ( Type )
import PrelNames ( iNTERACTIVE )
import StringBuffer ( stringToStringBuffer )
+import SrcLoc ( noSrcLoc )
+import Name ( Name )
+import CoreLint ( lintUnfolding )
#endif
import HsSyn
import RdrName ( nameRdrName )
-import Id ( idName )
-import IdInfo ( CafInfo(..), CgInfoEnv, CgInfo(..) )
import StringBuffer ( hGetStringBuffer, freeStringBuffer )
import Parser
import Lex ( ParseResult(..), ExtFlags(..), mkPState )
import SrcLoc ( mkSrcLoc )
import TcRnDriver ( checkOldIface, tcRnModule, tcRnExtCore, tcRnIface )
import RnEnv ( extendOrigNameCache )
-import Rules ( emptyRuleBase )
-import PrelInfo ( wiredInThingEnv, wiredInThings, knownKeyNames )
+import PrelInfo ( wiredInThingEnv, knownKeyNames )
import PrelRules ( builtinRules )
import MkIface ( mkIface )
-import InstEnv ( emptyInstEnv )
import Desugar
import Flattening ( flatten )
import SimplCore
-import CoreUtils ( coreBindsSize )
import TidyPgm ( tidyCorePgm )
import CorePrep ( corePrepPgm )
-import StgSyn
import CoreToStg ( coreToStg )
import SimplStg ( stg2stg )
import CodeGen ( codeGen )
import CodeOutput ( codeOutput )
-import Module ( ModuleName, moduleName, emptyModuleEnv )
+import Module ( emptyModuleEnv )
import CmdLineOpts
import DriverPhases ( isExtCore_file )
-import ErrUtils ( dumpIfSet_dyn, showPass, printError )
+import ErrUtils ( dumpIfSet_dyn, showPass )
import UniqSupply ( mkSplitUniqSupply )
import Bag ( consBag, emptyBag )
import MkExternalCore ( emitExternalCore )
import ParserCore
import ParserCoreUtils
-import FiniteMap ( FiniteMap, plusFM, emptyFM, addToFM )
-import OccName ( OccName )
-import Name ( Name, nameModule, nameOccName, getName )
-import NameEnv ( emptyNameEnv, mkNameEnv )
-import NameSet ( emptyNameSet )
+import FiniteMap ( emptyFM )
+import Name ( nameModule )
import Module ( Module, ModLocation(..), showModMsg )
import FastString
import Maybes ( expectJust )
-import DATA_IOREF ( newIORef, readIORef, writeIORef )
-import UNSAFE_IO ( unsafePerformIO )
-
import Monad ( when )
import Maybe ( isJust, fromJust )
import IO
; flat_result <- _scc_ "Flattening"
flatten hsc_env pcs_tc ds_result
- ; let pcs_middle = pcs_tc
-
-{- Again, omit this because it loses the usage info
- which is needed in mkIface. Maybe we should compute
- usage info earlier.
-
- ; pcs_middle
- <- _scc_ "pcs_middle"
- if one_shot then
- do init_pcs <- initPersistentCompilerState
- init_prs <- initPersistentRenamerState
- let
- rules = pcs_rules pcs_tc
- orig_tc = prsOrig (pcs_PRS pcs_tc)
- new_prs = init_prs{ prsOrig=orig_tc }
-
- orig_tc `seq` rules `seq` new_prs `seq`
- return init_pcs{ pcs_PRS = new_prs,
- pcs_rules = rules }
- else return pcs_tc
--}
-
--- Should we remove bits of flat_result at this point?
--- ; flat_result <- case flat_result of
--- ModResult { md_binds = binds } ->
--- return ModDetails { md_binds = binds,
--- md_rules = [],
--- md_types = emptyTypeEnv,
--- md_insts = [] }
+
+ ; let -- Rule-base accumulated from imported packages
+ pkg_rule_base = eps_rule_base (pcs_EPS pcs_tc)
+
+ -- In one-shot mode, ZAP the external package state at
+ -- this point, because we aren't going to need it from
+ -- now on. We keep the name cache, however, because
+ -- tidyCore needs it.
+ pcs_middle
+ | one_shot = pcs_tc{ pcs_EPS = error "pcs_EPS missing" }
+ | otherwise = pcs_tc
+
+ ; pkg_rule_base `seq` pcs_middle `seq` return ()
-- alive at this point:
-- pcs_middle
-- flat_result
+ -- pkg_rule_base
-------------------
-- SIMPLIFY
-------------------
; simpl_result <- _scc_ "Core2Core"
- core2core hsc_env pcs_middle flat_result
+ core2core hsc_env pkg_rule_base flat_result
-------------------
-- TIDY
-------------------
- ; cg_info_ref <- newIORef Nothing ;
- ; let cg_info :: CgInfoEnv
- cg_info = unsafePerformIO $ do {
- maybe_cg_env <- readIORef cg_info_ref ;
- case maybe_cg_env of
- Just env -> return env
- Nothing -> do { printError "Urk! Looked at CgInfo too early!";
- return emptyNameEnv } }
- -- cg_info_ref will be filled in just after restOfCodeGeneration
- -- Meanwhile, tidyCorePgm is careful not to look at cg_info!
-
; (pcs_simpl, tidy_result)
<- _scc_ "CoreTidy"
- tidyCorePgm dflags pcs_middle cg_info simpl_result
+ tidyCorePgm dflags pcs_middle simpl_result
--- Space-saving ploy doesn't work so well now
--- because mkIface needs the populated PIT to
--- generate usage info. Maybe we should re-visit this.
--- ; pcs_final <- if one_shot then initPersistentCompilerState
--- else return pcs_simpl
- ; let pcs_final = pcs_simpl
+ -- ZAP the persistent compiler state altogether now if we're
+ -- in one-shot mode, to save space.
+ ; pcs_final <- if one_shot then return (error "pcs_final missing")
+ else return pcs_simpl
+
+ ; emitExternalCore dflags tidy_result
-- Alive at this point:
-- tidy_result, pcs_final
-
- -------------------
- -- PREPARE FOR CODE GENERATION
- -- Do saturation and convert to A-normal form
- ; prepd_result <- _scc_ "CorePrep"
- corePrepPgm dflags tidy_result
-
- -------------------
- -- CONVERT TO STG and COMPLETE CODE GENERATION
- ; (stub_h_exists, stub_c_exists, maybe_bcos)
- <- hscBackEnd dflags cg_info_ref prepd_result
+ -- hsc_env
-------------------
-- BUILD THE NEW ModIface and ModDetails
-- This has to happen *after* code gen so that the back-end
-- info has been set. Not yet clear if it matters waiting
-- until after code output
- ; final_iface <- _scc_ "MkFinalIface"
+ ; new_iface <- _scc_ "MkFinalIface"
mkIface hsc_env location
maybe_checked_iface tidy_result
- ; let final_details = ModDetails { md_types = mg_types tidy_result,
+
+
+ -- Space leak reduction: throw away the new interface if
+ -- we're in one-shot mode; we won't be needing it any
+ -- more.
+ ; final_iface <-
+ if one_shot then return (error "no final iface")
+ else return new_iface
+
+ -- Build the final ModDetails (except in one-shot mode, where
+ -- we won't need this information after compilation).
+ ; final_details <-
+ if one_shot then return (error "no final details")
+ else return $! ModDetails {
+ md_types = mg_types tidy_result,
md_insts = mg_insts tidy_result,
md_rules = mg_rules tidy_result }
- ; emitExternalCore dflags tidy_result
+
+ -------------------
+ -- CONVERT TO STG and COMPLETE CODE GENERATION
+ ; (stub_h_exists, stub_c_exists, maybe_bcos)
+ <- hscBackEnd dflags tidy_result
-- and the answer is ...
; return (HscRecomp pcs_final
-- PARSE
-------------------
; maybe_parsed <- myParseModule (hsc_dflags hsc_env)
- (expectJust "hscRecomp:hspp" (ml_hspp_file location))
+ (expectJust "hscFrontEnd:hspp" (ml_hspp_file location))
; case maybe_parsed of {
Nothing -> return (Left (HscFail pcs_ch));
-------------------
-- RENAME and TYPECHECK
-------------------
- ; (pcs_tc, maybe_tc_result) <- _scc_ "Typecheck and Rename"
+ ; (pcs_tc, maybe_tc_result) <- _scc_ "Typecheck-Rename"
tcRnModule hsc_env pcs_ch rdr_module
; case maybe_tc_result of {
Nothing -> return (Left (HscFail pcs_ch));
Just tc_result -> do {
-
+
-------------------
-- DESUGAR
-------------------
}}}}}
-hscBackEnd dflags cg_info_ref prepd_result
- = case dopt_HscLang dflags of
+hscBackEnd dflags
+ ModGuts{ -- This is the last use of the ModGuts in a compilation.
+ -- From now on, we just use the bits we need.
+ mg_module = this_mod,
+ mg_binds = core_binds,
+ mg_types = type_env,
+ mg_dir_imps = dir_imps,
+ mg_foreign = foreign_stubs,
+ mg_deps = dependencies } = do {
+
+ -------------------
+ -- PREPARE FOR CODE GENERATION
+ -- Do saturation and convert to A-normal form
+ prepd_binds <- _scc_ "CorePrep"
+ corePrepPgm dflags core_binds type_env;
+
+ case dopt_HscLang dflags of
HscNothing -> return (False, False, Nothing)
HscInterpreted ->
#ifdef GHCI
do ----------------- Generate byte code ------------------
- comp_bc <- byteCodeGen dflags prepd_result
+ comp_bc <- byteCodeGen dflags prepd_binds type_env
- -- Fill in the code-gen info
- writeIORef cg_info_ref (Just emptyNameEnv)
-
------------------ Create f-x-dynamic C-side stuff ---
(istub_h_exists, istub_c_exists)
- <- outputForeignStubs dflags (mg_foreign prepd_result)
+ <- outputForeignStubs dflags foreign_stubs
- return ( istub_h_exists, istub_c_exists,
- Just comp_bc )
+ return ( istub_h_exists, istub_c_exists, Just comp_bc )
#else
panic "GHC not compiled with interpreter"
#endif
other ->
do
----------------- Convert to STG ------------------
- (stg_binds, cost_centre_info, stg_back_end_info)
- <- _scc_ "CoreToStg"
- myCoreToStg dflags prepd_result
-
- -- Fill in the code-gen info for the earlier tidyCorePgm
- writeIORef cg_info_ref (Just stg_back_end_info)
+ (stg_binds, cost_centre_info) <- _scc_ "CoreToStg"
+ myCoreToStg dflags this_mod prepd_binds
------------------ Code generation ------------------
abstractC <- _scc_ "CodeGen"
- codeGen dflags prepd_result
- cost_centre_info stg_binds
-
+ codeGen dflags this_mod type_env foreign_stubs
+ dir_imps cost_centre_info stg_binds
+
------------------ Code output -----------------------
(stub_h_exists, stub_c_exists)
- <- codeOutput dflags prepd_result
- stg_binds abstractC
-
+ <- codeOutput dflags this_mod foreign_stubs
+ dependencies abstractC
+
return (stub_h_exists, stub_c_exists, Nothing)
+ }
myParseModule dflags src_filename
_scc_ "Parser" do
buf <- hGetStringBuffer src_filename
- let exts = ExtFlags {glasgowExtsEF = dopt Opt_GlasgowExts dflags,
- ffiEF = dopt Opt_FFI dflags,
- withEF = dopt Opt_With dflags,
- parrEF = dopt Opt_PArr dflags}
+ let exts = mkExtFlags dflags
loc = mkSrcLoc (mkFastString src_filename) 1
case parseModule buf (mkPState loc exts) of {
}}
-myCoreToStg dflags (ModGuts {mg_module = this_mod, mg_binds = tidy_binds})
+myCoreToStg dflags this_mod prepd_binds
= do
- () <- coreBindsSize tidy_binds `seq` return ()
- -- TEMP: the above call zaps some space usage allocated by the
- -- simplifier, which for reasons I don't understand, persists
- -- thoroughout code generation -- JRS
- --
- -- This is still necessary. -- SDM (10 Dec 2001)
-
stg_binds <- _scc_ "Core2Stg"
- coreToStg dflags tidy_binds
+ coreToStg dflags prepd_binds
(stg_binds2, cost_centre_info) <- _scc_ "Core2Stg"
stg2stg dflags this_mod stg_binds
- let env_rhs :: CgInfoEnv
- env_rhs = mkNameEnv [ caf_info `seq` (idName bndr, CgInfo caf_info)
- | (bind,_) <- stg_binds2,
- let caf_info
- | stgBindHasCafRefs bind = MayHaveCafRefs
- | otherwise = NoCafRefs,
- bndr <- stgBinders bind ]
-
- return (stg_binds2, cost_centre_info, env_rhs)
+ return (stg_binds2, cost_centre_info)
\end{code}
-- Then desugar, code gen, and link it
; hval <- compileExpr hsc_env pcs1 iNTERACTIVE
- (icPrintUnqual new_ic) tc_expr
+ (ic_rn_gbl_env new_ic)
+ (ic_type_env new_ic)
+ tc_expr
; return (pcs1, Just (new_ic, bound_names, hval))
}}}}}
buf <- stringToStringBuffer str
- let exts = ExtFlags {glasgowExtsEF = dopt Opt_GlasgowExts dflags,
- ffiEF = dopt Opt_FFI dflags,
- withEF = dopt Opt_With dflags,
- parrEF = dopt Opt_PArr dflags}
+ let exts = mkExtFlags dflags
loc = mkSrcLoc FSLIT("<interactive>") 1
case parseStmt buf (mkPState loc exts) of {
myParseIdentifier dflags str
= do buf <- stringToStringBuffer str
- let exts = ExtFlags {glasgowExtsEF = dopt Opt_GlasgowExts dflags,
- ffiEF = dopt Opt_FFI dflags,
- withEF = dopt Opt_With dflags,
- parrEF = dopt Opt_PArr dflags}
+ let exts = mkExtFlags dflags
loc = mkSrcLoc FSLIT("<interactive>") 1
case parseIdentifier buf (mkPState loc exts) of
#ifdef GHCI
compileExpr :: HscEnv
-> PersistentCompilerState
- -> Module -> PrintUnqualified
+ -> Module -> GlobalRdrEnv -> TypeEnv
-> TypecheckedHsExpr
-> IO HValue
-compileExpr hsc_env pcs this_mod print_unqual tc_expr
- = do { let dflags = hsc_dflags hsc_env
-
+compileExpr hsc_env pcs this_mod rdr_env type_env tc_expr
+ = do { let { dflags = hsc_dflags hsc_env ;
+ lint_on = dopt Opt_DoCoreLinting dflags }
+
-- Desugar it
- ; ds_expr <- deSugarExpr hsc_env pcs this_mod print_unqual tc_expr
+ ; ds_expr <- deSugarExpr hsc_env pcs this_mod rdr_env type_env tc_expr
-- Flatten it
; flat_expr <- flattenExpr hsc_env pcs ds_expr
-- Prepare for codegen
; prepd_expr <- corePrepExpr dflags tidy_expr
+ -- Lint if necessary
+ -- ToDo: improve SrcLoc
+ ; if lint_on then
+ case lintUnfolding noSrcLoc [] prepd_expr of
+ Just err -> pprPanic "compileExpr" err
+ Nothing -> return ()
+ else
+ return ()
+
-- Convert to BCOs
; bcos <- coreExprToBCOs dflags prepd_expr
initExternalPackageState :: ExternalPackageState
initExternalPackageState
- = EPS {
- eps_decls = (emptyNameEnv, 0),
- eps_insts = (emptyBag, 0),
- eps_inst_gates = emptyNameSet,
- eps_rules = foldr add_rule (emptyBag, 0) builtinRules,
-
- eps_PIT = emptyPackageIfaceTable,
- eps_PTE = wiredInThingEnv,
- eps_inst_env = emptyInstEnv,
- eps_rule_base = emptyRuleBase }
-
+ = emptyExternalPackageState {
+ eps_rules = foldr add_rule (emptyBag, 0) builtinRules,
+ eps_PTE = wiredInThingEnv,
+ }
where
add_rule (name,rule) (rules, n_slurped)
= (gated_decl `consBag` rules, n_slurped)
where
gated_decl = (gate_fn, (mod, IfaceRuleOut rdr_name rule))
mod = nameModule name
- rdr_name = nameRdrName name
- gate_fn vis_fn = vis_fn name -- Load the rule whenever name is visible
+ rdr_name = nameRdrName name -- Seems a bit of a hack to go back
+ -- to the RdrName
+ gate_fn vis_fn = vis_fn name -- Load the rule whenever name is visible
initOrigNames :: OrigNameCache
-initOrigNames
- = insert knownKeyNames $
- insert (map getName wiredInThings) $
- emptyModuleEnv
- where
- insert names env = foldl extendOrigNameCache env names
+initOrigNames = foldl extendOrigNameCache emptyModuleEnv knownKeyNames
+
+mkExtFlags dflags
+ = ExtFlags { glasgowExtsEF = dopt Opt_GlasgowExts dflags,
+ ffiEF = dopt Opt_FFI dflags,
+ withEF = dopt Opt_With dflags,
+ arrowsEF = dopt Opt_Arrows dflags,
+ parrEF = dopt Opt_PArr dflags}
\end{code}
projects / ghc-hetmet.git / blobdiff