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 ...@@ -378,7 +378,7 @@ data DataConIds
-- The 'Nothing' case of DCIds is important -- The 'Nothing' case of DCIds is important
-- Not only is this efficient, -- Not only is this efficient,
-- but it also ensures that the wrapper is replaced -- 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 -- even when there are no args. E.g. in
-- f (:) x -- f (:) x
-- the (:) *is* the worker. -- the (:) *is* the worker.
......
...@@ -16,6 +16,7 @@ module Module ...@@ -16,6 +16,7 @@ module Module
pprModuleName, pprModuleName,
moduleNameFS, moduleNameFS,
moduleNameString, moduleNameString,
moduleNameSlashes,
mkModuleName, mkModuleName,
mkModuleNameFS, mkModuleNameFS,
...@@ -50,8 +51,8 @@ module Module ...@@ -50,8 +51,8 @@ module Module
extendModuleEnvList_C, plusModuleEnv_C, extendModuleEnvList_C, plusModuleEnv_C,
delModuleEnvList, delModuleEnv, plusModuleEnv, lookupModuleEnv, delModuleEnvList, delModuleEnv, plusModuleEnv, lookupModuleEnv,
lookupWithDefaultModuleEnv, mapModuleEnv, mkModuleEnv, emptyModuleEnv, lookupWithDefaultModuleEnv, mapModuleEnv, mkModuleEnv, emptyModuleEnv,
moduleEnvElts, unitModuleEnv, isEmptyModuleEnv, foldModuleEnv, moduleEnvKeys, moduleEnvElts, unitModuleEnv, isEmptyModuleEnv,
extendModuleEnv_C, filterModuleEnv, foldModuleEnv, extendModuleEnv_C, filterModuleEnv,
-- * ModuleName mappings -- * ModuleName mappings
ModuleNameEnv, ModuleNameEnv,
...@@ -173,6 +174,11 @@ mkModuleName s = ModuleName (mkFastString s) ...@@ -173,6 +174,11 @@ mkModuleName s = ModuleName (mkFastString s)
mkModuleNameFS :: FastString -> ModuleName mkModuleNameFS :: FastString -> ModuleName
mkModuleNameFS s = ModuleName s 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} \end{code}
%************************************************************************ %************************************************************************
...@@ -305,6 +311,7 @@ delModuleEnvList :: ModuleEnv a -> [Module] -> ModuleEnv a ...@@ -305,6 +311,7 @@ delModuleEnvList :: ModuleEnv a -> [Module] -> ModuleEnv a
delModuleEnv :: ModuleEnv a -> Module -> ModuleEnv a delModuleEnv :: ModuleEnv a -> Module -> ModuleEnv a
plusModuleEnv_C :: (a -> a -> a) -> ModuleEnv a -> ModuleEnv a -> ModuleEnv a plusModuleEnv_C :: (a -> a -> a) -> ModuleEnv a -> ModuleEnv a -> ModuleEnv a
mapModuleEnv :: (a -> b) -> ModuleEnv a -> ModuleEnv b mapModuleEnv :: (a -> b) -> ModuleEnv a -> ModuleEnv b
moduleEnvKeys :: ModuleEnv a -> [Module]
moduleEnvElts :: ModuleEnv a -> [a] moduleEnvElts :: ModuleEnv a -> [a]
isEmptyModuleEnv :: ModuleEnv a -> Bool isEmptyModuleEnv :: ModuleEnv a -> Bool
...@@ -329,6 +336,7 @@ lookupWithDefaultModuleEnv = lookupWithDefaultFM ...@@ -329,6 +336,7 @@ lookupWithDefaultModuleEnv = lookupWithDefaultFM
mapModuleEnv f = mapFM (\_ v -> f v) mapModuleEnv f = mapFM (\_ v -> f v)
mkModuleEnv = listToFM mkModuleEnv = listToFM
emptyModuleEnv = emptyFM emptyModuleEnv = emptyFM
moduleEnvKeys = keysFM
moduleEnvElts = eltsFM moduleEnvElts = eltsFM
unitModuleEnv = unitFM unitModuleEnv = unitFM
isEmptyModuleEnv = isEmptyFM 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 -- GHC Driver
...@@ -104,14 +97,9 @@ compile hsc_env summary mod_index nmods mb_old_iface maybe_old_linkable ...@@ -104,14 +97,9 @@ compile hsc_env summary mod_index nmods mb_old_iface maybe_old_linkable
let dflags0 = ms_hspp_opts summary let dflags0 = ms_hspp_opts summary
this_mod = ms_mod summary this_mod = ms_mod summary
src_flavour = ms_hsc_src summary src_flavour = ms_hsc_src summary
location = ms_location summary
have_object input_fn = expectJust "compile:hs" (ml_hs_file location)
| Just l <- maybe_old_linkable, isObjectLinkable l = True input_fnpp = ms_hspp_file summary
| otherwise = False
let location = ms_location summary
let input_fn = expectJust "compile:hs" (ml_hs_file location)
let input_fnpp = ms_hspp_file summary
debugTraceMsg dflags0 2 (text "compile: input file" <+> text input_fnpp) debugTraceMsg dflags0 2 (text "compile: input file" <+> text input_fnpp)
...@@ -267,12 +255,12 @@ link :: GhcLink -- interactive or batch ...@@ -267,12 +255,12 @@ link :: GhcLink -- interactive or batch
-- will succeed. -- will succeed.
#ifdef GHCI #ifdef GHCI
link LinkInMemory dflags batch_attempt_linking hpt link LinkInMemory _ _ _
= do -- Not Linking...(demand linker will do the job) = do -- Not Linking...(demand linker will do the job)
return Succeeded return Succeeded
#endif #endif
link NoLink dflags batch_attempt_linking hpt link NoLink _ _ _
= return Succeeded = return Succeeded
link LinkBinary dflags batch_attempt_linking hpt link LinkBinary dflags batch_attempt_linking hpt
...@@ -308,9 +296,9 @@ 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 extra_times <- mapM (IO.try . getModificationTime) extra_ld_inputs
let other_times = map linkableTime linkables let other_times = map linkableTime linkables
++ [ t' | Right t' <- extra_times ] ++ [ t' | Right t' <- extra_times ]
linking_needed linking_needed = case e_exe_time of
| Left _ <- e_exe_time = True Left _ -> True
| Right t <- e_exe_time = any (t <) other_times Right t -> any (t <) other_times
if not (dopt Opt_ForceRecomp dflags) && not linking_needed 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.")) 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 ...@@ -324,6 +312,7 @@ link LinkBinary dflags batch_attempt_linking hpt
let link = case ghcLink dflags of let link = case ghcLink dflags of
LinkBinary -> linkBinary LinkBinary -> linkBinary
LinkDynLib -> linkDynLib LinkDynLib -> linkDynLib
other -> panicBadLink other
link dflags obj_files pkg_deps link dflags obj_files pkg_deps
debugTraceMsg dflags 3 (text "link: done") debugTraceMsg dflags 3 (text "link: done")
...@@ -336,6 +325,12 @@ link LinkBinary dflags batch_attempt_linking hpt ...@@ -336,6 +325,12 @@ link LinkBinary dflags batch_attempt_linking hpt
text " Main.main not exported; not linking.") text " Main.main not exported; not linking.")
return Succeeded 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. -- Compile files in one-shot mode.
...@@ -366,7 +361,7 @@ compileFile dflags stop_phase (src, mb_phase) = do ...@@ -366,7 +361,7 @@ compileFile dflags stop_phase (src, mb_phase) = do
stop_phase' = case stop_phase of stop_phase' = case stop_phase of
As | split -> SplitAs As | split -> SplitAs
other -> stop_phase _ -> stop_phase
(_, out_file) <- runPipeline stop_phase' dflags (_, out_file) <- runPipeline stop_phase' dflags
(src, mb_phase) Nothing output (src, mb_phase) Nothing output
...@@ -384,6 +379,7 @@ doLink dflags stop_phase o_files ...@@ -384,6 +379,7 @@ doLink dflags stop_phase o_files
NoLink -> return () NoLink -> return ()
LinkBinary -> linkBinary dflags o_files link_pkgs LinkBinary -> linkBinary dflags o_files link_pkgs
LinkDynLib -> linkDynLib dflags o_files [] LinkDynLib -> linkDynLib dflags o_files []
other -> panicBadLink other
where where
-- Always link in the haskell98 package for static linking. Other -- Always link in the haskell98 package for static linking. Other
-- packages have to be specified via the -package flag. -- 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 ...@@ -658,7 +654,7 @@ runPhase (Hsc src_flavour) stop dflags0 basename suff input_fn get_output_fn _ma
; m <- getCoreModuleName input_fn ; m <- getCoreModuleName input_fn
; return (Nothing, mkModuleName m, [], []) } ; 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) ; (src_imps,imps,L _ mod_name) <- getImports dflags buf input_fn (basename `joinFileExt` suff)
; return (Just buf, mod_name, imps, src_imps) } ; 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 ...@@ -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 -- Make the ModSummary to hand to hscMain
let let
unused_field = panic "runPhase:ModSummary field"
-- Some fields are not looked at by hscMain
mod_summary = ModSummary { ms_mod = mod, mod_summary = ModSummary { ms_mod = mod,
ms_hsc_src = src_flavour, ms_hsc_src = src_flavour,
ms_hspp_file = input_fn, ms_hspp_file = input_fn,
...@@ -777,13 +771,13 @@ runPhase (Hsc src_flavour) stop dflags0 basename suff input_fn get_output_fn _ma ...@@ -777,13 +771,13 @@ runPhase (Hsc src_flavour) stop dflags0 basename suff input_fn get_output_fn _ma
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- Cmm phase -- 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 = do
output_fn <- get_output_fn dflags Cmm maybe_loc output_fn <- get_output_fn dflags Cmm maybe_loc
doCpp dflags False{-not raw-} True{-include CC opts-} input_fn output_fn doCpp dflags False{-not raw-} True{-include CC opts-} input_fn output_fn
return (Cmm, dflags, maybe_loc, 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 = do
let hsc_lang = hscMaybeAdjustTarget dflags stop HsSrcFile (hscTarget dflags) let hsc_lang = hscMaybeAdjustTarget dflags stop HsSrcFile (hscTarget dflags)
let next_phase = hscNextPhase dflags HsSrcFile hsc_lang 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 ...@@ -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 -- 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. -- 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 | cc_phase `eqPhase` Cc || cc_phase `eqPhase` Ccpp || cc_phase `eqPhase` HCc
= do let cc_opts = getOpts dflags opt_c = do let cc_opts = getOpts dflags opt_c
hcc = cc_phase `eqPhase` HCc hcc = cc_phase `eqPhase` HCc
...@@ -915,7 +909,7 @@ runPhase cc_phase stop dflags basename suff input_fn get_output_fn maybe_loc ...@@ -915,7 +909,7 @@ runPhase cc_phase stop dflags basename suff input_fn get_output_fn maybe_loc
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- Mangle phase -- 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 = do let mangler_opts = getOpts dflags opt_m
#if i386_TARGET_ARCH #if i386_TARGET_ARCH
...@@ -941,7 +935,7 @@ runPhase Mangle stop dflags _basename _suff input_fn get_output_fn maybe_loc ...@@ -941,7 +935,7 @@ runPhase Mangle stop dflags _basename _suff input_fn get_output_fn maybe_loc
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- Splitting phase -- 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 = 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) -- We also use it as the file to contain the no. of split .s files (sigh)
split_s_prefix <- SysTools.newTempName dflags "split" split_s_prefix <- SysTools.newTempName dflags "split"
...@@ -968,7 +962,7 @@ runPhase SplitMangle stop dflags _basename _suff input_fn get_output_fn maybe_lo ...@@ -968,7 +962,7 @@ runPhase SplitMangle stop dflags _basename _suff input_fn get_output_fn maybe_lo
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- As phase -- 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 = do let as_opts = getOpts dflags opt_a
let cmdline_include_paths = includePaths dflags let cmdline_include_paths = includePaths dflags
...@@ -1000,7 +994,7 @@ runPhase As stop dflags _basename _suff input_fn get_output_fn maybe_loc ...@@ -1000,7 +994,7 @@ runPhase As stop dflags _basename _suff input_fn get_output_fn maybe_loc
return (StopLn, dflags, maybe_loc, output_fn) 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 = do
output_fn <- get_output_fn dflags StopLn maybe_loc 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 ...@@ -1058,7 +1052,9 @@ runPhase SplitAs stop dflags basename _suff _input_fn get_output_fn maybe_loc
return (StopLn, dflags, maybe_loc, output_fn) 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 -- MoveBinary sort-of-phase
-- After having produced a binary, move it somewhere else and generate a -- 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 ...@@ -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 -- we don't need the generality of a phase (MoveBinary is always
-- done after linking and makes only sense in a parallel setup) -- HWL -- done after linking and makes only sense in a parallel setup) -- HWL
runPhase_MoveBinary :: DynFlags -> FilePath -> IO Bool
runPhase_MoveBinary dflags input_fn runPhase_MoveBinary dflags input_fn
= do = do
let sysMan = pgm_sysman dflags let sysMan = pgm_sysman dflags
...@@ -1146,6 +1143,7 @@ mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan = unlines $ ...@@ -1146,6 +1143,7 @@ mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan = unlines $
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- Complain about non-dynamic flags in OPTIONS pragmas -- Complain about non-dynamic flags in OPTIONS pragmas
checkProcessArgsResult :: [String] -> FilePath -> IO ()
checkProcessArgsResult flags filename checkProcessArgsResult flags filename
= do when (notNull flags) (throwDyn (ProgramError ( = do when (notNull flags) (throwDyn (ProgramError (
showSDoc (hang (text filename <> char ':') showSDoc (hang (text filename <> char ':')
...@@ -1300,10 +1298,11 @@ maybeCreateManifest ...@@ -1300,10 +1298,11 @@ maybeCreateManifest
:: DynFlags :: DynFlags
-> FilePath -- filename of executable -> FilePath -- filename of executable
-> IO [FilePath] -- extra objects to embed, maybe -> IO [FilePath] -- extra objects to embed, maybe
maybeCreateManifest dflags exe_filename = do
#ifndef mingw32_TARGET_OS #ifndef mingw32_TARGET_OS
maybeCreateManifest _ _ = do
return [] return []
#else #else
maybeCreateManifest dflags exe_filename = do
if not (dopt Opt_GenManifest dflags) then return [] else do if not (dopt Opt_GenManifest dflags) then return [] else do
let manifest_filename = exe_filename `joinFileExt` "manifest" let manifest_filename = exe_filename `joinFileExt` "manifest"
...@@ -1324,7 +1323,7 @@ maybeCreateManifest dflags exe_filename = do ...@@ -1324,7 +1323,7 @@ maybeCreateManifest dflags exe_filename = do
" </trustInfo>\n"++ " </trustInfo>\n"++
"</assembly>\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, -- However, for extra robustness, and so that we can move the binary around,
-- we can embed the manifest in the binary itself using windres: -- we can embed the manifest in the binary itself using windres:
if not (dopt Opt_EmbedManifest dflags) then return [] else do if not (dopt Opt_EmbedManifest dflags) then return [] else do
...@@ -1335,7 +1334,7 @@ maybeCreateManifest dflags exe_filename = do ...@@ -1335,7 +1334,7 @@ maybeCreateManifest dflags exe_filename = do
writeFile rc_filename $ writeFile rc_filename $
"1 24 MOVEABLE PURE " ++ show manifest_filename ++ "\n" "1 24 MOVEABLE PURE " ++ show manifest_filename ++ "\n"
-- magic numbers :-) -- 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. -- backslashes in the path.
let wr_opts = getOpts dflags opt_windres let wr_opts = getOpts dflags opt_windres
...@@ -1354,8 +1353,6 @@ maybeCreateManifest dflags exe_filename = do ...@@ -1354,8 +1353,6 @@ maybeCreateManifest dflags exe_filename = do
linkDynLib :: DynFlags -> [String] -> [PackageId] -> IO () linkDynLib :: DynFlags -> [String] -> [PackageId] -> IO ()
linkDynLib dflags o_files dep_packages = do linkDynLib dflags o_files dep_packages = do
let verb = getVerbFlag dflags let verb = getVerbFlag dflags
let static = opt_Static
let no_hs_main = dopt Opt_NoHsMain dflags
let o_file = outputFile dflags let o_file = outputFile dflags
pkg_lib_paths <- getPackageLibraryPath dflags dep_packages pkg_lib_paths <- getPackageLibraryPath dflags dep_packages
...@@ -1519,8 +1516,10 @@ doCpp dflags raw include_cc_opts input_fn output_fn = do ...@@ -1519,8 +1516,10 @@ doCpp dflags raw include_cc_opts input_fn output_fn = do
, SysTools.FileOption "" output_fn , SysTools.FileOption "" output_fn
]) ])
cHaskell1Version :: String
cHaskell1Version = "5" -- i.e., Haskell 98 cHaskell1Version = "5" -- i.e., Haskell 98
hsSourceCppOpts :: [String]
-- Default CPP defines in Haskell source -- Default CPP defines in Haskell source
hsSourceCppOpts = hsSourceCppOpts =
[ "-D__HASKELL1__="++cHaskell1Version [ "-D__HASKELL1__="++cHaskell1Version
...@@ -1534,8 +1533,8 @@ hsSourceCppOpts = ...@@ -1534,8 +1533,8 @@ hsSourceCppOpts =
-- Misc. -- Misc.
hscNextPhase :: DynFlags -> HscSource -> HscTarget -> Phase hscNextPhase :: DynFlags -> HscSource -> HscTarget -> Phase
hscNextPhase dflags HsBootFile hsc_lang = StopLn hscNextPhase _ HsBootFile _ = StopLn
hscNextPhase dflags other hsc_lang = hscNextPhase dflags _ hsc_lang =
case hsc_lang of case hsc_lang of
HscC -> HCc HscC -> HCc
HscAsm | dopt Opt_SplitObjs dflags -> SplitMangle HscAsm | dopt Opt_SplitObjs dflags -> SplitMangle
...@@ -1546,7 +1545,7 @@ hscNextPhase dflags other hsc_lang = ...@@ -1546,7 +1545,7 @@ hscNextPhase dflags other hsc_lang =
hscMaybeAdjustTarget :: DynFlags -> Phase -> HscSource -> HscTarget -> HscTarget hscMaybeAdjustTarget :: DynFlags -> Phase -> HscSource -> HscTarget -> HscTarget
hscMaybeAdjustTarget dflags stop other current_hsc_lang hscMaybeAdjustTarget dflags stop _ current_hsc_lang
= hsc_lang = hsc_lang
where where
keep_hc = dopt Opt_KeepHcFiles dflags keep_hc = dopt Opt_KeepHcFiles dflags
...@@ -1560,5 +1559,6 @@ hscMaybeAdjustTarget dflags stop other current_hsc_lang ...@@ -1560,5 +1559,6 @@ hscMaybeAdjustTarget dflags stop other current_hsc_lang
-- otherwise, stick to the plan -- otherwise, stick to the plan
| otherwise = current_hsc_lang | otherwise = current_hsc_lang
v_Split_info :: IORef (String, Int)
GLOBAL_VAR(v_Split_info, ("",0), (String,Int)) GLOBAL_VAR(v_Split_info, ("",0), (String,Int))
-- The split prefix and number of files -- The split prefix and number of files
...@@ -436,7 +436,7 @@ data GhcLink -- What to do in the link step, if there is one ...@@ -436,7 +436,7 @@ data GhcLink -- What to do in the link step, if there is one
| LinkBinary -- Link object code into a binary | LinkBinary -- Link object code into a binary
| LinkInMemory -- Use the in-memory dynamic linker | LinkInMemory -- Use the in-memory dynamic linker
| LinkDynLib -- Link objects into a dynamic lib (DLL on Windows, DSO on ELF platforms) | LinkDynLib -- Link objects into a dynamic lib (DLL on Windows, DSO on ELF platforms)
deriving Eq deriving (Eq, Show)
isNoLink :: GhcLink -> Bool isNoLink :: GhcLink -> Bool
isNoLink NoLink = True isNoLink NoLink = True
......
...@@ -12,6 +12,7 @@ module Finder ( ...@@ -12,6 +12,7 @@ module Finder (
findHomeModule, findHomeModule,
mkHomeModLocation, mkHomeModLocation,
mkHomeModLocation2, mkHomeModLocation2,
mkHiOnlyModLocation,
addHomeModuleToFinder, addHomeModuleToFinder,
uncacheModule, uncacheModule,
mkStubPaths, mkStubPaths,
...@@ -21,6 +22,7 @@ module Finder ( ...@@ -21,6 +22,7 @@ module Finder (
cannotFindModule, cannotFindModule,
cannotFindInterface, cannotFindInterface,
) where ) where
#include "HsVersions.h" #include "HsVersions.h"
...@@ -337,7 +339,7 @@ searchPathExts paths mod exts ...@@ -337,7 +339,7 @@ searchPathExts paths mod exts
return result return result
where where
basename = dots_to_slashes (moduleNameString (moduleName mod)) basename = moduleNameSlashes (moduleName mod)
to_search :: [(FilePath, IO ModLocation)] to_search :: [(FilePath, IO ModLocation)]
to_search = [ (file, fn path basename) to_search = [ (file, fn path basename)
...@@ -387,7 +389,7 @@ mkHomeModLocationSearched dflags mod suff path basename = do ...@@ -387,7 +389,7 @@ mkHomeModLocationSearched dflags mod suff path basename = do
-- (b) and (c): "." -- (b) and (c): "."
-- --
-- src_basename -- src_basename
-- (a): dots_to_slashes (moduleNameUserString mod) -- (a): (moduleNameSlashes mod)
-- (b) and (c): The filename of the source file, minus its extension -- (b) and (c): The filename of the source file, minus its extension
-- --
-- ext -- ext
...@@ -404,7 +406,7 @@ mkHomeModLocation2 :: DynFlags ...@@ -404,7 +406,7 @@ mkHomeModLocation2 :: DynFlags
-> String -- Suffix -> String -- Suffix
-> IO ModLocation -> IO ModLocation
mkHomeModLocation2 dflags mod src_basename ext = do 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 obj_fn <- mkObjPath dflags src_basename mod_basename
hi_fn <- mkHiPath dflags src_basename mod_basename hi_fn <- mkHiPath dflags src_basename mod_basename
...@@ -478,7 +480,7 @@ mkStubPaths dflags mod location ...@@ -478,7 +480,7 @@ mkStubPaths dflags mod location
= let = let
stubdir = stubDir dflags stubdir = stubDir dflags
mod_basename = dots_to_slashes (moduleNameString mod) mod_basename = moduleNameSlashes mod
src_basename = basenameOf (expectJust "mkStubPaths" src_basename = basenameOf (expectJust "mkStubPaths"
(ml_hs_file location)) (ml_hs_file location))
...@@ -529,12 +531,6 @@ findObjectLinkable mod obj_fn obj_time = do ...@@ -529,12 +531,6 @@ findObjectLinkable mod obj_fn obj_time = do
then return (LM obj_time mod [DotO obj_fn, DotO stub_fn]) then return (LM obj_time mod [DotO obj_fn, DotO stub_fn])
else return (LM obj_time mod [DotO obj_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 -- Error messages
......
...@@ -41,7 +41,8 @@ module GHC ( ...@@ -41,7 +41,8 @@ module GHC (
workingDirectoryChanged, workingDirectoryChanged,
checkModule, checkAndLoadModule, CheckedModule(..), checkModule, checkAndLoadModule, CheckedModule(..),
TypecheckedSource, ParsedSource, RenamedSource, TypecheckedSource, ParsedSource, RenamedSource,
compileToCore, compileToCoreModule, compileToCore, compileToCoreModule, compileToCoreSimplified,
compileCoreToObj,
-- * Parsing Haddock comments -- * Parsing Haddock comments
parseHaddockComment, parseHaddockComment,
...@@ -229,9 +230,12 @@ import FunDeps ...@@ -229,9 +230,12 @@ import FunDeps
import DataCon import DataCon
import Name hiding ( varName ) import Name hiding ( varName )
import OccName ( parenSymOcc ) import OccName ( parenSymOcc )
import InstEnv ( Instance, instanceDFunId, pprInstance, pprInstanceHdr ) import InstEnv ( Instance, instanceDFunId, pprInstance, pprInstanceHdr,
emptyInstEnv )
import FamInstEnv ( emptyFamInstEnv )
import SrcLoc import SrcLoc
import CoreSyn