, makeSimpleDetails
) where
-#include "HsVersions.h"
-
#ifdef GHCI
import CodeOutput ( outputForeignStubs )
import ByteCodeGen ( byteCodeGen, coreExprToBCOs )
import Linker ( HValue, linkExpr )
import CoreTidy ( tidyExpr )
import CorePrep ( corePrepExpr )
-import Flattening ( flattenExpr )
import Desugar ( deSugarExpr )
import SimplCore ( simplifyExpr )
import TcRnDriver ( tcRnStmt, tcRnExpr, tcRnType )
import Parser
import Lexer
import SrcLoc ( mkSrcLoc )
-import TcRnDriver ( tcRnModule, tcRnExtCore )
+import TcRnDriver ( tcRnModule )
import TcIface ( typecheckIface )
import TcRnMonad ( initIfaceCheck, TcGblEnv(..) )
import IfaceEnv ( initNameCache )
import CmmCPS
import CmmCPSZ
import CmmInfo
+import OptimizationFuel ( initOptFuelState )
import CmmCvt
import CmmTx
import CmmContFlowOpt
import HscStats ( ppSourceStats )
import HscTypes
import MkExternalCore ( emitExternalCore )
-import ParserCore
-import ParserCoreUtils
import FastString
-import UniqFM ( emptyUFM )
+import LazyUniqFM ( emptyUFM )
import UniqSupply ( initUs_ )
import Bag ( unitBag )
; us <- mkSplitUniqSupply 'r'
; nc_var <- newIORef (initNameCache us knownKeyNames)
; fc_var <- newIORef emptyUFM
- ; mlc_var <- newIORef emptyModuleEnv
+ ; mlc_var <- newIORef emptyModuleEnv
+ ; optFuel <- initOptFuelState
; return (HscEnv { hsc_dflags = dflags,
hsc_targets = [],
hsc_mod_graph = [],
- hsc_IC = emptyInteractiveContext,
- hsc_HPT = emptyHomePackageTable,
- hsc_EPS = eps_var,
- hsc_NC = nc_var,
- hsc_FC = fc_var,
- hsc_MLC = mlc_var,
+ hsc_IC = emptyInteractiveContext,
+ hsc_HPT = emptyHomePackageTable,
+ hsc_EPS = eps_var,
+ hsc_NC = nc_var,
+ hsc_FC = fc_var,
+ hsc_MLC = mlc_var,
+ hsc_OptFuel = optFuel,
+ hsc_type_env_var = Nothing,
hsc_global_rdr_env = emptyGlobalRdrEnv,
hsc_global_type_env = emptyNameEnv } ) }
makeSimpleIface :: HscEnv -> Maybe ModIface -> TcGblEnv -> ModDetails
-> IO (ModIface,Bool)
makeSimpleIface hsc_env maybe_old_iface tc_result details = do
- mkIfaceTc hsc_env maybe_old_iface details tc_result
+ mkIfaceTc hsc_env (fmap mi_iface_hash maybe_old_iface) details tc_result
-- | Make a 'ModDetails' from the results of typechecking. Used when
-- typechecking only, as opposed to full compilation.
-- Compile Haskell, boot and extCore in OneShot mode.
hscCompileOneShot :: Compiler HscStatus
-hscCompileOneShot
+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 <- newIORef emptyNameEnv
+ let
+ mod = ms_mod mod_summary
+ hsc_env' = hsc_env{ hsc_type_env_var = Just (mod, type_env_var) }
+ ---
+ hscCompilerOneShot' hsc_env' mod_summary src_changed mb_old_iface mb_i_of_n
+
+hscCompilerOneShot' :: Compiler HscStatus
+hscCompilerOneShot'
= hscCompiler norecompOneShot oneShotMsg (genComp backend boot_backend)
where
backend inp = hscSimplify inp >>= hscNormalIface >>= hscWriteIface >>= hscOneShot
genComp backend boot_backend = do
mod_summary <- gets compModSummary
case ms_hsc_src mod_summary of
- ExtCoreFile -> do
- mb_modguts <- hscCoreFrontEnd
- case mb_modguts of
- Nothing -> return Nothing
- Just guts -> backend guts
+ ExtCoreFile -> do
+ panic "GHC does not currently support reading External Core files"
_not_core -> do
mb_tc <- hscFileFrontEnd
case mb_tc of
--------------------------------------------------------------
-- FrontEnds
--------------------------------------------------------------
-
-hscCoreFrontEnd :: Comp (Maybe ModGuts)
-hscCoreFrontEnd =
- do hsc_env <- gets compHscEnv
- mod_summary <- gets compModSummary
- liftIO $ do
- -------------------
- -- PARSE
- -------------------
- inp <- readFile (ms_hspp_file mod_summary)
- case parseCore inp 1 of
- FailP s
- -> do errorMsg (hsc_dflags hsc_env) (text s{-ToDo: wrong-})
- return Nothing
- OkP rdr_module
- -------------------
- -- RENAME and TYPECHECK
- -------------------
- -> do (tc_msgs, maybe_tc_result) <- {-# SCC "TypeCheck" #-}
- tcRnExtCore hsc_env rdr_module
- printErrorsAndWarnings (hsc_dflags hsc_env) tc_msgs
- case maybe_tc_result of
- Nothing -> return Nothing
- Just mod_guts -> return (Just mod_guts) -- No desugaring to do!
-
-
hscFileFrontEnd :: Comp (Maybe TcGblEnv)
hscFileFrontEnd =
do hsc_env <- gets compHscEnv
details <- mkBootModDetailsTc hsc_env tc_result
(new_iface, no_change)
<- {-# SCC "MkFinalIface" #-}
- mkIfaceTc hsc_env maybe_old_iface details tc_result
+ mkIfaceTc hsc_env (fmap mi_iface_hash maybe_old_iface) details tc_result
-- And the answer is ...
dumpIfaceStats hsc_env
return (new_iface, no_change, details, tc_result)
-- until after code output
(new_iface, no_change)
<- {-# SCC "MkFinalIface" #-}
- mkIface hsc_env maybe_old_iface details simpl_result
+ mkIface hsc_env (fmap mi_iface_hash maybe_old_iface)
+ details simpl_result
-- Emit external core
- emitExternalCore (hsc_dflags hsc_env) (availsToNameSet (mg_exports simpl_result)) cg_guts -- Move this? --Lemmih 03/07/2006
+ -- This should definitely be here and not after CorePrep,
+ -- because CorePrep produces unqualified constructor wrapper declarations,
+ -- so its output isn't valid External Core (without some preprocessing).
+ emitExternalCore (hsc_dflags hsc_env) cg_guts
dumpIfaceStats hsc_env
-------------------
dir_imps cost_centre_info
stg_binds hpc_info
--- Optionally run experimental Cmm transformations ---
- cmms <- optionallyConvertAndOrCPS dflags cmms
+ cmms <- optionallyConvertAndOrCPS hsc_env cmms
-- ^ unless certain dflags are on, the identity function
------------------ Code output -----------------------
rawcmms <- cmmToRawCmm cmms
------------------------------
-hscCmmFile :: DynFlags -> FilePath -> IO Bool
-hscCmmFile dflags filename = do
+hscCmmFile :: HscEnv -> FilePath -> IO Bool
+hscCmmFile hsc_env filename = do
+ dflags <- return $ hsc_dflags hsc_env
maybe_cmm <- parseCmmFile dflags filename
case maybe_cmm of
Nothing -> return False
Just cmm -> do
- cmms <- optionallyConvertAndOrCPS dflags [cmm]
+ cmms <- optionallyConvertAndOrCPS hsc_env [cmm]
rawCmms <- cmmToRawCmm cmms
codeOutput dflags no_mod no_loc NoStubs [] rawCmms
return True
ml_hi_file = panic "hscCmmFile: no hi file",
ml_obj_file = panic "hscCmmFile: no obj file" }
-optionallyConvertAndOrCPS :: DynFlags -> [Cmm] -> IO [Cmm]
-optionallyConvertAndOrCPS dflags cmms =
- do -------- Optionally convert to and from zipper ------
+optionallyConvertAndOrCPS :: HscEnv -> [Cmm] -> IO [Cmm]
+optionallyConvertAndOrCPS hsc_env cmms =
+ do let dflags = hsc_dflags hsc_env
+ -------- Optionally convert to and from zipper ------
cmms <- if dopt Opt_ConvertToZipCfgAndBack dflags
- then mapM (testCmmConversion dflags) cmms
+ then mapM (testCmmConversion hsc_env) cmms
else return cmms
--------- Optionally convert to CPS (MDA) -----------
cmms <- if not (dopt Opt_ConvertToZipCfgAndBack dflags) &&
return cmms
-testCmmConversion :: DynFlags -> Cmm -> IO Cmm
-testCmmConversion dflags cmm =
- do showPass dflags "CmmToCmm"
+testCmmConversion :: HscEnv -> Cmm -> IO Cmm
+testCmmConversion hsc_env cmm =
+ do let dflags = hsc_dflags hsc_env
+ showPass dflags "CmmToCmm"
dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- pre-conversion" (ppr cmm)
--continuationC <- cmmCPS dflags abstractC >>= cmmToRawCmm
us <- mkSplitUniqSupply 'C'
let cvtm = do g <- cmmToZgraph cmm
return $ cfopts g
let zgraph = initUs_ us cvtm
- cps_zgraph <- protoCmmCPSZ dflags zgraph
+ cps_zgraph <- protoCmmCPSZ hsc_env zgraph
let chosen_graph = if dopt Opt_RunCPSZ dflags then cps_zgraph else zgraph
dumpIfSet_dyn dflags Opt_D_dump_cmmz "C-- Zipper Graph" (ppr chosen_graph)
showPass dflags "Convert from Z back to Cmm"
buf <- stringToStringBuffer str
- let loc = mkSrcLoc FSLIT("<interactive>") 1 0
+ let loc = mkSrcLoc (fsLit "<interactive>") 1 0
case unP parser (mkPState buf loc dflags) of {
= do { let { dflags = hsc_dflags hsc_env ;
lint_on = dopt Opt_DoCoreLinting dflags }
- -- Flatten it
- ; flat_expr <- flattenExpr hsc_env ds_expr
-
-- Simplify it
- ; simpl_expr <- simplifyExpr dflags flat_expr
+ ; simpl_expr <- simplifyExpr dflags ds_expr
-- Tidy it (temporary, until coreSat does cloning)
; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr
projects / ghc-hetmet.git / blobdiff