\section[GHC_Main]{Main driver for Glasgow Haskell compiler}
\begin{code}
-module HscMain ( HscResult(..), hscMain, hscExpr, hscTypeExpr,
+module HscMain ( HscResult(..), hscMain,
+#ifdef GHCI
+ hscExpr, hscTypeExpr,
+#endif
initPersistentCompilerState ) where
#include "HsVersions.h"
import RdrHsSyn ( RdrNameHsExpr )
import CoreToStg ( coreToStgExpr )
import StringBuffer ( stringToStringBuffer, freeStringBuffer )
+import Unique ( Uniquable(..) )
+import Type ( splitTyConApp_maybe )
+import PrelNames ( ioTyConKey )
#endif
import HsSyn
writeIface, pprIface )
import TcModule
import Type
-import TcHsSyn
import InstEnv ( emptyInstEnv )
import Desugar
import SimplCore
-import OccurAnal ( occurAnalyseBinds )
import CoreUtils ( coreBindsSize )
import CoreTidy ( tidyCorePgm )
import CoreToStg ( topCoreBindsToStg )
import CmdLineOpts
import ErrUtils ( dumpIfSet_dyn, showPass )
import Util ( unJust )
-import Unique ( Uniquable(..) )
-import PrelNames ( ioTyConKey )
import UniqSupply ( mkSplitUniqSupply )
import Bag ( emptyBag )
HomeSymbolTable,
OrigNameEnv(..), PackageRuleBase, HomeIfaceTable,
typeEnvClasses, typeEnvTyCons, emptyIfaceTable )
-import Type ( splitTyConApp_maybe )
import FiniteMap ( FiniteMap, plusFM, emptyFM, addToFM )
import OccName ( OccName )
import Name ( Name, nameModule, nameOccName, getName )
Just (pcs_tc, tc_result) -> do {
let env_tc = tc_env tc_result
- local_insts = tc_insts tc_result
local_rules = tc_rules tc_result
;
-- create a new details from the closed, typechecked, old iface
- let new_details = mkModDetailsFromIface env_tc local_insts local_rules
+ let new_details = mkModDetailsFromIface env_tc local_rules
;
return (HscNoRecomp pcs_tc new_details old_iface)
}}}}
-------------------
-- RENAME
-------------------
- ; showPass dflags "Rename"
; (pcs_rn, maybe_rn_result)
<- renameModule dflags hit hst pcs_ch this_mod rdr_module
; case maybe_rn_result of {
-------------------
-- TYPECHECK
-------------------
- ; showPass dflags "Typecheck"
; maybe_tc_result <- typecheckModule dflags pcs_rn hst new_iface
print_unqualified rn_hs_decls
; case maybe_tc_result of {
Nothing -> return (HscFail pcs_rn);
Just (pcs_tc, tc_result) -> do {
- ; let env_tc = tc_env tc_result
- local_insts = tc_insts tc_result
+ ; let env_tc = tc_env tc_result
-------------------
-- DESUGAR, SIMPLIFY, TIDY-CORE
-- We grab the the unfoldings at this point.
; simpl_result <- dsThenSimplThenTidy dflags pcs_tc hst this_mod
print_unqualified is_exported tc_result
- ; let (tidy_binds, orphan_rules, foreign_stuff) = simpl_result
+ ; let (pcs_simpl, tidy_binds, orphan_rules, foreign_stuff) = simpl_result
-------------------
-- CONVERT TO STG
-------------------
- ; (stg_binds, oa_tidy_binds, cost_centre_info, top_level_ids)
+ ; (stg_binds, cost_centre_info, top_level_ids)
<- myCoreToStg dflags this_mod tidy_binds
-------------------
-- BUILD THE NEW ModDetails AND ModIface
-------------------
- ; let new_details = mkModDetails env_tc local_insts tidy_binds
+ ; let new_details = mkModDetails env_tc tidy_binds
top_level_ids orphan_rules
; final_iface <- mkFinalIface ghci_mode dflags location
maybe_checked_iface new_iface new_details
; (maybe_stub_h_filename, maybe_stub_c_filename, maybe_ibinds)
<- restOfCodeGeneration dflags toInterp this_mod
(map ideclName (hsModuleImports rdr_module))
- cost_centre_info foreign_stuff env_tc stg_binds oa_tidy_binds
- hit (pcs_PIT pcs_tc)
+ cost_centre_info foreign_stuff env_tc stg_binds tidy_binds
+ hit (pcs_PIT pcs_simpl)
-- and the answer is ...
- ; return (HscRecomp pcs_tc new_details final_iface
+ ; return (HscRecomp pcs_simpl new_details final_iface
maybe_stub_h_filename maybe_stub_c_filename
maybe_ibinds)
}}}}}}}
restOfCodeGeneration dflags toInterp this_mod imported_module_names cost_centre_info
- foreign_stuff env_tc stg_binds oa_tidy_binds
+ foreign_stuff env_tc stg_binds tidy_binds
hit pit -- these last two for mapping ModNames to Modules
| toInterp
= do (ibinds,itbl_env)
-- _scc_ "CodeOutput"
(maybe_stub_h_name, maybe_stub_c_name)
<- codeOutput dflags this_mod local_tycons
- oa_tidy_binds stg_binds
+ tidy_binds stg_binds
c_code h_code abstractC
return (maybe_stub_h_name, maybe_stub_c_name, Nothing)
dsThenSimplThenTidy dflags pcs hst this_mod print_unqual is_exported tc_result
= do -------------------------- Desugaring ----------------
- showPass dflags "DeSugar"
-- _scc_ "DeSugar"
(desugared, rules, h_code, c_code, fe_binders)
<- deSugar dflags pcs hst this_mod print_unqual tc_result
<- core2core dflags pcs hst is_exported desugared rules
-- Do the final tidy-up
- showPass dflags "TidyCore"
- (tidy_binds, tidy_orphan_rules)
- <- tidyCorePgm dflags this_mod simplified orphan_rules
+ (pcs', tidy_binds, tidy_orphan_rules)
+ <- tidyCorePgm dflags this_mod pcs simplified orphan_rules
- return (tidy_binds, tidy_orphan_rules, (fe_binders,h_code,c_code))
+ return (pcs', tidy_binds, tidy_orphan_rules, (fe_binders,h_code,c_code))
myCoreToStg dflags this_mod tidy_binds
= do
- st_uniqs <- mkSplitUniqSupply 'g'
- let occ_anal_tidy_binds = occurAnalyseBinds tidy_binds
-
- () <- coreBindsSize occ_anal_tidy_binds `seq` return ()
+ () <- 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
-- _scc_ "Core2Stg"
- stg_binds <- topCoreBindsToStg dflags occ_anal_tidy_binds
+ stg_binds <- topCoreBindsToStg dflags this_mod tidy_binds
- showPass dflags "Stg2Stg"
-- _scc_ "Stg2Stg"
- (stg_binds2, cost_centre_info) <- stg2stg dflags this_mod st_uniqs stg_binds
+ (stg_binds2, cost_centre_info) <- stg2stg dflags this_mod stg_binds
let final_ids = collectFinalStgBinders (map fst stg_binds2)
- return (stg_binds2, occ_anal_tidy_binds, cost_centre_info, final_ids)
+ return (stg_binds2, cost_centre_info, final_ids)
\end{code}
-> PersistentCompilerState -- IN: persistent compiler state
-> Module -- Context for compiling
-> String -- The expression
- -> IO (PersistentCompilerState, Maybe Type)
+ -> IO (PersistentCompilerState, Maybe (PrintUnqualified, Type))
hscTypeExpr dflags hst hit pcs0 this_module expr
= do (pcs1, maybe_tc_result)
<- hscExprFrontEnd dflags hst hit pcs0 this_module expr
case maybe_tc_result of
Nothing -> return (pcs1, Nothing)
- Just (_,_,ty) -> return (pcs1, Just ty)
+ Just (print_unqual,_,ty) -> return (pcs1, Just (print_unqual,ty))
hscParseExpr :: DynFlags -> String -> IO (Maybe RdrNameHsExpr)
hscParseExpr dflags str
projects / ghc-hetmet.git / blobdiff