Commit 98c68a1c authored by chevalier@alum.wellesley.edu's avatar chevalier@alum.wellesley.edu
Browse files

Extend API for compiling to and from Core

Added API support for compiling Haskell to simplified Core, and for
compiling Core to machine code. The latter, especially, should be
considered experimental and has only been given cursory testing. Also
fixed warnings in DriverPipeline. Merry Christmas.
parent faf67664
......@@ -378,7 +378,7 @@ data DataConIds
-- The 'Nothing' case of DCIds is important
-- Not only is this efficient,
-- but it also ensures that the wrapper is replaced
-- by the worker (becuase it *is* the worker)
-- by the worker (because it *is* the worker)
-- even when there are no args. E.g. in
-- f (:) x
-- the (:) *is* the worker.
......
......@@ -16,6 +16,7 @@ module Module
pprModuleName,
moduleNameFS,
moduleNameString,
moduleNameSlashes,
mkModuleName,
mkModuleNameFS,
......@@ -50,8 +51,8 @@ module Module
extendModuleEnvList_C, plusModuleEnv_C,
delModuleEnvList, delModuleEnv, plusModuleEnv, lookupModuleEnv,
lookupWithDefaultModuleEnv, mapModuleEnv, mkModuleEnv, emptyModuleEnv,
moduleEnvElts, unitModuleEnv, isEmptyModuleEnv, foldModuleEnv,
extendModuleEnv_C, filterModuleEnv,
moduleEnvKeys, moduleEnvElts, unitModuleEnv, isEmptyModuleEnv,
foldModuleEnv, extendModuleEnv_C, filterModuleEnv,
-- * ModuleName mappings
ModuleNameEnv,
......@@ -173,6 +174,11 @@ mkModuleName s = ModuleName (mkFastString s)
mkModuleNameFS :: FastString -> ModuleName
mkModuleNameFS s = ModuleName s
-- Returns the string version of the module name, with dots replaced by slashes
moduleNameSlashes :: ModuleName -> String
moduleNameSlashes = dots_to_slashes . moduleNameString
where dots_to_slashes = map (\c -> if c == '.' then '/' else c)
\end{code}
%************************************************************************
......@@ -305,6 +311,7 @@ delModuleEnvList :: ModuleEnv a -> [Module] -> ModuleEnv a
delModuleEnv :: ModuleEnv a -> Module -> ModuleEnv a
plusModuleEnv_C :: (a -> a -> a) -> ModuleEnv a -> ModuleEnv a -> ModuleEnv a
mapModuleEnv :: (a -> b) -> ModuleEnv a -> ModuleEnv b
moduleEnvKeys :: ModuleEnv a -> [Module]
moduleEnvElts :: ModuleEnv a -> [a]
isEmptyModuleEnv :: ModuleEnv a -> Bool
......@@ -329,6 +336,7 @@ lookupWithDefaultModuleEnv = lookupWithDefaultFM
mapModuleEnv f = mapFM (\_ v -> f v)
mkModuleEnv = listToFM
emptyModuleEnv = emptyFM
moduleEnvKeys = keysFM
moduleEnvElts = eltsFM
unitModuleEnv = unitFM
isEmptyModuleEnv = isEmptyFM
......
{-# OPTIONS -w #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
-- for details
-----------------------------------------------------------------------------
--
-- GHC Driver
......@@ -104,14 +97,9 @@ compile hsc_env summary mod_index nmods mb_old_iface maybe_old_linkable
let dflags0 = ms_hspp_opts summary
this_mod = ms_mod summary
src_flavour = ms_hsc_src summary
have_object
| Just l <- maybe_old_linkable, isObjectLinkable l = True
| otherwise = False
let location = ms_location summary
let input_fn = expectJust "compile:hs" (ml_hs_file location)
let input_fnpp = ms_hspp_file summary
location = ms_location summary
input_fn = expectJust "compile:hs" (ml_hs_file location)
input_fnpp = ms_hspp_file summary
debugTraceMsg dflags0 2 (text "compile: input file" <+> text input_fnpp)
......@@ -267,12 +255,12 @@ link :: GhcLink -- interactive or batch
-- will succeed.
#ifdef GHCI
link LinkInMemory dflags batch_attempt_linking hpt
link LinkInMemory _ _ _
= do -- Not Linking...(demand linker will do the job)
return Succeeded
#endif
link NoLink dflags batch_attempt_linking hpt
link NoLink _ _ _
= return Succeeded
link LinkBinary dflags batch_attempt_linking hpt
......@@ -308,9 +296,9 @@ link LinkBinary dflags batch_attempt_linking hpt
extra_times <- mapM (IO.try . getModificationTime) extra_ld_inputs
let other_times = map linkableTime linkables
++ [ t' | Right t' <- extra_times ]
linking_needed
| Left _ <- e_exe_time = True
| Right t <- e_exe_time = any (t <) other_times
linking_needed = case e_exe_time of
Left _ -> True
Right t -> any (t <) other_times
if not (dopt Opt_ForceRecomp dflags) && not linking_needed
then do debugTraceMsg dflags 2 (text exe_file <+> ptext SLIT("is up to date, linking not required."))
......@@ -324,6 +312,7 @@ link LinkBinary dflags batch_attempt_linking hpt
let link = case ghcLink dflags of
LinkBinary -> linkBinary
LinkDynLib -> linkDynLib
other -> panicBadLink other
link dflags obj_files pkg_deps
debugTraceMsg dflags 3 (text "link: done")
......@@ -336,6 +325,12 @@ link LinkBinary dflags batch_attempt_linking hpt
text " Main.main not exported; not linking.")
return Succeeded
-- warning suppression
link other _ _ _ = panicBadLink other
panicBadLink :: GhcLink -> a
panicBadLink other = panic ("link: GHC not built to link this way: " ++
show other)
-- -----------------------------------------------------------------------------
-- Compile files in one-shot mode.
......@@ -366,7 +361,7 @@ compileFile dflags stop_phase (src, mb_phase) = do
stop_phase' = case stop_phase of
As | split -> SplitAs
other -> stop_phase
_ -> stop_phase
(_, out_file) <- runPipeline stop_phase' dflags
(src, mb_phase) Nothing output
......@@ -384,6 +379,7 @@ doLink dflags stop_phase o_files
NoLink -> return ()
LinkBinary -> linkBinary dflags o_files link_pkgs
LinkDynLib -> linkDynLib dflags o_files []
other -> panicBadLink other
where
-- Always link in the haskell98 package for static linking. Other
-- packages have to be specified via the -package flag.
......@@ -658,7 +654,7 @@ runPhase (Hsc src_flavour) stop dflags0 basename suff input_fn get_output_fn _ma
; m <- getCoreModuleName input_fn
; return (Nothing, mkModuleName m, [], []) }
other -> do { buf <- hGetStringBuffer input_fn
_ -> do { buf <- hGetStringBuffer input_fn
; (src_imps,imps,L _ mod_name) <- getImports dflags buf input_fn (basename `joinFileExt` suff)
; return (Just buf, mod_name, imps, src_imps) }
......@@ -737,8 +733,6 @@ runPhase (Hsc src_flavour) stop dflags0 basename suff input_fn get_output_fn _ma
-- Make the ModSummary to hand to hscMain
let
unused_field = panic "runPhase:ModSummary field"
-- Some fields are not looked at by hscMain
mod_summary = ModSummary { ms_mod = mod,
ms_hsc_src = src_flavour,
ms_hspp_file = input_fn,
......@@ -777,13 +771,13 @@ runPhase (Hsc src_flavour) stop dflags0 basename suff input_fn get_output_fn _ma
-----------------------------------------------------------------------------
-- Cmm phase
runPhase CmmCpp stop dflags basename suff input_fn get_output_fn maybe_loc
runPhase CmmCpp _stop dflags _basename _suff input_fn get_output_fn maybe_loc
= do
output_fn <- get_output_fn dflags Cmm maybe_loc
doCpp dflags False{-not raw-} True{-include CC opts-} input_fn output_fn
return (Cmm, dflags, maybe_loc, output_fn)
runPhase Cmm stop dflags basename suff input_fn get_output_fn maybe_loc
runPhase Cmm stop dflags basename _ input_fn get_output_fn maybe_loc
= do
let hsc_lang = hscMaybeAdjustTarget dflags stop HsSrcFile (hscTarget dflags)
let next_phase = hscNextPhase dflags HsSrcFile hsc_lang
......@@ -805,7 +799,7 @@ runPhase Cmm stop dflags basename suff input_fn get_output_fn maybe_loc
-- we don't support preprocessing .c files (with -E) now. Doing so introduces
-- way too many hacks, and I can't say I've ever used it anyway.
runPhase cc_phase stop dflags basename suff input_fn get_output_fn maybe_loc
runPhase cc_phase _stop dflags _basename _suff input_fn get_output_fn maybe_loc
| cc_phase `eqPhase` Cc || cc_phase `eqPhase` Ccpp || cc_phase `eqPhase` HCc
= do let cc_opts = getOpts dflags opt_c
hcc = cc_phase `eqPhase` HCc
......@@ -915,7 +909,7 @@ runPhase cc_phase stop dflags basename suff input_fn get_output_fn maybe_loc
-----------------------------------------------------------------------------
-- Mangle phase
runPhase Mangle stop dflags _basename _suff input_fn get_output_fn maybe_loc
runPhase Mangle _stop dflags _basename _suff input_fn get_output_fn maybe_loc
= do let mangler_opts = getOpts dflags opt_m
#if i386_TARGET_ARCH
......@@ -941,7 +935,7 @@ runPhase Mangle stop dflags _basename _suff input_fn get_output_fn maybe_loc
-----------------------------------------------------------------------------
-- Splitting phase
runPhase SplitMangle stop dflags _basename _suff input_fn get_output_fn maybe_loc
runPhase SplitMangle _stop dflags _basename _suff input_fn _get_output_fn maybe_loc
= do -- tmp_pfx is the prefix used for the split .s files
-- We also use it as the file to contain the no. of split .s files (sigh)
split_s_prefix <- SysTools.newTempName dflags "split"
......@@ -968,7 +962,7 @@ runPhase SplitMangle stop dflags _basename _suff input_fn get_output_fn maybe_lo
-----------------------------------------------------------------------------
-- As phase
runPhase As stop dflags _basename _suff input_fn get_output_fn maybe_loc
runPhase As _stop dflags _basename _suff input_fn get_output_fn maybe_loc
= do let as_opts = getOpts dflags opt_a
let cmdline_include_paths = includePaths dflags
......@@ -1000,7 +994,7 @@ runPhase As stop dflags _basename _suff input_fn get_output_fn maybe_loc
return (StopLn, dflags, maybe_loc, output_fn)
runPhase SplitAs stop dflags basename _suff _input_fn get_output_fn maybe_loc
runPhase SplitAs _stop dflags _basename _suff _input_fn get_output_fn maybe_loc
= do
output_fn <- get_output_fn dflags StopLn maybe_loc
......@@ -1058,7 +1052,9 @@ runPhase SplitAs stop dflags basename _suff _input_fn get_output_fn maybe_loc
return (StopLn, dflags, maybe_loc, output_fn)
-- warning suppression
runPhase other _stop _dflags _basename _suff _input_fn _get_output_fn _maybe_loc =
panic ("runPhase: don't know how to run phase " ++ show other)
-----------------------------------------------------------------------------
-- MoveBinary sort-of-phase
-- After having produced a binary, move it somewhere else and generate a
......@@ -1070,6 +1066,7 @@ runPhase SplitAs stop dflags basename _suff _input_fn get_output_fn maybe_loc
-- we don't need the generality of a phase (MoveBinary is always
-- done after linking and makes only sense in a parallel setup) -- HWL
runPhase_MoveBinary :: DynFlags -> FilePath -> IO Bool
runPhase_MoveBinary dflags input_fn
= do
let sysMan = pgm_sysman dflags
......@@ -1146,6 +1143,7 @@ mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan = unlines $
-----------------------------------------------------------------------------
-- Complain about non-dynamic flags in OPTIONS pragmas
checkProcessArgsResult :: [String] -> FilePath -> IO ()
checkProcessArgsResult flags filename
= do when (notNull flags) (throwDyn (ProgramError (
showSDoc (hang (text filename <> char ':')
......@@ -1300,10 +1298,11 @@ maybeCreateManifest
:: DynFlags
-> FilePath -- filename of executable
-> IO [FilePath] -- extra objects to embed, maybe
maybeCreateManifest dflags exe_filename = do
#ifndef mingw32_TARGET_OS
maybeCreateManifest _ _ = do
return []
#else
maybeCreateManifest dflags exe_filename = do
if not (dopt Opt_GenManifest dflags) then return [] else do
let manifest_filename = exe_filename `joinFileExt` "manifest"
......@@ -1324,7 +1323,7 @@ maybeCreateManifest dflags exe_filename = do
" </trustInfo>\n"++
"</assembly>\n"
-- Windows will fine the manifest file if it is named foo.exe.manifest.
-- Windows will find the manifest file if it is named foo.exe.manifest.
-- However, for extra robustness, and so that we can move the binary around,
-- we can embed the manifest in the binary itself using windres:
if not (dopt Opt_EmbedManifest dflags) then return [] else do
......@@ -1335,7 +1334,7 @@ maybeCreateManifest dflags exe_filename = do
writeFile rc_filename $
"1 24 MOVEABLE PURE " ++ show manifest_filename ++ "\n"
-- magic numbers :-)
-- show is a bit hackish above, but we need to esacpe the
-- show is a bit hackish above, but we need to escape the
-- backslashes in the path.
let wr_opts = getOpts dflags opt_windres
......@@ -1354,8 +1353,6 @@ maybeCreateManifest dflags exe_filename = do
linkDynLib :: DynFlags -> [String] -> [PackageId] -> IO ()
linkDynLib dflags o_files dep_packages = do
let verb = getVerbFlag dflags
let static = opt_Static
let no_hs_main = dopt Opt_NoHsMain dflags
let o_file = outputFile dflags
pkg_lib_paths <- getPackageLibraryPath dflags dep_packages
......@@ -1519,8 +1516,10 @@ doCpp dflags raw include_cc_opts input_fn output_fn = do
, SysTools.FileOption "" output_fn
])
cHaskell1Version :: String
cHaskell1Version = "5" -- i.e., Haskell 98
hsSourceCppOpts :: [String]
-- Default CPP defines in Haskell source
hsSourceCppOpts =
[ "-D__HASKELL1__="++cHaskell1Version
......@@ -1534,8 +1533,8 @@ hsSourceCppOpts =
-- Misc.
hscNextPhase :: DynFlags -> HscSource -> HscTarget -> Phase
hscNextPhase dflags HsBootFile hsc_lang = StopLn
hscNextPhase dflags other hsc_lang =
hscNextPhase _ HsBootFile _ = StopLn
hscNextPhase dflags _ hsc_lang =
case hsc_lang of
HscC -> HCc
HscAsm | dopt Opt_SplitObjs dflags -> SplitMangle
......@@ -1546,7 +1545,7 @@ hscNextPhase dflags other hsc_lang =
hscMaybeAdjustTarget :: DynFlags -> Phase -> HscSource -> HscTarget -> HscTarget
hscMaybeAdjustTarget dflags stop other current_hsc_lang
hscMaybeAdjustTarget dflags stop _ current_hsc_lang
= hsc_lang
where
keep_hc = dopt Opt_KeepHcFiles dflags
......@@ -1560,5 +1559,6 @@ hscMaybeAdjustTarget dflags stop other current_hsc_lang
-- otherwise, stick to the plan
| otherwise = current_hsc_lang
v_Split_info :: IORef (String, Int)
GLOBAL_VAR(v_Split_info, ("",0), (String,Int))
-- The split prefix and number of files
......@@ -436,7 +436,7 @@ data GhcLink -- What to do in the link step, if there is one
| LinkBinary -- Link object code into a binary
| LinkInMemory -- Use the in-memory dynamic linker
| LinkDynLib -- Link objects into a dynamic lib (DLL on Windows, DSO on ELF platforms)
deriving Eq
deriving (Eq, Show)
isNoLink :: GhcLink -> Bool
isNoLink NoLink = True
......
......@@ -12,6 +12,7 @@ module Finder (
findHomeModule,
mkHomeModLocation,
mkHomeModLocation2,
mkHiOnlyModLocation,
addHomeModuleToFinder,
uncacheModule,
mkStubPaths,
......@@ -21,6 +22,7 @@ module Finder (
cannotFindModule,
cannotFindInterface,
) where
#include "HsVersions.h"
......@@ -337,7 +339,7 @@ searchPathExts paths mod exts
return result
where
basename = dots_to_slashes (moduleNameString (moduleName mod))
basename = moduleNameSlashes (moduleName mod)
to_search :: [(FilePath, IO ModLocation)]
to_search = [ (file, fn path basename)
......@@ -387,7 +389,7 @@ mkHomeModLocationSearched dflags mod suff path basename = do
-- (b) and (c): "."
--
-- src_basename
-- (a): dots_to_slashes (moduleNameUserString mod)
-- (a): (moduleNameSlashes mod)
-- (b) and (c): The filename of the source file, minus its extension
--
-- ext
......@@ -404,7 +406,7 @@ mkHomeModLocation2 :: DynFlags
-> String -- Suffix
-> IO ModLocation
mkHomeModLocation2 dflags mod src_basename ext = do
let mod_basename = dots_to_slashes (moduleNameString mod)
let mod_basename = moduleNameSlashes mod
obj_fn <- mkObjPath dflags src_basename mod_basename
hi_fn <- mkHiPath dflags src_basename mod_basename
......@@ -478,7 +480,7 @@ mkStubPaths dflags mod location
= let
stubdir = stubDir dflags
mod_basename = dots_to_slashes (moduleNameString mod)
mod_basename = moduleNameSlashes mod
src_basename = basenameOf (expectJust "mkStubPaths"
(ml_hs_file location))
......@@ -529,12 +531,6 @@ findObjectLinkable mod obj_fn obj_time = do
then return (LM obj_time mod [DotO obj_fn, DotO stub_fn])
else return (LM obj_time mod [DotO obj_fn])
-- -----------------------------------------------------------------------------
-- Utils
dots_to_slashes :: String -> String
dots_to_slashes = map (\c -> if c == '.' then '/' else c)
-- -----------------------------------------------------------------------------
-- Error messages
......
......@@ -41,7 +41,8 @@ module GHC (
workingDirectoryChanged,
checkModule, checkAndLoadModule, CheckedModule(..),
TypecheckedSource, ParsedSource, RenamedSource,
compileToCore, compileToCoreModule,
compileToCore, compileToCoreModule, compileToCoreSimplified,
compileCoreToObj,
-- * Parsing Haddock comments
parseHaddockComment,
......@@ -229,9 +230,12 @@ import FunDeps
import DataCon
import Name hiding ( varName )
import OccName ( parenSymOcc )
import InstEnv ( Instance, instanceDFunId, pprInstance, pprInstanceHdr )
import InstEnv ( Instance, instanceDFunId, pprInstance, pprInstanceHdr,
emptyInstEnv )
import FamInstEnv ( emptyFamInstEnv )
import SrcLoc
import CoreSyn
import TidyPgm
import DriverPipeline
import DriverPhases ( HscSource(..), Phase(..), isHaskellSrcFilename, startPhase )
import HeaderInfo ( getImports, getOptions )
......@@ -263,13 +267,14 @@ import HaddockParse
import HaddockLex ( tokenise )
import Control.Concurrent
import System.Directory ( getModificationTime, doesFileExist )
import System.Directory ( getModificationTime, doesFileExist,
getCurrentDirectory )
import Data.Maybe
import Data.List
import qualified Data.List as List
import Control.Monad
import System.Exit ( exitWith, ExitCode(..) )
import System.Time ( ClockTime )
import System.Time ( ClockTime, getClockTime )
import Control.Exception as Exception hiding (handle)
import Data.IORef
import System.IO
......@@ -777,7 +782,7 @@ data CheckedModule =
renamedSource :: Maybe RenamedSource,
typecheckedSource :: Maybe TypecheckedSource,
checkedModuleInfo :: Maybe ModuleInfo,
coreModule :: Maybe CoreModule
coreModule :: Maybe ModGuts
}
-- ToDo: improvements that could be made here:
-- if the module succeeded renaming but not typechecking,
......@@ -867,12 +872,6 @@ checkModule_ ref ms compile_to_core load
then deSugarModule hsc_env ms tcg
else return Nothing
let mb_core = fmap (\ mg ->
CoreModule { cm_module = mg_module mg,
cm_types = mg_types mg,
cm_binds = mg_binds mg })
mb_guts
-- If we are loading this module so that we can typecheck
-- dependent modules, generate an interface and stuff it
-- all in the HomePackageTable.
......@@ -890,7 +889,7 @@ checkModule_ ref ms compile_to_core load
renamedSource = rn_info,
typecheckedSource = Just tc_binds,
checkedModuleInfo = Just minf,
coreModule = mb_core }))
coreModule = mb_guts }))
-- | This is the way to get access to the Core bindings corresponding
-- to a module. 'compileToCore' invokes 'checkModule' to parse, typecheck, and
......@@ -898,7 +897,90 @@ checkModule_ ref ms compile_to_core load
-- the module name, type declarations, and function declarations) if
-- successful.
compileToCoreModule :: Session -> FilePath -> IO (Maybe CoreModule)
compileToCoreModule session fn = do
compileToCoreModule = compileCore False
-- | Like compileToCoreModule, but invokes the simplifier, so
-- as to return simplified and tidied Core.
compileToCoreSimplified :: Session -> FilePath -> IO (Maybe CoreModule)
compileToCoreSimplified = compileCore True
-- | Provided for backwards-compatibility: compileToCore returns just the Core
-- bindings, but for most purposes, you probably want to call
-- compileToCoreModule.
compileToCore :: Session -> FilePath -> IO (Maybe [CoreBind])
compileToCore session fn = do
maybeCoreModule <- compileToCoreModule session fn
return $ fmap cm_binds maybeCoreModule
-- | Takes a CoreModule and compiles the bindings therein
-- to object code. The first argument is a bool flag indicating
-- whether to run the simplifier.
-- The resulting .o, .hi, and executable files, if any, are stored in the
-- current directory, and named according to the module name.
-- Returns True iff compilation succeeded.
-- This has only so far been tested with a single self-contained module.
compileCoreToObj :: Bool -> Session -> CoreModule -> IO Bool
compileCoreToObj simplify session cm@(CoreModule{ cm_module = mName }) = do
hscEnv <- sessionHscEnv session
dflags <- getSessionDynFlags session
currentTime <- getClockTime
cwd <- getCurrentDirectory
modLocation <- mkHiOnlyModLocation dflags (hiSuf dflags) cwd
((moduleNameSlashes . moduleName) mName)
let modSummary = ModSummary { ms_mod = mName,
ms_hsc_src = ExtCoreFile,
ms_location = modLocation,
-- By setting the object file timestamp to Nothing,
-- we always force recompilation, which is what we
-- want. (Thus it doesn't matter what the timestamp
-- for the (nonexistent) source file is.)
ms_hs_date = currentTime,
ms_obj_date = Nothing,
-- Only handling the single-module case for now, so no imports.
ms_srcimps = [],
ms_imps = [],
-- No source file
ms_hspp_file = "",
ms_hspp_opts = dflags,
ms_hspp_buf = Nothing
}
mbHscResult <- evalComp
((if simplify then hscSimplify else return) (mkModGuts cm)
>>= hscNormalIface >>= hscWriteIface >>= hscOneShot)
(CompState{ compHscEnv=hscEnv,
compModSummary=modSummary,
compOldIface=Nothing})
return $ isJust mbHscResult
-- Makes a "vanilla" ModGuts.
mkModGuts :: CoreModule -> ModGuts
mkModGuts coreModule = ModGuts {
mg_module = cm_module coreModule,
mg_boot = False,
mg_exports = [],
mg_deps = noDependencies,
mg_dir_imps = emptyModuleEnv,
mg_used_names = emptyNameSet,
mg_rdr_env = emptyGlobalRdrEnv,
mg_fix_env = emptyFixityEnv,
mg_types = emptyTypeEnv,
mg_insts = [],
mg_fam_insts = [],
mg_rules = [],
mg_binds = cm_binds coreModule,
mg_foreign = NoStubs,
mg_deprecs = NoDeprecs,
mg_hpc_info = emptyHpcInfo False,
mg_modBreaks = emptyModBreaks,
mg_vect_info = noVectInfo,
mg_inst_env = emptyInstEnv,
mg_fam_inst_env = emptyFamInstEnv
}
compileCore :: Bool -> Session -> FilePath -> IO (Maybe CoreModule)
compileCore simplify session fn = do
-- First, set the target to the desired filename
target <- guessTarget fn Nothing
addTarget session target
......@@ -916,17 +998,34 @@ compileToCoreModule session fn = do
maybeCheckedModule <- checkModule session mod True
case maybeCheckedModule of
Nothing -> return Nothing
Just checkedMod -> return $ coreModule checkedMod
Just checkedMod -> (liftM $ fmap gutsToCoreModule) $
case (coreModule checkedMod) of
Just mg | simplify -> (sessionHscEnv session)
-- If simplify is true: simplify (hscSimplify),
-- then tidy (tidyProgram).
>>= \ hscEnv -> evalComp (hscSimplify mg)
(CompState{ compHscEnv=hscEnv,
compModSummary=modSummary,
compOldIface=Nothing})
>>= (tidyProgram hscEnv)
>>= (return . Just . Left)
Just guts -> return $ Just $ Right guts
Nothing -> return Nothing
Nothing -> panic "compileToCoreModule: target FilePath not found in\
module dependency graph"
where -- two versions, based on whether we simplify (thus run tidyProgram,
-- which returns a (CgGuts, ModDetails) pair, or not (in which case
-- we just have a ModGuts.
gutsToCoreModule :: Either (CgGuts, ModDetails) ModGuts -> CoreModule
gutsToCoreModule (Left (cg, md)) = CoreModule {
cm_module = cg_module cg, cm_types = md_types md,
cm_imports = cg_dir_imps cg, cm_binds = cg_binds cg
}
gutsToCoreModule (Right mg) = CoreModule {
cm_module = mg_module mg, cm_types = mg_types mg,
cm_imports = moduleEnvKeys (mg_dir_imps mg), cm_binds = mg_binds mg
}
-- | Provided for backwards-compatibility: compileToCore returns just the Core
-- bindings, but for most purposes, you probably want to call
-- compileToCoreModule.
compileToCore :: Session -> FilePath -> IO (Maybe [CoreBind])
compileToCore session fn = do
maybeCoreModule <- compileToCoreModule session fn
return $ fmap cm_binds maybeCoreModule
-- ---------------------------------------------------------------------------
-- Unloading
......
......@@ -8,6 +8,10 @@
module HscMain
( newHscEnv, hscCmmFile
, hscParseIdentifier
, hscSimplify
, evalComp
, hscNormalIface, hscWriteIface, hscOneShot
, CompState (..)
#ifdef GHCI
, hscStmt, hscTcExpr, hscKcType
, compileExpr
......
......@@ -284,7 +284,7 @@ lookupIfaceByModule dflags hpt pit mod
-- (a) In OneShot mode, even home-package modules accumulate in the PIT
-- (b) Even in Batch (--make) mode, there is *one* case where a home-package
-- module is in the PIT, namely GHC.Prim when compiling the base package.
-- We could eliminate (b) if we wanted, by making GHC.Prim belong to a packake
-- We could eliminate (b) if we wanted, by making GHC.Prim belong to a package
-- of its own, but it doesn't seem worth the bother.
\end{code}
......@@ -560,7 +560,9 @@ data CoreModule
-- Type environment for types declared in this module
cm_types :: !TypeEnv,
-- Declarations
cm_binds :: [CoreBind]
cm_binds :: [CoreBind],
-- Imports
cm_imports :: ![Module]
}
instance Outputable CoreModule where
......