, hscSimplify
, hscNormalIface, hscWriteIface, hscGenHardCode
#ifdef GHCI
- , hscStmt, hscTcExpr, hscKcType
+ , hscStmt, hscTcExpr, hscImport, hscKcType
, compileExpr
#endif
, HsCompiler(..)
, hscCompileBatch -- :: Compiler (HscStatus, ModIface, ModDetails)
, hscCompileNothing -- :: Compiler (HscStatus, ModIface, ModDetails)
, hscCompileInteractive -- :: Compiler (InteractiveStatus, ModIface, ModDetails)
+ , hscCheckRecompBackend
, HscStatus' (..)
, InteractiveStatus, HscStatus
import {- Kind parts of -} Type ( Kind )
import CoreLint ( lintUnfolding )
import DsMeta ( templateHaskellNames )
-import SrcLoc ( SrcSpan, noSrcLoc, interactiveSrcLoc, srcLocSpan, noSrcSpan )
+import SrcLoc ( SrcSpan, noSrcLoc, interactiveSrcLoc, srcLocSpan, noSrcSpan, unLoc )
import VarSet
import VarEnv ( emptyTidyEnv )
#endif
import HscTypes
import MkExternalCore ( emitExternalCore )
import FastString
-import LazyUniqFM ( emptyUFM )
+import UniqFM ( emptyUFM )
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"
Just b -> return b
Nothing -> liftIO $ hGetStringBuffer src_filename
- let loc = mkSrcLoc (mkFastString src_filename) 1 0
+ let loc = mkSrcLoc (mkFastString src_filename) 1 1
- case unP parseModule (mkPState buf loc dflags) of
+ case unP parseModule (mkPState dflags buf loc) of
PFailed span err ->
throwOneError (mkPlainErrMsg span err)
-- exception/signal an error.
type RenamedStuff =
(Maybe (HsGroup Name, [LImportDecl Name], Maybe [LIE Name],
- Maybe (HsDoc Name), HaddockModInfo Name))
+ Maybe LHsDocString))
-- | Rename and typecheck a module, additionally returning the renamed syntax
hscTypecheckRename ::
<- {-# 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_hdr = tcg_doc_hdr tc_result
+ ; return (decl,imports,exports,doc_hdr) }
return (tc_result, rn_info)
data HsCompiler a
= HsCompiler {
- -- | The main interface.
- hscCompile :: GhcMonad m =>
- HscEnv -> ModSummary -> Bool
- -> Maybe ModIface -> Maybe (Int, Int)
- -> m a,
-
-- | Called when no recompilation is necessary.
hscNoRecomp :: GhcMonad m =>
ModIface -> m a,
-> do hscMessage mb_mod_index True mod_summary
hscRecompile compiler mod_summary mb_old_hash
+hscCheckRecompBackend :: HsCompiler a -> TcGblEnv -> Compiler a
+hscCheckRecompBackend compiler tc_result
+ hsc_env mod_summary source_unchanged mb_old_iface _m_of_n =
+ withTempSession (\_ -> hsc_env) $ do
+ (recomp_reqd, mb_checked_iface)
+ <- {-# SCC "checkOldIface" #-}
+ liftIO $ checkOldIface hsc_env mod_summary
+ source_unchanged mb_old_iface
+
+ let mb_old_hash = fmap mi_iface_hash mb_checked_iface
+ case mb_checked_iface of
+ Just iface | not recomp_reqd
+ -> hscNoRecomp compiler iface{ mi_globals = Just (tcg_rdr_env tc_result) }
+ _otherwise
+ -> hscBackend compiler tc_result mod_summary mb_old_hash
+
genericHscRecompile :: GhcMonad m =>
HsCompiler a
-> ModSummary -> Maybe Fingerprint
hscOneShotCompiler =
HsCompiler {
- hscCompile = \hsc_env mod_summary src_changed mb_old_iface mb_i_of_n -> do
- -- One-shot mode needs a knot-tying mutable variable for interface
- -- files. See TcRnTypes.TcGblEnv.tcg_type_env_var.
- type_env_var <- liftIO $ newIORef emptyNameEnv
- let
- mod = ms_mod mod_summary
- hsc_env' = hsc_env{ hsc_type_env_var = Just (mod, type_env_var) }
- ---
- genericHscCompile hscOneShotCompiler
- oneShotMsg hsc_env' mod_summary src_changed
- mb_old_iface mb_i_of_n
-
- , hscNoRecomp = \_old_iface -> do
+ hscNoRecomp = \_old_iface -> do
withSession (liftIO . dumpIfaceStats)
return HscNoRecomp
, hscRecompile = genericHscRecompile hscOneShotCompiler
- , hscBackend = genericHscBackend hscOneShotCompiler
+ , hscBackend = \ tc_result mod_summary mb_old_hash -> do
+ hsc_env <- getSession
+ case hscTarget (hsc_dflags hsc_env) of
+ HscNothing -> return (HscRecomp False ())
+ _otherw -> genericHscBackend hscOneShotCompiler
+ tc_result mod_summary mb_old_hash
, hscGenBootOutput = \tc_result mod_summary mb_old_iface -> do
(iface, changed, _) <- hscSimpleIface tc_result mb_old_iface
-- Compile Haskell, boot and extCore in OneShot mode.
hscCompileOneShot :: Compiler OneShotResult
-hscCompileOneShot = hscCompile hscOneShotCompiler
+hscCompileOneShot hsc_env mod_summary src_changed mb_old_iface mb_i_of_n = do
+ -- One-shot mode needs a knot-tying mutable variable for interface
+ -- files. See TcRnTypes.TcGblEnv.tcg_type_env_var.
+ type_env_var <- liftIO $ newIORef emptyNameEnv
+ let
+ mod = ms_mod mod_summary
+ hsc_env' = hsc_env{ hsc_type_env_var = Just (mod, type_env_var) }
+ ---
+ genericHscCompile hscOneShotCompiler
+ oneShotMsg hsc_env' mod_summary src_changed
+ mb_old_iface mb_i_of_n
+
--------------------------------------------------------------
hscBatchCompiler =
HsCompiler {
- hscCompile = genericHscCompile hscBatchCompiler batchMsg
-
- , hscNoRecomp = \iface -> do
+ hscNoRecomp = \iface -> do
details <- genModDetails iface
return (HscNoRecomp, iface, details)
-- Compile Haskell, boot and extCore in batch mode.
hscCompileBatch :: Compiler (HscStatus, ModIface, ModDetails)
-hscCompileBatch = hscCompile hscBatchCompiler
+hscCompileBatch = genericHscCompile hscBatchCompiler batchMsg
--------------------------------------------------------------
hscInteractiveCompiler :: HsCompiler InteractiveResult
hscInteractiveCompiler =
HsCompiler {
- hscCompile = genericHscCompile hscInteractiveCompiler batchMsg
-
- , hscNoRecomp = \iface -> do
+ hscNoRecomp = \iface -> do
details <- genModDetails iface
return (HscNoRecomp, iface, details)
-- Compile Haskell, extCore to bytecode.
hscCompileInteractive :: Compiler (InteractiveStatus, ModIface, ModDetails)
-hscCompileInteractive = hscCompile hscInteractiveCompiler
+hscCompileInteractive = genericHscCompile hscInteractiveCompiler batchMsg
--------------------------------------------------------------
hscNothingCompiler :: HsCompiler NothingResult
hscNothingCompiler =
HsCompiler {
- hscCompile = genericHscCompile hscNothingCompiler batchMsg
-
- , hscNoRecomp = \iface -> do
+ hscNoRecomp = \iface -> do
details <- genModDetails iface
return (HscNoRecomp, iface, details)
- , hscRecompile = \mod_summary mb_old_hash ->
- case ms_hsc_src mod_summary of
- ExtCoreFile ->
- panic "hscCompileNothing: cannot do external core"
- _otherwise -> do
- tc_result <- hscFileFrontEnd mod_summary
- hscBackend hscNothingCompiler tc_result mod_summary mb_old_hash
+ , hscRecompile = genericHscRecompile hscNothingCompiler
, hscBackend = \tc_result _mod_summary mb_old_iface -> do
(iface, _changed, details) <- hscSimpleIface tc_result mb_old_iface
, hscGenOutput = \_ _ _ ->
panic "hscCompileNothing: hscGenOutput should not be called"
}
+
-- Type-check Haskell and .hs-boot only (no external core)
hscCompileNothing :: Compiler (HscStatus, ModIface, ModDetails)
-hscCompileNothing = hscCompile hscNothingCompiler
+hscCompileNothing = genericHscCompile hscNothingCompiler batchMsg
--------------------------------------------------------------
-- NoRecomp handlers
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
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"
-> HpcInfo
-> IO [Cmm]
tryNewCodeGen hsc_env this_mod data_tycons imported_mods
- cost_centre_info stg_binds hpc_info
- | not (dopt Opt_TryNewCodeGen (hsc_dflags hsc_env))
- = return []
- | otherwise
- = do { let dflags = hsc_dflags hsc_env
+ cost_centre_info stg_binds hpc_info =
+ do { let dflags = hsc_dflags hsc_env
; prog <- StgCmm.codeGen dflags this_mod data_tycons imported_mods
cost_centre_info stg_binds hpc_info
; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Cmm produced by new codegen"
; prog <- return $ map (runTx $ runCmmOpts cmmCfgOptsZ) prog
-- Control flow optimisation
- -- Note: Have to thread the module's SRT through all the procedures
- -- because we greedily build it as we go.
+ -- We are building a single SRT for the entire module, so
+ -- we must thread it through all the procedures as we cps-convert them.
; us <- mkSplitUniqSupply 'S'
; let topSRT = initUs_ us emptySRT
; (topSRT, prog) <- foldM (protoCmmCPSZ hsc_env) (topSRT, []) prog
; 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
return $ Just (ids, hval)
+hscImport :: GhcMonad m => HscEnv -> String -> m (ImportDecl RdrName)
+hscImport hsc_env str = do
+ (L _ (HsModule{hsmodImports=is})) <- hscParseThing parseModule (hsc_dflags hsc_env) str
+ case is of
+ [i] -> return (unLoc i)
+ _ -> throwOneError (mkPlainErrMsg noSrcSpan (ptext (sLit "parse error in import declaration")))
hscTcExpr -- Typecheck an expression (but don't run it)
:: GhcMonad m =>
buf <- liftIO $ stringToStringBuffer str
- let loc = mkSrcLoc (fsLit "<interactive>") 1 0
+ let loc = mkSrcLoc (fsLit "<interactive>") 1 1
- case unP parser (mkPState buf loc dflags) of
+ case unP parser (mkPState dflags buf loc) of
PFailed span err -> do
let msg = mkPlainErrMsg span err
projects / ghc-hetmet.git / blobdiff