# - create a link tree. The problem with requiring link trees is that
# Windows doesn't support symbolic links.
+ifeq "$(stage)" ""
+stage=1
+endif
+
boot ::
$(MKDIRHIER) stage$(stage)
for i in $(ALL_DIRS); do \
# PS: 'ln -s foo baz' takes 'foo' relative to the path to 'baz'
# whereas 'cp foo baz' treats the two paths independently.
# Hence the "../.." in the ln command line
+ifeq "$(stage)" "1"
+ifeq "$(ghc_ge_603)" "NO"
ifeq "$(HOSTPLATFORM)" "i386-unknown-mingw32"
for i in */*hi-boot*; do \
cp -u -f $$i stage$(stage)/$$i; \
$(LN_S) -f ../../$$i stage$(stage)/$$i || true ; \
done
endif
-
-ifeq "$(stage)" ""
-stage=1
+endif
endif
ifeq "$(stage)" "1"
--- /dev/null
+\begin{code}
+module DataCon where
+import Name( Name )
+
+data DataCon
+dataConName :: DataCon -> Name
+isVanillaDataCon :: DataCon -> Bool
+\end{code}
--- /dev/null
+\begin{code}
+module IdInfo where
+
+data IdInfo
+data GlobalIdDetails
+
+notGlobalId :: GlobalIdDetails
+seqIdInfo :: IdInfo -> ()
+\end{code}
\ No newline at end of file
--- /dev/null
+\begin{code}
+module MkId where
+import Name( Name )
+import DataCon( DataCon, DataConIds )
+
+mkDataConIds :: Name -> Name -> DataCon -> DataConIds
+\end{code}
+
+
, pprModule -- :: ModuleName -> SDoc
, ModLocation(..),
- , showModMsg
+ , addBootSuffix, addBootSuffix_maybe, addBootSuffixLocn,
, moduleString -- :: ModuleName -> EncodedString
, moduleUserString -- :: ModuleName -> UserString
, delModuleEnvList, delModuleEnv, plusModuleEnv, lookupModuleEnv
, lookupWithDefaultModuleEnv, mapModuleEnv, mkModuleEnv, emptyModuleEnv
, moduleEnvElts, unitModuleEnv, isEmptyModuleEnv, foldModuleEnv
- , extendModuleEnv_C
+ , extendModuleEnv_C, filterModuleEnv,
, ModuleSet, emptyModuleSet, mkModuleSet, moduleSetElts, extendModuleSet, elemModuleSet
import OccName
import Outputable
import Unique ( Uniquable(..) )
-import Maybes ( expectJust )
import UniqFM
import UniqSet
import Binary
-import StringBuffer ( StringBuffer )
import FastString
\end{code}
data ModLocation
= ModLocation {
ml_hs_file :: Maybe FilePath,
- -- the source file, if we have one. Package modules
+ -- The source file, if we have one. Package modules
-- probably don't have source files.
- ml_hspp_file :: Maybe FilePath,
- -- filename of preprocessed source, if we have
- -- preprocessed it.
- ml_hspp_buf :: Maybe StringBuffer,
- -- the actual preprocessed source, maybe.
-
ml_hi_file :: FilePath,
-- Where the .hi file is, whether or not it exists
-- yet. Always of form foo.hi, even if there is an
instance Outputable ModLocation where
ppr = text . show
-
--- Rather a gruesome function to have in Module
-
-showModMsg :: Bool -> Module -> ModLocation -> String
-showModMsg use_object mod location =
- mod_str ++ replicate (max 0 (16 - length mod_str)) ' '
- ++" ( " ++ expectJust "showModMsg" (ml_hs_file location) ++ ", "
- ++ (if use_object
- then ml_obj_file location
- else "interpreted")
- ++ " )"
- where mod_str = moduleUserString mod
\end{code}
For a module in another package, the hs_file and obj_file
file doesn't exist, the ModLocation still contains the path to
where the object file will reside if/when it is created.
+\begin{code}
+addBootSuffix :: FilePath -> FilePath
+-- Add the "-boot" suffix to .hs, .hi and .o files
+addBootSuffix path = path ++ "-boot"
+
+addBootSuffix_maybe :: Bool -> FilePath -> FilePath
+addBootSuffix_maybe is_boot path
+ | is_boot = addBootSuffix path
+ | otherwise = path
+
+addBootSuffixLocn :: ModLocation -> ModLocation
+addBootSuffixLocn locn
+ = locn { ml_hs_file = fmap addBootSuffix (ml_hs_file locn)
+ , ml_hi_file = addBootSuffix (ml_hi_file locn)
+ , ml_obj_file = addBootSuffix (ml_obj_file locn) }
+\end{code}
+
%************************************************************************
%* *
lookupWithDefaultModuleEnv :: ModuleEnv a -> a -> Module -> a
elemModuleEnv :: Module -> ModuleEnv a -> Bool
foldModuleEnv :: (a -> b -> b) -> b -> ModuleEnv a -> b
+filterModuleEnv :: (a -> Bool) -> ModuleEnv a -> ModuleEnv a
+filterModuleEnv = filterUFM
elemModuleEnv = elemUFM
extendModuleEnv = addToUFM
extendModuleEnv_C = addToUFM_C
--- /dev/null
+\begin{code}
+module Module where
+
+data Module
+\end{code}
+
--- /dev/null
+\begin{code}
+module Name where
+
+data Name
+\end{code}
--- /dev/null
+\begin{code}
+module OccName where
+
+data OccName
+\end{code}
--- /dev/null
+\begin{code}
+module CgBindery where
+import VarEnv( IdEnv )
+
+data CgIdInfo
+data VolatileLoc
+data StableLoc
+type CgBindings = IdEnv CgIdInfo
+
+nukeVolatileBinds :: CgBindings -> CgBindings
+\end{code}
\ No newline at end of file
--- /dev/null
+\begin{code}
+module CgExpr where
+import StgSyn( StgExpr )
+import CgMonad( Code )
+
+cgExpr :: StgExpr -> Code
+\end{code}
--- /dev/null
+\begin{code}
+module ClosureInfo where
+
+data LambdaFormInfo
+data ClosureInfo
+\end{code}
\ No newline at end of file
cmInit, -- :: GhciMode -> IO CmState
cmDepAnal, -- :: CmState -> [FilePath] -> IO ModuleGraph
+ cmTopSort, -- :: Bool -> ModuleGraph -> [SCC ModSummary]
+ cyclicModuleErr, -- :: [ModSummary] -> String -- Used by DriverMkDepend
cmLoadModules, -- :: CmState -> ModuleGraph
-- -> IO (CmState, Bool, [String])
cmUnload, -- :: CmState -> IO CmState
+
#ifdef GHCI
cmModuleIsInterpreted, -- :: CmState -> String -> IO Bool
import DriverPipeline ( CompResult(..), preprocess, compile, link )
import HscMain ( newHscEnv )
import DriverState ( v_Output_file, v_NoHsMain, v_MainModIs )
-import DriverPhases
-import Finder
-import HscTypes
-import PrelNames ( gHC_PRIM )
-import Module ( Module, mkModule, delModuleEnvList, mkModuleEnv,
- lookupModuleEnv, moduleEnvElts, extendModuleEnv,
- moduleUserString,
+import DriverPhases ( HscSource(..), isHsBoot, hscSourceString, isHaskellSrcFilename )
+import Finder ( findModule, findLinkable, addHomeModuleToFinder, flushFinderCache,
+ mkHomeModLocation, FindResult(..), cantFindError )
+import HscTypes ( ModSummary(..), HomeModInfo(..), ModIface(..), msHsFilePath,
+ HscEnv(..), GhciMode(..),
+ InteractiveContext(..), emptyInteractiveContext,
+ HomePackageTable, emptyHomePackageTable, IsBootInterface,
+ Linkable(..), isObjectLinkable )
+import Module ( Module, mkModule, delModuleEnv, delModuleEnvList, mkModuleEnv,
+ lookupModuleEnv, moduleEnvElts, extendModuleEnv, filterModuleEnv,
+ moduleUserString, addBootSuffixLocn,
ModLocation(..) )
-import GetImports
-import LoadIface ( noIfaceErr )
+import GetImports ( getImports )
import Digraph ( SCC(..), stronglyConnComp, flattenSCC, flattenSCCs )
import ErrUtils ( showPass )
import SysTools ( cleanTempFilesExcept )
-import BasicTypes ( SuccessFlag(..), succeeded, failed )
+import BasicTypes ( SuccessFlag(..), succeeded )
import StringBuffer ( hGetStringBuffer )
import Util
import Outputable
#ifdef GHCI
import HscMain ( hscGetInfo, GetInfoResult, hscStmt, hscTcExpr, hscKcType )
+import HscTypes ( TyThing(..), icPrintUnqual, showModMsg )
import TcRnDriver ( mkExportEnv, getModuleContents )
import IfaceSyn ( IfaceDecl )
import RdrName ( GlobalRdrEnv, plusGlobalRdrEnv )
-import Module ( showModMsg )
import Name ( Name )
import NameEnv
import Id ( idType )
import Type ( tidyType )
import VarEnv ( emptyTidyEnv )
-import BasicTypes ( Fixity )
import Linker ( HValue, unload, extendLinkEnv )
import GHC.Exts ( unsafeCoerce# )
import Foreign
-import SrcLoc ( SrcLoc )
import Control.Exception as Exception ( Exception, try )
import CmdLineOpts ( DynFlag(..), dopt_unset )
#endif
import Monad
import List ( nub )
import Maybe
-import Time ( ClockTime )
\end{code}
emptyMG = []
--------------------
-data ModSummary
- = ModSummary {
- ms_mod :: Module, -- Name of the module
- ms_boot :: IsBootInterface, -- Whether this is an hi-boot file
- ms_location :: ModLocation, -- Location
- ms_srcimps :: [Module], -- Source imports
- ms_imps :: [Module], -- Non-source imports
- ms_hs_date :: ClockTime -- Timestamp of summarised file
- }
-
--- The ModLocation contains both the original source filename and the
--- filename of the cleaned-up source file after all preprocessing has been
--- done. The point is that the summariser will have to cpp/unlit/whatever
--- all files anyway, and there's no point in doing this twice -- just
--- park the result in a temp file, put the name of it in the location,
--- and let @compile@ read from that file on the way back up.
-
-instance Outputable ModSummary where
- ppr ms
- = sep [text "ModSummary {",
- nest 3 (sep [text "ms_hs_date = " <> text (show (ms_hs_date ms)),
- text "ms_mod =" <+> ppr (ms_mod ms) <> comma,
- text "ms_imps =" <+> ppr (ms_imps ms),
- text "ms_srcimps =" <+> ppr (ms_srcimps ms)]),
- char '}'
- ]
-
+ms_allimps :: ModSummary -> [Module]
ms_allimps ms = ms_srcimps ms ++ ms_imps ms
--------------------
-type NodeKey = (Module, IsBootInterface) -- The nodes of the graph are
-type NodeMap a = FiniteMap NodeKey a -- keyed by (mod,boot) pairs
+type NodeKey = (Module, HscSource) -- The nodes of the graph are
+type NodeMap a = FiniteMap NodeKey a -- keyed by (mod, src_file_type) pairs
msKey :: ModSummary -> NodeKey
-msKey (ModSummary { ms_mod = mod, ms_boot = boot }) = (mod,boot)
+msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) = (mod,boot)
emptyNodeMap :: NodeMap a
emptyNodeMap = emptyFM
-mkNodeMap :: [(NodeKey,a)] -> NodeMap a
-mkNodeMap = listToFM
+mkNodeMap :: [ModSummary] -> NodeMap ModSummary
+mkNodeMap summaries = listToFM [ (msKey s, s) | s <- summaries]
nodeMapElts :: NodeMap a -> [a]
nodeMapElts = eltsFM
[] -> Nothing
[li] -> Just li
many -> pprPanic "findModuleLinkable" (ppr mod)
+
+delModuleLinkable :: [Linkable] -> Module -> [Linkable]
+delModuleLinkable ls mod = [ l | l@(LM _ nm _) <- ls, nm /= mod ]
\end{code}
-----------------------------------------------------------------------------
cmShowModule :: CmState -> ModSummary -> String
cmShowModule cmstate mod_summary
- = case lookupModuleEnv hpt mod of
+ = case lookupModuleEnv hpt (ms_mod mod_summary) of
Nothing -> panic "missing linkable"
- Just mod_info -> showModMsg obj_linkable mod locn
+ Just mod_info -> showModMsg obj_linkable mod_summary
where
obj_linkable = isObjectLinkable (hm_linkable mod_info)
where
hpt = hsc_HPT (cm_hsc cmstate)
- mod = ms_mod mod_summary
- locn = ms_location mod_summary
-----------------------------------------------------------------------------
-- cmRunStmt: Run a statement/expr.
-- Start with a fresh CmState, but keep the PersistentCompilerState
return (discardCMInfo state)
-cm_unload hsc_env linkables
+cm_unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables'
= case hsc_mode hsc_env of
Batch -> return ()
#ifdef GHCI
- Interactive -> Linker.unload (hsc_dflags hsc_env) linkables
+ Interactive -> Linker.unload (hsc_dflags hsc_env) stable_linkables
#else
- Interactive -> panic "unload: no interpreter"
+ Interactive -> panic "cm_unload: no interpreter"
#endif
+ other -> panic "cm_unload: strange mode"
-----------------------------------------------------------------------------
-- mg2 should be cycle free; but it includes hi-boot ModSummary nodes
let mg2 :: [SCC ModSummary]
- mg2 = topological_sort False mg2unsorted
+ mg2 = cmTopSort False mg2unsorted
-- mg2_with_srcimps drops the hi-boot nodes, returning a
-- graph with cycles. Among other things, it is used for
-- upsweep, and for removing from hpt all the modules
-- not in strict downwards closure, during calls to compile.
let mg2_with_srcimps :: [SCC ModSummary]
- mg2_with_srcimps = topological_sort True mg2unsorted
+ mg2_with_srcimps = cmTopSort True mg2unsorted
-- Sort out which linkables we wish to keep in the unlinked image.
-- See getValidLinkables below for details.
-- putStrLn (showSDoc (vcat [ppr valid_old_linkables, ppr new_linkables]))
- let hpt2 = delModuleEnvList hpt1 (map linkableModule new_linkables)
- hsc_env2 = hsc_env { hsc_HPT = hpt2 }
+ -- The new_linkables are .o files we found on the disk, presumably
+ -- as a result of a GHC run "on the side". So we'd better forget
+ -- everything we know abouut those modules!
+ let old_hpt = delModuleEnvList hpt1 (map linkableModule new_linkables)
-- When (verb >= 2) $
-- putStrLn (showSDoc (text "Valid linkables:"
stable_linkables = filter (\m -> linkableModule m `elem` stable_mods)
valid_old_linkables
+ stable_hpt = filterModuleEnv is_stable_hm hpt1
+ is_stable_hm hm_info = mi_module (hm_iface hm_info) `elem` stable_mods
+
+ upsweep_these
+ = filter (\scc -> any (`notElem` stable_mods)
+ (map ms_mod (flattenSCC scc)))
+ mg2
+
when (verb >= 2) $
hPutStrLn stderr (showSDoc (text "Stable modules:"
<+> sep (map (text.moduleUserString) stable_mods)))
- -- Unload any modules which are going to be re-linked this
- -- time around.
- cm_unload hsc_env2 stable_linkables
+ -- Unload any modules which are going to be re-linked this time around.
+ cm_unload hsc_env stable_linkables
- -- we can now glom together our linkable sets
+ -- We can now glom together our linkable sets
let valid_linkables = valid_old_linkables ++ new_linkables
-- We could at this point detect cycles which aren't broken by
-- a source-import, and complain immediately, but it seems better
-- to let upsweep_mods do this, so at least some useful work gets
-- done before the upsweep is abandoned.
- let upsweep_these
- = filter (\scc -> any (`notElem` stable_mods)
- (map ms_mod (flattenSCC scc)))
- mg2
-
--hPutStrLn stderr "after tsort:\n"
--hPutStrLn stderr (showSDoc (vcat (map ppr mg2)))
(ppFilesFromSummaries (flattenSCCs mg2))
(upsweep_ok, hsc_env3, modsUpswept)
- <- upsweep_mods hsc_env2 valid_linkables
+ <- upsweep_mods (hsc_env { hsc_HPT = stable_hpt })
+ (old_hpt, valid_linkables)
cleanup upsweep_these
-- At this point, modsUpswept and newLis should have the same
-- used to fish out the preprocess output files for the purposes of
-- cleaning up. The preprocessed file *might* be the same as the
-- source file, but that doesn't do any harm.
-ppFilesFromSummaries summaries
- = [ fn | Just fn <- map (ml_hspp_file.ms_location) summaries ]
+ppFilesFromSummaries summaries = [ fn | Just fn <- map ms_hspp_file summaries ]
-----------------------------------------------------------------------------
-- getValidLinkables
-> [Module] -- all home modules
-> [SCC ModSummary] -- all modules in the program, dependency order
-> IO ( [Linkable], -- still-valid linkables
- [Linkable] -- new linkables we just found
+ [Linkable] -- new linkables we just found on the disk
+ -- presumably generated by separate run of ghc
)
getValidLinkables mode old_linkables all_home_mods module_graph
-- Compile multiple modules, stopping as soon as an error appears.
-- There better had not be any cyclic groups here -- we check for them.
-upsweep_mods :: HscEnv -- Includes up-to-date HPT
- -> [Linkable] -- Valid linkables
- -> IO () -- how to clean up unwanted tmp files
- -> [SCC ModSummary] -- mods to do (the worklist)
- -- ...... RETURNING ......
+upsweep_mods :: HscEnv -- Includes initially-empty HPT
+ -> (HomePackageTable, [Linkable]) -- HPT and valid linkables from last time round
+ -> IO () -- How to clean up unwanted tmp files
+ -> [SCC ModSummary] -- Mods to do (the worklist)
-> IO (SuccessFlag,
HscEnv, -- With an updated HPT
[ModSummary]) -- Mods which succeeded
upsweep_mods hsc_env oldUI cleanup
(CyclicSCC ms:_)
- = do hPutStrLn stderr ("Module imports form a cycle for modules:\n\t" ++
- unwords (map (moduleUserString.ms_mod) ms))
+ = do hPutStrLn stderr (showSDoc (cyclicModuleErr ms))
return (Failed, hsc_env, [])
-upsweep_mods hsc_env oldUI cleanup
+upsweep_mods hsc_env oldUI@(old_hpt, old_linkables) cleanup
(AcyclicSCC mod:mods)
= do -- putStrLn ("UPSWEEP_MOD: hpt = " ++
-- show (map (moduleUserString.moduleName.mi_module.hm_iface)
-- (moduleEnvElts (hsc_HPT hsc_env)))
- (ok_flag, hsc_env1) <- upsweep_mod hsc_env oldUI mod
+ mb_mod_info <- upsweep_mod hsc_env oldUI mod
cleanup -- Remove unwanted tmp files between compilations
- if failed ok_flag then
- return (Failed, hsc_env1, [])
- else do
- (restOK, hsc_env2, modOKs) <- upsweep_mods hsc_env1 oldUI cleanup mods
- return (restOK, hsc_env2, mod:modOKs)
+ case mb_mod_info of
+ Nothing -> return (Failed, hsc_env, [])
+ Just mod_info -> do
+ { let this_mod = ms_mod mod
+
+ -- Add new info to hsc_env
+ hpt1 = extendModuleEnv (hsc_HPT hsc_env) this_mod mod_info
+ hsc_env1 = hsc_env { hsc_HPT = hpt1 }
+
+ -- Space-saving: delete the old HPT entry and linkable for mod
+ -- BUT if mod is a hs-boot node, don't delete it
+ -- For the linkable this is dead right: the linkable relates only
+ -- to the main Haskell source file.
+ -- For the interface, the HPT entry is probaby for the main Haskell
+ -- source file. Deleting it would force
+ oldUI1 | isHsBoot (ms_hsc_src mod) = oldUI
+ | otherwise
+ = (delModuleEnv old_hpt this_mod,
+ delModuleLinkable old_linkables this_mod)
+
+ ; (restOK, hsc_env2, modOKs) <- upsweep_mods hsc_env1 oldUI1 cleanup mods
+ ; return (restOK, hsc_env2, mod:modOKs) }
-- Compile a single module. Always produce a Linkable for it if
-- successful. If no compilation happened, return the old Linkable.
upsweep_mod :: HscEnv
- -> UnlinkedImage
+ -> (HomePackageTable, UnlinkedImage)
-> ModSummary
- -> IO (SuccessFlag,
- HscEnv) -- With updated HPT
-
-upsweep_mod hsc_env oldUI summary1
- | ms_boot summary1 -- The summary describes an hi-boot file,
- = -- so there is nothing to do
- return (Succeeded, hsc_env)
+ -> IO (Maybe HomeModInfo) -- Nothing => Failed
- | otherwise -- The summary describes a regular source file, so compile it
+upsweep_mod hsc_env (old_hpt, old_linkables) summary
= do
- let this_mod = ms_mod summary1
- location = ms_location summary1
- hpt1 = hsc_HPT hsc_env
-
- let mb_old_iface = case lookupModuleEnv hpt1 this_mod of
- Just mod_info -> Just (hm_iface mod_info)
- Nothing -> Nothing
-
- let maybe_old_linkable = findModuleLinkable_maybe oldUI this_mod
+ let this_mod = ms_mod summary
+
+ -- The old interface is ok if it's in the old HPT
+ -- a) we're compiling a source file, and the old HPT entry is for a source file
+ -- b) we're compiling a hs-boot file
+ -- Case (b) allows an hs-boot file to get the interface of its real source file
+ -- on the second iteration of the compilation manager, but that does no harm.
+ -- Otherwise the hs-boot file will always be recompiled
+ mb_old_iface
+ = case lookupModuleEnv old_hpt this_mod of
+ Nothing -> Nothing
+ Just hm_info | isHsBoot (ms_hsc_src summary) -> Just iface
+ | not (mi_boot iface) -> Just iface
+ | otherwise -> Nothing
+ where
+ iface = hm_iface hm_info
+
+ maybe_old_linkable = findModuleLinkable_maybe old_linkables this_mod
source_unchanged = isJust maybe_old_linkable
old_linkable = expectJust "upsweep_mod:old_linkable" maybe_old_linkable
| Just l <- maybe_old_linkable, isObjectLinkable l = True
| otherwise = False
- compresult <- compile hsc_env this_mod location
- (ms_hs_date summary1)
- source_unchanged have_object mb_old_iface
+ compresult <- compile hsc_env summary source_unchanged have_object mb_old_iface
case compresult of
hm_globals = new_globals,
hm_details = new_details,
hm_linkable = new_linkable }
- hpt2 = extendModuleEnv hpt1 this_mod new_info
-
- return (Succeeded, hsc_env { hsc_HPT = hpt2 })
+ return (Just new_info)
-- Compilation failed. Compile may still have updated the PCS, tho.
- CompErrs -> return (Failed, hsc_env)
+ CompErrs -> return Nothing
-- Filter modules in the HPT
retainInTopLevelEnvs :: [Module] -> HomePackageTable -> HomePackageTable
, isJust mb_mod_info ]
-----------------------------------------------------------------------------
-topological_sort :: Bool -- Drop hi-boot nodes? (see below)
- -> [ModSummary]
- -> [SCC ModSummary]
+cmTopSort :: Bool -- Drop hi-boot nodes? (see below)
+ -> [ModSummary]
+ -> [SCC ModSummary]
-- Calculate SCCs of the module graph, possibly dropping the hi-boot nodes
--
-- Drop hi-boot nodes (first boolean arg)?
-- the a source-import of Foo is an import of Foo
-- The resulting graph has no hi-boot nodes, but can by cyclic
-topological_sort drop_hi_boot_nodes summaries
+cmTopSort drop_hs_boot_nodes summaries
= stronglyConnComp nodes
where
- keep_hi_boot_nodes = not drop_hi_boot_nodes
+ -- Drop hs-boot nodes by using HsSrcFile as the key
+ hs_boot_key | drop_hs_boot_nodes = HsSrcFile
+ | otherwise = HsBootFile
-- We use integers as the keys for the SCC algorithm
nodes :: [(ModSummary, Int, [Int])]
- nodes = [(s, fromJust (lookup_key (ms_boot s) (ms_mod s)),
- out_edge_keys keep_hi_boot_nodes (ms_srcimps s) ++
- out_edge_keys False (ms_imps s) )
+ nodes = [(s, fromJust (lookup_key (ms_hsc_src s) (ms_mod s)),
+ out_edge_keys hs_boot_key (ms_srcimps s) ++
+ out_edge_keys HsSrcFile (ms_imps s) )
| s <- summaries
- , not (ms_boot s) || keep_hi_boot_nodes ]
+ , not (ms_hsc_src s == HsBootFile && drop_hs_boot_nodes) ]
-- Drop the hi-boot ones if told to do so
key_map :: NodeMap Int
- key_map = listToFM ([(ms_mod s, ms_boot s) | s <- summaries]
+ key_map = listToFM ([(ms_mod s, ms_hsc_src s) | s <- summaries]
`zip` [1..])
- lookup_key :: IsBootInterface -> Module -> Maybe Int
- lookup_key hi_boot mod = lookupFM key_map (mod, hi_boot)
+ lookup_key :: HscSource -> Module -> Maybe Int
+ lookup_key hs_src mod = lookupFM key_map (mod, hs_src)
- out_edge_keys :: IsBootInterface -> [Module] -> [Int]
+ out_edge_keys :: HscSource -> [Module] -> [Int]
out_edge_keys hi_boot ms = mapCatMaybes (lookup_key hi_boot) ms
-- If we want keep_hi_boot_nodes, then we do lookup_key with
-- the IsBootInterface parameter True; else False
downsweep dflags roots old_summaries
= do rootSummaries <- mapM getRootSummary roots
checkDuplicates rootSummaries
- loop rootSummaries emptyNodeMap
+ loop (concatMap msImports rootSummaries)
+ (mkNodeMap rootSummaries)
where
old_summary_map :: NodeMap ModSummary
- old_summary_map = mkNodeMap [ (msKey s, s) | s <- old_summaries]
+ old_summary_map = mkNodeMap old_summaries
getRootSummary :: FilePath -> IO ModSummary
getRootSummary file
exists <- doesFileExist lhs_file
if exists then summariseFile dflags lhs_file else do
let mod_name = mkModule file
- maybe_summary <- getSummary file False {- Not hi-boot -} mod_name
+ maybe_summary <- summarise dflags emptyNodeMap Nothing False mod_name
case maybe_summary of
Nothing -> packageModErr mod_name
Just s -> return s
[ fromJust (ml_hs_file (ms_location summ'))
| summ' <- summaries, ms_mod summ' == modl ]
- loop :: [ModSummary] -- Work list: process the imports of these modules
+ loop :: [(FilePath,Module,IsBootInterface)] -- Work list: process these modules
-> NodeMap ModSummary -- Visited set
-> IO [ModSummary] -- The result includes the worklist, except
-- for those mentioned in the visited set
loop [] done = return (nodeMapElts done)
- loop (s:ss) done | key `elemFM` done = loop ss done
- | otherwise = do { new_ss <- children s
- ; loop (new_ss ++ ss) (addToFM done key s) }
- where
- key = (ms_mod s, ms_boot s)
-
- children :: ModSummary -> IO [ModSummary]
- children s = do { mb_kids1 <- mapM (getSummary cur_path True) (ms_srcimps s)
- ; mb_kids2 <- mapM (getSummary cur_path False) (ms_imps s)
- ; return (catMaybes mb_kids1 ++ catMaybes mb_kids2) }
- -- The Nothings are the ones from other packages: ignore
+ loop ((cur_path, wanted_mod, is_boot) : ss) done
+ | key `elemFM` done = loop ss done
+ | otherwise = do { mb_s <- summarise dflags old_summary_map
+ (Just cur_path) is_boot wanted_mod
+ ; case mb_s of
+ Nothing -> loop ss done
+ Just s -> loop (msImports s ++ ss)
+ (addToFM done key s) }
where
- cur_path = fromJust (ml_hs_file (ms_location s))
+ key = (wanted_mod, if is_boot then HsBootFile else HsSrcFile)
- getSummary :: FilePath -- Import directive is in here [only used for err msg]
- -> IsBootInterface -- Look for an hi-boot file?
- -> Module -- Look for this module
- -> IO (Maybe ModSummary)
- getSummary cur_mod is_boot wanted_mod
- = do found <- findModule dflags wanted_mod True {-explicit-}
- case found of
- Found location pkg
- | isHomePackage pkg -- Drop an external-package modules
- -> do { let old_summary = lookupFM old_summary_map (wanted_mod, is_boot)
- ; summarise dflags wanted_mod is_boot location old_summary }
- | otherwise
- -> return Nothing -- External package module
+msImports :: ModSummary -> [(FilePath, -- Importing module
+ Module, -- Imported module
+ IsBootInterface)] -- {-# SOURCE #-} import or not
+msImports s = [(f, m,True) | m <- ms_srcimps s]
+ ++ [(f, m,False) | m <- ms_imps s]
+ where
+ f = msHsFilePath s -- Keep the importing module for error reporting
- err -> throwDyn (noModError dflags cur_mod wanted_mod err)
-
-
--- ToDo: we don't have a proper line number for this error
-noModError dflags loc mod_nm err
- = ProgramError (showSDoc (hang (text loc <> colon) 4 $
- noIfaceErr dflags mod_nm err))
-----------------------------------------------------------------------------
-- Summarising modules
-- resides.
summariseFile :: DynFlags -> FilePath -> IO ModSummary
+-- Used for Haskell source only, I think
+-- We know the file name, and we know it exists,
+-- but we don't necessarily know the module name (might differ)
summariseFile dflags file
- = do hspp_fn <- preprocess dflags file
+ = do (dflags', hspp_fn) <- preprocess dflags file
+ -- The dflags' contains the OPTIONS pragmas
-- Read the file into a buffer. We're going to cache
-- this buffer in the ModLocation (ml_hspp_buf) so that it
-- doesn't have to be slurped again when hscMain parses the
-- file later.
buf <- hGetStringBuffer hspp_fn
- (srcimps,imps,mod) <- getImports dflags buf hspp_fn
-
- let -- GHC.Prim doesn't exist physically, so don't go looking for it.
- the_imps = filter (/= gHC_PRIM) imps
+ (srcimps,the_imps,mod) <- getImports dflags' buf hspp_fn
+ -- Make a ModLocation for this file
location <- mkHomeModLocation mod file
+ -- Tell the Finder cache where it is, so that subsequent calls
+ -- to findModule will find it, even if it's not on any search path
+ addHomeModuleToFinder mod location
+
src_timestamp
<- case ml_hs_file location of
- Nothing -> noHsFileErr mod
+ Nothing -> noHsFileErr Nothing mod
Just src_fn -> getModificationTime src_fn
- return (ModSummary { ms_mod = mod, ms_boot = False,
- ms_location = location{ml_hspp_file=Just hspp_fn},
+ return (ModSummary { ms_mod = mod, ms_hsc_src = HsSrcFile,
+ ms_location = location,
+ ms_hspp_file = Just hspp_fn,
+ ms_hspp_buf = Just buf,
ms_srcimps = srcimps, ms_imps = the_imps,
ms_hs_date = src_timestamp })
-- Summarise a module, and pick up source and timestamp.
summarise :: DynFlags
- -> Module -- Guaranteed a home-package module
- -> IsBootInterface
- -> ModLocation -> Maybe ModSummary
- -> IO (Maybe ModSummary)
-summarise dflags mod is_boot location old_summary
- = do { -- Find the source file to summarise
- src_fn <- if is_boot then
- hiBootFilePath location
- else
- case ml_hs_file location of
- Nothing -> noHsFileErr mod
- Just src_fn -> return src_fn
-
- -- Find its timestamp
- ; src_timestamp <- getModificationTime src_fn
-
- -- return the cached summary if the source didn't change
- ; case old_summary of {
- Just s | ms_hs_date s == src_timestamp -> return (Just s);
- _ -> do
-
- -- For now, we never pre-process hi-boot files
- { hspp_fn <- if is_boot then return src_fn
- else preprocess dflags src_fn
+ -> NodeMap ModSummary -- Map of old summaries
+ -> Maybe FilePath -- Importing module (for error messages)
+ -> IsBootInterface -- True <=> a {-# SOURCE #-} import
+ -> Module -- Imported module to be summarised
+ -> IO (Maybe ModSummary) -- Its new summary
+
+summarise dflags old_summary_map cur_mod is_boot wanted_mod
+ = do { found <- findModule dflags wanted_mod True {-explicit-}
+ ; case found of
+ Found location pkg
+ | isHomePackage pkg
+ -> do { summary <- do_summary location
+ ; return (Just summary) }
+ | otherwise
+ -> return Nothing -- Drop an external-package modules
+
+ err -> noModError dflags cur_mod wanted_mod err
+ }
+ where
+ hsc_src = if is_boot then HsBootFile else HsSrcFile
+
+ do_summary location
+ = do { -- Adjust location to point to the hs-boot source file,
+ -- hi file, object file, when is_boot says so
+ let location' | is_boot = addBootSuffixLocn location
+ | otherwise = location
+
+ -- Find the source file to summarise
+ ; src_fn <- case ml_hs_file location' of
+ Nothing -> noHsFileErr cur_mod wanted_mod
+ Just src_fn -> return src_fn
+
+ -- In the case of hs-boot files, check that it exists
+ -- The Finder was dealing only with the main source file
+ ; if is_boot then do
+ { exists <- doesFileExist src_fn
+ ; if exists then return ()
+ else noHsBootFileErr cur_mod src_fn }
+ else return ()
+
+ -- Find its timestamp
+ ; src_timestamp <- getModificationTime src_fn
+
+ -- return the cached summary if the source didn't change
+ ; case lookupFM old_summary_map (wanted_mod, hsc_src) of {
+ Just s | ms_hs_date s == src_timestamp -> return s;
+ _ -> do
+
+ -- Preprocess the source file
+ { (dflags', hspp_fn) <- preprocess dflags src_fn
+ -- The dflags' contains the OPTIONS pragmas
; buf <- hGetStringBuffer hspp_fn
- ; (srcimps,imps,mod_name) <- getImports dflags buf hspp_fn
- ; let
- -- GHC.Prim doesn't exist physically, so don't go looking for it.
- the_imps = filter (/= gHC_PRIM) imps
+ ; (srcimps, the_imps, mod_name) <- getImports dflags' buf hspp_fn
- ; when (mod_name /= mod) $
+ ; when (mod_name /= wanted_mod) $
throwDyn (ProgramError
(showSDoc (text src_fn
<> text ": file name does not match module name"
- <+> quotes (ppr mod))))
-
- ; let new_loc = location{ ml_hspp_file = Just hspp_fn,
- ml_hspp_buf = Just buf }
- ; return (Just (ModSummary mod is_boot new_loc
- srcimps the_imps src_timestamp))
+ <+> quotes (ppr mod_name))))
+
+ ; return (ModSummary { ms_mod = wanted_mod,
+ ms_hsc_src = hsc_src,
+ ms_location = location',
+ ms_hspp_file = Just hspp_fn,
+ ms_hspp_buf = Just buf,
+ ms_srcimps = srcimps,
+ ms_imps = the_imps,
+ ms_hs_date = src_timestamp })
}}}
-noHsFileErr mod
- = throwDyn (CmdLineError (showSDoc (text "no source file for module" <+> quotes (ppr mod))))
+
+-----------------------------------------------------------------------------
+-- Error messages
+-----------------------------------------------------------------------------
+
+noModError :: DynFlags -> Maybe FilePath -> Module -> FindResult -> IO ab
+-- ToDo: we don't have a proper line number for this error
+noModError dflags cur_mod wanted_mod err
+ = throwDyn $ ProgramError $ showSDoc $
+ vcat [cantFindError dflags wanted_mod err,
+ nest 2 (parens (pp_where cur_mod))]
+
+noHsFileErr :: Maybe FilePath -> Module -> IO a
+-- Complain about not being able to find an imported module
+noHsFileErr cur_mod mod
+ = throwDyn $ CmdLineError $ showSDoc $
+ vcat [text "No source file for module" <+> quotes (ppr mod),
+ nest 2 (parens (pp_where cur_mod))]
+
+noHsBootFileErr cur_mod path
+ = throwDyn $ CmdLineError $ showSDoc $
+ vcat [text "Can't find" <+> text path,
+ nest 2 (parens (pp_where cur_mod))]
+
+pp_where Nothing = text "one of the roots of the dependency analysis"
+pp_where (Just p) = text "imported from" <+> text p
packageModErr mod
= throwDyn (CmdLineError (showSDoc (text "module" <+>
text "module" <+> quotes (ppr mod) <+>
text "is defined in multiple files:" <+>
sep (map text files))))
-\end{code}
+cyclicModuleErr :: [ModSummary] -> SDoc
+cyclicModuleErr ms
+ = hang (ptext SLIT("Module imports form a cycle for modules:"))
+ 2 (vcat (map show_one ms))
+ where
+ show_one ms = vcat [show_mod (ms_hsc_src ms) (ms_mod ms),
+ ptext SLIT("Imports:") <+>
+ (pp_imps HsBootFile (ms_srcimps ms)
+ $$ pp_imps HsSrcFile (ms_imps ms))]
+ show_mod hsc_src mod = ppr mod <> text (hscSourceString hsc_src)
+ pp_imps src mods = fsep (map (show_mod src) mods)
+\end{code}
#include "HsVersions.h"
import CmdLineOpts ( DynFlag(..), DynFlags(..), dopt, opt_SccProfilingOn )
+import DriverPhases ( isHsBoot )
import HscTypes ( ModGuts(..), ModGuts, HscEnv(..), GhciMode(..),
Dependencies(..), TypeEnv, IsBootInterface )
import HsSyn ( RuleDecl(..), RuleBndr(..), HsExpr(..), LHsExpr,
deSugar hsc_env
tcg_env@(TcGblEnv { tcg_mod = mod,
+ tcg_src = hsc_src,
tcg_type_env = type_env,
tcg_imports = imports,
tcg_exports = exports,
mod_guts = ModGuts {
mg_module = mod,
+ mg_boot = isHsBoot hsc_src,
mg_exports = exports,
mg_deps = deps,
mg_usages = usages,
--- /dev/null
+\begin{code}
+module DsExpr where
+import HsSyn ( HsExpr, LHsExpr, HsBindGroup )
+import Var ( Id )
+import DsMonad ( DsM )
+import CoreSyn ( CoreExpr )
+
+dsExpr :: HsExpr Id -> DsM CoreExpr
+dsLExpr :: LHsExpr Id -> DsM CoreExpr
+dsLet :: [HsBindGroup Id] -> CoreExpr -> DsM CoreExpr
+\end{code}
DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
- dsWarn,
- DsWarning,
- DsMatchContext(..)
+ -- Warnings
+ DsWarning, dsWarn,
+
+ -- Data types
+ DsMatchContext(..),
+ EquationInfo(..), MatchResult(..),
+ CanItFail(..), orFail
) where
#include "HsVersions.h"
import TcRnMonad
+import CoreSyn ( CoreExpr )
import HsSyn ( HsExpr, HsMatchContext, Pat )
import TcIface ( tcIfaceGlobal )
import RdrName ( GlobalRdrEnv )
infixr 9 `thenDs`
\end{code}
+%************************************************************************
+%* *
+ Data types for the desugarer
+%* *
+%************************************************************************
+
+\begin{code}
+data DsMatchContext
+ = DsMatchContext (HsMatchContext Name) [Pat Id] SrcSpan
+ | NoMatchContext
+ deriving ()
+
+data EquationInfo
+ = EqnInfo { eqn_pats :: [Pat Id], -- The patterns for an eqn
+ eqn_rhs :: MatchResult } -- What to do after match
+
+-- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult
+-- \fail. wrap (case vs of { pats -> rhs fail })
+-- where vs are not in the domain of wrap
+
+
+-- A MatchResult is an expression with a hole in it
+data MatchResult
+ = MatchResult
+ CanItFail -- Tells whether the failure expression is used
+ (CoreExpr -> DsM CoreExpr)
+ -- Takes a expression to plug in at the
+ -- failure point(s). The expression should
+ -- be duplicatable!
+
+data CanItFail = CanFail | CantFail
+
+orFail CantFail CantFail = CantFail
+orFail _ _ = CanFail
+\end{code}
+
+
+%************************************************************************
+%* *
+ Monad stuff
+%* *
+%************************************************************************
+
Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around
a @UniqueSupply@ and some annotations, which
presumably include source-file location information:
mk_warn (loc,sdoc) = mkWarnMsg loc print_unqual sdoc
\end{code}
+%************************************************************************
+%* *
+ Operations in the monad
+%* *
+%************************************************************************
+
And all this mysterious stuff is so we can occasionally reach out and
grab one or more names. @newLocalDs@ isn't exported---exported
functions are defined with it. The difference in name-strings makes
\end{code}
-%************************************************************************
-%* *
-\subsection{Type synonym @EquationInfo@ and access functions for its pieces}
-%* *
-%************************************************************************
-
-\begin{code}
-data DsMatchContext
- = DsMatchContext (HsMatchContext Name) [Pat Id] SrcSpan
- | NoMatchContext
- deriving ()
-\end{code}
worthy of a type synonym and a few handy functions.
\begin{code}
-data EquationInfo
- = EqnInfo { eqn_pats :: [Pat Id], -- The patterns for an eqn
- eqn_rhs :: MatchResult } -- What to do after match
-
--- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult
--- \fail. wrap (case vs of { pats -> rhs fail })
--- where vs are not in the domain of wrap
-
firstPat :: EquationInfo -> Pat Id
firstPat eqn = head (eqn_pats eqn)
shiftPats (pat_with_no_sub_pats : pats) = pats
\end{code}
-
-\begin{code}
--- A MatchResult is an expression with a hole in it
-data MatchResult
- = MatchResult
- CanItFail -- Tells whether the failure expression is used
- (CoreExpr -> DsM CoreExpr)
- -- Takes a expression to plug in at the
- -- failure point(s). The expression should
- -- be duplicatable!
-
-data CanItFail = CanFail | CantFail
-
-orFail CantFail CantFail = CantFail
-orFail _ _ = CanFail
-\end{code}
-
Functions on MatchResults
\begin{code}
match :: [Var.Id]
-> TcType.TcType
- -> [DsUtils.EquationInfo]
- -> DsMonad.DsM DsUtils.MatchResult
+ -> [DsMonad.EquationInfo]
+ -> DsMonad.DsM DsMonad.MatchResult
matchWrapper
:: HsExpr.HsMatchContext Name.Name
-> DsMonad.DsMatchContext
-> HsPat.LPat Var.Id
-> TcType.TcType
- -> DsUtils.MatchResult
- -> DsMonad.DsM DsUtils.MatchResult
+ -> DsMonad.MatchResult
+ -> DsMonad.DsM DsMonad.MatchResult
--- /dev/null
+\begin{code}
+module Match where
+import Var ( Id )
+import TcType ( TcType )
+import DsMonad ( DsM, DsMatchContext, EquationInfo, MatchResult )
+import CoreSyn ( CoreExpr )
+import HsSyn ( LPat, HsMatchContext, MatchGroup )
+import Name ( Name )
+
+match :: [Id]
+ -> TcType
+ -> [EquationInfo]
+ -> DsM MatchResult
+
+matchWrapper
+ :: HsMatchContext Name
+ -> MatchGroup Id
+ -> DsM ([Id], CoreExpr)
+
+matchSimply
+ :: CoreExpr
+ -> HsMatchContext Name
+ -> LPat Id
+ -> CoreExpr
+ -> CoreExpr
+ -> DsM CoreExpr
+
+matchSinglePat
+ :: CoreExpr
+ -> DsMatchContext
+ -> LPat Id
+ -> TcType
+ -> MatchResult
+ -> DsM MatchResult
+\end{code}
where init_pkgs
| ExtPackage rts_id <- rtsPackageId (pkgState dflags) = [rts_id]
| otherwise = []
-
\end{code}
\begin{code}
f (FixSig (FixitySig n _)) = Just (unLoc n)
f other = Nothing
-isFixitySig :: Sig name -> Bool
-isFixitySig (FixSig _) = True
-isFixitySig _ = False
+isFixityLSig :: LSig name -> Bool
+isFixityLSig (L _ (FixSig _)) = True
+isFixityLSig _ = False
-isPragSig :: Sig name -> Bool
+isVanillaLSig :: LSig name -> Bool
+isVanillaLSig (L _(Sig name _)) = True
+isVanillaLSig sig = False
+
+isPragLSig :: LSig name -> Bool
-- Identifies pragmas
-isPragSig (SpecSig _ _) = True
-isPragSig (InlineSig _ _ _) = True
-isPragSig (SpecInstSig _) = True
-isPragSig other = False
+isPragLSig (L _ (SpecSig _ _)) = True
+isPragLSig (L _ (InlineSig _ _ _)) = True
+isPragLSig (L _ (SpecInstSig _)) = True
+isPragLSig other = False
hsSigDoc (Sig _ _) = ptext SLIT("type signature")
hsSigDoc (SpecSig _ _) = ptext SLIT("SPECIALISE pragma")
--- /dev/null
+\begin{code}
+module HsExpr where
+
+import SrcLoc ( Located )
+import Outputable ( SDoc, OutputableBndr )
+import {-# SOURCE #-} HsPat ( LPat )
+
+data HsExpr i
+data HsSplice i
+data MatchGroup a
+data GRHSs a
+
+type LHsExpr a = Located (HsExpr a)
+
+pprExpr :: (OutputableBndr i) =>
+ HsExpr i -> SDoc
+
+pprSplice :: (OutputableBndr i) =>
+ HsSplice i -> SDoc
+
+pprPatBind :: (OutputableBndr b, OutputableBndr i) =>
+ LPat b -> GRHSs i -> SDoc
+
+pprFunBind :: (OutputableBndr i) =>
+ i -> MatchGroup i -> SDoc
+\end{code}
--- /dev/null
+\begin{code}
+module HsPat where
+import SrcLoc( Located )
+
+data Pat i
+type LPat i = Located (Pat i)
+\end{code}
instance Binary ModIface where
put_ bh (ModIface {
mi_module = mod,
+ mi_boot = is_boot,
mi_mod_vers = mod_vers,
mi_package = _, -- we ignore the package on output
mi_orphan = orphan,
build_tag <- readIORef v_Build_tag
put bh build_tag
put_ bh mod
+ put_ bh is_boot
put_ bh mod_vers
put_ bh orphan
lazyPut bh deps
++ build_tag ++ ", found " ++ check_way))
mod_name <- get bh
-
+ is_boot <- get bh
mod_vers <- get bh
orphan <- get bh
deps <- lazyGet bh
return (ModIface {
mi_package = HomePackage, -- to be filled in properly later
mi_module = mod_name,
+ mi_boot = is_boot,
mi_mod_vers = mod_vers,
- mi_boot = False, -- Binary interfaces are never .hi-boot files!
mi_orphan = orphan,
mi_deps = deps,
mi_usages = usages,
IfaceType(..), IfaceKind, IfacePredType(..), IfaceTyCon(..),
IfaceContext, IfaceBndr(..), IfaceTvBndr, IfaceIdBndr,
- IfaceExtName(..), mkIfaceExtName, ifaceTyConName,
+ IfaceExtName(..), mkIfaceExtName, ifaceTyConName, ifPrintUnqual,
-- Conversion from Type -> IfaceType
toIfaceType, toIfacePred, toIfaceContext,
mkIfaceExtName name = ExtPkg (nameModule name) (nameOccName name)
-- Local helper for wired-in names
+
+ifPrintUnqual :: PrintUnqualified -> IfaceExtName -> Bool
+ifPrintUnqual print_unqual (ExtPkg mod occ) = print_unqual mod occ
+ifPrintUnqual print_unqual (HomePkg mod occ _) = print_unqual mod occ
+ifPrintUnqual print_unqual other = True
\end{code}
loadSrcInterface, loadOrphanModules, loadHiBootInterface,
readIface, -- Used when reading the module's old interface
predInstGates, ifaceInstGates, ifaceStats, discardDeclPrags,
- initExternalPackageState,
- noIfaceErr, -- used by CompManager too
+ initExternalPackageState
) where
#include "HsVersions.h"
import Packages ( PackageState(..), PackageIdH(..), isHomePackage )
import DriverState ( v_GhcMode, isCompManagerMode )
-import DriverUtil ( replaceFilenameSuffix )
import CmdLineOpts ( DynFlags(..), DynFlag( Opt_IgnoreInterfacePragmas ) )
-import Parser ( parseIface )
-
import IfaceSyn ( IfaceDecl(..), IfaceConDecl(..), IfaceClassOp(..),
IfaceConDecls(..), IfaceInst(..), IfaceRule(..),
IfaceExpr(..), IfaceTyCon(..), IfaceIdInfo(..),
import NameEnv
import MkId ( seqId )
import Module ( Module, ModLocation(ml_hi_file), emptyModuleEnv,
+ addBootSuffix_maybe,
extendModuleEnv, lookupModuleEnv, moduleUserString
)
import OccName ( OccName, mkOccEnv, lookupOccEnv, mkClassTyConOcc, mkClassDataConOcc,
mkSuperDictSelOcc, mkDataConWrapperOcc, mkDataConWorkerOcc )
import Class ( Class, className )
import TyCon ( tyConName )
-import SrcLoc ( mkSrcLoc, importedSrcLoc )
+import SrcLoc ( importedSrcLoc )
import Maybes ( mapCatMaybes, MaybeErr(..) )
-import StringBuffer ( hGetStringBuffer )
import FastString ( mkFastString )
-import ErrUtils ( Message, mkLocMessage )
-import Finder ( findModule, findPackageModule, FindResult(..),
- hiBootFilePath )
-import Lexer
+import ErrUtils ( Message )
+import Finder ( findModule, findPackageModule, FindResult(..), cantFindError )
import Outputable
import BinIface ( readBinIface )
import Panic ( ghcError, tryMost, showException, GhcException(..) )
import List ( nub )
import DATA_IOREF ( readIORef )
-
-import Directory
\end{code}
Failed err -> do
{ traceIf (ptext SLIT("...not found"))
; dflags <- getDOpts
- ; returnM (Failed (noIfaceErr dflags mod_name err)) } ;
+ ; returnM (Failed (cantFindError dflags mod_name err)) } ;
Succeeded (file_path, pkg) -> do
-- and start up GHCi - it won't complain that all the modules it tries
-- to load are found in the home location.
ghci_mode <- readIORef v_GhcMode ;
- let { home_allowed = hi_boot_file ||
- not (isCompManagerMode ghci_mode) } ;
+ let { home_allowed = not (isCompManagerMode ghci_mode) } ;
maybe_found <- if home_allowed
- then findModule dflags mod_name explicit
+ then findModule dflags mod_name explicit
else findPackageModule dflags mod_name explicit;
case maybe_found of
- Found loc pkg
- | hi_boot_file -> do { hi_boot_path <- hiBootFilePath loc
- ; return (Succeeded (hi_boot_path, pkg)) }
- | otherwise -> return (Succeeded (ml_hi_file loc, pkg)) ;
- err -> return (Failed err)
+ Found loc pkg -> return (Succeeded (path, pkg))
+ where
+ path = addBootSuffix_maybe hi_boot_file (ml_hi_file loc)
+
+ err -> return (Failed err)
}
\end{code}
-- Failed err <=> file not found, or unreadable, or illegible
-- Succeeded iface <=> successfully found and parsed
-readIface wanted_mod_name file_path is_hi_boot_file
+readIface wanted_mod file_path is_hi_boot_file
= do { dflags <- getDOpts
- ; ioToIOEnv (read_iface dflags wanted_mod_name file_path is_hi_boot_file) }
-
-read_iface dflags wanted_mod file_path is_hi_boot_file
- | is_hi_boot_file -- Read ascii
- = do { res <- tryMost (hGetStringBuffer file_path) ;
- case res of {
- Left exn -> return (Failed (text (showException exn))) ;
- Right buffer ->
- case unP parseIface (mkPState buffer loc dflags) of
- PFailed span err -> return (Failed (mkLocMessage span err))
- POk _ iface
- | wanted_mod == actual_mod -> return (Succeeded iface)
- | otherwise -> return (Failed err)
- where
- actual_mod = mi_module iface
- err = hiModuleNameMismatchWarn wanted_mod actual_mod
- }}
-
- | otherwise -- Read binary
- = do { res <- tryMost (readBinIface file_path)
+ ; ioToIOEnv $ do
+ { res <- tryMost (readBinIface file_path)
; case res of
- Right iface -> return (Succeeded iface)
- Left exn -> return (Failed (text (showException exn))) }
- where
- loc = mkSrcLoc (mkFastString file_path) 1 0
+ Right iface
+ | wanted_mod == actual_mod -> return (Succeeded iface)
+ | otherwise -> return (Failed err)
+ where
+ actual_mod = mi_module iface
+ err = hiModuleNameMismatchWarn wanted_mod actual_mod
+
+ Left exn -> return (Failed (text (showException exn)))
+ }}
\end{code}
, ppr read_mod
]
-noIfaceErr :: DynFlags -> Module -> FindResult -> SDoc
-noIfaceErr dflags mod_name (PackageHidden pkg)
- = ptext SLIT("Could not import") <+> quotes (ppr mod_name) <> colon
- $$ ptext SLIT("it is a member of package") <+> ppr pkg <> comma
- <+> ptext SLIT("which is hidden")
-
-noIfaceErr dflags mod_name (ModuleHidden pkg)
- = ptext SLIT("Could not import") <+> quotes (ppr mod_name) <> colon
- $$ ptext SLIT("it is hidden")
- <+> parens (ptext SLIT("in package") <+> ppr pkg)
-
-noIfaceErr dflags mod_name (NotFound files)
- = ptext SLIT("Could not find interface file for") <+> quotes (ppr mod_name)
- $$ extra files
- where
- extra files
- | verbosity dflags < 3 =
- text "(use -v to see a list of the files searched for)"
- | otherwise =
- hang (ptext SLIT("locations searched:")) 4 (vcat (map text files))
-
wrongIfaceModErr iface mod_name file_path
= sep [ptext SLIT("Interface file") <+> iface_file,
ptext SLIT("contains module") <+> quotes (ppr (mi_module iface)) <> comma,
\begin{code}
module MkIface (
- showIface, -- Print the iface in Foo.hi
+ pprModIface, showIface, -- Print the iface in Foo.hi
mkUsageInfo, -- Construct the usage info for a module
ModGuts(..), ModGuts, IfaceExport,
GhciMode(..), HscEnv(..), hscEPS,
Dependencies(..), FixItem(..),
+ ModSummary(..), msHiFilePath,
mkIfaceDepCache, mkIfaceFixCache, mkIfaceVerCache,
typeEnvElts,
GenAvailInfo(..), availName,
mkIface hsc_env location maybe_old_iface
guts@ModGuts{ mg_module = this_mod,
+ mg_boot = is_boot,
mg_usages = usages,
mg_deps = deps,
mg_exports = exports,
; intermediate_iface = ModIface {
mi_module = this_mod,
mi_package = HomePackage,
- mi_boot = False,
+ mi_boot = is_boot,
mi_deps = deps,
mi_usages = usages,
mi_exports = mkIfaceExports exports,
r1 `le_rule` r2 = ifRuleName r1 <= ifRuleName r2
i1 `le_inst` i2 = ifDFun i1 <= ifDFun i2
- dflags = hsc_dflags hsc_env
- ghci_mode = hsc_mode hsc_env
+ dflags = hsc_dflags hsc_env
+ ghci_mode = hsc_mode hsc_env
+ omit_prags = dopt Opt_OmitInterfacePragmas dflags
hi_file_path = ml_hi_file location
- omit_prags = dopt Opt_OmitInterfacePragmas dflags
mustExposeThing :: NameSet -> TyThing -> Bool
\begin{code}
checkOldIface :: HscEnv
- -> Module
- -> FilePath -- Where the interface file is
+ -> ModSummary
-> Bool -- Source unchanged
-> Maybe ModIface -- Old interface from compilation manager, if any
-> IO (RecompileRequired, Maybe ModIface)
-checkOldIface hsc_env mod iface_path source_unchanged maybe_iface
+checkOldIface hsc_env mod_summary source_unchanged maybe_iface
= do { showPass (hsc_dflags hsc_env)
- ("Checking old interface for " ++ moduleUserString mod) ;
+ ("Checking old interface for " ++ moduleUserString (ms_mod mod_summary)) ;
; initIfaceCheck hsc_env $
- check_old_iface mod iface_path source_unchanged maybe_iface
+ check_old_iface mod_summary source_unchanged maybe_iface
}
-check_old_iface this_mod iface_path source_unchanged maybe_iface
+check_old_iface mod_summary source_unchanged maybe_iface
= -- CHECK WHETHER THE SOURCE HAS CHANGED
ifM (not source_unchanged)
(traceHiDiffs (nest 4 (text "Source file changed or recompilation check turned off")))
-- Try and read the old interface for the current module
-- from the .hi file left from the last time we compiled it
- readIface this_mod iface_path False `thenM` \ read_result ->
+ let
+ iface_path = msHiFilePath mod_summary
+ in
+ readIface (ms_mod mod_summary) iface_path False `thenM` \ read_result ->
case read_result of {
Failed err -> -- Old interface file not found, or garbled; give up
traceIf (text "FYI: cannot read old interface file:"
pprModIface iface
= vcat [ ptext SLIT("interface")
<+> ppr_package (mi_package iface)
- <+> ppr (mi_module iface) <+> ppr (mi_mod_vers iface)
- <+> pp_sub_vers
+ <+> ppr (mi_module iface) <+> pp_boot
+ <+> ppr (mi_mod_vers iface) <+> pp_sub_vers
<+> (if mi_orphan iface then ptext SLIT("[orphan module]") else empty)
<+> int opt_HiVersion
<+> ptext SLIT("where")
, pprDeprecs (mi_deprecs iface)
]
where
+ pp_boot | mi_boot iface = ptext SLIT("[boot]")
+ | otherwise = empty
ppr_package HomePackage = empty
ppr_package (ExtPackage id) = doubleQuotes (ppr id)
--- /dev/null
+\begin{code}
+module TcIface where
+import IfaceSyn ( IfaceDecl )
+import TypeRep ( TyThing )
+import TcRnTypes ( IfL )
+
+tcIfaceDecl :: IfaceDecl -> IfL TyThing
+\end{code}
+
SimplifierSwitch(..),
SimplifierMode(..), FloatOutSwitches(..),
- HscLang(..),
+ HscTarget(..),
DynFlag(..), -- needed non-abstractly by DriverFlags
DynFlags(..),
PackageFlag(..),
dopt_set, dopt_unset, -- DynFlags -> DynFlag -> DynFlags
dopt_CoreToDo, -- DynFlags -> [CoreToDo]
dopt_StgToDo, -- DynFlags -> [StgToDo]
- dopt_HscLang, -- DynFlags -> HscLang
+ dopt_HscTarget, -- DynFlags -> HscTarget
dopt_OutName, -- DynFlags -> String
getOpts, -- (DynFlags -> [a]) -> IO [a]
getVerbFlag,
#include "HsVersions.h"
import {-# SOURCE #-} Packages (PackageState)
+import DriverPhases ( HscTarget(..), HscSource(..) )
import Constants -- Default values for some flags
import Util
import FastString ( FastString, mkFastString )
data DynFlags = DynFlags {
coreToDo :: Maybe [CoreToDo], -- reserved for use with -Ofile
stgToDo :: [StgToDo],
- hscLang :: HscLang,
+ hscTarget :: HscTarget,
hscOutName :: String, -- name of the output file
hscStubHOutName :: String, -- name of the .stub_h output file
hscStubCOutName :: String, -- name of the .stub_c output file
| HidePackage String
| IgnorePackage String
-data HscLang
- = HscC
- | HscAsm
- | HscJava
- | HscILX
- | HscInterpreted
- | HscNothing
- deriving (Eq, Show)
-
-defaultHscLang
+defaultHscTarget
| cGhcWithNativeCodeGen == "YES" &&
(prefixMatch "i386" cTARGETPLATFORM ||
prefixMatch "sparc" cTARGETPLATFORM ||
- prefixMatch "powerpc" cTARGETPLATFORM) = HscAsm
+ prefixMatch "powerpc" cTARGETPLATFORM) = HscAsm
| otherwise = HscC
defaultDynFlags = DynFlags {
coreToDo = Nothing, stgToDo = [],
- hscLang = defaultHscLang,
+ hscTarget = defaultHscTarget,
hscOutName = "",
hscStubHOutName = "", hscStubCOutName = "",
extCoreName = "",
dopt_OutName :: DynFlags -> String
dopt_OutName = hscOutName
-dopt_HscLang :: DynFlags -> HscLang
-dopt_HscLang = hscLang
+dopt_HscTarget :: DynFlags -> HscTarget
+dopt_HscTarget = hscTarget
dopt_set :: DynFlags -> DynFlag -> DynFlags
dopt_set dfs f = dfs{ flags = f : flags dfs }
updOptLevel n dfs
= if (n >= 1)
- then dfs2{ hscLang = HscC, optLevel = n } -- turn on -fvia-C with -O
+ then dfs2{ hscTarget = HscC, optLevel = n } -- turn on -fvia-C with -O
else dfs2{ optLevel = n }
where
dfs1 = foldr (flip dopt_unset) dfs remove_dopts
opt_DoTickyProfiling = lookUp FSLIT("-fticky-ticky")
-- language opts
-opt_AllStrict = lookUp FSLIT("-fall-strict")
opt_DictsStrict = lookUp FSLIT("-fdicts-strict")
opt_IrrefutableTuples = lookUp FSLIT("-firrefutable-tuples")
opt_MaxContextReductionDepth = lookup_def_int "-fcontext-stack" mAX_CONTEXT_REDUCTION_DEPTH
startsWith (c:cs) (s:ss)
= if c /= s then Nothing else startsWith cs ss
startsWith _ [] = Nothing
-
-endsWith :: String -> String -> Maybe String
-endsWith cs ss
- = case (startsWith (reverse cs) (reverse ss)) of
- Nothing -> Nothing
- Just rs -> Just (reverse rs)
\end{code}
; showPass dflags "CodeOutput"
; let filenm = dopt_OutName dflags
; stubs_exist <- outputForeignStubs dflags foreign_stubs
- ; case dopt_HscLang dflags of {
+ ; case dopt_HscTarget dflags of {
HscInterpreted -> return ();
HscAsm -> outputAsm dflags filenm flat_abstractC;
HscC -> outputC dflags filenm flat_abstractC stubs_exist
------- primary modes ------------------------------------------------
, ( "M" , PassFlag (setMode DoMkDependHS))
- , ( "E" , PassFlag (setMode (StopBefore Hsc)))
+ , ( "E" , PassFlag (setMode (StopBefore anyHsc)))
, ( "C" , PassFlag (\f -> do setMode (StopBefore HCc) f
- setLang HscC))
+ setTarget HscC))
, ( "S" , PassFlag (setMode (StopBefore As)))
- , ( "c" , PassFlag (setMode (StopBefore Ln)))
, ( "-make" , PassFlag (setMode DoMake))
, ( "-interactive" , PassFlag (setMode DoInteractive))
, ( "-mk-dll" , PassFlag (setMode DoMkDLL))
-- -fno-code says to stop after Hsc but don't generate any code.
, ( "fno-code" , PassFlag (\f -> do setMode (StopBefore HCc) f
- setLang HscNothing
+ setTarget HscNothing
writeIORef v_Recomp False))
------- GHCi -------------------------------------------------------
, ( "odir" , HasArg (writeIORef v_Output_dir . Just) )
, ( "o" , SepArg (writeIORef v_Output_file . Just) )
, ( "osuf" , HasArg (writeIORef v_Object_suf) )
- , ( "hcsuf" , HasArg (writeIORef v_HC_suf . Just) )
- , ( "hisuf" , HasArg (writeIORef v_Hi_suf) )
+ , ( "hcsuf" , HasArg (writeIORef v_HC_suf ) )
+ , ( "hisuf" , HasArg (writeIORef v_Hi_suf ) )
, ( "hidir" , HasArg (writeIORef v_Hi_dir . Just) )
, ( "buildtag" , HasArg (writeIORef v_Build_tag) )
, ( "tmpdir" , HasArg setTmpDir)
, ( "optdll" , HasArg (add v_Opt_dll) )
----- Linker --------------------------------------------------------
- , ( "no-link" , NoArg (writeIORef v_NoLink True) )
+ , ( "c" , NoArg (writeIORef v_NoLink True) )
+ , ( "no-link" , NoArg (writeIORef v_NoLink True) ) -- Deprecated
, ( "static" , NoArg (writeIORef v_Static True) )
, ( "dynamic" , NoArg (writeIORef v_Static False) )
, ( "rdynamic" , NoArg (return ()) ) -- ignored for compat w/ gcc
------ Compiler flags -----------------------------------------------
- , ( "fasm", AnySuffix (\_ -> setLang HscAsm) )
- , ( "fvia-c", NoArg (setLang HscC) )
- , ( "fvia-C", NoArg (setLang HscC) )
- , ( "filx", NoArg (setLang HscILX) )
+ , ( "fasm", AnySuffix (\_ -> setTarget HscAsm) )
+ , ( "fvia-c", NoArg (setTarget HscC) )
+ , ( "fvia-C", NoArg (setTarget HscC) )
+ , ( "filx", NoArg (setTarget HscILX) )
, ( "fglasgow-exts", NoArg (mapM_ setDynFlag glasgowExtsFlags) )
, ( "fno-glasgow-exts", NoArg (mapM_ unSetDynFlag glasgowExtsFlags) )
-- we can only switch between HscC, HscAsmm, and HscILX with dynamic flags
-- (-fvia-C, -fasm, -filx respectively).
-setLang l = updDynFlags (\dfs -> case hscLang dfs of
- HscC -> dfs{ hscLang = l }
- HscAsm -> dfs{ hscLang = l }
- HscILX -> dfs{ hscLang = l }
+setTarget l = updDynFlags (\dfs -> case hscTarget dfs of
+ HscC -> dfs{ hscTarget = l }
+ HscAsm -> dfs{ hscTarget = l }
+ HscILX -> dfs{ hscTarget = l }
_ -> dfs)
setOptLevel :: Int -> IO ()
setOptLevel n
= do dflags <- readIORef v_DynFlags
- if hscLang dflags == HscInterpreted && n > 0
+ if hscTarget dflags == HscInterpreted && n > 0
then putStr "warning: -O conflicts with --interactive; -O ignored.\n"
else writeIORef v_DynFlags (updOptLevel n dflags)
(ghc_usage_path,ghci_usage_path) <- getUsageMsgPaths
mode <- readIORef v_GhcMode
let usage_path
- | mode == DoInteractive = ghci_usage_path
- | otherwise = ghc_usage_path
+ | DoInteractive <- mode = ghci_usage_path
+ | otherwise = ghc_usage_path
usage <- readFile usage_path
dump usage
exitWith ExitSuccess
-----------------------------------------------------------------------------
--- $Id: DriverMkDepend.hs,v 1.36 2005/01/18 12:18:28 simonpj Exp $
+-- $Id: DriverMkDepend.hs,v 1.37 2005/01/27 10:44:27 simonpj Exp $
--
-- GHC Driver
--
-----------------------------------------------------------------------------
module DriverMkDepend (
- doMkDependHSPhase, beginMkDependHS, endMkDependHS
+ doMkDependHS
) where
#include "HsVersions.h"
-import GetImports ( getImportsFromFile )
-import CmdLineOpts ( DynFlags )
-import DriverState
-import DriverUtil
-import DriverFlags
+import CompManager ( cmInit, cmDepAnal, cmTopSort, cyclicModuleErr )
+import CmdLineOpts ( DynFlags( verbosity ) )
+import DriverState ( getStaticOpts, v_Opt_dep )
+import DriverUtil ( escapeSpaces, splitFilename, add )
+import DriverFlags ( processArgs, OptKind(..) )
+import HscTypes ( IsBootInterface, ModSummary(..), GhciMode(..),
+ msObjFilePath, msHsFilePath )
import Packages ( PackageIdH(..) )
import SysTools ( newTempName )
import qualified SysTools
-import Module ( Module, ModLocation(..), moduleUserString)
-import Finder ( findModule, hiBootExt, hiBootVerExt,
- mkHomeModLocation, FindResult(..) )
-import Util ( global, maybePrefixMatch )
+import Module ( Module, ModLocation(..), moduleUserString, addBootSuffix_maybe )
+import Digraph ( SCC(..) )
+import Finder ( findModule, FindResult(..) )
+import Util ( global )
+import Outputable
import Panic
import DATA_IOREF ( IORef, readIORef, writeIORef )
import Panic ( catchJust, ioErrors )
#endif
--------------------------------------------------------------------------------
--- mkdependHS
-
- -- flags
-GLOBAL_VAR(v_Dep_makefile, "Makefile", String);
-GLOBAL_VAR(v_Dep_include_prelude, False, Bool);
-GLOBAL_VAR(v_Dep_exclude_mods, ["GHC.Prim"], [String]);
-GLOBAL_VAR(v_Dep_suffixes, [], [String]);
-GLOBAL_VAR(v_Dep_warnings, True, Bool);
-
- -- global vars
-GLOBAL_VAR(v_Dep_makefile_hdl, error "dep_makefile_hdl", Maybe Handle);
-GLOBAL_VAR(v_Dep_tmp_file, error "dep_tmp_file", String);
-GLOBAL_VAR(v_Dep_tmp_hdl, error "dep_tmp_hdl", Handle);
-
-depStartMarker = "# DO NOT DELETE: Beginning of Haskell dependencies"
-depEndMarker = "# DO NOT DELETE: End of Haskell dependencies"
+-----------------------------------------------------------------
+--
+-- The main function
+--
+-----------------------------------------------------------------
+
+doMkDependHS :: DynFlags -> [FilePath] -> IO ()
+doMkDependHS dflags srcs
+ = do { -- Initialisation
+ cm_state <- cmInit Batch dflags
+ ; files <- beginMkDependHS
+
+ -- Do the downsweep to find all the modules
+ ; mod_summaries <- cmDepAnal cm_state srcs
+
+ -- Sort into dependency order
+ -- There should be no cycles
+ ; let sorted = cmTopSort False mod_summaries
+
+ -- Print out the dependencies if wanted
+ ; if verbosity dflags >= 3 then
+ hPutStrLn stderr (showSDoc (text "Module dependencies" $$ ppr sorted))
+ else return ()
+
+ -- Prcess them one by one, dumping results into makefile
+ -- and complaining about cycles
+ ; mapM (processDeps dflags (mkd_tmp_hdl files)) sorted
+
+ -- Tidy up
+ ; endMkDependHS dflags files }
+
+-----------------------------------------------------------------
+--
+-- beginMkDependHs
+-- Create a temporary file,
+-- find the Makefile,
+-- slurp through it, etc
+--
+-----------------------------------------------------------------
--- for compatibility with the old mkDependHS, we accept options of the form
--- -optdep-f -optdep.depend, etc.
-dep_opts =
- [ ( "s", SepArg (add v_Dep_suffixes) )
- , ( "f", SepArg (writeIORef v_Dep_makefile) )
- , ( "w", NoArg (writeIORef v_Dep_warnings False) )
- , ( "-include-prelude", NoArg (writeIORef v_Dep_include_prelude True) )
- , ( "-exclude-module=", Prefix (add v_Dep_exclude_mods) )
- , ( "x", Prefix (add v_Dep_exclude_mods) )
- ]
+data MkDepFiles
+ = MkDep { mkd_make_file :: FilePath, -- Name of the makefile
+ mkd_make_hdl :: Maybe Handle, -- Handle for the open makefile
+ mkd_tmp_file :: FilePath, -- Name of the temporary file
+ mkd_tmp_hdl :: Handle } -- Handle of the open temporary file
-beginMkDependHS :: IO ()
+beginMkDependHS :: IO MkDepFiles
+
beginMkDependHS = do
-
-- slurp in the mkdependHS-style options
flags <- getStaticOpts v_Opt_dep
_ <- processArgs dep_opts flags []
-- open a new temp file in which to stuff the dependency info
-- as we go along.
- dep_file <- newTempName "dep"
- writeIORef v_Dep_tmp_file dep_file
- tmp_hdl <- openFile dep_file WriteMode
- writeIORef v_Dep_tmp_hdl tmp_hdl
+ tmp_file <- newTempName "dep"
+ tmp_hdl <- openFile tmp_file WriteMode
-- open the makefile
makefile <- readIORef v_Dep_makefile
exists <- doesFileExist makefile
- if not exists
- then do
- writeIORef v_Dep_makefile_hdl Nothing
- return ()
-
+ mb_make_hdl <-
+ if not exists
+ then return Nothing
else do
makefile_hdl <- openFile makefile ReadMode
- writeIORef v_Dep_makefile_hdl (Just makefile_hdl)
-- slurp through until we get the magic start string,
-- copying the contents into dep_makefile
catchJust ioErrors chuck
(\e -> if isEOFError e then return () else ioError e)
+ return (Just makefile_hdl)
+
-- write the magic marker into the tmp file
hPutStrLn tmp_hdl depStartMarker
- return ()
-
-
-doMkDependHSPhase dflags basename suff input_fn
- = do (import_sources, import_normals, mod_name)
- <- getImportsFromFile dflags input_fn
- let orig_fn = basename ++ '.':suff
- location' <- mkHomeModLocation mod_name orig_fn
-
- -- take -ohi into account if present
- ohi <- readIORef v_Output_hi
- let location | Just fn <- ohi = location'{ ml_hi_file = fn }
- | otherwise = location'
+ return (MkDep { mkd_make_file = makefile, mkd_make_hdl = mb_make_hdl,
+ mkd_tmp_file = tmp_file, mkd_tmp_hdl = tmp_hdl})
- deps_sources <- mapM (findDependency dflags True orig_fn) import_sources
- deps_normals <- mapM (findDependency dflags False orig_fn) import_normals
- let deps = deps_sources ++ deps_normals
- osuf <- readIORef v_Object_suf
- extra_suffixes <- readIORef v_Dep_suffixes
- let suffixes = map (++ ('_':osuf)) extra_suffixes
- obj_file = ml_obj_file location
- objs = obj_file : map (replaceFilenameSuffix obj_file) suffixes
-
- -- Handle for file that accumulates dependencies
- hdl <- readIORef v_Dep_tmp_hdl
-
- -- std dependency of the object(s) on the source file
- hPutStrLn hdl (unwords (map escapeSpaces objs) ++ " : " ++
- escapeSpaces (basename ++ '.':suff))
+-----------------------------------------------------------------
+--
+-- processDeps
+--
+-----------------------------------------------------------------
+
+processDeps :: DynFlags
+ -> Handle -- Write dependencies to here
+ -> SCC ModSummary
+ -> IO ()
+-- Write suitable dependencies to handle
+-- Always:
+-- this.o : this.hs
+--
+-- If the dependency is on something other than a .hi file:
+-- this.o this.p_o ... : dep
+-- otherwise
+-- this.o ... : dep.hi
+-- this.p_o ... : dep.p_hi
+-- ...
+-- (where .o is $osuf, and the other suffixes come from
+-- the cmdline -s options).
+--
+-- For {-# SOURCE #-} imports the "hi" will be "hi-boot".
+
+processDeps dflags hdl (CyclicSCC nodes)
+ = -- There shouldn't be any cycles; report them
+ throwDyn (ProgramError (showSDoc $ cyclicModuleErr nodes))
+
+processDeps dflags hdl (AcyclicSCC node)
+ = do { extra_suffixes <- readIORef v_Dep_suffixes
+ ; let src_file = msHsFilePath node
+ obj_file = msObjFilePath node
+ obj_files = insertSuffixes obj_file extra_suffixes
+
+ do_imp is_boot imp_mod
+ = do { mb_hi <- findDependency dflags src_file imp_mod is_boot
+ ; case mb_hi of {
+ Nothing -> return () ;
+ Just hi_file -> do
+ { let hi_files = insertSuffixes hi_file extra_suffixes
+ write_dep (obj,hi) = writeDependency hdl [obj] hi
+
+ -- Add one dependency for each suffix;
+ -- e.g. A.o : B.hi
+ -- A.x_o : B.x_hi
+ ; mapM_ write_dep (obj_files `zip` hi_files) }}}
+
+
+ -- Emit std dependency of the object(s) on the source file
+ -- Something like A.o : A.hs
+ ; writeDependency hdl obj_files src_file
+
+ -- Emit a dependency for each import
+ ; mapM_ (do_imp True) (ms_srcimps node) -- SOURCE imports
+ ; mapM_ (do_imp False) (ms_imps node) -- regular imports
+ }
+
+
+findDependency :: DynFlags
+ -> FilePath -- Importing module: used only for error msg
+ -> Module -- Imported module
+ -> IsBootInterface -- Source import
+ -> IO (Maybe FilePath) -- Interface file file
+findDependency dflags src imp is_boot
+ = do { excl_mods <- readIORef v_Dep_exclude_mods
+ ; include_prelude <- readIORef v_Dep_include_prelude
+
+ -- Deal with the excluded modules
+ ; let imp_mod = moduleUserString imp
+ ; if imp_mod `elem` excl_mods
+ then return Nothing
+ else do
+ { -- Find the module; this will be fast because
+ -- we've done it once during downsweep
+ r <- findModule dflags imp True {-explicit-}
+ ; case r of
+ Found loc pkg
+ -- Not in this package: we don't need a dependency
+ | ExtPackage _ <- pkg, not include_prelude
+ -> return Nothing
- let genDep (dep, False {- not an hi file -}) =
- hPutStrLn hdl (unwords (map escapeSpaces objs) ++ " : " ++
- escapeSpaces dep)
- genDep (dep, True {- is an hi file -}) = do
- hisuf <- readIORef v_Hi_suf
- let
+ -- Home package: just depend on the .hi or hi-boot file
+ | otherwise
+ -> return (Just (addBootSuffix_maybe is_boot (ml_hi_file loc)))
+
+ _ -> throwDyn (ProgramError
+ (src ++ ": " ++ "can't locate import `" ++ imp_mod ++ "'"
+ ++ if is_boot then " (SOURCE import)" else ""))
+ }}
+
+-----------------------------
+writeDependency :: Handle -> [FilePath] -> FilePath -> IO ()
+-- (writeDependency h [t1,t2] dep) writes to handle h the dependency
+-- t1 t2 : dep
+writeDependency hdl targets dep
+ = hPutStrLn hdl (unwords (map escapeSpaces targets) ++ " : "
+ ++ escapeSpaces dep)
+
+-----------------------------
+insertSuffixes
+ :: FilePath -- Original filename; e.g. "foo.o"
+ -> [String] -- Extra suffices e.g. ["x","y"]
+ -> [FilePath] -- Zapped filenames e.g. ["foo.o", "foo.x_o", "foo.y_o"]
+ -- Note that that the extra bit gets inserted *before* the old suffix
+ -- We assume the old suffix contains no dots, so we can strip it with removeSuffix
+
+ -- NOTE: we used to have this comment
-- In order to construct hi files with alternate suffixes, we
-- now have to find the "basename" of the hi file. This is
-- difficult because we can't just split the hi filename
-- check whether the hi filename ends in hisuf, and if it does,
-- we strip off hisuf, otherwise we strip everything after the
-- last dot.
- dep_base
- | Just rest <- maybePrefixMatch rev_hisuf rev_dep
- = reverse rest
- | otherwise
- = remove_suffix '.' dep
- where
- rev_hisuf = reverse hisuf
- rev_dep = reverse dep
-
- deps = dep : map (\suf -> dep_base ++ suf ++ '_':hisuf)
- extra_suffixes
- -- length objs should be == length deps
- sequence_ (zipWith (\o d -> hPutStrLn hdl (escapeSpaces o ++ " : " ++ escapeSpaces d)) objs deps)
-
- sequence_ (map genDep [ d | Just d <- deps ])
- return location
-
--- add the lines to dep_makefile:
- -- always:
- -- this.o : this.hs
-
- -- if the dependency is on something other than a .hi file:
- -- this.o this.p_o ... : dep
- -- otherwise
- -- if the import is {-# SOURCE #-}
- -- this.o this.p_o ... : dep.hi-boot[-$vers]
-
- -- else
- -- this.o ... : dep.hi
- -- this.p_o ... : dep.p_hi
- -- ...
-
- -- (where .o is $osuf, and the other suffixes come from
- -- the cmdline -s options).
-
-
-
-endMkDependHS :: DynFlags -> IO ()
-endMkDependHS dflags = do
- makefile <- readIORef v_Dep_makefile
- makefile_hdl <- readIORef v_Dep_makefile_hdl
- tmp_file <- readIORef v_Dep_tmp_file
- tmp_hdl <- readIORef v_Dep_tmp_hdl
+ -- But I'm not sure we care about hisufs with dots in them.
+ -- Lots of other things will break first!
- -- write the magic marker into the tmp file
- hPutStrLn tmp_hdl depEndMarker
+insertSuffixes file_name extras
+ = file_name : [ basename ++ "." ++ extra ++ "_" ++ suffix | extra <- extras ]
+ where
+ (basename, suffix) = splitFilename file_name
+
+
+-----------------------------------------------------------------
+--
+-- endMkDependHs
+-- Complete the makefile, close the tmp file etc
+--
+-----------------------------------------------------------------
- case makefile_hdl of
- Nothing -> return ()
- Just hdl -> do
+endMkDependHS :: DynFlags -> MkDepFiles -> IO ()
+endMkDependHS dflags (MkDep { mkd_make_file = make_file, mkd_make_hdl = makefile_hdl,
+ mkd_tmp_file = tmp_file, mkd_tmp_hdl = tmp_hdl })
+ = do { -- write the magic marker into the tmp file
+ hPutStrLn tmp_hdl depEndMarker
+
+ ; case makefile_hdl of
+ Nothing -> return ()
+ Just hdl -> do
+ {
-- slurp the rest of the original makefile and copy it into the output
- let slurp = do
+ let slurp = do
l <- hGetLine hdl
hPutStrLn tmp_hdl l
slurp
- catchJust ioErrors slurp
+ ; catchJust ioErrors slurp
(\e -> if isEOFError e then return () else ioError e)
- hClose hdl
+ ; hClose hdl
- hClose tmp_hdl -- make sure it's flushed
+ ; hClose tmp_hdl -- make sure it's flushed
- -- Create a backup of the original makefile
- when (isJust makefile_hdl)
- (SysTools.copy dflags ("Backing up " ++ makefile)
- makefile (makefile++".bak"))
+ -- Create a backup of the original makefile
+ ; when (isJust makefile_hdl)
+ (SysTools.copy dflags ("Backing up " ++ make_file)
+ make_file (make_file++".bak"))
- -- Copy the new makefile in place
- SysTools.copy dflags "Installing new makefile" tmp_file makefile
+ -- Copy the new makefile in place
+ ; SysTools.copy dflags "Installing new makefile" tmp_file make_file
+ }}
-findDependency :: DynFlags -> Bool -> FilePath -> Module -> IO (Maybe (String, Bool))
-findDependency dflags is_source src imp = do
- excl_mods <- readIORef v_Dep_exclude_mods
- include_prelude <- readIORef v_Dep_include_prelude
- let imp_mod = moduleUserString imp
- if imp_mod `elem` excl_mods
- then return Nothing
- else do
- r <- findModule dflags imp True{-explicit-}
- case r of
- Found loc pkg
- -- not in this package: we don't need a dependency
- | ExtPackage _ <- pkg, not include_prelude
- -> return Nothing
+-----------------------------------------------------------------
+--
+-- Flags
+--
+-----------------------------------------------------------------
+
+ -- Flags
+GLOBAL_VAR(v_Dep_makefile, "Makefile", String);
+GLOBAL_VAR(v_Dep_include_prelude, False, Bool);
+GLOBAL_VAR(v_Dep_exclude_mods, ["GHC.Prim"], [String]);
+GLOBAL_VAR(v_Dep_suffixes, [], [String]);
+GLOBAL_VAR(v_Dep_warnings, True, Bool);
- -- normal import: just depend on the .hi file
- | not is_source
- -> return (Just (ml_hi_file loc, not is_source))
+depStartMarker = "# DO NOT DELETE: Beginning of Haskell dependencies"
+depEndMarker = "# DO NOT DELETE: End of Haskell dependencies"
- -- if it's a source import, we want to generate a dependency
- -- on the .hi-boot file, not the .hi file
- | otherwise
- -> let hi_file = ml_hi_file loc
- boot_hi_file = replaceFilenameSuffix hi_file hiBootExt
- boot_ver_hi_file = replaceFilenameSuffix hi_file hiBootVerExt
- in do
- b <- doesFileExist boot_ver_hi_file
- if b
- then return (Just (boot_ver_hi_file, not is_source))
- else do
- b <- doesFileExist boot_hi_file
- if b
- then return (Just (boot_hi_file, not is_source))
- else return (Just (hi_file, not is_source))
-
- _ -> throwDyn (ProgramError
- (src ++ ": " ++ "can't locate import `" ++ imp_mod ++ "'" ++
- if is_source then " (SOURCE import)" else ""))
+-- for compatibility with the old mkDependHS, we accept options of the form
+-- -optdep-f -optdep.depend, etc.
+dep_opts =
+ [ ( "s", SepArg (add v_Dep_suffixes) )
+ , ( "f", SepArg (writeIORef v_Dep_makefile) )
+ , ( "w", NoArg (writeIORef v_Dep_warnings False) )
+ , ( "-include-prelude", NoArg (writeIORef v_Dep_include_prelude True) )
+ , ( "-exclude-module=", Prefix (add v_Dep_exclude_mods) )
+ , ( "x", Prefix (add v_Dep_exclude_mods) )
+ ]
-----------------------------------------------------------------------------
--- $Id: DriverPhases.hs,v 1.31 2005/01/18 13:51:28 simonmar Exp $
+-- $Id: DriverPhases.hs,v 1.32 2005/01/27 10:44:27 simonpj Exp $
--
-- GHC Driver
--
#include "../includes/ghcconfig.h"
module DriverPhases (
- Phase(..),
- happensBefore,
+ HscSource(..), isHsBoot, hscSourceString,
+ HscTarget(..), Phase(..),
+ happensBefore, eqPhase, anyHsc, isStopPhase,
startPhase, -- :: String -> Phase
phaseInputExt, -- :: Phase -> String
) where
import DriverUtil
+import Panic ( panic )
-----------------------------------------------------------------------------
-- Phases
linker | other | - | a.out
-}
+data HscSource
+ = HsSrcFile | HsBootFile | ExtCoreFile
+ deriving( Eq, Ord, Show )
+ -- Ord needed for the finite maps we build in CompManager
+
+
+hscSourceString :: HscSource -> String
+hscSourceString HsSrcFile = ""
+hscSourceString HsBootFile = "[boot]"
+hscSourceString ExtCoreFile = "[ext core]"
+
+isHsBoot :: HscSource -> Bool
+isHsBoot HsBootFile = True
+isHsBoot other = False
+
+data HscTarget
+ = HscC
+ | HscAsm
+ | HscJava
+ | HscILX
+ | HscInterpreted
+ | HscNothing
+ deriving (Eq, Show)
+
data Phase
- = Unlit
- | Cpp
- | HsPp
- | Hsc
+ = Unlit HscSource
+ | Cpp HscSource
+ | HsPp HscSource
+ | Hsc HscSource
| Cc
| HCc -- Haskellised C (as opposed to vanilla C) compilation
| Mangle -- assembly mangling, now done by a separate script.
| SplitMangle -- after mangler if splitting
| SplitAs
| As
- | Ln
| CmmCpp -- pre-process Cmm source
| Cmm -- parse & compile Cmm code
#ifdef ILX
| Ilx2Il
| Ilasm
#endif
- deriving (Eq, Show)
+
+ -- The final phase is a pseudo-phase that tells the pipeline to stop.
+ -- There is no runPhase case for it.
+ | StopLn -- Stop, but linking will follow, so generate .o file
+
+ deriving (Show)
+
+anyHsc :: Phase
+anyHsc = Hsc (panic "anyHsc")
+
+isStopPhase :: Phase -> Bool
+isStopPhase StopLn = True
+isStopPhase other = False
+
+eqPhase :: Phase -> Phase -> Bool
+-- Equality of constructors, ignoring the HscSource field
+eqPhase (Unlit _) (Unlit _) = True
+eqPhase (Cpp _) (Cpp _) = True
+eqPhase (HsPp _) (HsPp _) = True
+eqPhase (Hsc _) (Hsc _) = True
+eqPhase Cc Cc = True
+eqPhase HCc HCc = True
+eqPhase Mangle Mangle = True
+eqPhase SplitMangle SplitMangle = True
+eqPhase SplitAs SplitAs = True
+eqPhase As As = True
+eqPhase CmmCpp CmmCpp = True
+eqPhase Cmm Cmm = True
+eqPhase StopLn StopLn = True
+eqPhase _ _ = False
-- Partial ordering on phases: we want to know which phases will occur before
-- which others. This is used for sanity checking, to ensure that the
-- pipeline will stop at some point (see DriverPipeline.runPipeline).
-x `happensBefore` y
- | x `elem` haskell_pipe = y `elem` tail (dropWhile (/= x) haskell_pipe)
- | x `elem` cmm_pipe = y `elem` tail (dropWhile (/= x) cmm_pipe)
- | x `elem` c_pipe = y `elem` tail (dropWhile (/= x) c_pipe)
- | otherwise = False
-
-haskell_post_hsc = [HCc,Mangle,SplitMangle,As,SplitAs,Ln]
-haskell_pipe = Unlit : Cpp : HsPp : Hsc : haskell_post_hsc
-cmm_pipe = CmmCpp : Cmm : haskell_post_hsc
-c_pipe = [Cc,As,Ln]
+StopLn `happensBefore` y = False
+x `happensBefore` y = after_x `eqPhase` y || after_x `happensBefore` y
+ where
+ after_x = nextPhase x
+
+nextPhase :: Phase -> Phase
+-- A conservative approximation the next phase, used in happensBefore
+nextPhase (Unlit sf) = Cpp sf
+nextPhase (Cpp sf) = HsPp sf
+nextPhase (HsPp sf) = Hsc sf
+nextPhase (Hsc sf) = HCc
+nextPhase HCc = Mangle
+nextPhase Mangle = SplitMangle
+nextPhase SplitMangle = As
+nextPhase As = SplitAs
+nextPhase SplitAs = StopLn
+nextPhase Cc = As
+nextPhase CmmCpp = Cmm
+nextPhase Cmm = HCc
+nextPhase StopLn = panic "nextPhase: nothing after StopLn"
-- the first compilation phase for a given file is determined
-- by its suffix.
-startPhase "lhs" = Unlit
-startPhase "hs" = Cpp
-startPhase "hscpp" = HsPp
-startPhase "hspp" = Hsc
-startPhase "hcr" = Hsc
-startPhase "hc" = HCc
-startPhase "c" = Cc
-startPhase "cpp" = Cc
-startPhase "C" = Cc
-startPhase "cc" = Cc
-startPhase "cxx" = Cc
-startPhase "raw_s" = Mangle
-startPhase "s" = As
-startPhase "S" = As
-startPhase "o" = Ln
-startPhase "cmm" = CmmCpp
-startPhase "cmmcpp" = Cmm
-startPhase _ = Ln -- all unknown file types
+startPhase "lhs" = Unlit HsSrcFile
+startPhase "lhs-boot" = Unlit HsBootFile
+startPhase "hs" = Cpp HsSrcFile
+startPhase "hs-boot" = Cpp HsBootFile
+startPhase "hscpp" = HsPp HsSrcFile
+startPhase "hspp" = Hsc HsSrcFile
+startPhase "hcr" = Hsc ExtCoreFile
+startPhase "hc" = HCc
+startPhase "c" = Cc
+startPhase "cpp" = Cc
+startPhase "C" = Cc
+startPhase "cc" = Cc
+startPhase "cxx" = Cc
+startPhase "raw_s" = Mangle
+startPhase "s" = As
+startPhase "S" = As
+startPhase "o" = StopLn
+startPhase "cmm" = CmmCpp
+startPhase "cmmcpp" = Cmm
+startPhase _ = StopLn -- all unknown file types
-- This is used to determine the extension for the output from the
-- current phase (if it generates a new file). The extension depends
-- on the next phase in the pipeline.
-phaseInputExt Unlit = "lhs"
-phaseInputExt Cpp = "lpp" -- intermediate only
-phaseInputExt HsPp = "hscpp"
-phaseInputExt Hsc = "hspp"
-phaseInputExt HCc = "hc"
-phaseInputExt Cc = "c"
-phaseInputExt Mangle = "raw_s"
-phaseInputExt SplitMangle = "split_s" -- not really generated
-phaseInputExt As = "s"
-phaseInputExt SplitAs = "split_s" -- not really generated
-phaseInputExt Ln = "o"
-phaseInputExt CmmCpp = "cmm"
-phaseInputExt Cmm = "cmmcpp"
+phaseInputExt (Unlit HsSrcFile) = "lhs"
+phaseInputExt (Unlit HsBootFile) = "lhs-boot"
+phaseInputExt (Unlit ExtCoreFile) = "lhcr"
+phaseInputExt (Cpp _) = "lpp" -- intermediate only
+phaseInputExt (HsPp _) = "hscpp" -- intermediate only
+phaseInputExt (Hsc _) = "hspp" -- intermediate only
+ -- NB: as things stand, phaseInputExt (Hsc x) must not evaluate x
+ -- because runPipeline uses the StopBefore phase to pick the
+ -- output filename. That could be fixed, but watch out.
+phaseInputExt HCc = "hc"
+phaseInputExt Cc = "c"
+phaseInputExt Mangle = "raw_s"
+phaseInputExt SplitMangle = "split_s" -- not really generated
+phaseInputExt As = "s"
+phaseInputExt SplitAs = "split_s" -- not really generated
+phaseInputExt CmmCpp = "cmm"
+phaseInputExt Cmm = "cmmcpp"
+phaseInputExt StopLn = "o"
#ifdef ILX
-phaseInputExt Ilx2Il = "ilx"
-phaseInputExt Ilasm = "il"
+phaseInputExt Ilx2Il = "ilx"
+phaseInputExt Ilasm = "il"
#endif
-haskellish_suffixes = [ "hs", "lhs", "hspp", "hscpp", "hcr", "hc", "raw_s", "cmm" ]
-haskellish_src_suffixes = [ "hs", "lhs", "hspp", "hscpp", "hcr", "cmm" ]
+haskellish_src_suffixes = haskellish_user_src_suffixes ++
+ [ "hspp", "hscpp", "hcr", "cmm" ]
+haskellish_suffixes = haskellish_src_suffixes ++ ["hc", "raw_s"]
cish_suffixes = [ "c", "cpp", "C", "cc", "cxx", "s", "S" ]
extcoreish_suffixes = [ "hcr" ]
-haskellish_user_src_suffixes = [ "hs", "lhs" ]
+haskellish_user_src_suffixes = [ "hs", "lhs", "hs-boot", "lhs-boot" ] -- Will not be deleted as temp files
-- Use the appropriate suffix for the system on which
-- the GHC-compiled code will run
module DriverPipeline (
-- Interfaces for the batch-mode driver
- runPipeline, staticLink,
+ compileFile, staticLink,
-- Interfaces for the compilation manager (interpreted/batch-mode)
preprocess,
import GetImports
import DriverState
import DriverUtil
-import DriverMkDepend
import DriverPhases
import DriverFlags
import SysTools ( newTempName, addFilesToClean, getSysMan, copy )
import EXCEPTION
import DATA_IOREF ( readIORef, writeIORef )
-import Time ( ClockTime )
import Directory
import System
import IO
-- Just preprocess a file, put the result in a temp. file (used by the
-- compilation manager during the summary phase).
+--
+-- We return the augmented DynFlags, because they contain the result
+-- of slurping in the OPTIONS pragmas
-preprocess :: DynFlags -> FilePath -> IO FilePath
+preprocess :: DynFlags -> FilePath -> IO (DynFlags, FilePath)
preprocess dflags filename =
ASSERT2(isHaskellSrcFilename filename, text filename)
- do runPipeline (StopBefore Hsc) dflags ("preprocess")
+ runPipeline (StopBefore anyHsc) dflags ("preprocess")
False{-temporary output file-}
Nothing{-no specific output file-}
filename
Nothing{-no ModLocation-}
+
+
+-- ---------------------------------------------------------------------------
+-- Compile a file
+-- This is used in batch mode
+compileFile :: GhcMode -> DynFlags -> FilePath -> IO FilePath
+compileFile mode dflags src = do
+ exists <- doesFileExist src
+ when (not exists) $
+ throwDyn (CmdLineError ("file `" ++ src ++ "' does not exist"))
+
+ o_file <- readIORef v_Output_file
+ no_link <- readIORef v_NoLink -- Set by -c or -no-link
+ -- When linking, the -o argument refers to the linker's output.
+ -- otherwise, we use it as the name for the pipeline's output.
+ let maybe_o_file | no_link = o_file
+ | otherwise = Nothing
+
+ stop_flag <- readIORef v_GhcModeFlag
+ (_, out_file) <- runPipeline mode dflags stop_flag True maybe_o_file
+ src Nothing{-no ModLocation-}
+ return out_file
+
+
-- ---------------------------------------------------------------------------
-- Compile
-- NB. No old interface can also mean that the source has changed.
compile :: HscEnv
- -> Module
- -> ModLocation
- -> ClockTime -- timestamp of original source file
- -> Bool -- True <=> source unchanged
- -> Bool -- True <=> have object
- -> Maybe ModIface -- old interface, if available
+ -> ModSummary
+ -> Bool -- True <=> source unchanged
+ -> Bool -- True <=> have object
+ -> Maybe ModIface -- Old interface, if available
-> IO CompResult
data CompResult
| CompErrs
-compile hsc_env this_mod location src_timestamp
- source_unchanged have_object
- old_iface = do
+compile hsc_env mod_summary
+ source_unchanged have_object old_iface = do
- let dyn_flags = hsc_dflags hsc_env
+ let dyn_flags = hsc_dflags hsc_env
+ this_mod = ms_mod mod_summary
+ src_flavour = ms_hsc_src mod_summary
- showPass dyn_flags
- (showSDoc (text "Compiling" <+> ppr this_mod))
+ showPass dyn_flags ("Compiling " ++ showModMsg have_object mod_summary)
let verb = verbosity dyn_flags
+ let location = ms_location mod_summary
let input_fn = expectJust "compile:hs" (ml_hs_file location)
- let input_fnpp = expectJust "compile:hspp" (ml_hspp_file location)
+ let input_fnpp = expectJust "compile:hspp" (ms_hspp_file mod_summary)
when (verb >= 2) (hPutStrLn stderr ("compile: input file " ++ input_fnpp))
- -- add in the OPTIONS from the source file
+ -- Add in the OPTIONS from the source file
+ -- This is nasty: we've done this once already, in the compilation manager
+ -- It might be better to cache the flags in the ml_hspp_file field,say
opts <- getOptionsFromSource input_fnpp
(dyn_flags,unhandled_flags) <- processDynamicFlags opts dyn_flags
checkProcessArgsResult unhandled_flags input_fn
-- put back the old include paths afterward.
later (writeIORef v_Include_paths old_paths) $ do
- -- figure out what lang we're generating
- hsc_lang <- hscMaybeAdjustLang (hscLang dyn_flags)
- -- figure out what the next phase should be
- next_phase <- hscNextPhase hsc_lang
- -- figure out what file to generate the output into
- get_output_fn <- genOutputFilenameFunc False Nothing next_phase basename
- output_fn <- get_output_fn next_phase (Just location)
+ -- Figure out what lang we're generating
+ todo <- readIORef v_GhcMode
+ hsc_lang <- hscMaybeAdjustTarget todo src_flavour (hscTarget dyn_flags)
+ -- ... and what the next phase should be
+ next_phase <- hscNextPhase src_flavour hsc_lang
+ -- ... and what file to generate the output into
+ get_output_fn <- genOutputFilenameFunc next_phase False Nothing basename
+ output_fn <- get_output_fn next_phase (Just location)
- let dyn_flags' = dyn_flags { hscLang = hsc_lang,
+ let dyn_flags' = dyn_flags { hscTarget = hsc_lang,
hscOutName = output_fn,
hscStubCOutName = basename ++ "_stub.c",
hscStubHOutName = basename ++ "_stub.h",
hsc_env' = hsc_env { hsc_dflags = dyn_flags' }
-- run the compiler
- hsc_result <- hscMain hsc_env' printErrorsAndWarnings this_mod location
+ hsc_result <- hscMain hsc_env' printErrorsAndWarnings mod_summary
source_unchanged' have_object old_iface
case hsc_result of
HscNoRecomp details iface -> return (CompOK details Nothing iface Nothing)
HscRecomp details rdr_env iface
- stub_h_exists stub_c_exists maybe_interpreted_code -> do
+ stub_h_exists stub_c_exists maybe_interpreted_code
+
+ | isHsBoot src_flavour -- No further compilation to do
+ -> return (CompOK details rdr_env iface Nothing)
+
+ | otherwise -- Normal Haskell source files
+ -> do
let
maybe_stub_o <- compileStub dyn_flags' stub_c_exists
let stub_unlinked = case maybe_stub_o of
HscInterpreted ->
case maybe_interpreted_code of
#ifdef GHCI
- Just comp_bc -> return ([BCOs comp_bc], src_timestamp)
+ Just comp_bc -> return ([BCOs comp_bc], ms_hs_date mod_summary)
-- Why do we use the timestamp of the source file here,
-- rather than the current time? This works better in
-- the case where the local clock is out of sync
_other -> do
let object_filename = ml_obj_file location
- runPipeline (StopBefore Ln) dyn_flags ""
- True Nothing output_fn (Just location)
+ runPipeline DoLink dyn_flags ""
+ True Nothing output_fn (Just location)
-- the object filename comes from the ModLocation
o_time <- getModificationTime object_filename
| stub_c_exists = do
-- compile the _stub.c file w/ gcc
let stub_c = hscStubCOutName dflags
- stub_o <- runPipeline (StopBefore Ln) dflags "stub-compile"
- True{-persistent output-}
- Nothing{-no specific output file-}
- stub_c
- Nothing{-no ModLocation-}
+ (_, stub_o) <- runPipeline DoLink dflags "stub-compile"
+ True{-persistent output-}
+ Nothing{-no specific output file-}
+ stub_c
+ Nothing{-no ModLocation-}
return (Just stub_o)
omit_linking <- readIORef v_NoLink
if omit_linking
then do when (verb >= 3) $
- hPutStrLn stderr "link(batch): linking omitted (-no-link flag given)."
+ hPutStrLn stderr "link(batch): linking omitted (-c flag given)."
return Succeeded
else do
-> Maybe FilePath -- where to put the output, optionally
-> FilePath -- input filename
-> Maybe ModLocation -- a ModLocation for this module, if we have one
- -> IO FilePath -- output filename
+ -> IO (DynFlags, FilePath) -- (final flags, output filename)
runPipeline todo dflags stop_flag keep_output
maybe_output_filename input_fn maybe_loc
let (basename, suffix) = splitFilename input_fn
start_phase = startPhase suffix
- stop_phase = case todo of
- StopBefore As | split -> SplitAs
- StopBefore phase -> phase
- DoMkDependHS -> Ln
- DoLink -> Ln
- DoMkDLL -> Ln
+ todo' = case todo of
+ StopBefore As | split -> StopBefore SplitAs
+ other -> todo
-- We want to catch cases of "you can't get there from here" before
-- we start the pipeline, because otherwise it will just run off the
-- There is a partial ordering on phases, where A < B iff A occurs
-- before B in a normal compilation pipeline.
--
+ let stop_phase = case todo' of
+ StopBefore phase -> phase
+ other -> StopLn
+
when (not (start_phase `happensBefore` stop_phase)) $
throwDyn (UsageError
("flag `" ++ stop_flag
-- generate a function which will be used to calculate output file names
-- as we go along.
- get_output_fn <- genOutputFilenameFunc keep_output maybe_output_filename
- stop_phase basename
+ get_output_fn <- genOutputFilenameFunc stop_phase keep_output
+ maybe_output_filename basename
- -- and execute the pipeline...
- (output_fn, maybe_loc) <-
- pipeLoop dflags start_phase stop_phase input_fn basename suffix
- get_output_fn maybe_loc
+ -- Execute the pipeline...
+ (dflags', output_fn, maybe_loc) <- pipeLoop todo' dflags start_phase stop_phase input_fn
+ basename suffix get_output_fn maybe_loc
- -- sometimes, a compilation phase doesn't actually generate any output
+ -- Sometimes, a compilation phase doesn't actually generate any output
-- (eg. the CPP phase when -fcpp is not turned on). If we end on this
-- stage, but we wanted to keep the output, then we have to explicitly
-- copy the file.
- if keep_output
+ if keep_output
then do final_fn <- get_output_fn stop_phase maybe_loc
when (final_fn /= output_fn) $
copy dflags ("Copying `" ++ output_fn ++ "' to `" ++ final_fn
++ "'") output_fn final_fn
- return final_fn
+ return (dflags', final_fn)
else
- return output_fn
+ return (dflags', output_fn)
-pipeLoop :: DynFlags -> Phase -> Phase -> FilePath -> String -> Suffix
- -> (Phase -> Maybe ModLocation -> IO FilePath)
- -> Maybe ModLocation -> IO (FilePath, Maybe ModLocation)
+pipeLoop :: GhcMode -> DynFlags -> Phase -> Phase
+ -> FilePath -> String -> Suffix
+ -> (Phase -> Maybe ModLocation -> IO FilePath)
+ -> Maybe ModLocation
+ -> IO (DynFlags, FilePath, Maybe ModLocation)
-pipeLoop dflags phase stop_phase input_fn orig_basename orig_suff
- get_output_fn maybe_loc
+pipeLoop orig_todo dflags phase stop_phase
+ input_fn orig_basename orig_suff
+ orig_get_output_fn maybe_loc
- | phase == stop_phase = return (input_fn, maybe_loc) -- all done
+ | phase `eqPhase` stop_phase -- All done
+ = return (dflags, input_fn, maybe_loc)
- | not (phase `happensBefore` stop_phase) =
+ | not (phase `happensBefore` stop_phase)
-- Something has gone wrong. We'll try to cover all the cases when
-- this could happen, so if we reach here it is a panic.
-- eg. it might happen if the -C flag is used on a source file that
-- has {-# OPTIONS -fasm #-}.
- panic ("pipeLoop: at phase " ++ show phase ++
- " but I wanted to stop at phase " ++ show stop_phase)
-
- | otherwise = do
- maybe_next_phase <- runPhase phase dflags orig_basename
- orig_suff input_fn get_output_fn maybe_loc
- case maybe_next_phase of
- (Nothing, dflags, maybe_loc, output_fn) -> do
- -- we stopped early, but return the *final* filename
- -- (it presumably already exists)
- final_fn <- get_output_fn stop_phase maybe_loc
- return (final_fn, maybe_loc)
- (Just next_phase, dflags', maybe_loc, output_fn) ->
- pipeLoop dflags' next_phase stop_phase output_fn
- orig_basename orig_suff get_output_fn maybe_loc
-
-
-genOutputFilenameFunc :: Bool -> Maybe FilePath -> Phase -> String
+ = panic ("pipeLoop: at phase " ++ show phase ++
+ " but I wanted to stop at phase " ++ show stop_phase)
+
+ | otherwise
+ = do { (next_phase, dflags', maybe_loc, output_fn)
+ <- runPhase phase orig_todo dflags orig_basename
+ orig_suff input_fn orig_get_output_fn maybe_loc
+ ; pipeLoop orig_todo dflags' next_phase stop_phase output_fn
+ orig_basename orig_suff orig_get_output_fn maybe_loc }
+
+genOutputFilenameFunc :: Phase -> Bool -> Maybe FilePath -> String
-> IO (Phase{-next phase-} -> Maybe ModLocation -> IO FilePath)
-genOutputFilenameFunc keep_final_output maybe_output_filename
- stop_phase basename
+genOutputFilenameFunc stop_phase keep_final_output maybe_output_filename basename
= do
hcsuf <- readIORef v_HC_suf
odir <- readIORef v_Output_dir
keep_raw_s <- readIORef v_Keep_raw_s_files
keep_s <- readIORef v_Keep_s_files
let
- myPhaseInputExt HCc | Just s <- hcsuf = s
- myPhaseInputExt Ln = osuf
- myPhaseInputExt other = phaseInputExt other
+ myPhaseInputExt HCc = hcsuf
+ myPhaseInputExt StopLn = osuf
+ myPhaseInputExt other = phaseInputExt other
func next_phase maybe_location
| is_last_phase, Just f <- maybe_output_filename = return f
| otherwise = newTempName suffix
where
- is_last_phase = next_phase == stop_phase
+ is_last_phase = next_phase `eqPhase` stop_phase
-- sometimes, we keep output from intermediate stages
keep_this_output =
case next_phase of
- Ln -> True
+ StopLn -> True
Mangle | keep_raw_s -> True
As | keep_s -> True
HCc | keep_hc -> True
-- persistent object files get put in odir
persistent_fn
- | Ln <- next_phase = return odir_persistent
- | otherwise = return persistent
+ | StopLn <- next_phase = return odir_persistent
+ | otherwise = return persistent
persistent = basename ++ '.':suffix
-- taking the via-C route to using the native code generator.
runPhase :: Phase
+ -> GhcMode
-> DynFlags
-> String -- basename of original input source
-> String -- its extension
-> (Phase -> Maybe ModLocation -> IO FilePath)
-- how to calculate the output filename
-> Maybe ModLocation -- the ModLocation, if we have one
- -> IO (Maybe Phase, -- next phase
+ -> IO (Phase, -- next phase
DynFlags, -- new dynamic flags
Maybe ModLocation, -- the ModLocation, if we have one
FilePath) -- output filename
+ -- Invariant: the output filename always contains the output
+ -- Interesting case: Hsc when there is no recompilation to do
+ -- Then the output filename is still a .o file
+
-------------------------------------------------------------------------------
-- Unlit phase
-runPhase Unlit dflags _basename _suff input_fn get_output_fn maybe_loc
+runPhase (Unlit sf) _todo dflags _basename _suff input_fn get_output_fn maybe_loc
= do let unlit_flags = getOpts dflags opt_L
-- The -h option passes the file name for unlit to put in a #line directive
- output_fn <- get_output_fn Cpp maybe_loc
+ output_fn <- get_output_fn (Cpp sf) maybe_loc
SysTools.runUnlit dflags
(map SysTools.Option unlit_flags ++
, SysTools.FileOption "" output_fn
])
- return (Just Cpp, dflags, maybe_loc, output_fn)
+ return (Cpp sf, dflags, maybe_loc, output_fn)
-------------------------------------------------------------------------------
--- Cpp phase
+-- Cpp phase : (a) gets OPTIONS out of file
+-- (b) runs cpp if necessary
-runPhase Cpp dflags basename suff input_fn get_output_fn maybe_loc
+runPhase (Cpp sf) _todo dflags basename suff input_fn get_output_fn maybe_loc
= do src_opts <- getOptionsFromSource input_fn
(dflags,unhandled_flags) <- processDynamicFlags src_opts dflags
checkProcessArgsResult unhandled_flags (basename++'.':suff)
if not (cppFlag dflags) then
-- no need to preprocess CPP, just pass input file along
-- to the next phase of the pipeline.
- return (Just HsPp, dflags, maybe_loc, input_fn)
+ return (HsPp sf, dflags, maybe_loc, input_fn)
else do
- output_fn <- get_output_fn HsPp maybe_loc
+ output_fn <- get_output_fn (HsPp sf) maybe_loc
doCpp dflags True{-raw-} False{-no CC opts-} input_fn output_fn
- return (Just HsPp, dflags, maybe_loc, output_fn)
+ return (HsPp sf, dflags, maybe_loc, output_fn)
-------------------------------------------------------------------------------
-- HsPp phase
-runPhase HsPp dflags basename suff input_fn get_output_fn maybe_loc
+runPhase (HsPp sf) _todo dflags basename suff input_fn get_output_fn maybe_loc
= do if not (ppFlag dflags) then
-- no need to preprocess, just pass input file along
-- to the next phase of the pipeline.
- return (Just Hsc, dflags, maybe_loc, input_fn)
+ return (Hsc sf, dflags, maybe_loc, input_fn)
else do
let hspp_opts = getOpts dflags opt_F
hs_src_pp_opts <- readIORef v_Hs_source_pp_opts
let orig_fn = basename ++ '.':suff
- output_fn <- get_output_fn Hsc maybe_loc
+ output_fn <- get_output_fn (Hsc sf) maybe_loc
SysTools.runPp dflags
( [ SysTools.Option orig_fn
, SysTools.Option input_fn
map SysTools.Option hs_src_pp_opts ++
map SysTools.Option hspp_opts
)
- return (Just Hsc, dflags, maybe_loc, output_fn)
+ return (Hsc sf, dflags, maybe_loc, output_fn)
-----------------------------------------------------------------------------
-- Hsc phase
-- Compilation of a single module, in "legacy" mode (_not_ under
-- the direction of the compilation manager).
-runPhase Hsc dflags basename suff input_fn get_output_fn _maybe_loc = do
- todo <- readIORef v_GhcMode
- if todo == DoMkDependHS then do
- locn <- doMkDependHSPhase dflags basename suff input_fn
- return (Nothing, dflags, Just locn, input_fn) -- Ln is a dummy stop phase
-
- else do
- -- normal Hsc mode, not mkdependHS
+runPhase (Hsc src_flavour) todo dflags basename suff input_fn get_output_fn _maybe_loc
+ = do -- normal Hsc mode, not mkdependHS
-- we add the current directory (i.e. the directory in which
-- the .hs files resides) to the import path, since this is
-- gather the imports and module name
(hspp_buf,mod_name) <-
- if isExtCoreFilename ('.':suff)
- then do
- -- no explicit imports in ExtCore input.
- m <- getCoreModuleName input_fn
- return (Nothing, mkModule m)
- else do
- buf <- hGetStringBuffer input_fn
- (_,_,mod_name) <- getImports dflags buf input_fn
- return (Just buf, mod_name)
-
- -- build a ModLocation to pass to hscMain.
- location' <- mkHomeModLocation mod_name (basename ++ '.':suff)
-
- -- take -ohi into account if present
+ case src_flavour of
+ ExtCoreFile -> do { -- no explicit imports in ExtCore input.
+ ; m <- getCoreModuleName input_fn
+ ; return (Nothing, mkModule m) }
+
+ other -> do { buf <- hGetStringBuffer input_fn
+ ; (_,_,mod_name) <- getImports dflags buf input_fn
+ ; return (Just buf, mod_name) }
+
+ -- Build a ModLocation to pass to hscMain.
+ -- The source filename is rather irrelevant by now, but it's used
+ -- by hscMain for messages. hscMain also needs
+ -- the .hi and .o filenames, and this is as good a way
+ -- as any to generate them, and better than most. (e.g. takes
+ -- into accout the -osuf flags)
+ location1 <- mkHomeModLocation2 mod_name basename suff
+
+ -- Boot-ify it if necessary
+ let location2 | isHsBoot src_flavour = addBootSuffixLocn location1
+ | otherwise = location1
+
+
+ -- Take -ohi into account if present
+ -- This can't be done in mkHomeModuleLocation because
+ -- it only applies to the module being compiles
ohi <- readIORef v_Output_hi
- let location | Just fn <- ohi = location'{ ml_hi_file = fn }
- | otherwise = location'
-
- -- figure out if the source has changed, for recompilation avoidance.
+ let location3 | Just fn <- ohi = location2{ ml_hi_file = fn }
+ | otherwise = location2
+
+ -- Take -o into account if present
+ -- Very like -ohi, but we must *only* do this if we aren't linking
+ -- (If we're linking then the -o applies to the linked thing, not to
+ -- the object file for one module.)
+ -- Note the nasty duplication with the same computation in compileFile above
+ expl_o_file <- readIORef v_Output_file
+ no_link <- readIORef v_NoLink
+ let location4 | Just ofile <- expl_o_file, no_link
+ = location3 { ml_obj_file = ofile }
+ | otherwise = location3
+
+ -- Tell the finder cache about this module
+ addHomeModuleToFinder mod_name location4
+
+ -- Make the ModSummary to hand to hscMain
+ src_timestamp <- getModificationTime (basename ++ '.':suff)
+ let
+ unused_field = panic "runPhase:ModSummary field"
+ -- Some fields are not looked at by hscMain
+ mod_summary = ModSummary { ms_mod = mod_name,
+ ms_hsc_src = src_flavour,
+ ms_hspp_file = Just input_fn,
+ ms_hspp_buf = hspp_buf,
+ ms_location = location4,
+ ms_hs_date = src_timestamp,
+ ms_imps = unused_field,
+ ms_srcimps = unused_field }
+
+ o_file = ml_obj_file location4 -- The real object file
+
+
+ -- Figure out if the source has changed, for recompilation avoidance.
-- only do this if we're eventually going to generate a .o file.
-- (ToDo: do when generating .hc files too?)
--
-- changed (which the compiler itself figures out).
-- Setting source_unchanged to False tells the compiler that M.o is out of
-- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless.
- do_recomp <- readIORef v_Recomp
- expl_o_file <- readIORef v_Output_file
-
- let o_file -- if the -o option is given and IT IS THE OBJECT FILE FOR
- -- THIS COMPILATION, then use that to determine if the
- -- source is unchanged.
- | Just x <- expl_o_file, todo == StopBefore Ln = x
- | otherwise = ml_obj_file location
-
+ do_recomp <- readIORef v_Recomp
source_unchanged <-
- if not (do_recomp && ( todo == DoLink || todo == StopBefore Ln ))
+ if not (do_recomp && case todo of { DoLink -> True; other -> False })
then return False
- else do t1 <- getModificationTime (basename ++ '.':suff)
- o_file_exists <- doesFileExist o_file
+ else do o_file_exists <- doesFileExist o_file
if not o_file_exists
then return False -- Need to recompile
else do t2 <- getModificationTime o_file
- if t2 > t1
+ if t2 > src_timestamp
then return True
else return False
-- get the DynFlags
- hsc_lang <- hscMaybeAdjustLang (hscLang dflags)
- next_phase <- hscNextPhase hsc_lang
- output_fn <- get_output_fn next_phase (Just location)
+ hsc_lang <- hscMaybeAdjustTarget todo src_flavour (hscTarget dflags)
+ next_phase <- hscNextPhase src_flavour hsc_lang
+ output_fn <- get_output_fn next_phase (Just location4)
- let dflags' = dflags { hscLang = hsc_lang,
+ let dflags' = dflags { hscTarget = hsc_lang,
hscOutName = output_fn,
hscStubCOutName = basename ++ "_stub.c",
hscStubHOutName = basename ++ "_stub.h",
extCoreName = basename ++ ".hcr" }
+
hsc_env <- newHscEnv OneShot dflags'
-- run the compiler!
- result <- hscMain hsc_env printErrorsAndWarnings mod_name
- location{ ml_hspp_file = Just input_fn,
- ml_hspp_buf = hspp_buf }
- source_unchanged
- False
- Nothing -- no iface
+ result <- hscMain hsc_env printErrorsAndWarnings
+ mod_summary source_unchanged
+ False -- No object file
+ Nothing -- No iface
case result of
HscNoRecomp details iface -> do
SysTools.touch dflags' "Touching object file" o_file
- return (Nothing, dflags', Just location, output_fn)
+ return (StopLn, dflags', Just location4, o_file)
HscRecomp _details _rdr_env _iface
stub_h_exists stub_c_exists
_maybe_interpreted_code -> do
- -- deal with stubs
+ -- Deal with stubs
maybe_stub_o <- compileStub dflags' stub_c_exists
case maybe_stub_o of
- Nothing -> return ()
+ Nothing -> return ()
Just stub_o -> add v_Ld_inputs stub_o
- case hscLang dflags' of
- HscNothing -> return (Nothing, dflags', Just location, output_fn)
- _ -> return (Just next_phase, dflags', Just location, output_fn)
+
+ -- In the case of hs-boot files, generate a dummy .o-boot
+ -- stamp file for the benefit of Make
+ case src_flavour of
+ HsBootFile -> SysTools.touch dflags' "Touching object file" o_file
+ other -> return ()
+
+ return (next_phase, dflags', Just location4, output_fn)
-----------------------------------------------------------------------------
-- Cmm phase
-runPhase CmmCpp dflags basename suff input_fn get_output_fn maybe_loc
+runPhase CmmCpp todo dflags basename suff input_fn get_output_fn maybe_loc
= do
output_fn <- get_output_fn Cmm maybe_loc
doCpp dflags False{-not raw-} True{-include CC opts-} input_fn output_fn
- return (Just Cmm, dflags, maybe_loc, output_fn)
+ return (Cmm, dflags, maybe_loc, output_fn)
-runPhase Cmm dflags basename suff input_fn get_output_fn maybe_loc
+runPhase Cmm todo dflags basename suff input_fn get_output_fn maybe_loc
= do
- hsc_lang <- hscMaybeAdjustLang (hscLang dflags)
- next_phase <- hscNextPhase hsc_lang
+ hsc_lang <- hscMaybeAdjustTarget todo HsSrcFile (hscTarget dflags)
+ next_phase <- hscNextPhase HsSrcFile hsc_lang
output_fn <- get_output_fn next_phase maybe_loc
- let dflags' = dflags { hscLang = hsc_lang,
+ let dflags' = dflags { hscTarget = hsc_lang,
hscOutName = output_fn,
hscStubCOutName = basename ++ "_stub.c",
hscStubHOutName = basename ++ "_stub.h",
when (not ok) $ throwDyn (PhaseFailed "cmm" (ExitFailure 1))
- return (Just next_phase, dflags, maybe_loc, output_fn)
+ return (next_phase, dflags, maybe_loc, output_fn)
-----------------------------------------------------------------------------
-- Cc phase
-- 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 dflags basename suff input_fn get_output_fn maybe_loc
- | cc_phase == Cc || cc_phase == HCc
+runPhase cc_phase todo dflags basename suff input_fn get_output_fn maybe_loc
+ | cc_phase `eqPhase` Cc || cc_phase `eqPhase` HCc
= do let cc_opts = getOpts dflags opt_c
- cmdline_include_paths <- readIORef v_Include_paths
-
- split <- readIORef v_Split_object_files
- mangle <- readIORef v_Do_asm_mangling
+ hcc = cc_phase `eqPhase` HCc
- let hcc = cc_phase == HCc
-
- next_phase
- | hcc && mangle = Mangle
- | otherwise = As
-
- output_fn <- get_output_fn next_phase maybe_loc
+ cmdline_include_paths <- readIORef v_Include_paths
-- HC files have the dependent packages stamped into them
pkgs <- if hcc then getHCFilePackages input_fn else return []
let include_paths = foldr (\ x xs -> "-I" : x : xs) []
(cmdline_include_paths ++ pkg_include_dirs)
- mangle <- readIORef v_Do_asm_mangling
(md_c_flags, md_regd_c_flags) <- machdepCCOpts dflags
let verb = getVerbFlag dflags
excessPrecision <- readIORef v_Excess_precision
+ -- Decide next phase
+ mangle <- readIORef v_Do_asm_mangling
+ let next_phase
+ | hcc && mangle = Mangle
+ | otherwise = As
+ output_fn <- get_output_fn next_phase maybe_loc
+
-- force the C compiler to interpret this file as C when
-- compiling .hc files, by adding the -x c option.
- let langopt
- | cc_phase == HCc = [ SysTools.Option "-x", SysTools.Option "c"]
- | otherwise = [ ]
+ let langopt | hcc = [ SysTools.Option "-x", SysTools.Option "c"]
+ | otherwise = [ ]
SysTools.runCc dflags (langopt ++
[ SysTools.FileOption "" input_fn
]
++ map SysTools.Option (
md_c_flags
- ++ (if cc_phase == HCc && mangle
+ ++ (if hcc && mangle
then md_regd_c_flags
else [])
++ [ verb, "-S", "-Wimplicit", "-O" ]
++ pkg_extra_cc_opts
))
- return (Just next_phase, dflags, maybe_loc, output_fn)
+ return (next_phase, dflags, maybe_loc, output_fn)
-- ToDo: postprocess the output from gcc
-----------------------------------------------------------------------------
-- Mangle phase
-runPhase Mangle dflags _basename _suff input_fn get_output_fn maybe_loc
+runPhase Mangle todo dflags _basename _suff input_fn get_output_fn maybe_loc
= do let mangler_opts = getOpts dflags opt_m
machdep_opts <- if (prefixMatch "i386" cTARGETPLATFORM)
then do let n_regs = stolen_x86_regs dflags
]
++ map SysTools.Option machdep_opts)
- return (Just next_phase, dflags, maybe_loc, output_fn)
+ return (next_phase, dflags, maybe_loc, output_fn)
-----------------------------------------------------------------------------
-- Splitting phase
-runPhase SplitMangle dflags _basename _suff input_fn get_output_fn maybe_loc
+runPhase SplitMangle todo 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 "split"
addFilesToClean [ split_s_prefix ++ "__" ++ show n ++ ".s"
| n <- [1..n_files]]
- return (Just SplitAs, dflags, maybe_loc, "**splitmangle**")
+ return (SplitAs, dflags, maybe_loc, "**splitmangle**")
-- we don't use the filename
-----------------------------------------------------------------------------
-- As phase
-runPhase As dflags _basename _suff input_fn get_output_fn maybe_loc
+runPhase As todo dflags _basename _suff input_fn get_output_fn maybe_loc
= do let as_opts = getOpts dflags opt_a
cmdline_include_paths <- readIORef v_Include_paths
- output_fn <- get_output_fn Ln maybe_loc
+ output_fn <- get_output_fn StopLn maybe_loc
-- we create directories for the object file, because it
-- might be a hierarchical module.
, SysTools.FileOption "" output_fn
])
- return (Just Ln, dflags, maybe_loc, output_fn)
+ return (StopLn, dflags, maybe_loc, output_fn)
-runPhase SplitAs dflags basename _suff _input_fn get_output_fn maybe_loc
+runPhase SplitAs todo dflags basename _suff _input_fn get_output_fn maybe_loc
= do let as_opts = getOpts dflags opt_a
(split_s_prefix, n) <- readIORef v_Split_info
mapM_ assemble_file [1..n]
- output_fn <- get_output_fn Ln maybe_loc
- return (Just Ln, dflags, maybe_loc, output_fn)
+ output_fn <- get_output_fn StopLn maybe_loc
+ return (StopLn, dflags, maybe_loc, output_fn)
#ifdef ILX
-----------------------------------------------------------------------------
-- Ilx2Il phase
-- Run ilx2il over the ILX output, getting an IL file
-runPhase Ilx2Il dflags _basename _suff input_fn get_output_fn maybe_loc
+runPhase Ilx2Il todo dflags _basename _suff input_fn get_output_fn maybe_loc
= do let ilx2il_opts = getOpts dflags opt_I
SysTools.runIlx2il (map SysTools.Option ilx2il_opts
++ [ SysTools.Option "--no-add-suffix-to-assembly",
-- Ilasm phase
-- Run ilasm over the IL, getting a DLL
-runPhase Ilasm dflags _basename _suff input_fn get_output_fn maybe_loc
+runPhase Ilasm todo dflags _basename _suff input_fn get_output_fn maybe_loc
= do let ilasm_opts = getOpts dflags opt_i
SysTools.runIlasm (map SysTools.Option ilasm_opts
++ [ SysTools.Option "/QUIET",
pkg_frameworks <- getPackageFrameworks dflags dep_packages
let pkg_framework_opts = concat [ ["-framework", fw] | fw <- pkg_frameworks ]
-
frameworks <- readIORef v_Cmdline_frameworks
let framework_opts = concat [ ["-framework", fw] | fw <- reverse frameworks ]
-- reverse because they're added in reverse order from the cmd line
-- opts from -optl-<blah> (including -l<blah> options)
extra_ld_opts <- getStaticOpts v_Opt_l
- let pstate = pkgState dflags
- rts_id | ExtPackage id <- rtsPackageId pstate = id
- | otherwise = panic "staticLink: rts package missing"
- base_id | ExtPackage id <- basePackageId pstate = id
- | otherwise = panic "staticLink: base package missing"
- rts_pkg = getPackageDetails pstate rts_id
- base_pkg = getPackageDetails pstate base_id
-
ways <- readIORef v_Ways
-- Here are some libs that need to be linked at the *end* of
]
| otherwise = []
- let extra_os = if static || no_hs_main
- then []
- else []
-
(md_c_flags, _) <- machdepCCOpts dflags
SysTools.runLink dflags (
[ SysTools.Option verb
++ map SysTools.Option (
md_c_flags
++ o_files
- ++ extra_os
++ extra_ld_inputs
++ lib_path_opts
++ extra_ld_opts
-- -----------------------------------------------------------------------------
-- Misc.
-hscNextPhase :: HscLang -> IO Phase
-hscNextPhase hsc_lang = do
+hscNextPhase :: HscSource -> HscTarget -> IO Phase
+hscNextPhase HsBootFile hsc_lang
+ = return StopLn
+
+hscNextPhase other hsc_lang = do
split <- readIORef v_Split_object_files
return (case hsc_lang of
HscC -> HCc
HscAsm | split -> SplitMangle
| otherwise -> As
- HscNothing -> HCc -- dummy (no output will be generated)
- HscInterpreted -> HCc -- "" ""
- _other -> HCc -- "" ""
+ HscNothing -> StopLn
+ HscInterpreted -> StopLn
+ _other -> StopLn
)
-hscMaybeAdjustLang :: HscLang -> IO HscLang
-hscMaybeAdjustLang current_hsc_lang = do
- todo <- readIORef v_GhcMode
- keep_hc <- readIORef v_Keep_hc_files
- let hsc_lang
- -- don't change the lang if we're interpreting
- | current_hsc_lang == HscInterpreted = current_hsc_lang
- -- force -fvia-C if we are being asked for a .hc file
- | todo == StopBefore HCc || keep_hc = HscC
- -- otherwise, stick to the plan
- | otherwise = current_hsc_lang
- return hsc_lang
+hscMaybeAdjustTarget :: GhcMode -> HscSource -> HscTarget -> IO HscTarget
+hscMaybeAdjustTarget todo HsBootFile current_hsc_lang
+ = return HscNothing -- No output (other than Foo.hi-boot) for hs-boot files
+hscMaybeAdjustTarget todo other current_hsc_lang
+ = do { keep_hc <- readIORef v_Keep_hc_files
+ ; let hsc_lang
+ -- don't change the lang if we're interpreting
+ | current_hsc_lang == HscInterpreted = current_hsc_lang
+
+ -- force -fvia-C if we are being asked for a .hc file
+ | StopBefore HCc <- todo = HscC
+ | keep_hc = HscC
+ -- otherwise, stick to the plan
+ | otherwise = current_hsc_lang
+ ; return hsc_lang }
| DoInteractive -- ghc --interactive
| DoLink -- [ the default ]
| DoEval String -- ghc -e
- deriving (Eq,Show)
+ deriving (Show)
GLOBAL_VAR(v_GhcMode, DoLink, GhcMode)
GLOBAL_VAR(v_GhcModeFlag, "", String)
writeIORef v_GhcMode m
writeIORef v_GhcModeFlag flag
+isInteractiveMode, isInterpretiveMode :: GhcMode -> Bool
+isMakeMode, isLinkMode, isCompManagerMode :: GhcMode -> Bool
+
+isInteractiveMode DoInteractive = True
+isInteractiveMode _ = False
+
+-- isInterpretiveMode: byte-code compiler involved
+isInterpretiveMode DoInteractive = True
+isInterpretiveMode (DoEval _) = True
+isInterpretiveMode _ = False
+
+isMakeMode DoMake = True
+isMakeMode _ = False
+
+isLinkMode DoLink = True
+isLinkMode DoMkDLL = True
+isLinkMode _ = False
+
isCompManagerMode DoMake = True
isCompManagerMode DoInteractive = True
isCompManagerMode (DoEval _) = True
show dir ++ " does not exist (used with " ++
show flg ++ " option.)"))
-GLOBAL_VAR(v_Object_suf, phaseInputExt Ln, String)
-GLOBAL_VAR(v_HC_suf, Nothing, Maybe String)
+GLOBAL_VAR(v_Object_suf, phaseInputExt StopLn, String)
+GLOBAL_VAR(v_HC_suf, phaseInputExt HCc, String)
GLOBAL_VAR(v_Hi_dir, Nothing, Maybe String)
GLOBAL_VAR(v_Hi_suf, "hi", String)
module Finder (
flushFinderCache, -- :: IO ()
FindResult(..),
- findModule, -- :: ModuleName -> Bool -> IO FindResult
- findPackageModule, -- :: ModuleName -> Bool -> IO FindResult
- mkHomeModLocation, -- :: ModuleName -> FilePath -> IO ModLocation
- findLinkable, -- :: ModuleName -> ModLocation -> IO (Maybe Linkable)
+ findModule, -- :: ModuleName -> Bool -> IO FindResult
+ findPackageModule, -- :: ModuleName -> Bool -> IO FindResult
+ mkHomeModLocation, -- :: ModuleName -> FilePath -> IO ModLocation
+ mkHomeModLocation2, -- :: ModuleName -> FilePath -> String -> IO ModLocation
+ addHomeModuleToFinder, -- :: Module -> ModLocation -> IO ()
- hiBootFilePath, -- :: ModLocation -> IO FilePath
- hiBootExt, -- :: String
- hiBootVerExt, -- :: String
+ findLinkable, -- :: ModuleName -> ModLocation -> IO (Maybe Linkable)
+ cantFindError, -- :: DynFlags -> Module -> FindResult -> SDoc
) where
#include "HsVersions.h"
import DriverState
import DriverUtil
import FastString
-import Config
import Util
import CmdLineOpts ( DynFlags(..) )
+import Outputable
import DATA_IOREF ( IORef, writeIORef, readIORef )
import System.Directory
import System.IO
import Control.Monad
+import Maybes ( MaybeErr(..) )
import Data.Maybe ( isNothing )
+
+type FileExt = String -- Filename extension
+type BaseName = String -- Basename of file
+
-- -----------------------------------------------------------------------------
-- The Finder
GLOBAL_VAR(finder_cache, emptyModuleEnv, ModuleEnv FinderCacheEntry)
-type FinderCacheEntry = (ModLocation,Maybe (PackageConfig,Bool))
+type FinderCacheEntry = (ModLocation, Maybe (PackageConfig,Bool))
-- remove all the home modules from the cache; package modules are
-- assumed to not move around during a session.
| NotFound [FilePath]
-- the module was not found, the specified places were searched.
+type LocalFindResult = MaybeErr [FilePath] FinderCacheEntry
+ -- LocalFindResult is used for internal functions which
+ -- return a more informative type; it's munged into
+ -- the external FindResult by 'cached'
+
+cached :: (DynFlags -> Module -> IO LocalFindResult)
+ -> DynFlags -> Module -> Bool -> IO FindResult
+cached wrapped_fn dflags name explicit
+ = do { -- First try the cache
+ mb_entry <- lookupFinderCache name
+ ; case mb_entry of {
+ Just old_entry -> return (found old_entry) ;
+ Nothing -> do
+
+ { -- Now try the wrapped function
+ mb_entry <- wrapped_fn dflags name
+ ; case mb_entry of
+ Failed paths -> return (NotFound paths)
+ Succeeded new_entry -> do { addToFinderCache name new_entry
+ ; return (found new_entry) }
+ }}}
+ where
+ -- We've found the module, so the remaining question is
+ -- whether it's visible or not
+ found :: FinderCacheEntry -> FindResult
+ found (loc, Nothing) = Found loc HomePackage
+ found (loc, Just (pkg, exposed_mod))
+ | explicit && not exposed_mod = ModuleHidden pkg_name
+ | explicit && not (exposed pkg) = PackageHidden pkg_name
+ | otherwise = Found loc (ExtPackage (mkPackageId (package pkg)))
+ where
+ pkg_name = packageConfigId pkg
+
+addHomeModuleToFinder :: Module -> ModLocation -> IO ()
+addHomeModuleToFinder mod loc = addToFinderCache mod (loc, Nothing)
+
+
+-- -----------------------------------------------------------------------------
+-- The two external entry points
+
+
findModule :: DynFlags -> Module -> Bool -> IO FindResult
-findModule = cached findModule'
+findModule = cached findModule'
-findModule' :: DynFlags -> Module -> Bool -> IO FindResult
-findModule' dflags name explicit = do
- r <- findPackageModule' dflags name explicit
+findPackageModule :: DynFlags -> Module -> Bool -> IO FindResult
+findPackageModule = cached findPackageModule'
+
+-- -----------------------------------------------------------------------------
+-- The internal workers
+
+findModule' :: DynFlags -> Module -> IO LocalFindResult
+-- Find home or package module
+findModule' dflags name = do
+ r <- findPackageModule' dflags name
case r of
- NotFound pkg_files -> do
- j <- maybeHomeModule dflags name
+ Failed pkg_files -> do
+ j <- findHomeModule' dflags name
case j of
- NotFound home_files ->
- return (NotFound (home_files ++ pkg_files))
+ Failed home_files ->
+ return (Failed (home_files ++ pkg_files))
other_result
-> return other_result
other_result
-> return other_result
-cached fn dflags name explicit = do
- m <- lookupFinderCache name
- case m of
- Nothing -> fn dflags name explicit
- Just (loc,maybe_pkg)
- | Just err <- visible explicit maybe_pkg -> return err
- | otherwise -> return (Found loc (pkgInfoToId maybe_pkg))
-
-pkgInfoToId :: Maybe (PackageConfig,Bool) -> PackageIdH
-pkgInfoToId (Just (pkg,_)) = ExtPackage (mkPackageId (package pkg))
-pkgInfoToId Nothing = HomePackage
-
--- Is a module visible or not? Returns Nothing if the import is ok,
--- or Just err if there's a visibility error.
-visible :: Bool -> Maybe (PackageConfig,Bool) -> Maybe FindResult
-visible explicit maybe_pkg
- | Nothing <- maybe_pkg = Nothing -- home module ==> YES
- | not explicit = Nothing -- implicit import ==> YES
- | Just (pkg, exposed_module) <- maybe_pkg
- = case () of
- _ | not exposed_module -> Just (ModuleHidden pkgname)
- | not (exposed pkg) -> Just (PackageHidden pkgname)
- | otherwise -> Nothing
- where
- pkgname = packageConfigId pkg
-
-
-hiBootExt = "hi-boot"
-hiBootVerExt = "hi-boot-" ++ cHscIfaceFileVersion
-
-maybeHomeModule :: DynFlags -> Module -> IO FindResult
-maybeHomeModule dflags mod = do
+findHomeModule' :: DynFlags -> Module -> IO LocalFindResult
+findHomeModule' dflags mod = do
let home_path = importPaths dflags
hisuf <- readIORef v_Hi_suf
mode <- readIORef v_GhcMode
let
source_exts =
- [ ("hs", mkHomeModLocationSearched mod)
- , ("lhs", mkHomeModLocationSearched mod)
+ [ ("hs", mkHomeModLocationSearched mod "hs")
+ , ("lhs", mkHomeModLocationSearched mod "lhs")
]
- hi_exts = [ (hisuf, mkHiOnlyModLocation hisuf mod) ]
+ hi_exts = [ (hisuf, mkHiOnlyModLocation hisuf)
+ , (addBootSuffix hisuf, mkHiOnlyModLocation hisuf)
+ ]
- boot_exts =
- [ (hiBootVerExt, mkHiOnlyModLocation hisuf mod)
- , (hiBootExt, mkHiOnlyModLocation hisuf mod)
- ]
-
-- In compilation manager modes, we look for source files in the home
-- package because we can compile these automatically. In one-shot
-- compilation mode we look for .hi and .hi-boot files only.
- --
- -- When generating dependencies, we're interested in either category.
- --
exts
- | mode == DoMkDependHS = hi_exts ++ source_exts ++ boot_exts
+ | DoMkDependHS <- mode = source_exts
| isCompManagerMode mode = source_exts
- | otherwise {-one-shot-} = hi_exts ++ boot_exts
+ | otherwise {-one-shot-} = hi_exts
searchPathExts home_path mod exts
--- -----------------------------------------------------------------------------
--- Looking for a package module
-
-findPackageModule :: DynFlags -> Module -> Bool -> IO FindResult
-findPackageModule = cached findPackageModule'
-
-findPackageModule' :: DynFlags -> Module -> Bool -> IO FindResult
-findPackageModule' dflags mod explicit = do
- mode <- readIORef v_GhcMode
-
- case moduleToPackageConfig dflags mod of
- Nothing -> return (NotFound [])
- pkg_info@(Just (pkg_conf, module_exposed))
- | Just err <- visible explicit pkg_info -> return err
- | otherwise -> findPackageIface mode mod paths pkg_info
- where
- paths = importDirs pkg_conf
-
-findPackageIface
- :: GhcMode
- -> Module
- -> [FilePath]
- -> Maybe (PackageConfig,Bool)
- -> IO FindResult
-findPackageIface mode mod imp_dirs pkg_info = do
- -- hi-suffix for packages depends on the build tag.
- package_hisuf <-
- do tag <- readIORef v_Build_tag
- if null tag
- then return "hi"
- else return (tag ++ "_hi")
-
+findPackageModule' :: DynFlags -> Module -> IO LocalFindResult
+findPackageModule' dflags mod
+ = case moduleToPackageConfig dflags mod of
+ Nothing -> return (Failed [])
+ Just pkg_info -> findPackageIface mod pkg_info
+
+findPackageIface :: Module -> (PackageConfig,Bool) -> IO LocalFindResult
+findPackageIface mod pkg_info@(pkg_conf, _) = do
+ mode <- readIORef v_GhcMode
+ tag <- readIORef v_Build_tag
let
+ -- hi-suffix for packages depends on the build tag.
+ package_hisuf | null tag = "hi"
+ | otherwise = tag ++ "_hi"
hi_exts =
[ (package_hisuf,
- mkPackageModLocation pkg_info package_hisuf mod) ]
+ mkPackageModLocation pkg_info package_hisuf) ]
source_exts =
- [ ("hs", mkPackageModLocation pkg_info package_hisuf mod)
- , ("lhs", mkPackageModLocation pkg_info package_hisuf mod)
+ [ ("hs", mkPackageModLocation pkg_info package_hisuf)
+ , ("lhs", mkPackageModLocation pkg_info package_hisuf)
]
-- mkdependHS needs to look for source files in packages too, so
-- that we can make dependencies between package before they have
-- been built.
exts
- | mode == DoMkDependHS = hi_exts ++ source_exts
- | otherwise = hi_exts
-
+ | DoMkDependHS <- mode = hi_exts ++ source_exts
+ | otherwise = hi_exts
-- we never look for a .hi-boot file in an external package;
-- .hi-boot files only make sense for the home package.
- searchPathExts imp_dirs mod exts
+
+ searchPathExts (importDirs pkg_conf) mod exts
-- -----------------------------------------------------------------------------
-- General path searching
:: [FilePath] -- paths to search
-> Module -- module name
-> [ (
- String, -- suffix
- String -> String -> String -> IO FindResult -- action
+ FileExt, -- suffix
+ FilePath -> BaseName -> IO FinderCacheEntry -- action
)
]
- -> IO FindResult
+ -> IO LocalFindResult
+
+searchPathExts paths mod exts
+ = do result <- search to_search
+{-
+ hPutStrLn stderr (showSDoc $
+ vcat [text "Search" <+> ppr mod <+> sep (map (text. fst) exts)
+ , nest 2 (vcat (map text paths))
+ , case result of
+ Succeeded (loc, p) -> text "Found" <+> ppr loc
+ Failed fs -> text "not found"])
+-}
+ return result
-searchPathExts path mod exts = search to_search
where
basename = dots_to_slashes (moduleUserString mod)
- to_search :: [(FilePath, IO FindResult)]
- to_search = [ (file, fn p basename ext)
- | p <- path,
+ to_search :: [(FilePath, IO FinderCacheEntry)]
+ to_search = [ (file, fn path basename)
+ | path <- paths,
(ext,fn) <- exts,
- let base | p == "." = basename
- | otherwise = p ++ '/':basename
+ let base | path == "." = basename
+ | otherwise = path ++ '/':basename
file = base ++ '.':ext
]
- search [] = return (NotFound (map fst to_search))
- search ((file, result) : rest) = do
+ search [] = return (Failed (map fst to_search))
+ search ((file, mk_result) : rest) = do
b <- doesFileExist file
if b
- then result
+ then do { res <- mk_result; return (Succeeded res) }
else search rest
--- -----------------------------------------------------------------------------
--- Building ModLocations
+mkHomeModLocationSearched :: Module -> FileExt
+ -> FilePath -> BaseName -> IO FinderCacheEntry
+mkHomeModLocationSearched mod suff path basename = do
+ loc <- mkHomeModLocation2 mod (path ++ '/':basename) suff
+ return (loc, Nothing)
-mkHiOnlyModLocation hisuf mod path basename _ext = do
- -- basename == dots_to_slashes (moduleNameUserString mod)
+mkHiOnlyModLocation :: FileExt -> FilePath -> BaseName -> IO FinderCacheEntry
+mkHiOnlyModLocation hisuf path basename = do
loc <- hiOnlyModLocation path basename hisuf
- addToFinderCache mod (loc, Nothing)
- return (Found loc HomePackage)
+ return (loc, Nothing)
-mkPackageModLocation pkg_info hisuf mod path basename _ext = do
- -- basename == dots_to_slashes (moduleNameUserString mod)
+mkPackageModLocation :: (PackageConfig, Bool) -> FileExt
+ -> FilePath -> BaseName -> IO FinderCacheEntry
+mkPackageModLocation pkg_info hisuf path basename = do
loc <- hiOnlyModLocation path basename hisuf
- addToFinderCache mod (loc, pkg_info)
- return (Found loc (pkgInfoToId pkg_info))
-
-hiOnlyModLocation path basename hisuf
- = do let full_basename = path++'/':basename
- obj_fn <- mkObjPath full_basename basename
- return ModLocation{ ml_hspp_file = Nothing,
- ml_hspp_buf = Nothing,
- ml_hs_file = Nothing,
- ml_hi_file = full_basename ++ '.':hisuf,
- -- Remove the .hi-boot suffix from
- -- hi_file, if it had one. We always
- -- want the name of the real .hi file
- -- in the ml_hi_file field.
- ml_obj_file = obj_fn
- }
+ return (loc, Just pkg_info)
-- -----------------------------------------------------------------------------
-- Constructing a home module location
-- ext
-- The filename extension of the source file (usually "hs" or "lhs").
+mkHomeModLocation :: Module -> FilePath -> IO ModLocation
mkHomeModLocation mod src_filename = do
let (basename,extension) = splitFilename src_filename
- mkHomeModLocation' mod basename extension
+ mkHomeModLocation2 mod basename extension
-mkHomeModLocationSearched mod path basename ext = do
- loc <- mkHomeModLocation' mod (path ++ '/':basename) ext
- return (Found loc HomePackage)
-
-mkHomeModLocation' mod src_basename ext = do
+mkHomeModLocation2 :: Module
+ -> FilePath -- Of source module, without suffix
+ -> String -- Suffix
+ -> IO ModLocation
+mkHomeModLocation2 mod src_basename ext = do
let mod_basename = dots_to_slashes (moduleUserString mod)
obj_fn <- mkObjPath src_basename mod_basename
hi_fn <- mkHiPath src_basename mod_basename
- let loc = ModLocation{ ml_hspp_file = Nothing,
- ml_hspp_buf = Nothing,
- ml_hs_file = Just (src_basename ++ '.':ext),
- ml_hi_file = hi_fn,
- ml_obj_file = obj_fn }
+ return (ModLocation{ ml_hs_file = Just (src_basename ++ '.':ext),
+ ml_hi_file = hi_fn,
+ ml_obj_file = obj_fn })
- addToFinderCache mod (loc, Nothing)
- return loc
+hiOnlyModLocation :: FilePath -> String -> Suffix -> IO ModLocation
+hiOnlyModLocation path basename hisuf
+ = do let full_basename = path++'/':basename
+ obj_fn <- mkObjPath full_basename basename
+ return ModLocation{ ml_hs_file = Nothing,
+ ml_hi_file = full_basename ++ '.':hisuf,
+ -- Remove the .hi-boot suffix from
+ -- hi_file, if it had one. We always
+ -- want the name of the real .hi file
+ -- in the ml_hi_file field.
+ ml_obj_file = obj_fn
+ }
-- | Constructs the filename of a .o file for a given source file.
-- Does /not/ check whether the .o file exists
return (hi_basename ++ '.':hisuf)
---------------------
-hiBootFilePath :: ModLocation -> IO FilePath
--- Return Foo.hi-boot, or Foo.hi-boot-n, as appropriate
-hiBootFilePath (ModLocation { ml_hi_file = hi_path })
- = do { hi_ver_exists <- doesFileExist hi_boot_ver_path
- ; if hi_ver_exists then return hi_boot_ver_path
- else return hi_boot_path }
- where
- hi_boot_path = replaceFilenameSuffix hi_path hiBootExt ;
- hi_boot_ver_path = replaceFilenameSuffix hi_path hiBootVerExt
-
-
-- -----------------------------------------------------------------------------
-- findLinkable isn't related to the other stuff in here,
-- but there's no other obvious place for it
dots_to_slashes = map (\c -> if c == '.' then '/' else c)
+
+-- -----------------------------------------------------------------------------
+-- Error messages
+
+cantFindError :: DynFlags -> Module -> FindResult -> SDoc
+cantFindError dflags mod_name find_result
+ = hang (ptext SLIT("Could not find module") <+> quotes (ppr mod_name) <> colon)
+ 2 more_info
+ where
+ more_info
+ = case find_result of
+ PackageHidden pkg
+ -> ptext SLIT("it is a member of package") <+> ppr pkg <> comma
+ <+> ptext SLIT("which is hidden")
+
+ ModuleHidden pkg
+ -> ptext SLIT("it is hidden") <+> parens (ptext SLIT("in package")
+ <+> ppr pkg)
+
+ NotFound files
+ | verbosity dflags < 3
+ -> ptext SLIT("use -v to see a list of the files searched for")
+ | otherwise
+ -> hang (ptext SLIT("locations searched:"))
+ 2 (vcat (map text files))
+
+ Found _ _ -> panic "cantFindErr"
\end{code}
import Lexer ( P(..), ParseResult(..), mkPState )
import HsSyn ( ImportDecl(..), HsModule(..) )
import Module ( Module, mkModule )
+import PrelNames ( gHC_PRIM )
import StringBuffer ( StringBuffer, hGetStringBuffer )
import SrcLoc ( Located(..), mkSrcLoc, unLoc )
import FastString ( mkFastString )
| otherwise = mkModule "Main"
(src_idecls, ord_idecls) = partition isSourceIdecl (map unLoc imps)
source_imps = map getImpMod src_idecls
- ordinary_imps = map getImpMod ord_idecls
+ ordinary_imps = filter (/= gHC_PRIM) (map getImpMod ord_idecls)
+ -- GHC.Prim doesn't exist physically, so don't go looking for it.
in
return (source_imps, ordinary_imps, mod_name)
#ifdef GHCI
import HsSyn ( Stmt(..), LStmt, LHsExpr, LHsType )
import IfaceSyn ( IfaceDecl, IfaceInst )
+import Module ( Module )
import CodeOutput ( outputForeignStubs )
import ByteCodeGen ( byteCodeGen, coreExprToBCOs )
import Linker ( HValue, linkExpr )
import CodeOutput ( codeOutput )
import CmdLineOpts
-import DriverPhases ( isExtCoreFilename )
+import DriverPhases ( HscSource(..) )
import ErrUtils
import UniqSupply ( mkSplitUniqSupply )
import MkExternalCore ( emitExternalCore )
import ParserCore
import ParserCoreUtils
-import Module ( Module, ModLocation(..), showModMsg )
import FastString
import Maybes ( expectJust )
import StringBuffer ( StringBuffer )
import Bag ( unitBag, emptyBag )
import Monad ( when )
-import Maybe ( isJust, fromJust )
+import Maybe ( isJust )
import IO
import DATA_IOREF ( newIORef, readIORef )
\end{code}
hscMain
:: HscEnv
- -> MessageAction -- what to do with errors/warnings
- -> Module
- -> ModLocation -- location info
- -> Bool -- True <=> source unchanged
- -> Bool -- True <=> have an object file (for msgs only)
- -> Maybe ModIface -- old interface, if available
+ -> MessageAction -- What to do with errors/warnings
+ -> ModSummary
+ -> Bool -- True <=> source unchanged
+ -> Bool -- True <=> have an object file (for msgs only)
+ -> Maybe ModIface -- Old interface, if available
-> IO HscResult
-hscMain hsc_env msg_act mod location
+hscMain hsc_env msg_act mod_summary
source_unchanged have_object maybe_old_iface
= do {
(recomp_reqd, maybe_checked_iface) <-
_scc_ "checkOldIface"
- checkOldIface hsc_env mod
- (ml_hi_file location)
+ checkOldIface hsc_env mod_summary
source_unchanged maybe_old_iface;
let no_old_iface = not (isJust maybe_checked_iface)
what_next | recomp_reqd || no_old_iface = hscRecomp
| otherwise = hscNoRecomp
- ; what_next hsc_env msg_act have_object
- mod location maybe_checked_iface
+ ; what_next hsc_env msg_act mod_summary have_object
+ maybe_checked_iface
}
+------------------------------
-- hscNoRecomp definitely expects to have the old interface available
-hscNoRecomp hsc_env msg_act have_object
- mod location (Just old_iface)
+hscNoRecomp hsc_env msg_act mod_summary
+ have_object (Just old_iface)
| isOneShot (hsc_mode hsc_env)
= do {
compilationProgressMsg (hsc_dflags hsc_env) $
return (HscNoRecomp bomb bomb)
}
| otherwise
- = do {
- compilationProgressMsg (hsc_dflags hsc_env) $
- ("Skipping " ++ showModMsg have_object mod location);
+ = do { compilationProgressMsg (hsc_dflags hsc_env) $
+ ("Skipping " ++ showModMsg have_object mod_summary)
- new_details <- _scc_ "tcRnIface"
+ ; new_details <- _scc_ "tcRnIface"
typecheckIface hsc_env old_iface ;
- dumpIfaceStats hsc_env ;
+ ; dumpIfaceStats hsc_env
- return (HscNoRecomp new_details old_iface)
- }
+ ; return (HscNoRecomp new_details old_iface)
+ }
-hscRecomp hsc_env msg_act have_object
- mod location maybe_checked_iface
- = do {
- -- what target are we shooting for?
- ; let one_shot = isOneShot (hsc_mode hsc_env)
- ; let dflags = hsc_dflags hsc_env
- ; let toInterp = dopt_HscLang dflags == HscInterpreted
- ; let toCore = isJust (ml_hs_file location) &&
- isExtCoreFilename (fromJust (ml_hs_file location))
+------------------------------
+hscRecomp hsc_env msg_act mod_summary
+ have_object maybe_checked_iface
+ = case ms_hsc_src mod_summary of
+ HsSrcFile -> do { front_res <- hscFileFrontEnd hsc_env msg_act mod_summary
+ ; hscBackEnd hsc_env mod_summary maybe_checked_iface front_res }
+
+ HsBootFile -> do { front_res <- hscFileFrontEnd hsc_env msg_act mod_summary
+ ; hscBootBackEnd hsc_env mod_summary maybe_checked_iface front_res }
+ ExtCoreFile -> do { front_res <- hscCoreFrontEnd hsc_env msg_act mod_summary
+ ; hscBackEnd hsc_env mod_summary maybe_checked_iface front_res }
+
+hscCoreFrontEnd hsc_env msg_act mod_summary = do {
+ -------------------
+ -- PARSE
+ -------------------
+ ; inp <- readFile (expectJust "hscCoreFrontEnd" (ms_hspp_file mod_summary))
+ ; case parseCore inp 1 of
+ FailP s -> putMsg s{-ToDo: wrong-} >> return Nothing
+ OkP rdr_module -> do {
+
+ -------------------
+ -- RENAME and TYPECHECK
+ -------------------
+ ; (tc_msgs, maybe_tc_result) <- _scc_ "TypeCheck"
+ tcRnExtCore hsc_env rdr_module
+ ; msg_act tc_msgs
+ ; case maybe_tc_result of
+ Nothing -> return Nothing
+ Just mod_guts -> return (Just mod_guts) -- No desugaring to do!
+ }}
+
+
+hscFileFrontEnd hsc_env msg_act mod_summary = do {
+ -------------------
+ -- DISPLAY PROGRESS MESSAGE
+ -------------------
+ let one_shot = isOneShot (hsc_mode hsc_env)
+ ; let dflags = hsc_dflags hsc_env
+ ; let toInterp = dopt_HscTarget dflags == HscInterpreted
; when (not one_shot) $
- compilationProgressMsg dflags $
- ("Compiling " ++ showModMsg (not toInterp) mod location);
+ compilationProgressMsg dflags $
+ ("Compiling " ++ showModMsg (not toInterp) mod_summary)
- ; let hspp_file = expectJust "hscFrontEnd:hspp" (ml_hspp_file location)
- ; front_res <- if toCore then
- hscCoreFrontEnd hsc_env msg_act hspp_file
- else
- hscFileFrontEnd hsc_env msg_act hspp_file (ml_hspp_buf location)
+ -------------------
+ -- PARSE
+ -------------------
+ ; let hspp_file = expectJust "hscFileFrontEnd" (ms_hspp_file mod_summary)
+ hspp_buf = ms_hspp_buf mod_summary
- ; case front_res of
- Left flure -> return flure;
- Right ds_result -> do {
+ ; maybe_parsed <- myParseModule (hsc_dflags hsc_env) hspp_file hspp_buf
+ ; case maybe_parsed of {
+ Left err -> do { msg_act (unitBag err, emptyBag)
+ ; return Nothing } ;
+ Right rdr_module -> do {
- -- OMITTED:
- -- ; seqList imported_modules (return ())
+ -------------------
+ -- RENAME and TYPECHECK
+ -------------------
+ (tc_msgs, maybe_tc_result)
+ <- _scc_ "Typecheck-Rename"
+ tcRnModule hsc_env (ms_hsc_src mod_summary) rdr_module
+
+ ; msg_act tc_msgs
+ ; case maybe_tc_result of {
+ Nothing -> return Nothing ;
+ Just tc_result -> do {
+
+ -------------------
+ -- DESUGAR
+ -------------------
+ ; (warns, maybe_ds_result) <- _scc_ "DeSugar"
+ deSugar hsc_env tc_result
+ ; msg_act (warns, emptyBag)
+ ; case maybe_ds_result of
+ Nothing -> return Nothing
+ Just ds_result -> return (Just ds_result)
+ }}}}}
+
+------------------------------
+hscBootBackEnd :: HscEnv -> ModSummary -> Maybe ModIface -> Maybe ModGuts -> IO HscResult
+-- For hs-boot files, there's no code generation to do
+
+hscBootBackEnd hsc_env mod_summary maybe_checked_iface Nothing
+ = return HscFail
+hscBootBackEnd hsc_env mod_summary maybe_checked_iface (Just ds_result)
+ = do { final_iface <- _scc_ "MkFinalIface"
+ mkIface hsc_env (ms_location mod_summary)
+ maybe_checked_iface ds_result
+
+ ; let { final_globals = Just $! (mg_rdr_env ds_result)
+ ; final_details = ModDetails { md_types = mg_types ds_result,
+ md_insts = mg_insts ds_result,
+ md_rules = mg_rules ds_result } }
+ -- And the answer is ...
+ ; dumpIfaceStats hsc_env
+
+ ; return (HscRecomp final_details
+ final_globals
+ final_iface
+ False False Nothing)
+ }
+
+------------------------------
+hscBackEnd :: HscEnv -> ModSummary -> Maybe ModIface -> Maybe ModGuts -> IO HscResult
+
+hscBackEnd hsc_env mod_summary maybe_checked_iface Nothing
+ = return HscFail
+
+hscBackEnd hsc_env mod_summary maybe_checked_iface (Just ds_result)
+ = do { -- OMITTED:
+ -- ; seqList imported_modules (return ())
+
+ let one_shot = isOneShot (hsc_mode hsc_env)
+ dflags = hsc_dflags hsc_env
-------------------
-- FLATTENING
-- info has been set. Not yet clear if it matters waiting
-- until after code output
; new_iface <- _scc_ "MkFinalIface"
- mkIface hsc_env location
+ mkIface hsc_env (ms_location mod_summary)
maybe_checked_iface tidy_result
-
-- Space leak reduction: throw away the new interface if
-- we're in one-shot mode; we won't be needing it any
-- more.
-------------------
-- CONVERT TO STG and COMPLETE CODE GENERATION
; (stub_h_exists, stub_c_exists, maybe_bcos)
- <- hscBackEnd dflags tidy_result
+ <- hscCodeGen dflags tidy_result
-- And the answer is ...
; dumpIfaceStats hsc_env
final_iface
stub_h_exists stub_c_exists
maybe_bcos)
- }}
-
-hscCoreFrontEnd hsc_env msg_act hspp_file = do {
- -------------------
- -- PARSE
- -------------------
- ; inp <- readFile hspp_file
- ; case parseCore inp 1 of
- FailP s -> putMsg s{-ToDo: wrong-} >> return (Left HscFail)
- OkP rdr_module -> do {
-
- -------------------
- -- RENAME and TYPECHECK
- -------------------
- ; (tc_msgs, maybe_tc_result) <- _scc_ "TypeCheck"
- tcRnExtCore hsc_env rdr_module
- ; msg_act tc_msgs
- ; case maybe_tc_result of {
- Nothing -> return (Left HscFail);
- Just mod_guts -> return (Right mod_guts)
- -- No desugaring to do!
- }}}
-
-
-hscFileFrontEnd hsc_env msg_act hspp_file hspp_buf = do {
- -------------------
- -- PARSE
- -------------------
- ; maybe_parsed <- myParseModule (hsc_dflags hsc_env) hspp_file hspp_buf
-
- ; case maybe_parsed of {
- Left err -> do { msg_act (unitBag err, emptyBag) ;
- ; return (Left HscFail) ;
- };
- Right rdr_module -> do {
-
- -------------------
- -- RENAME and TYPECHECK
- -------------------
- ; (tc_msgs, maybe_tc_result) <- _scc_ "Typecheck-Rename"
- tcRnModule hsc_env rdr_module
- ; msg_act tc_msgs
- ; case maybe_tc_result of {
- Nothing -> return (Left HscFail);
- Just tc_result -> do {
-
- -------------------
- -- DESUGAR
- -------------------
- ; (warns, maybe_ds_result) <- _scc_ "DeSugar"
- deSugar hsc_env tc_result
- ; msg_act (warns, emptyBag)
- ; case maybe_ds_result of
- Nothing -> return (Left HscFail);
- Just ds_result -> return (Right ds_result);
- }}}}}
+ }
hscFileCheck hsc_env msg_act hspp_file = do {
hscBufferTypecheck hsc_env rdr_module msg_act = do
(tc_msgs, maybe_tc_result) <- _scc_ "Typecheck-Rename"
- tcRnModule hsc_env rdr_module
+ tcRnModule hsc_env HsSrcFile rdr_module
msg_act tc_msgs
case maybe_tc_result of
Nothing -> return (HscChecked rdr_module Nothing)
Just r -> return (HscChecked rdr_module (Just r))
-hscBackEnd dflags
+hscCodeGen dflags
ModGuts{ -- This is the last use of the ModGuts in a compilation.
-- From now on, we just use the bits we need.
mg_module = this_mod,
prepd_binds <- _scc_ "CorePrep"
corePrepPgm dflags core_binds type_env;
- case dopt_HscLang dflags of
+ case dopt_HscTarget dflags of
HscNothing -> return (False, False, Nothing)
HscInterpreted ->
ModDetails(..),
ModGuts(..), ModImports(..), ForeignStubs(..),
+ ModSummary(..), showModMsg,
+ msHsFilePath, msHiFilePath, msObjFilePath,
+
+ HscSource(..), isHsBoot, hscSourceString, -- Re-exported from DriverPhases
+
HomePackageTable, HomeModInfo(..), emptyHomePackageTable,
hptInstances, hptRules,
import DataCon ( dataConImplicitIds )
import Packages ( PackageIdH, PackageId )
import CmdLineOpts ( DynFlags )
-
+import DriverPhases ( HscSource(..), isHsBoot, hscSourceString )
import BasicTypes ( Version, initialVersion, IPName,
Fixity, defaultFixity, DeprecTxt )
import FiniteMap ( FiniteMap )
import CoreSyn ( IdCoreRule )
-import Maybes ( orElse, fromJust )
+import Maybes ( orElse, fromJust, expectJust )
import Outputable
import SrcLoc ( SrcSpan )
import UniqSupply ( UniqSupply )
import FastString ( FastString )
import DATA_IOREF ( IORef, readIORef )
+import StringBuffer ( StringBuffer )
import Time ( ClockTime )
\end{code}
data ModGuts
= ModGuts {
mg_module :: !Module,
+ mg_boot :: IsBootInterface, -- Whether it's an hs-boot module
mg_exports :: !NameSet, -- What it exports
mg_deps :: !Dependencies, -- What is below it, directly or otherwise
mg_dir_imps :: ![Module], -- Directly-imported modules; used to
%************************************************************************
%* *
+ The ModSummary type
+ A ModSummary is a node in the compilation manager's
+ dependency graph, and it's also passed to hscMain
+%* *
+%************************************************************************
+
+The nodes of the module graph are
+ EITHER a regular Haskell source module
+ OR a hi-boot source module
+
+\begin{code}
+data ModSummary
+ = ModSummary {
+ ms_mod :: Module, -- Name of the module
+ ms_hsc_src :: HscSource, -- Source is Haskell, hs-boot, external core
+ ms_location :: ModLocation, -- Location
+ ms_hs_date :: ClockTime, -- Timestamp of summarised file
+ ms_srcimps :: [Module], -- Source imports
+ ms_imps :: [Module], -- Non-source imports
+ ms_hspp_file :: Maybe FilePath, -- Filename of preprocessed source,
+ -- once we have preprocessed it.
+ ms_hspp_buf :: Maybe StringBuffer -- The actual preprocessed source, maybe.
+ }
+
+-- The ModLocation contains both the original source filename and the
+-- filename of the cleaned-up source file after all preprocessing has been
+-- done. The point is that the summariser will have to cpp/unlit/whatever
+-- all files anyway, and there's no point in doing this twice -- just
+-- park the result in a temp file, put the name of it in the location,
+-- and let @compile@ read from that file on the way back up.
+
+-- The ModLocation is stable over successive up-sweeps in GHCi, wheres
+-- the ms_hs_date and imports can, of course, change
+
+msHsFilePath, msHiFilePath, msObjFilePath :: ModSummary -> FilePath
+msHsFilePath ms = expectJust "msHsFilePath" (ml_hs_file (ms_location ms))
+msHiFilePath ms = ml_hi_file (ms_location ms)
+msObjFilePath ms = ml_obj_file (ms_location ms)
+
+
+instance Outputable ModSummary where
+ ppr ms
+ = sep [text "ModSummary {",
+ nest 3 (sep [text "ms_hs_date = " <> text (show (ms_hs_date ms)),
+ text "ms_mod =" <+> ppr (ms_mod ms)
+ <> text (hscSourceString (ms_hsc_src ms)) <> comma,
+ text "ms_imps =" <+> ppr (ms_imps ms),
+ text "ms_srcimps =" <+> ppr (ms_srcimps ms)]),
+ char '}'
+ ]
+
+showModMsg :: Bool -> ModSummary -> String
+showModMsg use_object mod_summary
+ = showSDoc (hsep [text (mod_str ++ replicate (max 0 (16 - length mod_str)) ' '),
+ char '(', text (msHsFilePath mod_summary) <> comma,
+ if use_object then text (msObjFilePath mod_summary)
+ else text "interpreted",
+ char ')'])
+ where
+ mod = ms_mod mod_summary
+ mod_str = moduleUserString mod ++ hscSourceString (ms_hsc_src mod_summary)
+\end{code}
+
+
+%************************************************************************
+%* *
\subsection{Linkable stuff}
%* *
%************************************************************************
{-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}
-----------------------------------------------------------------------------
--- $Id: Main.hs,v 1.142 2005/01/18 12:18:34 simonpj Exp $
+-- $Id: Main.hs,v 1.143 2005/01/27 10:44:39 simonpj Exp $
--
-- GHC Driver program
--
import Config ( cBooterVersion, cGhcUnregisterised, cProjectVersion )
import SysTools ( initSysTools, cleanTempFiles, normalisePath )
import Packages ( dumpPackages, initPackages, haskell98PackageId, PackageIdH(..) )
-import DriverPipeline ( staticLink, doMkDLL, runPipeline )
-import DriverState ( buildStgToDo,
- findBuildTag, unregFlags,
+import DriverPipeline ( staticLink, doMkDLL, compileFile )
+import DriverState ( isLinkMode, isMakeMode, isInteractiveMode,
+ isCompManagerMode, isInterpretiveMode,
+ buildStgToDo, findBuildTag, unregFlags,
v_GhcMode, v_GhcModeFlag, GhcMode(..),
v_Keep_tmp_files, v_Ld_inputs, v_Ways,
v_Output_file, v_Output_hi,
)
import DriverFlags
-import DriverMkDepend ( beginMkDependHS, endMkDependHS )
+import DriverMkDepend ( doMkDependHS )
import DriverPhases ( isSourceFilename )
import DriverUtil ( add, handle, handleDyn, later, unknownFlagsErr )
-import CmdLineOpts ( DynFlags(..), HscLang(..), v_Static_hsc_opts,
+import CmdLineOpts ( DynFlags(..), HscTarget(..), v_Static_hsc_opts,
defaultDynFlags )
import BasicTypes ( failed )
import Outputable
-- -O and --interactive are not a good combination
-- ditto with any kind of way selection
orig_ways <- readIORef v_Ways
- when (notNull orig_ways && isInteractive mode) $
+ when (notNull orig_ways && isInterpretiveMode mode) $
do throwDyn (UsageError
"--interactive can't be used with -prof, -ticky, -unreg or -smp.")
stg_todo <- buildStgToDo
- -- set the "global" HscLang. The HscLang can be further adjusted on a module
+ -- set the "global" HscTarget. The HscTarget can be further adjusted on a module
-- by module basis, using only the -fvia-C and -fasm flags. If the global
- -- HscLang is not HscC or HscAsm, -fvia-C and -fasm have no effect.
+ -- HscTarget is not HscC or HscAsm, -fvia-C and -fasm have no effect.
let dflags0 = defaultDynFlags
let lang = case mode of
DoInteractive -> HscInterpreted
DoEval _ -> HscInterpreted
- _other -> hscLang dflags0
+ _other -> hscTarget dflags0
let dflags1 = dflags0{ stgToDo = stg_todo,
- hscLang = lang,
+ hscTarget = lang,
-- leave out hscOutName for now
hscOutName = panic "Main.main:hscOutName not set",
verbosity = case mode of
case mode of
DoMake -> doMake dflags srcs
-
- DoMkDependHS -> do { beginMkDependHS ;
- compileFiles mode dflags srcs;
- endMkDependHS dflags }
+ DoMkDependHS -> doMkDependHS dflags srcs
StopBefore p -> do { compileFiles mode dflags srcs; return () }
DoMkDLL -> do { o_files <- compileFiles mode dflags srcs;
doMkDLL dflags o_files link_pkgs }
-- -ohi sanity check
ohi <- readIORef v_Output_hi
if (isJust ohi &&
- (mode == DoMake || isInteractive mode || srcs `lengthExceeds` 1))
+ (isCompManagerMode mode || srcs `lengthExceeds` 1))
then throwDyn (UsageError "-ohi can only be used when compiling a single source file")
else do
-- -o sanity checking
o_file <- readIORef v_Output_file
- if (srcs `lengthExceeds` 1 && isJust o_file && mode /= DoLink && mode /= DoMkDLL)
+ if (srcs `lengthExceeds` 1 && isJust o_file && not (isLinkMode mode))
then throwDyn (UsageError "can't apply -o to multiple source files")
else do
- -- Check that there are some input files (except in the interactive
- -- case)
- if null srcs && null objs && not (isInteractive mode)
+ -- Check that there are some input files
+ -- (except in the interactive case)
+ if null srcs && null objs && not (isInterpretiveMode mode)
then throwDyn (UsageError "no input files")
else do
-- Verify that output files point somewhere sensible.
verifyOutputFiles
-isInteractive DoInteractive = True
-isInteractive (DoEval _) = True
-isInteractive _ = False
-
-- -----------------------------------------------------------------------------
-- Compile files in one-shot mode.
-> DynFlags
-> [String] -- Source files
-> IO [String] -- Object files
-compileFiles mode dflags srcs = do
- stop_flag <- readIORef v_GhcModeFlag
- mapM (compileFile mode dflags stop_flag) srcs
-
-
-compileFile mode dflags stop_flag src = do
- exists <- doesFileExist src
- when (not exists) $
- throwDyn (CmdLineError ("file `" ++ src ++ "' does not exist"))
-
- o_file <- readIORef v_Output_file
- -- when linking, the -o argument refers to the linker's output.
- -- otherwise, we use it as the name for the pipeline's output.
- let maybe_o_file
- | mode==DoLink || mode==DoMkDLL = Nothing
- | otherwise = o_file
-
- runPipeline mode dflags stop_flag True maybe_o_file src
- Nothing{-no ModLocation-}
+compileFiles mode dflags srcs = mapM (compileFile mode dflags) srcs
-- ----------------------------------------------------------------------------
-- Show the GHCi banner
# ifdef GHCI
- when (mode == DoInteractive && verb >= 1) $
+ when (isInteractiveMode mode && verb >= 1) $
hPutStrLn stdout ghciWelcomeMsg
# endif
--- /dev/null
+\begin{code}
+module Packages where
+data PackageState
+\end{code}
-- ---------------------------------------------------------------------------
{
-module Parser ( parseModule, parseStmt, parseIdentifier, parseIface, parseType,
+module Parser ( parseModule, parseStmt, parseIdentifier, parseType,
parseHeader ) where
#define INCLUDE #include
%name parseModule module
%name parseStmt maybe_stmt
%name parseIdentifier identifier
-%name parseIface iface
%name parseType ctype
%partial parseHeader header
%tokentype { Located Token }
| vocurly importdecls { $2 }
-----------------------------------------------------------------------------
--- Interfaces (.hi-boot files)
-
-iface :: { ModIface }
- : 'module' modid 'where' ifacebody { mkBootIface (unLoc $2) $4 }
-
-ifacebody :: { ([(Module, IsBootInterface)], [HsDecl RdrName]) }
- : '{' ifacetop '}' { $2 }
- | vocurly ifacetop close { $2 }
-
-ifacetop :: { ([(Module, IsBootInterface)], [HsDecl RdrName]) }
- : ifaceimps { ($1,[]) }
- | ifaceimps ';' ifacedecls { ($1,$3) }
- | ifacedecls { ([],$1) }
-
-ifaceimps :: { [(Module, IsBootInterface)] } -- Reversed, but that's ok
- : ifaceimps ';' ifaceimp { $3 : $1 }
- | ifaceimp { [$1] }
-
-ifaceimp :: { (Module, IsBootInterface) }
- : 'import' maybe_src modid { (unLoc $3, $2) }
-
--- The defn of iface decls allows a trailing ';', which the lexer geneates for
--- module Foo where
--- foo :: ()
-ifacedecls :: { [HsDecl RdrName] } -- Reversed, but doesn't matter
- : ifacedecls ';' ifacedecl { $3 : $1 }
- | ifacedecls ';' { $1 }
- | ifacedecl { [$1] }
-
-ifacedecl :: { HsDecl RdrName }
- : var '::' sigtype
- { SigD (Sig $1 $3) }
- | 'type' syn_hdr '=' ctype
- { let (tc,tvs) = $2 in TyClD (TySynonym tc tvs $4) }
- | 'data' tycl_hdr constrs -- No deriving in hi-boot
- { TyClD (mkTyData DataType $2 Nothing (reverse (unLoc $3)) Nothing) }
- | 'data' tycl_hdr 'where' gadt_constrlist
- { TyClD (mkTyData DataType $2 Nothing (reverse (unLoc $4)) Nothing) }
- | 'newtype' tycl_hdr -- Constructor is optional
- { TyClD (mkTyData NewType $2 Nothing [] Nothing) }
- | 'newtype' tycl_hdr '=' newconstr
- { TyClD (mkTyData NewType $2 Nothing [$4] Nothing) }
- | 'class' tycl_hdr fds
- { TyClD (mkClassDecl (unLoc $2) (unLoc $3) [] emptyBag) }
-
------------------------------------------------------------------------------
-- The Export List
maybeexports :: { Maybe [LIE RdrName] }
mkHsDo, mkHsSplice,
mkTyData, mkPrefixCon, mkRecCon,
mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
- mkBootIface,
cvBindGroup,
cvBindsAndSigs,
%************************************************************************
%* *
- Hi-boot files
-%* *
-%************************************************************************
-
-mkBootIface, and its deeply boring helper functions, have two purposes:
-
-a) HsSyn to IfaceSyn. The parser parses the former, but we're reading
- an hi-boot file, and interfaces consist of the latter
-
-b) Convert unqualifed names from the "current module" to qualified Orig
- names. E.g.
- module This where
- foo :: GHC.Base.Int -> GHC.Base.Int
- becomes
- This.foo :: GHC.Base.Int -> GHC.Base.Int
-
-It assumes that everything is well kinded, of course. Failure causes a
-fatal error using pgmError, rather than a monadic error. You're supposed
-to get hi-boot files right!
-
-
-\begin{code}
-mkBootIface :: Module -> ([(Module, IsBootInterface)], [HsDecl RdrName]) -> ModIface
--- Make the ModIface for a hi-boot file
--- The decls are of very limited form
--- The package will be filled in later (see LoadIface.readIface)
-mkBootIface mod (imports, decls)
- = (emptyModIface HomePackage{-fill in later-} mod) {
- mi_boot = True,
- mi_deps = noDependencies { dep_mods = imports },
- mi_exports = [(mod, map mk_export decls')],
- mi_decls = decls_w_vers,
- mi_ver_fn = mkIfaceVerCache decls_w_vers }
- where
- decls' = map hsIfaceDecl decls
- decls_w_vers = repeat initialVersion `zip` decls'
-
- -- hi-boot declarations don't (currently)
- -- expose constructors or class methods
- mk_export decl | isValOcc occ = Avail occ
- | otherwise = AvailTC occ [occ]
- where
- occ = ifName decl
-
-
-hsIfaceDecl :: HsDecl RdrName -> IfaceDecl
- -- Change to Iface syntax, and replace unqualified names with
- -- qualified Orig names from this module. Reason: normal
- -- iface files have everything fully qualified, so it's convenient
- -- for hi-boot files to look the same
- --
- -- NB: no constructors or class ops to worry about
-hsIfaceDecl (SigD (Sig name ty))
- = IfaceId { ifName = rdrNameOcc (unLoc name),
- ifType = hsIfaceLType ty,
- ifIdInfo = NoInfo }
-
-hsIfaceDecl (TyClD decl@(ClassDecl {}))
- = IfaceClass { ifName = rdrNameOcc (tcdName decl),
- ifTyVars = hsIfaceTvs (tcdTyVars decl),
- ifCtxt = hsIfaceCtxt (unLoc (tcdCtxt decl)),
- ifFDs = hsIfaceFDs (map unLoc (tcdFDs decl)),
- ifSigs = [], -- Is this right??
- ifRec = NonRecursive, ifVrcs = [] }
-
-hsIfaceDecl (TyClD decl@(TySynonym {}))
- = IfaceSyn { ifName = rdrNameOcc (tcdName decl),
- ifTyVars = hsIfaceTvs (tcdTyVars decl),
- ifSynRhs = hsIfaceLType (tcdSynRhs decl),
- ifVrcs = [] }
-
-hsIfaceDecl (TyClD decl@(TyData {}))
- = IfaceData { ifName = rdrNameOcc (tcdName decl),
- ifTyVars = tvs,
- ifCons = hsIfaceCons tvs decl,
- ifRec = Recursive, -- Hi-boot decls are always loop-breakers
- ifVrcs = [], ifGeneric = False }
- -- I'm not sure that [] is right for ifVrcs, but
- -- since we don't use them I'm not going to fiddle
- where
- tvs = hsIfaceTvs (tcdTyVars decl)
-
-hsIfaceDecl decl = pprPgmError "Illegal declaration in hi-boot file:" (ppr decl)
-
-hsIfaceCons :: [IfaceTvBndr] -> TyClDecl RdrName -> IfaceConDecls
-hsIfaceCons tvs decl@(TyData {tcdCtxt = L _ stupid_ctxt})
- | not (null stupid_ctxt) -- Keep it simple: no data type contexts
- -- Else we'll have to do "thinning"; sigh
- = pprPgmError "Can't do data type contexts in hi-boot file:" (ppr decl)
-
-hsIfaceCons tvs (TyData {tcdND = DataType, tcdCons = []})
- = -- data T a, meaning "constructors unspecified",
- IfAbstractTyCon -- not "no constructors"
-
-hsIfaceCons tvs (TyData {tcdND = DataType, tcdCons = cons})
- = IfDataTyCon Nothing (map (hsIfaceCon tvs . unLoc) cons)
-
-hsIfaceCons tvs (TyData {tcdND = NewType, tcdCons = [con]})
- = IfNewTyCon (hsIfaceCon tvs (unLoc con))
-
-hsIfaceCons tvs decl = pprPgmError "Illegal declaration in hi-boot file:" (ppr decl)
-
-
-hsIfaceCon :: [IfaceTvBndr] -> ConDecl RdrName -> IfaceConDecl
-hsIfaceCon tvs (ConDecl lname ex_tvs ex_ctxt details)
- | null ex_tvs && null (unLoc ex_ctxt)
- = IfVanillaCon { ifConOcc = get_occ lname,
- ifConInfix = is_infix,
- ifConArgTys = map hsIfaceLType args,
- ifConStricts = map (hsStrictMark . getBangStrictness) args,
- ifConFields = flds }
- | null flds
- = IfGadtCon { ifConOcc = get_occ lname,
- ifConTyVars = tvs ++ hsIfaceTvs ex_tvs,
- ifConCtxt = hsIfaceCtxt (unLoc ex_ctxt),
- ifConArgTys = map hsIfaceLType args,
- ifConResTys = map (IfaceTyVar . fst) tvs,
- ifConStricts = map (hsStrictMark . getBangStrictness) args }
- | otherwise = pprPgmError "Fields illegal in existential" (ppr (unLoc lname))
- where
- (is_infix, args, flds) = case details of
- PrefixCon args -> (False, args, [])
- InfixCon a1 a2 -> (True, [a1,a2], [])
- RecCon fs -> (False, map snd fs, map (get_occ . fst) fs)
- get_occ lname = rdrNameOcc (unLoc lname)
-
-hsIfaceCon _tvs (GadtDecl lname con_ty) -- Not yet
- = pprPgmError "Can't use GADTs in hi-boot files (yet)" (ppr (unLoc lname))
-
-hsStrictMark :: HsBang -> StrictnessMark
--- Warning: in source files the {-# UNPACK #-} pragma (HsUnbox) is a request
--- but in an hi-boot file it's interpreted as the Truth!
-hsStrictMark HsNoBang = NotMarkedStrict
-hsStrictMark HsStrict = MarkedStrict
-hsStrictMark HsUnbox = MarkedUnboxed
-
-hsIfaceName rdr_name -- Qualify unqualifed occurrences
- -- with the module name
- | isUnqual rdr_name = LocalTop (rdrNameOcc rdr_name)
- | otherwise = ExtPkg (rdrNameModule rdr_name) (rdrNameOcc rdr_name)
-
-hsIfaceLType :: LHsType RdrName -> IfaceType
-hsIfaceLType = hsIfaceType . unLoc
-
-hsIfaceType :: HsType RdrName -> IfaceType
-hsIfaceType (HsForAllTy exp tvs cxt ty)
- = foldr (IfaceForAllTy . hsIfaceTv) rho tvs'
- where
- rho = foldr (IfaceFunTy . IfacePredTy . hsIfaceLPred) tau (unLoc cxt)
- tau = hsIfaceLType ty
- tvs' = case exp of
- Explicit -> map unLoc tvs
- Implicit -> map (UserTyVar . unLoc) (extractHsRhoRdrTyVars cxt ty)
-
-hsIfaceType ty@(HsTyVar _) = hs_tc_app ty []
-hsIfaceType ty@(HsAppTy t1 t2) = hs_tc_app ty []
-hsIfaceType (HsFunTy t1 t2) = IfaceFunTy (hsIfaceLType t1) (hsIfaceLType t2)
-hsIfaceType (HsListTy t) = IfaceTyConApp IfaceListTc [hsIfaceLType t]
-hsIfaceType (HsPArrTy t) = IfaceTyConApp IfacePArrTc [hsIfaceLType t]
-hsIfaceType (HsTupleTy bx ts) = IfaceTyConApp (IfaceTupTc bx (length ts)) (hsIfaceLTypes ts)
-hsIfaceType (HsOpTy t1 tc t2) = hs_tc_app (HsTyVar (unLoc tc)) (hsIfaceLTypes [t1, t2])
-hsIfaceType (HsParTy t) = hsIfaceLType t
-hsIfaceType (HsBangTy _ t) = hsIfaceLType t
-hsIfaceType (HsPredTy p) = IfacePredTy (hsIfacePred p)
-hsIfaceType (HsKindSig t _) = hsIfaceLType t
-hsIfaceType ty = pprPanic "hsIfaceType" (ppr ty)
- -- HsNumTy, HsSpliceTy
-
------------
-hsIfaceLTypes tys = map (hsIfaceType.unLoc) tys
-
------------
-hsIfaceCtxt :: [LHsPred RdrName] -> [IfacePredType]
-hsIfaceCtxt ctxt = map hsIfaceLPred ctxt
-
------------
-hsIfaceLPred :: LHsPred RdrName -> IfacePredType
-hsIfaceLPred = hsIfacePred . unLoc
-
-hsIfacePred :: HsPred RdrName -> IfacePredType
-hsIfacePred (HsClassP cls ts) = IfaceClassP (hsIfaceName cls) (hsIfaceLTypes ts)
-hsIfacePred (HsIParam ip t) = IfaceIParam (mapIPName rdrNameOcc ip) (hsIfaceLType t)
-
------------
-hs_tc_app :: HsType RdrName -> [IfaceType] -> IfaceType
-hs_tc_app (HsAppTy t1 t2) args = hs_tc_app (unLoc t1) (hsIfaceLType t2 : args)
-hs_tc_app (HsTyVar n) args
- | isTcOcc (rdrNameOcc n) = IfaceTyConApp (IfaceTc (hsIfaceName n)) args
- | otherwise = foldl IfaceAppTy (IfaceTyVar (rdrNameOcc n)) args
-hs_tc_app ty args = foldl IfaceAppTy (hsIfaceType ty) args
-
------------
-hsIfaceTvs :: [LHsTyVarBndr RdrName] -> [IfaceTvBndr]
-hsIfaceTvs tvs = map (hsIfaceTv.unLoc) tvs
-
------------
-hsIfaceTv (UserTyVar n) = (rdrNameOcc n, liftedTypeKind)
-hsIfaceTv (KindedTyVar n k) = (rdrNameOcc n, k)
-
------------
-hsIfaceFDs :: [([RdrName], [RdrName])] -> [([OccName], [OccName])]
-hsIfaceFDs fds = [ (map rdrNameOcc xs, map rdrNameOcc ys)
- | (xs,ys) <- fds ]
-\end{code}
-
-%************************************************************************
-%* *
\subsection[cvBinds-etc]{Converting to @HsBinds@, etc.}
%* *
%************************************************************************
-- the top level scope resolution does that
rnTopBinds mbinds sigs
- = bindPatSigTyVars (collectSigTysFromHsBinds (bagToList mbinds)) $ \ _ ->
- -- Hmm; by analogy with Ids, this doesn't look right
- -- Top-level bound type vars should really scope over
- -- everything, but we only scope them over the other bindings
-
- rnBinds TopLevel mbinds sigs
+ = do { is_boot <- tcIsHsBoot
+ ; if is_boot then
+ rnHsBoot mbinds sigs
+ else bindPatSigTyVars (collectSigTysFromHsBinds (bagToList mbinds)) $ \ _ ->
+ -- Hmm; by analogy with Ids, this doesn't look right
+ -- Top-level bound type vars should really scope over
+ -- everything, but we only scope them over the other bindings
+ rnBinds TopLevel mbinds sigs }
+
+rnHsBoot :: LHsBinds RdrName
+ -> [LSig RdrName]
+ -> RnM ([HsBindGroup Name], DefUses)
+-- A hs-boot file has no bindings.
+-- Return a single HsBindGroup with empty binds and renamed signatures
+rnHsBoot mbinds sigs
+ = do { checkErr (isEmptyLHsBinds mbinds) (bindsInHsBootFile mbinds)
+ ; sigs' <- renameSigs sigs
+ ; return ([HsBindGroup emptyLHsBinds sigs' NonRecursive],
+ usesOnly (hsSigsFVs sigs')) }
\end{code}
-- Doesn't seem worth much trouble to sort this.
renameSigs :: [LSig RdrName] -> RnM [LSig Name]
-renameSigs sigs = mappM (wrapLocM renameSig) (filter (not . isFixitySig . unLoc) sigs)
+renameSigs sigs = mappM (wrapLocM renameSig) (filter (not . isFixityLSig) sigs)
-- Remove fixity sigs which have been dealt with already
renameSig :: Sig RdrName -> RnM (Sig Name)
methodBindErr mbind
= hang (ptext SLIT("Pattern bindings (except simple variables) not allowed in instance declarations"))
- 4 (ppr mbind)
+ 2 (ppr mbind)
+
+bindsInHsBootFile mbinds
+ = hang (ptext SLIT("Bindings in hs-boot files are not allowed"))
+ 2 (ppr mbinds)
\end{code}
returnM (RecordCon conname rbinds', fvRbinds `addOneFV` unLoc conname)
rnExpr (RecordUpd expr rbinds)
- = rnLExpr expr `thenM` \ (expr', fvExpr) ->
+ = rnLExpr expr `thenM` \ (expr', fvExpr) ->
rnRbinds "update" rbinds `thenM` \ (rbinds', fvRbinds) ->
returnM (RecordUpd expr' rbinds', fvExpr `plusFV` fvRbinds)
rnExpr (ExprWithTySig expr pty)
- = rnLExpr expr `thenM` \ (expr', fvExpr) ->
+ = rnLExpr expr `thenM` \ (expr', fvExpr) ->
rnHsTypeFVs doc pty `thenM` \ (pty', fvTy) ->
returnM (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy)
where
import CmdLineOpts ( DynFlag(..) )
import HsSyn ( IE(..), ieName, ImportDecl(..), LImportDecl,
- ForeignDecl(..), HsGroup(..),
- collectGroupBinders, tyClDeclNames
+ ForeignDecl(..), HsGroup(..), HsBindGroup(..),
+ Sig(..), collectGroupBinders, tyClDeclNames
)
import RnEnv
import IfaceEnv ( lookupOrig, newGlobalBinder )
-- an export indicator because they are all implicitly exported.
mappM new_tc tycl_decls `thenM` \ tc_avails ->
- mappM new_simple (for_hs_bndrs ++ val_hs_bndrs) `thenM` \ simple_avails ->
- returnM (tc_avails ++ simple_avails)
+
+ -- In a hs-boot file, the value binders come from the
+ -- *signatures*, and there should be no foreign binders
+ tcIsHsBoot `thenM` \ is_hs_boot ->
+ let val_bndrs | is_hs_boot = sig_hs_bndrs
+ | otherwise = for_hs_bndrs ++ val_hs_bndrs
+ in
+ mappM new_simple val_bndrs `thenM` \ names ->
+
+ returnM (tc_avails ++ map Avail names)
where
- new_simple rdr_name = newTopSrcBinder mod Nothing rdr_name `thenM` \ name ->
- returnM (Avail name)
+ new_simple rdr_name = newTopSrcBinder mod Nothing rdr_name
+ sig_hs_bndrs = [nm | HsBindGroup _ lsigs _ <- val_decls,
+ L _ (Sig nm _) <- lsigs]
val_hs_bndrs = collectGroupBinders val_decls
for_hs_bndrs = [nm | L _ (ForeignImport nm _ _ _) <- foreign_decls]
import Outputable
import SrcLoc ( Located(..), unLoc, getLoc, noLoc )
import CmdLineOpts ( DynFlag(..) )
- -- Warn of unused for-all'd tyvars
+import DriverPhases ( isHsBoot )
import Maybes ( seqMaybe )
import Maybe ( catMaybes, isNothing )
\end{code}
\begin{code}
rnConDecls :: Name -> [LConDecl RdrName] -> RnM [LConDecl Name]
rnConDecls tycon condecls
- = -- Check that there's at least one condecl,
- -- or else we're reading an interface file, or -fglasgow-exts
- (if null condecls then
- doptM Opt_GlasgowExts `thenM` \ glaExts ->
- checkErr glaExts (emptyConDeclsErr tycon)
- else returnM ()
- ) `thenM_`
- mappM (wrapLocM rnConDecl) condecls
+ = mappM (wrapLocM rnConDecl) condecls
rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name)
rnConDecl (ConDecl name tvs cxt details)
badDataCon name
= hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
-
-emptyConDeclsErr tycon
- = sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"),
- nest 4 (ptext SLIT("(-fglasgow-exts permits this)"))]
\end{code}
--- /dev/null
+\begin{code}
+module RnSource where
+import HsSyn ( HsBindGroup, HsGroup, HsSplice )
+import NameSet ( FreeVars, DefUses )
+import TcRnTypes ( RnM, TcGblEnv )
+import RdrName ( RdrName )
+import Name ( Name )
+
+rnBindGroupsAndThen :: forall b . [HsBindGroup RdrName]
+ -> ([HsBindGroup Name]
+ -> RnM (b, FreeVars))
+ -> RnM (b, FreeVars)
+
+rnBindGroups :: [HsBindGroup RdrName] -> RnM ([HsBindGroup Name], DefUses)
+
+rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name)
+rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars)
+\end{code}
+
+
\section[TcBinds]{TcBinds}
\begin{code}
-module TcBinds ( tcBindsAndThen, tcTopBinds, tcMonoBinds, tcSpecSigs ) where
+module TcBinds ( tcBindsAndThen, tcTopBinds, tcHsBootSigs, tcMonoBinds, tcSpecSigs ) where
#include "HsVersions.h"
import CmdLineOpts ( DynFlag(Opt_MonomorphismRestriction) )
import HsSyn ( HsExpr(..), HsBind(..), LHsBinds, Sig(..),
LSig, Match(..), HsBindGroup(..), IPBind(..),
- HsType(..), hsLTyVarNames,
+ HsType(..), hsLTyVarNames, isVanillaLSig,
LPat, GRHSs, MatchGroup(..), emptyLHsBinds, isEmptyLHsBinds,
collectHsBindBinders, collectPatBinders, pprPatBind
)
-- want. The bit we care about is the local bindings
-- and the free type variables thereof
tcTopBinds binds
- = tc_binds_and_then TopLevel glue binds $
- getLclEnv `thenM` \ env ->
- returnM (emptyLHsBinds, env)
+ = tc_binds_and_then TopLevel glue binds $
+ do { env <- getLclEnv
+ ; return (emptyLHsBinds, env) }
where
-- The top level bindings are flattened into a giant
-- implicitly-mutually-recursive MonoBinds
glue (HsBindGroup binds1 _ _) (binds2, env) = (binds1 `unionBags` binds2, env)
+ glue (HsIPBinds _) _ = panic "Top-level HsIpBinds"
-- Can't have a HsIPBinds at top level
+tcHsBootSigs :: [HsBindGroup Name] -> TcM (LHsBinds TcId, TcLclEnv)
+-- A hs-boot file has only one BindGroup, and it only has type
+-- signatures in it. The renamer checked all this
+tcHsBootSigs [HsBindGroup _ sigs _]
+ = do { ids <- mapM (addLocM tc_sig) (filter isVanillaLSig sigs)
+ ; tcExtendIdEnv ids $ do
+ { env <- getLclEnv
+ ; return (emptyLHsBinds, env) }}
+ where
+ tc_sig (Sig (L _ name) ty)
+ = do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty
+ ; return (mkLocalId name sigma_ty) }
tcBindsAndThen
:: (HsBindGroup TcId -> thing -> thing) -- Combinator
tcBindWithSigs top_lvl mbind sigs is_rec = do
{ -- TYPECHECK THE SIGNATURES
tc_ty_sigs <- recoverM (returnM []) $
- tcTySigs [sig | sig@(L _(Sig name _)) <- sigs]
+ tcTySigs (filter isVanillaLSig sigs)
; let lookup_sig = lookupSig tc_ty_sigs
-- SET UP THE MAIN RECOVERY; take advantage of any type sigs
-- default methods. Better to make separate AbsBinds for each
let
(tyvars, _, _, op_items) = classBigSig clas
- prags = filter (isPragSig.unLoc) sigs
+ prags = filter isPragLSig sigs
tc_dm = tcDefMeth clas tyvars default_binds prags
dm_sel_ids = [sel_id | (sel_id, DefMeth) <- op_items]
-- Add the newtype-derived instances to the inst env
-- before tacking the "ordinary" ones
+ ; let inst_info = newtype_inst_info ++ ordinary_inst_info
+
+ -- If we are compiling a hs-boot file,
+ -- don't generate any derived bindings
+ ; is_boot <- tcIsHsBoot
+ ; if is_boot then
+ return (inst_info, [])
+ else do
+ {
+
-- Generate the generic to/from functions from each type declaration
; gen_binds <- mkGenericBinds tycl_decls
- ; let inst_info = newtype_inst_info ++ ordinary_inst_info
-- Rename these extra bindings, discarding warnings about unused bindings etc
-- Set -fglasgow exts so that we can have type signatures in patterns,
(ddump_deriving inst_info rn_binds))
; returnM (inst_info, rn_binds)
- }
+ }}
where
ddump_deriving :: [InstInfo] -> [HsBindGroup Name] -> SDoc
ddump_deriving inst_infos extra_binds
tcMonoExpr ::
HsExpr.LHsExpr Name.Name
- -> TcUnify.Expected TcType.TcType
+ -> TcType.Expected TcType.TcType
-> TcRnTypes.TcM (HsExpr.LHsExpr Var.Id)
--- /dev/null
+\begin{code}
+module TcExpr where
+import HsSyn ( LHsExpr )
+import Name ( Name )
+import Var ( Id )
+import TcType ( TcType, Expected )
+import TcRnTypes( TcM )
+
+tcCheckSigma ::
+ LHsExpr Name
+ -> TcType
+ -> TcM (LHsExpr Id)
+
+tcCheckRho ::
+ LHsExpr Name
+ -> TcType
+ -> TcM (LHsExpr Id)
+
+tcInferRho ::
+ LHsExpr Name
+ -> TcM (LHsExpr Id, TcType)
+
+tcMonoExpr ::
+ LHsExpr Name
+ -> Expected TcType
+ -> TcM (LHsExpr Id)
+\end{code}
CLabelString, isCLabelString,
isDynamicTarget, withDNTypes, DNKind(..), DNCallSpec(..) )
import PrelNames ( hasKey, ioTyConKey )
-import CmdLineOpts ( dopt_HscLang, HscLang(..) )
+import CmdLineOpts ( dopt_HscTarget, HscTarget(..) )
import Outputable
import SrcLoc ( Located(..), srcSpanStart )
import Bag ( consBag )
checkCg check
= getDOpts `thenM` \ dflags ->
- let hscLang = dopt_HscLang dflags in
- case hscLang of
+ let hscTarget = dopt_HscTarget dflags in
+ case hscTarget of
HscNothing -> returnM ()
otherwise ->
- case check hscLang of
+ case check hscTarget of
Nothing -> returnM ()
Just err -> addErrTc (text "Illegal foreign declaration:" <+> err)
\end{code}
; ty <- tcHsKindedType kinded_ty
; checkValidType ctxt ty
; returnM ty }
+
-- Used for the deriving(...) items
tcHsDeriv :: LHsType Name -> TcM ([TyVar], Class, [Type])
tcHsDeriv = addLocM (tc_hs_deriv [])
module TcMatches where
tcGRHSsPat :: HsExpr.GRHSs Name.Name
- -> TcUnify.Expected TcType.TcType
+ -> TcType.Expected TcType.TcType
-> TcRnTypes.TcM (HsExpr.GRHSs Var.Id)
tcMatchesFun :: Name.Name
-> HsExpr.MatchGroup Name.Name
- -> TcUnify.Expected TcType.TcType
+ -> TcType.Expected TcType.TcType
-> TcRnTypes.TcM (HsExpr.MatchGroup Var.Id)
--- /dev/null
+\begin{code}
+module TcMatches where
+import HsSyn ( GRHSs, MatchGroup )
+import Name ( Name )
+import Var ( Id )
+import TcType ( TcType, Expected )
+import TcRnTypes( TcM )
+
+tcGRHSsPat :: GRHSs Name
+ -> Expected TcType
+ -> TcM (GRHSs Id)
+
+tcMatchesFun :: Name
+ -> MatchGroup Name
+ -> Expected TcType
+ -> TcM (MatchGroup Id)
+\end{code}
-s%
+%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[TcModule]{Typechecking a whole module}
import TcType ( tidyTopType, tcEqType, mkTyVarTys, substTyWith )
import Inst ( showLIE )
import InstEnv ( extendInstEnvList )
-import TcBinds ( tcTopBinds )
+import TcBinds ( tcTopBinds, tcHsBootSigs )
import TcDefaults ( tcDefaults )
import TcEnv ( tcExtendGlobalValEnv )
import TcRules ( tcRules )
import ErrUtils ( Messages, mkDumpDoc, showPass )
import Id ( mkExportedLocalId, isLocalId, idName, idType )
import Var ( Var )
+import VarEnv ( varEnvElts )
import Module ( Module, ModuleEnv, mkModule, moduleEnvElts )
import OccName ( mkVarOcc )
-import Name ( Name, isExternalName, getSrcLoc, getOccName )
+import Name ( Name, isExternalName, getSrcLoc, getOccName, isWiredInName )
import NameSet
import TyCon ( tyConHasGenerics, isSynTyCon, getSynTyConDefn, tyConKind )
import SrcLoc ( srcLocSpan, Located(..), noLoc )
-import Outputable
+import DriverPhases ( HscSource(..), isHsBoot )
import HscTypes ( ModGuts(..), HscEnv(..), ExternalPackageState(..),
GhciMode(..), IsBootInterface, noDependencies,
Deprecs( NoDeprecs ), plusDeprecs,
ForeignStubs(NoStubs), TyThing(..),
- TypeEnv, lookupTypeEnv, hptInstances,
+ TypeEnv, lookupTypeEnv, hptInstances, lookupType,
extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons,
emptyFixityEnv
)
+import Outputable
+
#ifdef GHCI
import HsSyn ( HsStmtContext(..), Stmt(..), HsExpr(..), HsBindGroup(..),
LStmt, LHsExpr, LHsType, mkMatchGroup,
import TcEnv ( tcLookupTyCon, tcLookupId, tcLookupGlobal )
import RnTypes ( rnLHsType )
import Inst ( tcStdSyntaxName, tcGetInstEnvs )
-import InstEnv ( DFunId, classInstances, instEnvElts )
+import InstEnv ( classInstances, instEnvElts )
import RnExpr ( rnStmts, rnLExpr )
import RnNames ( exportsToAvails )
-import LoadIface ( loadSrcInterface )
+import LoadIface ( loadSrcInterface, ifaceInstGates )
import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..),
IfaceExtName(..), IfaceConDecls(..), IfaceInst(..),
tyThingToIfaceDecl, dfunToIfaceInst )
+import IfaceType ( IfaceTyCon(..), ifPrintUnqual )
import IfaceEnv ( lookupOrig )
import RnEnv ( lookupOccRn, dataTcOccs, lookupFixityRn )
import Id ( Id, isImplicitId, setIdType, globalIdDetails )
import Name ( nameOccName, nameModule )
import NameEnv ( delListFromNameEnv )
import PrelNames ( iNTERACTIVE, ioTyConName, printName, monadNames, itName, returnIOName )
-import Module ( Module, lookupModuleEnv )
+import Module ( lookupModuleEnv )
import HscTypes ( InteractiveContext(..), HomeModInfo(..), typeEnvElts, typeEnvClasses,
- availNames, availName, ModIface(..),
+ availNames, availName, ModIface(..), icPrintUnqual,
ModDetails(..), Dependencies(..) )
import BasicTypes ( RecFlag(..), Fixity )
import Bag ( unitBag )
\begin{code}
tcRnModule :: HscEnv
+ -> HscSource
-> Located (HsModule RdrName)
-> IO (Messages, Maybe TcGblEnv)
-tcRnModule hsc_env (L loc (HsModule maybe_mod export_ies
+tcRnModule hsc_env hsc_src (L loc (HsModule maybe_mod export_ies
import_decls local_decls mod_deprec))
= do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
let { this_mod = case maybe_mod of
- Nothing -> mAIN
- -- 'module M where' is omitted
- Just (L _ mod) -> mod } ;
- -- The normal case
+ Nothing -> mAIN -- 'module M where' is omitted
+ Just (L _ mod) -> mod } ; -- The normal case
- initTc hsc_env this_mod $
+ initTc hsc_env hsc_src this_mod $
setSrcSpan loc $
do {
checkForPackageModule (hsc_dflags hsc_env) this_mod;
traceRn (text "rn1a") ;
-- Rename and type check the declarations
- tcg_env <- tcRnSrcDecls local_decls ;
+ tcg_env <- if isHsBoot hsc_src then
+ tcRnHsBootDecls local_decls
+ else
+ tcRnSrcDecls local_decls ;
setGblEnv tcg_env $ do {
traceRn (text "rn3") ;
-- The decls are IfaceDecls; all names are original names
= do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
- initTc hsc_env this_mod $ do {
+ initTc hsc_env ExtCoreFile this_mod $ do {
let { ldecls = map noLoc decls } ;
final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ;
mod_guts = ModGuts { mg_module = this_mod,
+ mg_boot = False,
mg_usages = [], -- ToDo: compute usage
mg_dir_imps = [], -- ??
mg_deps = noDependencies, -- ??
%************************************************************************
%* *
- Comparing the hi-boot interface with the real thing
+ Compiling hs-boot source files, and
+ comparing the hi-boot interface with the real thing
%* *
%************************************************************************
+\begin{code}
+tcRnHsBootDecls :: [LHsDecl RdrName] -> TcM TcGblEnv
+tcRnHsBootDecls decls
+ = do { let { (first_group, group_tail) = findSplice decls }
+
+ ; case group_tail of
+ Just stuff -> spliceInHsBootErr stuff
+ Nothing -> return ()
+
+ -- Rename the declarations
+ ; (tcg_env, rn_group) <- rnTopSrcDecls first_group
+ ; setGblEnv tcg_env $ do {
+
+ -- Todo: check no foreign decls, no rules, no default decls
+
+ -- Typecheck type/class decls
+ ; traceTc (text "Tc2")
+ ; let tycl_decls = hs_tyclds rn_group
+ ; tcg_env <- checkNoErrs (tcTyAndClassDecls [{- no boot_names -}] tycl_decls)
+ ; setGblEnv tcg_env $ do {
+
+ -- Typecheck instance decls
+ ; traceTc (text "Tc3")
+ ; (tcg_env, inst_infos, _binds) <- tcInstDecls1 tycl_decls (hs_instds rn_group)
+ ; setGblEnv tcg_env $ do {
+
+ -- Typecheck value declarations
+ ; traceTc (text "Tc5")
+ ; (tc_val_binds, lcl_env) <- tcHsBootSigs (hs_valds rn_group)
+
+ -- Wrap up
+ -- No simplification or zonking to do
+ ; traceTc (text "Tc7a")
+ ; gbl_env <- getGblEnv
+
+ ; let { new_ids = [ id | ATcId id _ _ <- varEnvElts (tcl_env lcl_env) ]
+ ; final_type_env = extendTypeEnvWithIds (tcg_type_env gbl_env) new_ids }
+
+ ; return (gbl_env { tcg_type_env = final_type_env })
+ }}}}
+
+spliceInHsBootErr (SpliceDecl (L loc _), _)
+ = addErrAt loc (ptext SLIT("Splices are not allowed in hs-boot files"))
+\end{code}
+
In both one-shot mode and GHCi mode, hi-boot interfaces are demand-loaded
into the External Package Table. Once we've typechecked the body of the
module, we want to compare what we've found (gathered in a TypeEnv) with
----------------
check_one local_env name
- = do { eps <- getEps
+ | isWiredInName name -- No checking for wired-in names. In particular, 'error'
+ = return () -- is handled by a rather gross hack (see comments in GHC.Err.hs-boot)
+ | otherwise
+ = do { (eps,hpt) <- getEpsAndHpt
-- Look up the hi-boot one;
-- it should jolly well be there (else GHC bug)
- ; case lookupTypeEnv (eps_PTE eps) name of {
+ ; case lookupType hpt (eps_PTE eps) name of {
Nothing -> pprPanic "checkHiBootIface" (ppr name) ;
Just boot_thing ->
----------------
missingBootThing thing
- = ppr thing <+> ptext SLIT("is defined in the hi-boot file, but not in the module")
+ = ppr thing <+> ptext SLIT("is defined in the hs-boot file, but not in the module")
bootMisMatch thing
- = ppr thing <+> ptext SLIT("has conflicting definitions in the module and its hi-boot file")
+ = ppr thing <+> ptext SLIT("has conflicting definitions in the module and its hs-boot file")
\end{code}
\begin{code}
#ifdef GHCI
-setInteractiveContext :: InteractiveContext -> TcRn a -> TcRn a
-setInteractiveContext icxt thing_inside
- = traceTc (text "setIC" <+> ppr (ic_type_env icxt)) `thenM_`
- (updGblEnv (\env -> env {tcg_rdr_env = ic_rn_gbl_env icxt,
- tcg_type_env = ic_type_env icxt}) $
- updLclEnv (\env -> env {tcl_rdr = ic_rn_local_env icxt}) $
- thing_inside)
+setInteractiveContext :: HscEnv -> InteractiveContext -> TcRn a -> TcRn a
+setInteractiveContext hsc_env icxt thing_inside
+ = let
+ root_modules :: [(Module, IsBootInterface)]
+ root_modules = [(mkModule m, False) | m <- ic_toplev_scope icxt]
+ dfuns = hptInstances hsc_env root_modules
+ in
+ updGblEnv (\env -> env {
+ tcg_rdr_env = ic_rn_gbl_env icxt,
+ tcg_type_env = ic_type_env icxt,
+ tcg_inst_env = extendInstEnvList (tcg_inst_env env) dfuns }) $
+
+ updLclEnv (\env -> env { tcl_rdr = ic_rn_local_env icxt }) $
+
+ do { traceTc (text "setIC" <+> ppr (ic_type_env icxt))
+ ; thing_inside }
\end{code}
tcRnStmt hsc_env ictxt rdr_stmt
= initTcPrintErrors hsc_env iNTERACTIVE $
- setInteractiveContext ictxt $ do {
+ setInteractiveContext hsc_env ictxt $ do {
-- Rename; use CmdLineMode because tcRnStmt is only used interactively
([rn_stmt], fvs) <- rnStmts DoExpr [rdr_stmt] ;
-> IO (Maybe Type)
tcRnExpr hsc_env ictxt rdr_expr
= initTcPrintErrors hsc_env iNTERACTIVE $
- setInteractiveContext ictxt $ do {
+ setInteractiveContext hsc_env ictxt $ do {
(rn_expr, fvs) <- rnLExpr rdr_expr ;
failIfErrsM ;
-> IO (Maybe Kind)
tcRnType hsc_env ictxt rdr_type
= initTcPrintErrors hsc_env iNTERACTIVE $
- setInteractiveContext ictxt $ do {
+ setInteractiveContext hsc_env ictxt $ do {
rn_type <- rnLHsType doc rdr_type ;
failIfErrsM ;
-- hence the call to dataTcOccs, and we return up to two results
tcRnGetInfo hsc_env ictxt rdr_name
= initTcPrintErrors hsc_env iNTERACTIVE $
- setInteractiveContext ictxt $ do {
+ setInteractiveContext hsc_env ictxt $ do {
-- If the identifier is a constructor (begins with an
-- upper-case letter), then we need to consider both
-- And lookup up the entities, avoiding duplicates, which arise
-- because constructors and record selectors are represented by
-- their parent declaration
- let { do_one name = do { thing <- tcLookupGlobal name
- ; let decl = toIfaceDecl thing
+ let { do_one name = do { thing <- tcLookupGlobal name
; fixity <- lookupFixityRn name
- ; insts <- lookupInsts thing
- ; return (decl, fixity, getSrcLoc thing,
- map mk_inst insts) } ;
+ ; insts <- lookupInsts print_unqual thing
+ ; return (toIfaceDecl thing, fixity,
+ getSrcLoc thing, insts) } } ;
-- For the SrcLoc, the 'thing' has better info than
-- the 'name' because getting the former forced the
-- declaration to be loaded into the cache
- mk_inst dfun = (dfunToIfaceInst dfun, getSrcLoc dfun) ;
- cmp (d1,_,_,_) (d2,_,_,_) = ifName d1 `compare` ifName d2 } ;
+
results <- mapM do_one good_names ;
return (fst (removeDups cmp results))
}
+ where
+ cmp (d1,_,_,_) (d2,_,_,_) = ifName d1 `compare` ifName d2
+
+ print_unqual :: PrintUnqualified
+ print_unqual = icPrintUnqual ictxt
-lookupInsts :: TyThing -> TcM [DFunId]
-lookupInsts (AClass cls)
+
+lookupInsts :: PrintUnqualified -> TyThing -> TcM [(IfaceInst, SrcLoc)]
+-- Filter the instances by the ones whose tycons (or clases resp)
+-- are in scope unqualified. Otherwise we list a whole lot too many!
+lookupInsts print_unqual (AClass cls)
= do { loadImportedInsts cls [] -- [] means load all instances for cls
; inst_envs <- tcGetInstEnvs
- ; return [df | (_,_,df) <- classInstances inst_envs cls] }
+ ; return [ (inst, getSrcLoc dfun)
+ | (_,_,dfun) <- classInstances inst_envs cls
+ , let inst = dfunToIfaceInst dfun
+ (_, tycons) = ifaceInstGates (ifInstHead inst)
+ , all print_tycon_unqual tycons ] }
+ where
+ print_tycon_unqual (IfaceTc ext_nm) = ifPrintUnqual print_unqual ext_nm
+ print_tycon_unqual other = True -- Int etc
+
-lookupInsts (ATyCon tc)
+lookupInsts print_unqual (ATyCon tc)
= do { eps <- getEps -- Load all instances for all classes that are
-- in the type environment (which are all the ones
- -- we've seen in any interface file so far
+ -- we've seen in any interface file so far)
; mapM_ (\c -> loadImportedInsts c [])
(typeEnvClasses (eps_PTE eps))
; (pkg_ie, home_ie) <- tcGetInstEnvs -- Search all
- ; return (get home_ie ++ get pkg_ie) }
+ ; return [ (inst, getSrcLoc dfun)
+ | (_, _, dfun) <- instEnvElts home_ie ++ instEnvElts pkg_ie
+ , relevant dfun
+ , let inst = dfunToIfaceInst dfun
+ (cls, _) = ifaceInstGates (ifInstHead inst)
+ , ifPrintUnqual print_unqual cls ] }
where
- get ie = [df | (_,_,df) <- instEnvElts ie, relevant df]
relevant df = tc_name `elemNameSet` tyClsNamesOfDFunHead (idType df)
- tc_name = tyConName tc
+ tc_name = tyConName tc
-lookupInsts other = return []
+lookupInsts print_unqual other = return []
toIfaceDecl :: TyThing -> IfaceDecl
where
ext_nm n = ExtPkg (nameModule n) (nameOccName n)
- -- munge transforms a thing to it's "parent" thing
+ -- munge transforms a thing to its "parent" thing
munge (ADataCon dc) = ATyCon (dataConTyCon dc)
munge (AnId id) = case globalIdDetails id of
RecordSelId tc lbl -> ATyCon tc
import HsSyn ( emptyLHsBinds )
import HscTypes ( HscEnv(..), ModGuts(..), ModIface(..),
- TyThing, TypeEnv, emptyTypeEnv,
+ TyThing, TypeEnv, emptyTypeEnv, HscSource(..), isHsBoot,
ExternalPackageState(..), HomePackageTable,
- Deprecs(..), FixityEnv, FixItem,
+ Deprecs(..), FixityEnv, FixItem,
GhciMode, lookupType, unQualInScope )
import Module ( Module, unitModuleEnv )
import RdrName ( GlobalRdrEnv, emptyGlobalRdrEnv,
\begin{code}
initTc :: HscEnv
+ -> HscSource
-> Module
-> TcM r
-> IO (Messages, Maybe r)
-- Nothing => error thrown by the thing inside
-- (error messages should have been printed already)
-initTc hsc_env mod do_this
+initTc hsc_env hsc_src mod do_this
= do { errs_var <- newIORef (emptyBag, emptyBag) ;
tvs_var <- newIORef emptyVarSet ;
type_env_var <- newIORef emptyNameEnv ;
let {
gbl_env = TcGblEnv {
tcg_mod = mod,
+ tcg_src = hsc_src,
tcg_rdr_env = emptyGlobalRdrEnv,
tcg_fix_env = emptyNameEnv,
tcg_default = Nothing,
-- list, and there are no bindings in M, we don't bleat
-- "unknown module M".
-initTcPrintErrors
+initTcPrintErrors -- Used from the interactive loop only
:: HscEnv
-> Module
-> TcM r
-> IO (Maybe r)
initTcPrintErrors env mod todo = do
- (msgs, res) <- initTc env mod todo
+ (msgs, res) <- initTc env HsSrcFile mod todo
printErrorsAndWarnings msgs
return res
getModule :: TcRn Module
getModule = do { env <- getGblEnv; return (tcg_mod env) }
+tcIsHsBoot :: TcRn Bool
+tcIsHsBoot = do { env <- getGblEnv; return (isHsBoot (tcg_src env)) }
+
getGlobalRdrEnv :: TcRn GlobalRdrEnv
getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) }
ArithSeqInfo, DictBinds, LHsBinds )
import HscTypes ( FixityEnv,
HscEnv, TypeEnv, TyThing,
- GenAvailInfo(..), AvailInfo,
+ GenAvailInfo(..), AvailInfo, HscSource(..),
availName, IsBootInterface, Deprecations )
import Packages ( PackageId )
import Type ( Type, TvSubstEnv, pprParendType )
data TcGblEnv
= TcGblEnv {
tcg_mod :: Module, -- Module being compiled
+ tcg_src :: HscSource, -- What kind of module
+ -- (regular Haskell, hs-boot, ext-core)
+
tcg_rdr_env :: GlobalRdrEnv, -- Top level envt; used during renaming
tcg_default :: Maybe [Type], -- Types used for defaulting
-- Nothing => no 'default' decl
module TcSplice where
tcSpliceExpr :: HsExpr.HsSplice Name.Name
- -> TcUnify.Expected TcType.TcType
+ -> TcType.Expected TcType.TcType
-> TcRnTypes.TcM (HsExpr.HsExpr Var.Id)
kcSpliceType :: HsExpr.HsSplice Name.Name
-> TcRnTypes.TcM (HsTypes.HsType Name.Name, TcType.TcKind)
tcBracket :: HsExpr.HsBracket Name.Name
- -> TcUnify.Expected TcType.TcType
+ -> TcType.Expected TcType.TcType
-> TcRnTypes.TcM (HsExpr.LHsExpr Var.Id)
tcSpliceDecls :: HsExpr.LHsExpr Name.Name
--- /dev/null
+\begin{code}
+module TcSplice where
+import HsSyn ( HsSplice, HsBracket, HsExpr, LHsExpr, HsType, LHsDecl )
+import Var ( Id )
+import Name ( Name )
+import RdrName ( RdrName )
+import TcRnTypes( TcM )
+import TcType ( TcType, TcKind, Expected )
+
+tcSpliceExpr :: HsSplice Name
+ -> Expected TcType
+ -> TcM (HsExpr Id)
+
+kcSpliceType :: HsSplice Name -> TcM (HsType Name, TcKind)
+
+tcBracket :: HsBracket Name
+ -> Expected TcType
+ -> TcM (LHsExpr Id)
+
+tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
+\end{code}
import Type ( splitTyConApp_maybe, pprThetaArrow, pprParendType )
import Generics ( validGenericMethodType, canDoGenerics )
import Class ( Class, className, classTyCon, DefMeth(..), classBigSig, classTyVars )
-import TyCon ( TyCon, ArgVrcs,
+import TyCon ( TyCon, ArgVrcs, AlgTyConRhs( AbstractTyCon ),
tyConDataCons, mkForeignTyCon, isProductTyCon, isRecursiveTyCon,
tyConStupidTheta, getSynTyConDefn, isSynTyCon, tyConName )
import DataCon ( DataCon, dataConWrapId, dataConName, dataConSig,
{ extra_tvs <- tcDataKindSig mb_ksig
; let final_tvs = tvs' ++ extra_tvs
; stupid_theta <- tcStupidTheta ctxt cons
+
; want_generic <- doptM Opt_Generics
+ ; unbox_strict <- doptM Opt_UnboxStrictFields
+ ; gla_exts <- doptM Opt_GlasgowExts
+ ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file?
+
+ -- Check that we don't use GADT syntax in H98 world
+ ; checkTc (gla_exts || h98_syntax) (badGadtDecl tc_name)
+
+ -- Check that there's at least one condecl,
+ -- or else we're reading an interface file, or -fglasgow-exts
+ ; checkTc (not (null cons) || gla_exts || is_boot)
+ (emptyConDeclsErr tc_name)
+
; tycon <- fixM (\ tycon -> do
- { unbox_strict <- doptM Opt_UnboxStrictFields
- ; gla_exts <- doptM Opt_GlasgowExts
- ; checkTc (gla_exts || h98_syntax) (badGadtDecl tc_name)
-
- ; data_cons <- mappM (addLocM (tcConDecl unbox_strict new_or_data tycon final_tvs)) cons
- ; let tc_rhs = case new_or_data of
+ { data_cons <- mappM (addLocM (tcConDecl unbox_strict new_or_data
+ tycon final_tvs))
+ cons
+ ; let tc_rhs
+ | null cons && is_boot -- In a hs-boot file, empty cons means
+ = AbstractTyCon -- "don't know"; hence Abstract
+ | otherwise
+ = case new_or_data of
DataType -> mkDataTyConRhs stupid_theta data_cons
NewType -> ASSERT( isSingleton data_cons )
mkNewTyConRhs tycon (head data_cons)
badGadtDecl tc_name
= vcat [ ptext SLIT("Illegal generalised algebraic data declaration for") <+> quotes (ppr tc_name)
, nest 2 (parens $ ptext SLIT("Use -fglasgow-exts to allow GADTs")) ]
+
+emptyConDeclsErr tycon
+ = sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"),
+ nest 4 (ptext SLIT("(-fglasgow-exts permits this)"))]
\end{code}
--------------------------------
-- MetaDetails
- TcTyVarDetails(..),
+ Expected(..), TcRef, TcTyVarDetails(..),
MetaDetails(Flexi, Indirect), SkolemInfo(..), pprSkolemTyVar,
isImmutableTyVar, isSkolemTyVar, isMetaTyVar, isExistentialTyVar, skolemTvInfo, metaTvRef,
isFlexi, isIndirect,
type TcTauType = TcType
type TcKind = Kind
type TcTyVarSet = TyVarSet
+
+type TcRef a = IORef a
+data Expected ty = Infer (TcRef ty) -- The hole to fill in for type inference
+ | Check ty -- The type to check during type checking
\end{code}
--- /dev/null
+\begin{code}
+module TcType where
+
+data TcTyVarDetails
+\end{code}
import TcRnMonad -- TcType, amongst others
import TcType ( TcKind, TcType, TcSigmaType, TcRhoType, TcTyVar, TcTauType,
- TcTyVarSet, TcThetaType,
+ TcTyVarSet, TcThetaType, Expected(..),
SkolemInfo( GenSkol ), MetaDetails(..),
pprSkolemTyVar, isTauTy, isSigmaTy, mkFunTys, mkTyConApp,
tcSplitAppTy_maybe, tcSplitTyConApp_maybe,
%************************************************************************
\begin{code}
-data Expected ty = Infer (TcRef ty) -- The hole to fill in for type inference
- | Check ty -- The type to check during type checking
-
newHole = newMutVar (error "Empty hole in typechecker")
tcInfer :: (Expected ty -> TcM a) -> TcM (a,ty)
--- /dev/null
+\begin{code}
+module TcUnify where
+import TcType ( TcTauType )
+import TcRnTypes( TcM )
+
+-- This boot file exists only to tie the knot between
+-- TcUnify and TcSimplify
+
+unifyTauTy :: TcTauType -> TcTauType -> TcM ()
+\end{code}
--- /dev/null
+\begin{code}
+module TyCon where
+
+data TyCon
+
+isTupleTyCon :: TyCon -> Bool
+isUnboxedTupleTyCon :: TyCon -> Bool
+isFunTyCon :: TyCon -> Bool
+\end{code}
--- /dev/null
+\begin{code}
+module TypeRep where
+
+data Type
+data PredType
+data TyThing
+\end{code}
+
Literal (TysPrim, PprType) <br>
DataCon (loop PprType, loop Subst.substTyWith, FieldLabel.FieldLabel)
<p><li>
- TysWiredIn (loop MkId.mkDataConWorkId, loop Generics.mkGenInfo, DataCon.mkDataCon)
+ TysWiredIn (loop MkId.mkDataConIds)
<p><li>
TcType( lots of TysWiredIn stuff)
<p><li>
</ul></tt>
</ul>
-
-
+HsSyn stuff
+<ul>
+<li> HsPat.hs-boot
+<li> HsExpr.hs-boot (loop HsPat.LPat)
+<li> HsTypes (loop HsExpr.HsSplice)
+<li> HsBinds (HsTypes.LHsType, loop HsPat.LPat, HsExpr.pprFunBind and others)
+ HsLit (HsTypes.SyntaxName)
+<li> HsPat (HsBinds, HsLit)
+ HsDecls (HsBinds)
+<li> HsExpr (HsDecls, HsPat)
+</ul>
<p><small>
-> IO ()
registerPackage input defines db_stack auto_ghci_libs update force = do
let
- db_to_operate_on = head db_stack
+ db_to_operate_on = my_head "db" db_stack
db_filename = fst db_to_operate_on
--
checkConfigAccess db_filename
when (not update && exposed pkg && not (null exposed_pkgs_with_same_name)) $
die ("trying to register " ++ showPackageId pkgid
++ " as exposed, but "
- ++ showPackageId (package (head exposed_pkgs_with_same_name))
+ ++ showPackageId (package (my_head "when" exposed_pkgs_with_same_name))
++ " is also exposed.")
resolveDep pkgid
| realVersion pkgid = pkgid
| otherwise = lookupDep (pkgName pkgid)
-
+-- = pkgid
+
lookupDep name
- = head [ pid | p <- concat (map snd db_stack),
+ = my_head "dep" [ pid | p <- concat (map snd db_stack),
let pid = package p,
pkgName pid == name ]
let auto_ghci_libs = any isAuto clis
where isAuto OF_AutoGHCiLibs = True; isAuto _ = False
- input_file = head ([ f | (OF_Input f) <- clis] ++ ["-"])
+ input_file = my_head "inp" ([ f | (OF_Input f) <- clis] ++ ["-"])
force = OF_Force `elem` clis
_ -> do prog <- getProgramName
die (usageInfo (usageHeader prog) flags)
+my_head s [] = error s
+my_head s (x:xs) = x
+
-- ---------------------------------------------------------------------------
#ifdef OLD_STUFF
projects / ghc-hetmet.git / commitdiff