, hscParseIdentifier
, hscTcRcLookupName
, hscTcRnGetInfo
- , hscRnImportDecls
#ifdef GHCI
+ , hscRnImportDecls
, hscGetModuleExports
, hscTcRnLookupRdrName
, hscStmt, hscStmtWithLocation
import TcRnDriver
import TcIface ( typecheckIface )
import TcRnMonad
-import RnNames ( rnImports )
import IfaceEnv ( initNameCache )
import LoadIface ( ifaceStats, initExternalPackageState )
import PrelInfo ( wiredInThings, basicKnownKeyNames )
import qualified StgCmm ( codeGen )
import StgSyn
import CostCentre
-import TyCon ( TyCon, isDataTyCon )
+import ProfInit
+import TyCon ( TyCon, isDataTyCon )
import Name ( Name, NamedThing(..) )
import SimplStg ( stg2stg )
import CodeGen ( codeGen )
import PprCmm ( pprCmms )
import CmmParse ( parseCmmFile )
import CmmBuildInfoTables
-import CmmCPS
+import CmmPipeline
import CmmInfo
import OptimizationFuel ( initOptFuelState )
import CmmCvt
hscGetModuleExports :: HscEnv -> Module -> IO (Maybe [AvailInfo])
hscGetModuleExports hsc_env mdl =
runHsc hsc_env $ ioMsgMaybe' $ getModuleExports hsc_env mdl
-#endif
-- -----------------------------------------------------------------------------
-- | Rename some import declarations
-> [LImportDecl RdrName]
-> IO GlobalRdrEnv
-hscRnImportDecls hsc_env this_mod import_decls = runHsc hsc_env $ do
- (_, r, _, _) <-
- ioMsgMaybe $ initTc hsc_env HsSrcFile False this_mod $
- rnImports import_decls
- return r
+-- It is important that we use tcRnImports instead of calling rnImports directly
+-- because tcRnImports will force-load any orphan modules necessary, making extra
+-- instances/family instances visible (GHC #4832)
+hscRnImportDecls hsc_env this_mod import_decls
+ = runHsc hsc_env $ ioMsgMaybe $ initTc hsc_env HsSrcFile False this_mod $
+ fmap tcg_rdr_env $ tcRnImports hsc_env this_mod import_decls
+
+#endif
-- -----------------------------------------------------------------------------
-- | parse a file, returning the abstract syntax
Just b -> return b
Nothing -> liftIO $ hGetStringBuffer src_filename
- let loc = mkSrcLoc (mkFastString src_filename) 1 1
+ let loc = mkRealSrcLoc (mkFastString src_filename) 1 1
case unP parseModule (mkPState dflags buf loc) of
PFailed span err ->
It's the task of the compilation proper to compile Haskell, hs-boot and
-core files to either byte-code, hard-code (C, asm, Java, ect) or to
+core files to either byte-code, hard-code (C, asm, LLVM, ect) or to
nothing at all (the module is still parsed and type-checked. This
feature is mostly used by IDE's and the likes).
Compilation can happen in either 'one-shot', 'batch', 'nothing',
data HscStatus' a
= HscNoRecomp
| HscRecomp
- Bool -- Has stub files. This is a hack. We can't compile C files here
+ (Maybe FilePath)
+ -- Has stub files. This is a hack. We can't compile C files here
-- since it's done in DriverPipeline. For now we just return True
-- if we want the caller to compile them for us.
a
, hscBackend = \ tc_result mod_summary mb_old_hash -> do
dflags <- getDynFlags
case hscTarget dflags of
- HscNothing -> return (HscRecomp False ())
+ HscNothing -> return (HscRecomp Nothing ())
_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
hscWriteIface iface changed mod_summary
- return (HscRecomp False ())
+ return (HscRecomp Nothing ())
, hscGenOutput = \guts0 mod_summary mb_old_iface -> do
guts <- hscSimplify' guts0
, hscGenBootOutput = \tc_result mod_summary mb_old_iface -> do
(iface, changed, details) <- hscSimpleIface tc_result mb_old_iface
hscWriteIface iface changed mod_summary
- return (HscRecomp False (), iface, details)
+ return (HscRecomp Nothing (), iface, details)
, hscGenOutput = \guts0 mod_summary mb_old_iface -> do
guts <- hscSimplify' guts0
, hscGenBootOutput = \tc_result _mod_summary mb_old_iface -> do
(iface, _changed, details) <- hscSimpleIface tc_result mb_old_iface
- return (HscRecomp False Nothing, iface, details)
+ return (HscRecomp Nothing Nothing, iface, details)
, hscGenOutput = \guts0 mod_summary mb_old_iface -> do
guts <- hscSimplify' guts0
, hscBackend = \tc_result _mod_summary mb_old_iface -> do
handleWarnings
(iface, _changed, details) <- hscSimpleIface tc_result mb_old_iface
- return (HscRecomp False (), iface, details)
+ return (HscRecomp Nothing (), iface, details)
, hscGenBootOutput = \_ _ _ ->
panic "hscCompileNothing: hscGenBootOutput should not be called"
-- | Compile to hard-code.
hscGenHardCode :: CgGuts -> ModSummary
- -> Hsc Bool -- ^ @True@ <=> stub.c exists
+ -> Hsc (Maybe FilePath) -- ^ @Just f@ <=> _stub.c is f
hscGenHardCode cgguts mod_summary
= do
hsc_env <- getHscEnv
cg_module = this_mod,
cg_binds = core_binds,
cg_tycons = tycons,
- cg_dir_imps = dir_imps,
- cg_foreign = foreign_stubs,
+ cg_foreign = foreign_stubs0,
cg_dep_pkgs = dependencies,
cg_hpc_info = hpc_info } = cgguts
dflags = hsc_dflags hsc_env
<- {-# SCC "CoreToStg" #-}
myCoreToStg dflags this_mod prepd_binds
+ let prof_init = profilingInitCode this_mod cost_centre_info
+ foreign_stubs = foreign_stubs0 `appendStubC` prof_init
+
------------------ Code generation ------------------
cmms <- if dopt Opt_TryNewCodeGen dflags
then do cmms <- tryNewCodeGen hsc_env this_mod data_tycons
- dir_imps cost_centre_info
+ cost_centre_info
stg_binds hpc_info
return cmms
else {-# SCC "CodeGen" #-}
codeGen dflags this_mod data_tycons
- dir_imps cost_centre_info
+ cost_centre_info
stg_binds hpc_info
--- Optionally run experimental Cmm transformations ---
-------------------- Stuff for new code gen ---------------------
-tryNewCodeGen :: HscEnv -> Module -> [TyCon] -> [Module]
- -> CollectedCCs
- -> [(StgBinding,[(Id,[Id])])]
- -> HpcInfo
- -> IO [Cmm]
-tryNewCodeGen hsc_env this_mod data_tycons imported_mods
- 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"
- (pprCmms prog)
-
- ; prog <- return $ map runCmmContFlowOpts prog
- -- Control flow optimisation
+tryNewCodeGen :: HscEnv -> Module -> [TyCon]
+ -> CollectedCCs
+ -> [(StgBinding,[(Id,[Id])])]
+ -> HpcInfo
+ -> IO [Cmm]
+tryNewCodeGen hsc_env this_mod data_tycons
+ cost_centre_info stg_binds hpc_info =
+ do { let dflags = hsc_dflags hsc_env
+ ; prog <- StgCmm.codeGen dflags this_mod data_tycons
+ cost_centre_info stg_binds hpc_info
+ ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Cmm produced by new codegen"
+ (pprCmms prog)
-- 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 (protoCmmCPS hsc_env) (topSRT, []) prog
- -- The main CPS conversion
-
- ; prog <- return $ map runCmmContFlowOpts (srtToData topSRT : prog)
- -- Control flow optimisation, again
+ ; let initTopSRT = initUs_ us emptySRT
+ ; (topSRT, prog) <- foldM (cmmPipeline hsc_env) (initTopSRT, []) prog
- ; let prog' = map cmmOfZgraph prog
- ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" (ppr prog')
- ; return prog' }
+ ; let prog' = map cmmOfZgraph (srtToData topSRT : prog)
+ ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" (ppr prog')
+ ; return prog' }
optionallyConvertAndOrCPS :: HscEnv -> [Cmm] -> IO [Cmm]
dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- pre-conversion" (ppr cmm)
--continuationC <- cmmCPS dflags abstractC >>= cmmToRawCmm
us <- mkSplitUniqSupply 'C'
- let cvtm = runCmmContFlowOpts `liftM` cmmToZgraph cmm
- let zgraph = initUs_ us cvtm
- us <- mkSplitUniqSupply 'S'
- let topSRT = initUs_ us emptySRT
- (_, [cps_zgraph]) <- protoCmmCPS hsc_env (topSRT, []) zgraph
- let chosen_graph = if dopt Opt_RunCPSZ dflags then cps_zgraph else zgraph
+ let zgraph = initUs_ us (cmmToZgraph cmm)
+ chosen_graph <-
+ if dopt Opt_RunCPSZ dflags
+ then do us <- mkSplitUniqSupply 'S'
+ let topSRT = initUs_ us emptySRT
+ (_, [zgraph]) <- cmmPipeline hsc_env (topSRT, []) zgraph
+ return zgraph
+ else return (runCmmContFlowOpts zgraph)
dumpIfSet_dyn dflags Opt_D_dump_cmmz "C-- Zipper Graph" (ppr chosen_graph)
showPass dflags "Convert from Z back to Cmm"
- let cvt = cmmOfZgraph $ runCmmContFlowOpts $ chosen_graph
+ let cvt = cmmOfZgraph chosen_graph
dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- post-conversion" (ppr cvt)
return cvt
hscTcExpr hsc_env expr = runHsc hsc_env $ do
maybe_stmt <- hscParseStmt expr
case maybe_stmt of
- Just (L _ (ExprStmt expr _ _)) ->
- ioMsgMaybe $ tcRnExpr hsc_env (hsc_IC hsc_env) expr
- _ ->
- liftIO $ throwIO $ mkSrcErr $ unitBag $
- mkPlainErrMsg noSrcSpan
- (text "not an expression:" <+> quotes (text expr))
+ Just (L _ (ExprStmt expr _ _ _)) ->
+ ioMsgMaybe $ tcRnExpr hsc_env (hsc_IC hsc_env) expr
+ _ ->
+ liftIO $ throwIO $ mkSrcErr $ unitBag $ mkPlainErrMsg noSrcSpan
+ (text "not an expression:" <+> quotes (text expr))
-- | Find the kind of a type
hscKcType
liftIO $ showPass dflags "Parser"
let buf = stringToStringBuffer str
- loc = mkSrcLoc (fsLit source) linenumber 1
+ loc = mkRealSrcLoc (fsLit source) linenumber 1
case unP parser (mkPState dflags buf loc) of
projects / ghc-hetmet.git / blobdiff