-- 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.
pprModuleName,
moduleNameFS,
moduleNameString,
+ moduleNameSlashes,
mkModuleName,
mkModuleNameFS,
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,
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}
%************************************************************************
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
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
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)
-- 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
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."))
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")
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.
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
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.
; 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) }
-- 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,
-----------------------------------------------------------------------------
-- 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
-- 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
-----------------------------------------------------------------------------
-- 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
-----------------------------------------------------------------------------
-- 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"
-----------------------------------------------------------------------------
-- 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
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
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
-- 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
-----------------------------------------------------------------------------
-- 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 ':')
:: 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"
" </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
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
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
, SysTools.FileOption "" output_fn
])
+cHaskell1Version :: String
cHaskell1Version = "5" -- i.e., Haskell 98
+hsSourceCppOpts :: [String]
-- Default CPP defines in Haskell source
hsSourceCppOpts =
[ "-D__HASKELL1__="++cHaskell1Version
-- 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
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
-- 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
| 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
findHomeModule,
mkHomeModLocation,
mkHomeModLocation2,
+ mkHiOnlyModLocation,
addHomeModuleToFinder,
uncacheModule,
mkStubPaths,
cannotFindModule,
cannotFindInterface,
+
) where
#include "HsVersions.h"
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)
-- (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
-> 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
= let
stubdir = stubDir dflags
- mod_basename = dots_to_slashes (moduleNameString mod)
+ mod_basename = moduleNameSlashes mod
src_basename = basenameOf (expectJust "mkStubPaths"
(ml_hs_file location))
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
cannotFindModule :: DynFlags -> ModuleName -> FindResult -> SDoc
workingDirectoryChanged,
checkModule, checkAndLoadModule, CheckedModule(..),
TypecheckedSource, ParsedSource, RenamedSource,
- compileToCore, compileToCoreModule,
+ compileToCore, compileToCoreModule, compileToCoreSimplified,
+ compileCoreToObj,
-- * Parsing Haddock comments
parseHaddockComment,
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 )
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
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,
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.
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
-- 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
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
module HscMain
( newHscEnv, hscCmmFile
, hscParseIdentifier
+ , hscSimplify
+ , evalComp
+ , hscNormalIface, hscWriteIface, hscOneShot
+ , CompState (..)
#ifdef GHCI
, hscStmt, hscTcExpr, hscKcType
, compileExpr
-- (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}
-- 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