import CoreTidy ( tidyExpr )
import CorePrep ( corePrepExpr )
import Flattening ( flattenExpr )
+import Vectorise ( vectorise )
import Desugar ( deSugarExpr )
import SimplCore ( simplifyExpr )
import TcRnDriver ( tcRnStmt, tcRnExpr, tcRnType )
import RdrName ( GlobalRdrEnv, RdrName, emptyGlobalRdrEnv )
import HsSyn ( HsModule, LHsBinds, HsGroup, LIE, LImportDecl, HsDoc,
HaddockModInfo )
+import CoreSyn
import SrcLoc ( Located(..) )
import StringBuffer ( hGetStringBuffer, stringToStringBuffer )
import Parser
import MkIface ( checkOldIface, mkIface, writeIfaceFile )
import Desugar ( deSugar )
import Flattening ( flatten )
+import Vectorise ( vectorise )
import SimplCore ( core2core )
import TidyPgm ( tidyProgram, mkBootModDetails )
import CorePrep ( corePrepPgm )
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
hscSimplify ds_result
= do hsc_env <- gets compHscEnv
liftIO $ do
- flat_result <- {-# SCC "Flattening" #-}
- flatten hsc_env ds_result
+ vect_result <- {-# SCC "Vectorisation" #-}
+ vectorise hsc_env ds_result
-------------------
-- SIMPLIFY
-------------------
simpl_result <- {-# SCC "Core2Core" #-}
- core2core hsc_env flat_result
+ core2core hsc_env vect_result
return simpl_result
--------------------------------------------------------------
codeGen dflags this_mod data_tycons
foreign_stubs 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
-------------------
; 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_rules = [panic "no rules"],
-- Rules are CoreRules, not the
-- RuleDecls we get out of the typechecker
- md_vect_info =
- panic "HscMain.hscFileCheck: no VectInfo"
+ md_vect_info = noVectInfo
-- VectInfo is added by the Core
-- vectorisation pass
}
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"