From: simonmar Date: Mon, 20 Nov 2000 16:28:32 +0000 (+0000) Subject: [project @ 2000-11-20 16:28:29 by simonmar] X-Git-Tag: Approximately_9120_patches~3300 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=acef71564746becef2c85c310ed57dc8fdd54581;p=ghc-hetmet.git [project @ 2000-11-20 16:28:29 by simonmar] Allow the root of the module tree to have a filename which is different from its module name. The argument to cmLoadModule is now a filename. --- diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs index 9e78ee0..7f0885a 100644 --- a/ghc/compiler/compMan/CompManager.lhs +++ b/ghc/compiler/compMan/CompManager.lhs @@ -29,11 +29,12 @@ import Name ( lookupNameEnv ) import Module import PrelNames ( mainName ) import HscMain ( initPersistentCompilerState ) -import Finder ( findModule, emptyHomeDirCache ) +import Finder import UniqFM ( emptyUFM, lookupUFM, addToUFM, delListFromUFM, UniqFM, listToUFM ) import Unique ( Uniquable ) import Digraph ( SCC(..), stronglyConnComp ) +import DriverPhases import DriverUtil ( BarfKind(..), splitFilename3 ) import Util import Outputable @@ -149,8 +150,10 @@ the system state at the same time. \begin{code} cmLoadModule :: CmState - -> ModuleName - -> IO (CmState, Maybe ModuleName) + -> FilePath + -> IO (CmState, -- new state + Bool, -- was successful + [ModuleName]) -- list of modules loaded cmLoadModule cmstate1 rootname = do -- version 1's are the original, before downsweep @@ -235,7 +238,7 @@ cmLoadModule cmstate1 rootname pci=pcii, gmode=ghci_mode } let cmstate3 = CmState { pcms=pcms3, pcs=pcs3, pls=pls3 } - return (cmstate3, Just rootname) + return (cmstate3, True, map name_of_summary modsDone) else -- Tricky. We need to back out the effects of compiling any @@ -269,10 +272,7 @@ cmLoadModule cmstate1 rootname pci=pcii, gmode=ghci_mode } let cmstate4 = CmState { pcms=pcms4, pcs=pcs3, pls=pls4 } - return (cmstate4, - -- choose rather arbitrarily who to return - if null mods_to_keep then Nothing - else Just (last mods_to_keep_names)) + return (cmstate4, False, mods_to_keep_names) -- Return (names of) all those in modsDone who are part of a cycle @@ -391,6 +391,17 @@ upsweep_mod ghci_mode oldUI threaded1 summary1 reachable_from_here let (CmThreaded pcs1 hst1 hit1) = threaded1 let old_iface = lookupUFM hit1 (name_of_summary summary1) + -- We *have* to compile it if we're in batch mode and we can't see + -- a previous linkable for it on disk. + compilation_mandatory + <- if ghci_mode /= Batch then return False + else case ml_obj_file (ms_location summary1) of + Nothing -> do --putStrLn "cmcm: object?!" + return True + Just obj_fn -> do --putStrLn ("cmcm: old obj " ++ obj_fn) + b <- doesFileExist obj_fn + return (not b) + let maybe_oldUI_linkable = findModuleLinkable_maybe oldUI mod_name maybe_oldDisk_linkable <- case ml_obj_file (ms_location summary1) of @@ -531,11 +542,21 @@ topological_sort include_source_imports summaries -- Chase downwards from the specified root set, returning summaries -- for all home modules encountered. Only follow source-import -- links. -downsweep :: [ModuleName] -> IO [ModSummary] +downsweep :: [FilePath] -> IO [ModSummary] downsweep rootNm - = do rootSummaries <- mapM getSummary rootNm + = do rootSummaries <- mapM getRootSummary rootNm loop (filter (isModuleInThisPackage.ms_mod) rootSummaries) where + getRootSummary :: FilePath -> IO ModSummary + getRootSummary file + | haskellish_file file + = do exists <- doesFileExist file + if exists then summariseFile file + else getSummary (mkModuleName file) + -- ToDo: should check import paths + | otherwise + = getSummary (mkModuleName file) + getSummary :: ModuleName -> IO ModSummary getSummary nm | trace ("getSummary: "++ showSDoc (ppr nm)) True @@ -569,6 +590,40 @@ downsweep rootNm else loop (newHomeSummaries ++ homeSummaries) +----------------------------------------------------------------------------- +-- Summarising modules + +-- We have two types of summarisation: +-- +-- * Summarise a file. This is used for the root module passed to +-- cmLoadModule. The file is read, and used to determine the root +-- module name. The module name may differ from the filename. +-- +-- * Summarise a module. We are given a module name, and must provide +-- a summary. The finder is used to locate the file in which the module +-- resides. + +summariseFile :: FilePath -> IO ModSummary +summariseFile file + = do hspp_fn <- preprocess file + modsrc <- readFile hspp_fn + + let (srcimps,imps,mod_name) = getImports modsrc + (path, basename, ext) = splitFilename3 file + + Just (mod, location) + <- mkHomeModuleLocn mod_name (path ++ '/':basename) file + + maybe_src_timestamp + <- case ml_hs_file location of + Nothing -> return Nothing + Just src_fn -> maybe_getModificationTime src_fn + + return (ModSummary mod + location{ml_hspp_file=Just hspp_fn} + srcimps imps + maybe_src_timestamp) + -- Summarise a module, and pick up source and interface timestamps. summarise :: Module -> ModuleLocation -> IO ModSummary summarise mod location @@ -583,44 +638,24 @@ summarise mod location Nothing -> return Nothing Just src_fn -> maybe_getModificationTime src_fn - -- If the module name is Main, allow it to be in a file - -- different from Main.hs, and mash the mod and loc - -- to match. Otherwise just moan. - (mashed_mod, mashed_loc) - <- case () of - () | mod_name == moduleName mod - -> return (mod, location) - | mod_name /= moduleName mod && mod_name == mkModuleName "Main" - -> return (mash mod location "Main") - | otherwise - -> do hPutStrLn stderr (showSDoc ( - text "ghc: warning: file name - module name mismatch:" <+> - ppr (moduleName mod) <+> text "vs" <+> ppr mod_name)) - return (mash mod location (moduleNameUserString (moduleName mod))) - where - mash old_mod old_loc new_nm - = (mkHomeModule (mkModuleName new_nm), - old_loc{ml_hi_file = maybe_swizzle_basename new_nm - (ml_hi_file old_loc)}) - - maybe_swizzle_basename new Nothing = Nothing - maybe_swizzle_basename new (Just old) - = case splitFilename3 old of - (dir, name, ext) -> Just (dir ++ new ++ ext) - - return (ModSummary mashed_mod - mashed_loc{ml_hspp_file=Just hspp_fn} - srcimps imps - maybe_src_timestamp) + if mod_name == moduleName mod + then return () + else throwDyn (OtherError + (showSDoc (text "file name does not match module name: " + <+> ppr (moduleName mod) <+> text "vs" + <+> ppr mod_name))) + + return (ModSummary mod location{ml_hspp_file=Just hspp_fn} + srcimps imps + maybe_src_timestamp) | otherwise = return (ModSummary mod location [] [] Nothing) - where - maybe_getModificationTime :: FilePath -> IO (Maybe ClockTime) - maybe_getModificationTime fn - = (do time <- getModificationTime fn - return (Just time)) - `catch` - (\err -> return Nothing) +maybe_getModificationTime :: FilePath -> IO (Maybe ClockTime) +maybe_getModificationTime fn + = (do time <- getModificationTime fn + return (Just time)) + `catch` + (\err -> return Nothing) \end{code} diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index 4f16a56..df05c6e 100644 --- a/ghc/compiler/ghci/InteractiveUI.hs +++ b/ghc/compiler/ghci/InteractiveUI.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: InteractiveUI.hs,v 1.4 2000/11/17 16:53:27 simonmar Exp $ +-- $Id: InteractiveUI.hs,v 1.5 2000/11/20 16:28:29 simonmar Exp $ -- -- GHC Interactive User Interface -- @@ -18,6 +18,7 @@ import DriverUtil import DriverState import Linker import Module +import Outputable import Panic import Util @@ -49,8 +50,7 @@ commands = [ ("reload", reloadModule), ("set", setOptions), ("type", typeOfExpr), - ("quit", quit), - ("!", shellEscape) + ("quit", quit) ] shortHelpText = "use :? for help.\n" @@ -81,7 +81,8 @@ interactiveUI st = do #ifndef NO_READLINE Readline.initialize #endif - _ <- (unGHCi uiLoop) GHCiState{ current_module = mkModuleName "Main", + _ <- (unGHCi uiLoop) GHCiState{ modules = [], + current_module = Nothing, target = Nothing, cmstate = st } return () @@ -90,7 +91,7 @@ uiLoop :: GHCi () uiLoop = do st <- getGHCiState #ifndef NO_READLINE - l <- io (readline (moduleNameUserString (current_module st) ++ "> ")) + l <- io (readline (mkPrompt (current_module st) ++ "> ")) #else l <- io (hGetLine stdin) #endif @@ -104,7 +105,11 @@ uiLoop = do runCommand l uiLoop --- Top level exception handler, just prints out the exception and carries on. +mkPrompt Nothing = "> " +mkPrompt (Just mod_name) = moduleNameUserString mod_name + +-- Top level exception handler, just prints out the exception +-- and carries on. runCommand c = ghciHandle ( \other_exception ->io (putStrLn (show other_exception) )) $ ghciHandleDyn @@ -120,12 +125,15 @@ runCommand c = doCommand (':' : command) = specialCommand command doCommand expr = do st <- getGHCiState - dflags <- io (readIORef v_DynFlags) - (st, maybe_hvalue) <- - io (cmGetExpr (cmstate st) dflags (current_module st) expr) - case maybe_hvalue of - Nothing -> return () - Just hv -> io (cmRunExpr hv) + case current_module st of + Nothing -> throwDyn (OtherError "no module context in which to run the expression") + Just mod -> do + dflags <- io (readIORef v_DynFlags) + (st, maybe_hvalue) <- + io (cmGetExpr (cmstate st) dflags mod expr) + case maybe_hvalue of + Nothing -> return () + Just hv -> io (cmRunExpr hv) {- let (mod,'.':str) = break (=='.') expr case cmLookupSymbol (mkOrig varName (mkModuleName mod) (_PK_ str)) (cmstate st) of @@ -134,6 +142,7 @@ doCommand expr = do return () -} +specialCommand ('!':str) = shellEscape (dropWhile isSpace str) specialCommand str = do let (cmd,rest) = break isSpace str case [ (s,f) | (s,f) <- commands, prefixMatch cmd s ] of @@ -159,24 +168,36 @@ changeDirectory = io . setCurrentDirectory loadModule :: String -> GHCi () loadModule path = do state <- getGHCiState - (new_cmstate, mod) <- io (cmLoadModule (cmstate state) - ({-ToDo!!-}mkModuleName path)) + (new_cmstate, ok, mods) <- io (cmLoadModule (cmstate state) path) + let new_state = GHCiState { cmstate = new_cmstate, - current_module = case mod of - Nothing -> current_module state - Just m -> m, + modules = mods, + current_module = case mods of + [] -> Nothing + xs -> Just (last xs), target = Just path } setGHCiState new_state + let mod_commas + | null mods = text "none." + | otherwise = hsep ( + punctuate comma (map (text.moduleNameUserString) mods)) <> text "." + case ok of + False -> + io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas))) + True -> + io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas))) + reloadModule :: String -> GHCi () reloadModule "" = do state <- getGHCiState case target state of - Nothing -> io (putStr "no current target\n") - Just path -> do (new_cmstate, mod) <- io (cmLoadModule (cmstate state) (mkModuleName path)) - setGHCiState state{cmstate=new_cmstate} + Nothing -> io (putStr "no current target\n") + Just path -> do (new_cmstate, ok, mod) + <- io (cmLoadModule (cmstate state) path) + setGHCiState state{cmstate=new_cmstate} reloadModule _ = noArgs ":reload" -- set options in the interpreter. Syntax is exactly the same as the @@ -213,7 +234,8 @@ shellEscape str = io (system str >> return ()) data GHCiState = GHCiState { - current_module :: ModuleName, + modules :: [ModuleName], + current_module :: Maybe ModuleName, target :: Maybe FilePath, cmstate :: CmState } diff --git a/ghc/compiler/main/DriverUtil.hs b/ghc/compiler/main/DriverUtil.hs index 0270e7c..764be3f 100644 --- a/ghc/compiler/main/DriverUtil.hs +++ b/ghc/compiler/main/DriverUtil.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverUtil.hs,v 1.10 2000/11/20 15:40:54 simonmar Exp $ +-- $Id: DriverUtil.hs,v 1.11 2000/11/20 16:28:29 simonmar Exp $ -- -- Utils for the driver -- @@ -133,10 +133,7 @@ addNoDups var x = do unless (x `elem` xs) $ writeIORef var (x:xs) splitFilename :: String -> (String,String) -splitFilename f = (reverse (stripDot rev_basename), reverse rev_ext) - where (rev_ext, rev_basename) = span ('.' /=) (reverse f) - stripDot ('.':xs) = xs - stripDot xs = xs +splitFilename f = split_longest_prefix f '.' -- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext") splitFilename3 :: String -> (String,String,String) diff --git a/ghc/compiler/main/Finder.lhs b/ghc/compiler/main/Finder.lhs index 5431719..43e29d9 100644 --- a/ghc/compiler/main/Finder.lhs +++ b/ghc/compiler/main/Finder.lhs @@ -7,6 +7,8 @@ module Finder ( initFinder, -- :: PackageConfigInfo -> IO (), findModule, -- :: ModuleName -> IO (Maybe (Module, ModuleLocation)) + mkHomeModuleLocn, -- :: ModuleName -> String -> FilePath + -- -> IO ModuleLocation emptyHomeDirCache -- :: IO () ) where @@ -16,6 +18,7 @@ import HscTypes ( ModuleLocation(..) ) import CmStaticInfo import DriverPhases import DriverState +import DriverUtil import Module import FiniteMap import Util @@ -87,41 +90,46 @@ maybeHomeModule mod_name = do Just home_map -> return home_map - let basename = moduleNameUserString mod_name + let basename = moduleNameUserString mod_name hs = basename ++ ".hs" lhs = basename ++ ".lhs" case lookupFM home_map hs of { - Just path -> mkHomeModuleLocn mod_name (path ++ '/':basename) - (path ++ '/':hs); + Just path -> mkHomeModuleLocn mod_name + (path ++ '/':basename) (path ++ '/':hs); Nothing -> case lookupFM home_map lhs of { - Just path -> mkHomeModuleLocn mod_name (path ++ '/':basename) - (path ++ '/':lhs); + Just path -> mkHomeModuleLocn mod_name + (path ++ '/':basename) (path ++ '/':lhs); Nothing -> do -- can't find a source file anywhere, check for a lone .hi file. hisuf <- readIORef v_Hi_suf let hi = basename ++ '.':hisuf case lookupFM home_map hi of { - Just path -> mkHomeModuleLocn mod_name (path ++ '/':basename) - (path ++ '/':hs); + Just path -> mkHomeModuleLocn mod_name + (path ++ '/':basename) (path ++ '/':hs); Nothing -> do -- last chance: .hi-boot- and .hi-boot let hi_boot = basename ++ ".hi-boot" let hi_boot_ver = basename ++ ".hi-boot-" ++ cHscIfaceFileVersion case lookupFM home_map hi_boot_ver of { - Just path -> mkHomeModuleLocn mod_name (path ++ '/':basename) - (path ++ '/':hs); + Just path -> mkHomeModuleLocn mod_name + (path ++ '/':basename) (path ++ '/':hs); Nothing -> do case lookupFM home_map hi_boot of { - Just path -> mkHomeModuleLocn mod_name (path ++ '/':basename) - (path ++ '/':hs); + Just path -> mkHomeModuleLocn mod_name + (path ++ '/':basename) (path ++ '/':hs); Nothing -> return Nothing }}}}} + +-- The .hi file always follows the module name, whereas the object +-- file may follow the name of the source file in the case where the +-- two differ (see summariseFile in compMan/CompManager.lhs). + mkHomeModuleLocn mod_name basename source_fn = do -- figure out the .hi file name: it lives in the same dir as the @@ -129,7 +137,9 @@ mkHomeModuleLocn mod_name basename source_fn = do ohi <- readIORef v_Output_hi hisuf <- readIORef v_Hi_suf let hifile = case ohi of - Nothing -> basename ++ '.':hisuf + Nothing -> getdir basename + ++ '/':moduleNameUserString mod_name + ++ '.':hisuf Just fn -> fn -- figure out the .o file name. It also lives in the same dir diff --git a/ghc/compiler/main/Interpreter.hs b/ghc/compiler/main/Interpreter.hs index af1d952..2945115 100644 --- a/ghc/compiler/main/Interpreter.hs +++ b/ghc/compiler/main/Interpreter.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: Interpreter.hs,v 1.7 2000/11/20 14:48:54 simonpj Exp $ +-- $Id: Interpreter.hs,v 1.8 2000/11/20 16:28:29 simonmar Exp $ -- -- Interpreter subsystem wrapper -- @@ -16,7 +16,7 @@ module Interpreter ( ClosureEnv, emptyClosureEnv, ItblEnv, emptyItblEnv, linkIModules, - stgToInterpSyn, stgBindsToInterpSyn, + stgExprToInterpSyn, stgBindsToInterpSyn, HValue, UnlinkedIBind, UnlinkedIExpr, loadObjs, resolveObjs, @@ -56,7 +56,7 @@ instance Outputable UnlinkedIBind where ppr x = text "Can't output UnlinkedIBind" linkIModules = error "linkIModules" -stgToInterpSyn = error "stgToInterpSyn" +stgExprToInterpSyn = error "stgToInterpSyn" stgBindsToInterpSyn = error "stgBindsToInterpSyn" loadObjs = error "loadObjs" resolveObjs = error "loadObjs" diff --git a/ghc/compiler/main/Main.hs b/ghc/compiler/main/Main.hs index 81c5459..5e61fdb 100644 --- a/ghc/compiler/main/Main.hs +++ b/ghc/compiler/main/Main.hs @@ -1,6 +1,6 @@ {-# OPTIONS -W -fno-warn-incomplete-patterns #-} ----------------------------------------------------------------------------- --- $Id: Main.hs,v 1.26 2000/11/19 19:40:08 simonmar Exp $ +-- $Id: Main.hs,v 1.27 2000/11/20 16:28:29 simonmar Exp $ -- -- GHC Driver program -- @@ -279,7 +279,7 @@ beginMake pkg_details mods = do case mods of [] -> throwDyn (UsageError "no input files") [mod] -> do state <- cmInit pkg_details Batch - cmLoadModule state (mkModuleName mod) + cmLoadModule state mod return () _ -> throwDyn (UsageError "only one module allowed with --make") @@ -290,7 +290,7 @@ beginInteractive pkg_details mods = do state <- cmInit pkg_details Interactive case mods of [] -> return () - [mod] -> do cmLoadModule state (mkModuleName mod); return () + [mod] -> do cmLoadModule state mod; return () _ -> throwDyn (UsageError "only one module allowed with --interactive") interactiveUI state diff --git a/ghc/compiler/utils/FiniteMap.lhs b/ghc/compiler/utils/FiniteMap.lhs index b4c4f60..87bf81f 100644 --- a/ghc/compiler/utils/FiniteMap.lhs +++ b/ghc/compiler/utils/FiniteMap.lhs @@ -1,4 +1,4 @@ -% + % (c) The AQUA Project, Glasgow University, 1994-1998 % \section[FiniteMap]{An implementation of finite maps}