, hscStmt, hscTcExpr, hscKcType
, compileExpr
#endif
+ , HsCompiler(..)
+ , hscOneShotCompiler, hscNothingCompiler
+ , hscInteractiveCompiler, hscBatchCompiler
, hscCompileOneShot -- :: Compiler HscStatus
, hscCompileBatch -- :: Compiler (HscStatus, ModIface, ModDetails)
, hscCompileNothing -- :: Compiler (HscStatus, ModIface, ModDetails)
import UniqSupply ( initUs_ )
import Bag ( unitBag )
import Exception
-import MonadUtils
+-- import MonadUtils
import Control.Monad
-import System.IO
+-- import System.IO
import Data.IORef
\end{code}
#include "HsVersions.h"
<- {-# SCC "Typecheck-Rename" #-}
ioMsgMaybe $ tcRnModule hsc_env (ms_hsc_src mod_summary) True rdr_module
- let rn_info = 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
- let hmi = tcg_hmi tc_result
- return (decl,imports,exports,doc,hmi)
+ let -- This 'do' is in the Maybe monad!
+ rn_info = do { decl <- tcg_rn_decls tc_result
+ ; let imports = tcg_rn_imports tc_result
+ exports = tcg_rn_exports tc_result
+ doc = tcg_doc tc_result
+ hmi = tcg_hmi tc_result
+ ; return (decl,imports,exports,doc,hmi) }
return (tc_result, rn_info)
-- result type. Therefore we need to artificially distinguish some types. We
-- do this by adding type tags which will simply be ignored by the caller.
type HscStatus = HscStatus' ()
-type InteractiveStatus = HscStatus' (CompiledByteCode, ModBreaks)
+type InteractiveStatus = HscStatus' (Maybe (CompiledByteCode, ModBreaks))
+ -- INVARIANT: result is @Nothing@ <=> input was a boot file
type OneShotResult = HscStatus
type BatchResult = (HscStatus, ModIface, ModDetails)
hscRecompile :: GhcMonad m =>
ModSummary -> Maybe Fingerprint -> m a,
+ hscBackend :: GhcMonad m =>
+ TcGblEnv -> ModSummary -> Maybe Fingerprint -> m a,
+
-- | Code generation for Boot modules.
hscGenBootOutput :: GhcMonad m =>
TcGblEnv -> ModSummary -> Maybe Fingerprint -> m a,
panic "GHC does not currently support reading External Core files"
| otherwise = do
tc_result <- hscFileFrontEnd mod_summary
- case ms_hsc_src mod_summary of
- HsBootFile ->
- hscGenBootOutput compiler tc_result mod_summary mb_old_hash
- _other -> do
- guts <- hscDesugar mod_summary tc_result
- hscGenOutput compiler guts mod_summary mb_old_hash
+ hscBackend compiler tc_result mod_summary mb_old_hash
+
+genericHscBackend :: GhcMonad m =>
+ HsCompiler a
+ -> TcGblEnv -> ModSummary -> Maybe Fingerprint
+ -> m a
+genericHscBackend compiler tc_result mod_summary mb_old_hash
+ | HsBootFile <- ms_hsc_src mod_summary =
+ hscGenBootOutput compiler tc_result mod_summary mb_old_hash
+ | otherwise = do
+ guts <- hscDesugar mod_summary tc_result
+ hscGenOutput compiler guts mod_summary mb_old_hash
--------------------------------------------------------------
-- Compilers
, hscRecompile = genericHscRecompile hscOneShotCompiler
+ , hscBackend = genericHscBackend hscOneShotCompiler
+
, hscGenBootOutput = \tc_result mod_summary mb_old_iface -> do
(iface, changed, _) <- hscSimpleIface tc_result mb_old_iface
hscWriteIface iface changed mod_summary
, hscRecompile = genericHscRecompile hscBatchCompiler
+ , hscBackend = genericHscBackend hscBatchCompiler
+
, hscGenBootOutput = \tc_result mod_summary mb_old_iface -> do
(iface, changed, details)
<- hscSimpleIface tc_result mb_old_iface
, hscRecompile = genericHscRecompile hscInteractiveCompiler
- , hscGenBootOutput = \_ _ _ -> panic "hscCompileInteractive: HsBootFile"
+ , hscBackend = genericHscBackend hscInteractiveCompiler
+
+ , hscGenBootOutput = \tc_result _mod_summary mb_old_iface -> do
+ (iface, _changed, details) <- hscSimpleIface tc_result mb_old_iface
+ return (HscRecomp False Nothing, iface, details)
, hscGenOutput = \guts0 mod_summary mb_old_iface -> do
guts <- hscSimplify guts0
panic "hscCompileNothing: cannot do external core"
_otherwise -> do
tc_result <- hscFileFrontEnd mod_summary
- hscGenBootOutput hscNothingCompiler tc_result mod_summary mb_old_hash
+ hscBackend hscNothingCompiler tc_result mod_summary mb_old_hash
- , hscGenBootOutput = \tc_result _mod_summary mb_old_iface -> do
+ , hscBackend = \tc_result _mod_summary mb_old_iface -> do
(iface, _changed, details) <- hscSimpleIface tc_result mb_old_iface
return (HscRecomp False (), iface, details)
+ , hscGenBootOutput = \_ _ _ ->
+ panic "hscCompileNothing: hscGenBootOutput should not be called"
+
, hscGenOutput = \_ _ _ ->
panic "hscCompileNothing: hscGenOutput should not be called"
}
stg_binds hpc_info
--- Optionally run experimental Cmm transformations ---
- cmms <- optionallyConvertAndOrCPS hsc_env cmms
+ -- cmms <- optionallyConvertAndOrCPS hsc_env cmms
-- unless certain dflags are on, the identity function
------------------ Code output -----------------------
rawcmms <- cmmToRawCmm cmms
+ dumpIfSet_dyn dflags Opt_D_dump_cmmz "Raw Cmm" (ppr rawcmms)
(_stub_h_exists, stub_c_exists)
<- codeOutput dflags this_mod location foreign_stubs
dependencies rawcmms
------------------ Create f-x-dynamic C-side stuff ---
(_istub_h_exists, istub_c_exists)
<- outputForeignStubs dflags this_mod location foreign_stubs
- return (HscRecomp istub_c_exists (comp_bc, mod_breaks), iface, details)
+ return (HscRecomp istub_c_exists (Just (comp_bc, mod_breaks))
+ , iface, details)
#else
hscInteractive _ _ = panic "GHC not compiled with interpreter"
#endif
parseCmmFile dflags filename
cmms <- liftIO $ optionallyConvertAndOrCPS hsc_env [cmm]
rawCmms <- liftIO $ cmmToRawCmm cmms
- liftIO $ codeOutput dflags no_mod no_loc NoStubs [] rawCmms
+ _ <- liftIO $ codeOutput dflags no_mod no_loc NoStubs [] rawCmms
return ()
where
no_mod = panic "hscCmmFile: no_mod"
; prog <- return $ map (runTx $ runCmmOpts cmmCfgOptsZ) (srtToData topSRT : prog)
-- Control flow optimisation, again
- ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" (pprCmms prog)
-
; let prog' = map cmmOfZgraph prog
- ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Raw Cmm" (ppr prog')
+ ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" (ppr prog')
; return prog' }
let cvt = cmmOfZgraph $ cfopts $ chosen_graph
dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- post-conversion" (ppr cvt)
return cvt
- -- return cmm -- don't use the conversion
myCoreToStg :: DynFlags -> Module -> [CoreBind]
-> IO ( [(StgBinding,[(Id,[Id])])] -- output program
projects / ghc-hetmet.git / blobdiff