\section[GHC_Main]{Main driver for Glasgow Haskell compiler}
\begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/CodingStyle#Warnings
+-- for details
+
module HscMain
( newHscEnv, hscCmmFile
, hscFileCheck
import RdrName ( GlobalRdrEnv, RdrName, emptyGlobalRdrEnv )
import HsSyn ( HsModule, LHsBinds, HsGroup, LIE, LImportDecl, HsDoc,
HaddockModInfo )
+import CoreSyn
import SrcLoc ( Located(..) )
-import StringBuffer ( hGetStringBuffer, stringToStringBuffer )
+import StringBuffer
import Parser
import Lexer
import SrcLoc ( mkSrcLoc )
import SimplStg ( stg2stg )
import CodeGen ( codeGen )
import CmmParse ( parseCmmFile )
+import CmmCPS
+import CmmInfo
import CodeOutput ( codeOutput )
import NameEnv ( emptyNameEnv )
Maybe (HsDoc Name), HaddockModInfo Name))
-- typechecked
(Maybe (LHsBinds Id, GlobalRdrEnv, ModDetails))
-
+ -- desugared
+ (Maybe [CoreBind])
-- Status of a compilation to hard-code or nothing.
data HscStatus
liftIO $ do
if recomp
then showMsg "Compiling "
- else if verbosity (hsc_dflags hsc_env) >= 1
+ else if verbosity (hsc_dflags hsc_env) >= 2
then showMsg "Skipping "
else return ()
hscSimplify ds_result
= do hsc_env <- gets compHscEnv
liftIO $ do
- flat_result <- {-# SCC "Flattening" #-}
- flatten hsc_env ds_result
-------------------
-- SIMPLIFY
-------------------
simpl_result <- {-# SCC "Core2Core" #-}
- core2core hsc_env flat_result
+ core2core hsc_env ds_result
return simpl_result
--------------------------------------------------------------
------------------ Code generation ------------------
abstractC <- {-# SCC "CodeGen" #-}
codeGen dflags this_mod data_tycons
- foreign_stubs dir_imps cost_centre_info
+ dir_imps cost_centre_info
stg_binds hpc_info
+ ------------------ Convert to CPS --------------------
+ --continuationC <- cmmCPS dflags abstractC >>= cmmToRawCmm
+ continuationC <- cmmToRawCmm abstractC
------------------ Code output -----------------------
(stub_h_exists,stub_c_exists)
<- codeOutput dflags this_mod location foreign_stubs
- dependencies abstractC
+ dependencies continuationC
return stub_c_exists
hscConst :: b -> a -> Comp b
------------------------------
-hscFileCheck :: HscEnv -> ModSummary -> IO (Maybe HscChecked)
-hscFileCheck hsc_env mod_summary = do {
+hscFileCheck :: HscEnv -> ModSummary -> Bool -> IO (Maybe HscChecked)
+hscFileCheck hsc_env mod_summary compileToCore = do {
-------------------
-- PARSE
-------------------
-- RENAME and TYPECHECK
-------------------
(tc_msgs, maybe_tc_result)
- <- _scc_ "Typecheck-Rename"
+ <- {-# SCC "Typecheck-Rename" #-}
tcRnModule hsc_env (ms_hsc_src mod_summary)
True{-save renamed syntax-}
rdr_module
; printErrorsAndWarnings dflags tc_msgs
; case maybe_tc_result of {
- Nothing -> return (Just (HscChecked rdr_module Nothing Nothing));
+ Nothing -> return (Just (HscChecked rdr_module Nothing Nothing Nothing));
Just tc_result -> do
let type_env = tcg_type_env tc_result
md = ModDetails {
md_insts = tcg_insts tc_result,
md_fam_insts = tcg_fam_insts tc_result,
md_modBreaks = emptyModBreaks,
- md_rules = [panic "no rules"] }
+ md_rules = [panic "no rules"],
-- Rules are CoreRules, not the
-- RuleDecls we get out of the typechecker
+ md_vect_info = noVectInfo
+ -- VectInfo is added by the Core
+ -- vectorisation pass
+ }
rnInfo = do decl <- tcg_rn_decls tc_result
imports <- tcg_rn_imports tc_result
let exports = tcg_rn_exports tc_result
let doc = tcg_doc tc_result
hmi = tcg_hmi tc_result
return (decl,imports,exports,doc,hmi)
- return (Just (HscChecked rdr_module
+ maybeModGuts <-
+ if compileToCore then
+ deSugar hsc_env (ms_location mod_summary) tc_result
+ else
+ return Nothing
+ return (Just (HscChecked rdr_module
rnInfo
(Just (tcg_binds tc_result,
tcg_rdr_env tc_result,
- md))))
+ md))
+ (fmap mg_binds maybeModGuts)))
}}}}
case maybe_cmm of
Nothing -> return False
Just cmm -> do
- codeOutput dflags no_mod no_loc NoStubs [] [cmm]
+ --continuationC <- cmmCPS dflags [cmm] >>= cmmToRawCmm
+ continuationC <- cmmToRawCmm [cmm]
+ codeOutput dflags no_mod no_loc NoStubs [] continuationC
return True
where
no_mod = panic "hscCmmFile: no_mod"
ml_obj_file = panic "hscCmmFile: no obj file" }
+myParseModule :: DynFlags -> FilePath -> Maybe StringBuffer
+ -> IO (Either ErrMsg (Located (HsModule RdrName)))
myParseModule dflags src_filename maybe_src_buf
= -------------------------- Parser ----------------
showPass dflags "Parser" >>
hscStmt -- Compile a stmt all the way to an HValue, but don't run it
:: HscEnv
-> String -- The statement
- -> IO (Maybe (InteractiveContext, [Name], HValue))
+ -> IO (Maybe ([Id], HValue))
hscStmt hsc_env stmt
= do { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) stmt
; case maybe_tc_result of {
Nothing -> return Nothing ;
- Just (new_ic, bound_names, tc_expr) -> do {
-
+ Just (ids, tc_expr) -> do {
-- Desugar it
- ; let rdr_env = ic_rn_gbl_env new_ic
- type_env = ic_type_env new_ic
+ ; let rdr_env = ic_rn_gbl_env icontext
+ type_env = mkTypeEnv (map AnId (ic_tmp_ids icontext))
; mb_ds_expr <- deSugarExpr hsc_env iNTERACTIVE rdr_env type_env tc_expr
; case mb_ds_expr of {
; let src_span = srcLocSpan interactiveSrcLoc
; hval <- compileExpr hsc_env src_span ds_expr
- ; return (Just (new_ic, bound_names, hval))
+ ; return (Just (ids, hval))
}}}}}}}
hscTcExpr -- Typecheck an expression (but don't run it)
projects / ghc-hetmet.git / blobdiff