clash-ghc 0.5 → 0.5.1
raw patch · 17 files changed
+474/−469 lines, 17 filesdep +ghc-typelits-natnormalisedep ~clash-preludedep ~ghcdep ~transformers
Dependencies added: ghc-typelits-natnormalise
Dependency ranges changed: clash-prelude, ghc, transformers, unbound-generics
Files
- CHANGELOG.md +6/−0
- clash-ghc.cabal +23/−28
- src-bin/GhciMonad.hs +16/−4
- src-bin/InteractiveUI.hs +214/−127
- src-bin/Main.hs +119/−85
- src-bin/PosixSource.h +1/−1
- src-bin/hschooks.c +2/−5
- src-ghc/CLaSH/GHC/Compat/DynFlags.hs +0/−37
- src-ghc/CLaSH/GHC/Compat/FastString.hs +0/−28
- src-ghc/CLaSH/GHC/Compat/GHC.hs +0/−20
- src-ghc/CLaSH/GHC/Compat/Outputable.hs +0/−28
- src-ghc/CLaSH/GHC/Compat/PrelNames.hs +0/−15
- src-ghc/CLaSH/GHC/Compat/TyCon.hs +0/−17
- src-ghc/CLaSH/GHC/GHC2Core.hs +52/−44
- src-ghc/CLaSH/GHC/LoadInterfaceFiles.hs +13/−7
- src-ghc/CLaSH/GHC/LoadModules.hs +12/−7
- src-ghc/CLaSH/GHC/NetlistTypes.hs +16/−16
CHANGELOG.md view
@@ -1,5 +1,11 @@ # Changelog for the [`clash-ghc`](http://hackage.haskell.org/package/clash-ghc) package +## 0.5.1 *April 20th 2015*+* New features+ * GHC 7.10 support+ * Update to clash-prelude 0.7.2+ * Use http://hackage.haskell.org/package/ghc-typelits-natnormalise typechecker plugin for better type-level natural number handling+ ## 0.5 *March 11th 2015* * New features: * SystemVerilog backend. [#45](https://github.com/clash-lang/clash-compiler/issues/45)
clash-ghc.cabal view
@@ -1,5 +1,5 @@ Name: clash-ghc-Version: 0.5+Version: 0.5.1 Synopsis: CAES Language for Synchronous Hardware Description: CλaSH (pronounced ‘clash’) is a functional hardware description language that@@ -52,28 +52,29 @@ PatternGuards NondecreasingIndentation - Build-Depends: array >= 0.4,- base >= 4.3.1.0 && < 5,- bifunctors >= 4.1.1,- bytestring >= 0.9,- containers >= 0.5.4.0,- directory >= 1.2,- filepath >= 1.3,- ghc >= 7.8,- process >= 1.2,- hashable >= 1.1.2.3,- haskeline >= 0.7.0.3,- lens >= 4.0.5,- mtl >= 2.1.1,- text >= 0.11.3.1,- transformers >= 0.3,- unbound-generics >= 0.1,- unordered-containers >= 0.2.1.0,+ Build-Depends: array >= 0.4,+ base >= 4.3.1.0 && < 5,+ bifunctors >= 4.1.1,+ bytestring >= 0.9,+ containers >= 0.5.4.0,+ directory >= 1.2,+ filepath >= 1.3,+ ghc >= 7.10.1,+ process >= 1.2,+ hashable >= 1.1.2.3,+ haskeline >= 0.7.0.3,+ lens >= 4.0.5,+ mtl >= 2.1.1,+ text >= 0.11.3.1,+ transformers >= 0.4.2,+ unbound-generics >= 0.1,+ unordered-containers >= 0.2.1.0, - clash-lib >= 0.5,- clash-vhdl >= 0.5,- clash-systemverilog >= 0.5,- clash-prelude >= 0.7+ clash-lib >= 0.5,+ clash-vhdl >= 0.5,+ clash-systemverilog >= 0.5,+ clash-prelude >= 0.7.2,+ ghc-typelits-natnormalise >= 0.1.1 if os(windows) Build-Depends: Win32@@ -86,12 +87,6 @@ GhciMonad GhciTags - CLaSH.GHC.Compat.DynFlags- CLaSH.GHC.Compat.FastString- CLaSH.GHC.Compat.GHC- CLaSH.GHC.Compat.Outputable- CLaSH.GHC.Compat.PrelNames- CLaSH.GHC.Compat.TyCon CLaSH.GHC.Evaluator CLaSH.GHC.GenerateBindings CLaSH.GHC.GHC2Core
src-bin/GhciMonad.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP, FlexibleInstances, UnboxedTuples, MagicHash #-} {-# OPTIONS_GHC -fno-cse -fno-warn-orphans #-} -- -fno-cse is needed for GLOBAL_VAR's to behave properly @@ -32,6 +33,7 @@ import qualified Outputable import Util import DynFlags+import FastString import HscTypes import SrcLoc import Module@@ -46,7 +48,6 @@ import System.CPUTime import System.Environment import System.IO-import Control.Applicative (Applicative(..)) import Control.Monad import GHC.Exts @@ -55,9 +56,14 @@ import Control.Monad.Trans.Class import Control.Monad.IO.Class +#if __GLASGOW_HASKELL__ < 709+import Control.Applicative (Applicative(..))+#endif+ ----------------------------------------------------------------------------- -- GHCi monad +-- the Bool means: True = we should exit GHCi (:quit) type Command = (String, String -> InputT GHCi Bool, CompletionFunc GHCi) data GHCiState = GHCiState@@ -104,7 +110,8 @@ -- help text to display to a user short_help :: String,- long_help :: String+ long_help :: String,+ lastErrorLocations :: IORef [(FastString, Int)] } type TickArray = Array Int [(BreakIndex,SrcSpan)]@@ -135,7 +142,7 @@ instance Outputable BreakLocation where ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc) <+> if null (onBreakCmd loc)- then empty+ then Outputable.empty else doubleQuotes (text (onBreakCmd loc)) recordBreak :: BreakLocation -> GHCi (Bool{- was already present -}, Int)@@ -316,7 +323,12 @@ secs_str = showFFloat (Just 2) secs putStrLn (showSDoc dflags ( parens (text (secs_str "") <+> text "secs" <> comma <+>- text (show allocs) <+> text "bytes")))+ text (separateThousands allocs) <+> text "bytes")))+ where+ separateThousands n = reverse . sep . reverse . show $ n+ where sep n'+ | length n' <= 3 = n'+ | otherwise = take 3 n' ++ "," ++ sep (drop 3 n') ----------------------------------------------------------------------------- -- reverting CAFs
src-bin/InteractiveUI.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP, MagicHash, NondecreasingIndentation, TupleSections #-} {-# OPTIONS -fno-cse #-} -- -fno-cse is needed for GLOBAL_VAR's to behave properly @@ -28,6 +29,7 @@ -- The GHC interface import DynFlags+import ErrUtils import GhcMonad ( modifySession ) import qualified GHC import GHC ( LoadHowMuch(..), Target(..), TargetId(..), InteractiveImport(..),@@ -38,14 +40,13 @@ setInteractivePrintName ) import Module import Name-import Packages ( trusted, getPackageDetails, exposed, exposedModules, pkgIdMap )+import Packages ( trusted, getPackageDetails, listVisibleModuleNames, pprFlag ) import PprTyThing import RdrName ( getGRE_NameQualifier_maybes ) import SrcLoc import qualified Lexer import StringBuffer-import UniqFM ( eltsUFM ) import Outputable hiding ( printForUser, printForUserPartWay, bold ) -- Other random utilities@@ -62,8 +63,9 @@ -- Haskell Libraries import System.Console.Haskeline as Haskeline -import Control.Applicative hiding (empty) import Control.Monad as Monad++import Control.Applicative hiding (empty) import Control.Monad.Trans.Class import Control.Monad.IO.Class @@ -71,7 +73,7 @@ import qualified Data.ByteString.Char8 as BS import Data.Char import Data.Function-import Data.IORef ( IORef, readIORef, writeIORef )+import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef ) import Data.List ( find, group, intercalate, intersperse, isPrefixOf, nub, partition, sort, sortBy ) import Data.Maybe@@ -79,7 +81,11 @@ import Exception hiding (catch) import Foreign.C+#if __GLASGOW_HASKELL__ >= 709+import Foreign+#else import Foreign.Safe+#endif import System.Directory import System.Environment@@ -139,7 +145,7 @@ ghciWelcomeMsg :: String ghciWelcomeMsg = "CLaSHi, version " ++ Data.Version.showVersion Paths_clash_ghc.version ++ " (using clash-lib, version " ++ Data.Version.showVersion clashLibVersion ++- "):\nhttp://christiaanb.github.io/clash2/ :? for help"+ "):\nhttp://www.clash-lang.org/ :? for help" cmdName :: Command -> String cmdName (n,_,_) = n@@ -275,6 +281,8 @@ " :!<command> run the shell command <command>\n" ++ " :vhdl synthesize currently loaded module to vhdl\n" ++ " :vhdl [<module>] synthesize specified modules/files to vhdl\n" +++ " :systemverilog synthesize currently loaded module to systemverilog\n" +++ " :systemverilog [<module>] synthesize specified modules/files to systemverilog\n" ++ "\n" ++ " -- Commands for debugging:\n" ++ "\n" ++@@ -291,8 +299,8 @@ " :list show the source code around current breakpoint\n" ++ " :list <identifier> show the source code for <identifier>\n" ++ " :list [<module>] <line> show the source code around line number <line>\n" ++- " :print [<name> ...] prints a value without forcing its computation\n" ++- " :sprint [<name> ...] simplifed version of :print\n" +++ " :print [<name> ...] show a value without forcing its computation\n" +++ " :sprint [<name> ...] simplified version of :print\n" ++ " :step single-step after stopping at a breakpoint\n"++ " :step <expr> single-step into <expr>\n"++ " :steplocal single-step within the current top-level binding\n"++@@ -396,6 +404,11 @@ $ dflags GHC.setInteractiveDynFlags dflags' + lastErrLocationsRef <- liftIO $ newIORef []+ progDynFlags <- GHC.getProgramDynFlags+ _ <- GHC.setProgramDynFlags $+ progDynFlags { log_action = ghciLogAction lastErrLocationsRef }+ liftIO $ when (isNothing maybe_exprs) $ do -- Only for GHCi (not runghc and ghc -e): @@ -416,31 +429,46 @@ #endif default_editor <- liftIO $ findEditor- startGHCi (runGHCi srcs maybe_exprs)- GHCiState{ progname = default_progname,- GhciMonad.args = default_args,- prompt = defPrompt config,- prompt2 = defPrompt2 config,- stop = default_stop,- editor = default_editor,- options = [],- line_number = 1,- break_ctr = 0,- breaks = [],- tickarrays = emptyModuleEnv,- ghci_commands = availableCommands config,- last_command = Nothing,- cmdqueue = [],- remembered_ctx = [],- transient_ctx = [],- ghc_e = isJust maybe_exprs,- short_help = shortHelpText config,- long_help = fullHelpText config+ GHCiState{ progname = default_progname,+ GhciMonad.args = default_args,+ prompt = defPrompt config,+ prompt2 = defPrompt2 config,+ stop = default_stop,+ editor = default_editor,+ options = [],+ line_number = 1,+ break_ctr = 0,+ breaks = [],+ tickarrays = emptyModuleEnv,+ ghci_commands = availableCommands config,+ last_command = Nothing,+ cmdqueue = [],+ remembered_ctx = [],+ transient_ctx = [],+ ghc_e = isJust maybe_exprs,+ short_help = shortHelpText config,+ long_help = fullHelpText config,+ lastErrorLocations = lastErrLocationsRef } return () +resetLastErrorLocations :: GHCi ()+resetLastErrorLocations = do+ st <- getGHCiState+ liftIO $ writeIORef (lastErrorLocations st) []++ghciLogAction :: IORef [(FastString, Int)] -> LogAction+ghciLogAction lastErrLocations dflags severity srcSpan style msg = do+ defaultLogAction dflags severity srcSpan style msg+ case severity of+ SevError -> case srcSpan of+ RealSrcSpan rsp -> modifyIORef lastErrLocations+ (++ [(srcLocFile (realSrcSpanStart rsp), srcLocLine (realSrcSpanStart rsp))])+ _ -> return ()+ _ -> return ()+ withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a withGhcAppData right left = do either_dir <- tryIO (getAppUserDataDirectory "ghc")@@ -472,13 +500,18 @@ canonicalizePath' fp = liftM Just (canonicalizePath fp) `catchIO` \_ -> return Nothing - sourceConfigFile :: FilePath -> GHCi ()- sourceConfigFile file = do+ sourceConfigFile :: (FilePath, Bool) -> GHCi ()+ sourceConfigFile (file, check_perms) = do exists <- liftIO $ doesFileExist file when exists $ do- dir_ok <- liftIO $ checkPerms (getDirectory file)- file_ok <- liftIO $ checkPerms file- when (dir_ok && file_ok) $ do+ perms_ok <-+ if not check_perms+ then return True+ else do+ dir_ok <- liftIO $ checkPerms (getDirectory file)+ file_ok <- liftIO $ checkPerms file+ return (dir_ok && file_ok)+ when perms_ok $ do either_hdl <- liftIO $ tryIO (openFile file ReadMode) case either_hdl of Left _e -> return ()@@ -496,9 +529,14 @@ setGHCContextFromGHCiState when (read_dot_files) $ do- mcfgs0 <- sequence $ [ current_dir, app_user_dir, home_dir ] ++ map (return . Just ) (ghciScripts dflags)- mcfgs <- liftIO $ mapM canonicalizePath' (catMaybes mcfgs0)- mapM_ sourceConfigFile $ nub $ catMaybes mcfgs+ mcfgs0 <- catMaybes <$> sequence [ current_dir, app_user_dir, home_dir ]+ let mcfgs1 = zip mcfgs0 (repeat True)+ ++ zip (ghciScripts dflags) (repeat False)+ -- False says "don't check permissions". We don't+ -- require that a script explicitly added by+ -- -ghci-script is owned by the current user. (#6017)+ mcfgs <- liftIO $ mapM (\(f, b) -> (,b) <$> canonicalizePath' f) mcfgs1+ mapM_ sourceConfigFile $ nub $ [ (f,b) | (Just f, b) <- mcfgs ] -- nub, because we don't want to read .ghci twice if the -- CWD is $HOME. @@ -571,8 +609,9 @@ fileLoop stdin -- NOTE: We only read .ghci files if they are owned by the current user,--- and aren't world writable. Otherwise, we could be accidentally--- running code planted by a malicious third party.+-- and aren't world writable (files owned by root are ok, see #9324).+-- Otherwise, we could be accidentally running code planted by+-- a malicious third party. -- Furthermore, We only read ./.ghci if . is owned by the current user -- and isn't writable by anyone else. I think this is sufficient: we@@ -587,18 +626,14 @@ handleIO (\_ -> return False) $ do st <- getFileStatus name me <- getRealUserID- if fileOwner st /= me then do- putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"- return False- else do- let mode = System.Posix.fileMode st- if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))- || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))- then do- putStrLn $ "*** WARNING: " ++ name ++- " is writable by someone else, IGNORING!"- return False- else return True+ let mode = System.Posix.fileMode st+ ok = (fileOwner st == me || fileOwner st == 0) &&+ groupWriteMode /= mode `intersectFileModes` groupWriteMode &&+ otherWriteMode /= mode `intersectFileModes` otherWriteMode+ unless ok $+ putStrLn $ "*** WARNING: " ++ name +++ " is writable by someone else, IGNORING!"+ return ok #endif incrementLineNo :: InputT GHCi ()@@ -714,7 +749,11 @@ when (not success) $ maybe (return ()) lift sourceErrorHandler runCommands' eh sourceErrorHandler gCmd --- | Evaluate a single line of user input (either :<command> or Haskell code)+-- | Evaluate a single line of user input (either :<command> or Haskell code).+-- A result of Nothing means there was no more input to process.+-- Otherwise the result is Just b where b is True if the command succeeded;+-- this is relevant only to ghc -e, which will exit with status 1+-- if the commmand was unsuccessful. GHCi will continue in either case. runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String) -> InputT GHCi (Maybe Bool) runOneCommand eh gCmd = do@@ -725,14 +764,14 @@ case mb_cmd1 of Nothing -> return Nothing Just c -> ghciHandle (\e -> lift $ eh e >>= return . Just) $- handleSourceError printErrorAndKeepGoing+ handleSourceError printErrorAndFail (doCommand c) -- source error's are handled by runStmt -- is the handler necessary here? where- printErrorAndKeepGoing err = do+ printErrorAndFail err = do GHC.printException err- return $ Just True+ return $ Just False -- Exit ghc -e, but not GHCi noSpace q = q >>= maybe (return Nothing) (\c -> case removeSpaces c of@@ -853,7 +892,7 @@ eof <- Lexer.nextIsEOF if eof then Lexer.activeContext- else Lexer.lexer return >> goToEnd+ else Lexer.lexer False return >> goToEnd enqueueCommands :: [String] -> GHCi () enqueueCommands cmds = do@@ -861,40 +900,62 @@ setGHCiState st{ cmdqueue = cmds ++ cmdqueue st } -- | If we one of these strings prefixes a command, then we treat it as a decl--- rather than a stmt.-declPrefixes :: [String]-declPrefixes = ["class ","data ","newtype ","type ","instance ", "deriving ",- "foreign ", "default ", "default("]+-- rather than a stmt. NB that the appropriate decl prefixes depends on the+-- flag settings (Trac #9915)+declPrefixes :: DynFlags -> [String]+declPrefixes dflags = keywords ++ concat opt_keywords+ where+ keywords = [ "class ", "instance "+ , "data ", "newtype ", "type "+ , "default ", "default("+ ] --- | Entry point to execute some haskell code from user+ opt_keywords = [ ["foreign " | xopt Opt_ForeignFunctionInterface dflags]+ , ["deriving " | xopt Opt_StandaloneDeriving dflags]+ , ["pattern " | xopt Opt_PatternSynonyms dflags]+ ]++-- | Entry point to execute some haskell code from user.+-- The return value True indicates success, as in `runOneCommand`. runStmt :: String -> SingleStep -> GHCi Bool runStmt stmt step- -- empty+ -- empty; this should be impossible anyways since we filtered out+ -- whitespace-only input in runOneCommand's noSpace | null (filter (not.isSpace) stmt)- = return False+ = return True -- import- | "import " `isPrefixOf` stmt- = do addImportToContext stmt; return False-- -- data, class, newtype...- | any (flip isPrefixOf stmt) declPrefixes- = do _ <- liftIO $ tryIO $ hFlushAll stdin- result <- GhciMonad.runDecls stmt- afterRunStmt (const True) (GHC.RunOk result)+ | stmt `looks_like` "import "+ = do addImportToContext stmt; return True | otherwise- = do -- In the new IO library, read handles buffer data even if the Handle- -- is set to NoBuffering. This causes problems for GHCi where there- -- are really two stdin Handles. So we flush any bufferred data in- -- GHCi's stdin Handle here (only relevant if stdin is attached to- -- a file, otherwise the read buffer can't be flushed).- _ <- liftIO $ tryIO $ hFlushAll stdin- m_result <- GhciMonad.runStmt stmt step- case m_result of- Nothing -> return False- Just result -> afterRunStmt (const True) result+ = do dflags <- getDynFlags+ if any (stmt `looks_like`) (declPrefixes dflags)+ then run_decl+ else run_stmt+ where+ run_decl =+ do _ <- liftIO $ tryIO $ hFlushAll stdin+ result <- GhciMonad.runDecls stmt+ afterRunStmt (const True) (GHC.RunOk result) + run_stmt =+ do -- In the new IO library, read handles buffer data even if the Handle+ -- is set to NoBuffering. This causes problems for GHCi where there+ -- are really two stdin Handles. So we flush any bufferred data in+ -- GHCi's stdin Handle here (only relevant if stdin is attached to+ -- a file, otherwise the read buffer can't be flushed).+ _ <- liftIO $ tryIO $ hFlushAll stdin+ m_result <- GhciMonad.runStmt stmt step+ case m_result of+ Nothing -> return False+ Just result -> afterRunStmt (const True) result++ s `looks_like` prefix = prefix `isPrefixOf` dropWhile isSpace s+ -- Ignore leading spaces (see Trac #9914), so that+ -- ghci> data T = T+ -- (note leading spaces) works properly+ -- | Clean up the GHCi environment after a statement has run afterRunStmt :: (SrcSpan -> Bool) -> GHC.RunResult -> GHCi Bool afterRunStmt _ (GHC.RunException e) = liftIO $ Exception.throwIO e@@ -1126,9 +1187,10 @@ Left err -> liftIO (hPutStrLn stderr err) Right args -> do dflags <- getDynFlags- case mainFunIs dflags of- Nothing -> doWithArgs args "main"- Just f -> doWithArgs args f+ let main = fromMaybe "main" (mainFunIs dflags)+ -- Wrap the main function in 'void' to discard its value instead+ -- of printing it (#9086). See Haskell 2010 report Chapter 5.+ doWithArgs args $ "Control.Monad.void (" ++ main ++ ")" ----------------------------------------------------------------------------- -- :run@@ -1176,10 +1238,18 @@ editFile str = do file <- if null str then lift chooseEditFile else expandPath str st <- lift getGHCiState+ errs <- liftIO $ readIORef $ lastErrorLocations st let cmd = editor st when (null cmd) $ throwGhcException (CmdLineError "editor not set, use :set editor")- code <- liftIO $ system (cmd ++ ' ':file)+ lineOpt <- liftIO $ do+ curFileErrs <- filterM (\(f, _) -> unpackFS f `sameFile` file) errs+ return $ case curFileErrs of+ (_, line):_ -> " +" ++ show line+ _ -> ""+ let cmdArgs = ' ':(file ++ lineOpt)+ code <- liftIO $ system (cmd ++ cmdArgs)+ when (code == ExitSuccess) $ reloadModule "" @@ -1370,6 +1440,7 @@ -- the ModBreaks will have gone away. lift discardActiveBreakPoints + lift resetLastErrorLocations -- Enable buffering stdout and stderr as we're compiling. Keeping these -- handles unbuffered will just slow the compilation down, especially when -- compiling in parallel.@@ -1394,7 +1465,6 @@ modulesLoadedMsg ok loaded_mods lift $ setContextAfterLoad retain_context loaded_mod_summaries - setContextAfterLoad :: Bool -> [GHC.ModSummary] -> GHCi () setContextAfterLoad keep_ctxt [] = do setContextKeepingPackageModules keep_ctxt []@@ -1449,7 +1519,10 @@ transient_ctx = filterSubsumed new_rem_ctx trans_ctx } setGHCContextFromGHCiState -+-- | Filters a list of 'InteractiveImport', clearing out any home package+-- imports so only imports from external packages are preserved. ('IIModule'+-- counts as a home package import, because we are only able to bring a+-- full top-level into scope when the source is available.) keepPackageImports :: [InteractiveImport] -> GHCi [InteractiveImport] keepPackageImports = filterM is_pkg_import where@@ -1508,8 +1581,6 @@ CLaSH.Driver.generateHDL bindingsMap (Just backend) primMap tcm ghcTypeToHWType reduceConstant DebugNone -- makeVHDL :: [FilePath] -> InputT GHCi () makeVHDL = makeHDL' (CLaSH.Backend.initBackend :: VHDLState) @@ -1535,7 +1606,7 @@ $ do (ty, kind) <- GHC.typeKind norm str printForUser $ vcat [ text str <+> dcolon <+> pprTypeForUser kind- , ppWhen norm $ equals <+> ppr ty ]+ , ppWhen norm $ equals <+> pprTypeForUser ty ] -----------------------------------------------------------------------------@@ -1618,26 +1689,25 @@ liftIO $ putStrLn $ "Package Trust: " ++ (if packageTrustOn dflags then "On" else "Off") when (not $ null good) (liftIO $ putStrLn $ "Trusted package dependencies (trusted): " ++- (intercalate ", " $ map packageIdString good))+ (intercalate ", " $ map (showPpr dflags) good)) case msafe && null bad of True -> liftIO $ putStrLn $ mname ++ " is trusted!" False -> do when (not $ null bad) (liftIO $ putStrLn $ "Trusted package dependencies (untrusted): "- ++ (intercalate ", " $ map packageIdString bad))+ ++ (intercalate ", " $ map (showPpr dflags) bad)) liftIO $ putStrLn $ mname ++ " is NOT trusted!" where mname = GHC.moduleNameString $ GHC.moduleName m packageTrusted dflags md- | thisPackage dflags == modulePackageId md = True- | otherwise = trusted $ getPackageDetails (pkgState dflags) (modulePackageId md)+ | thisPackage dflags == modulePackageKey md = True+ | otherwise = trusted $ getPackageDetails dflags (modulePackageKey md) tallyPkgs dflags deps | not (packageTrustOn dflags) = ([], []) | otherwise = partition part deps- where state = pkgState dflags- part pkg = trusted $ getPackageDetails state pkg+ where part pkg = trusted $ getPackageDetails dflags pkg ----------------------------------------------------------------------------- -- :browse@@ -1960,9 +2030,10 @@ && (not (ideclQualified d1) || ideclQualified d2) && (ideclHiding d1 `hidingSubsumes` ideclHiding d2) where- _ `hidingSubsumes` Just (False,[]) = True- Just (False, xs) `hidingSubsumes` Just (False,ys) = all (`elem` xs) ys- h1 `hidingSubsumes` h2 = h1 == h2+ _ `hidingSubsumes` Just (False,L _ []) = True+ Just (False, L _ xs) `hidingSubsumes` Just (False,L _ ys)+ = all (`elem` xs) ys+ h1 `hidingSubsumes` h2 = h1 == h2 iiSubsumes _ _ = False @@ -2032,11 +2103,13 @@ text "warning settings:" $$ nest 2 (vcat (map (setting wopt) DynFlags.fWarningFlags)) where- setting test (str, f, _)+ setting test flag | quiet = empty- | is_on = fstr str- | otherwise = fnostr str- where is_on = test f dflags+ | is_on = fstr name+ | otherwise = fnostr name+ where name = flagSpecName flag+ f = flagSpecFlag flag+ is_on = test f dflags quiet = not show_all && test f default_dflags == is_on default_dflags = defaultDynFlags (settings dflags)@@ -2044,7 +2117,7 @@ fstr str = text "-f" <> text str fnostr str = text "-fno-" <> text str - (ghciFlags,others) = partition (\(_, f, _) -> f `elem` flgs)+ (ghciFlags,others) = partition (\f -> flagSpecFlag f `elem` flgs) DynFlags.fFlags flgs = [ Opt_PrintExplicitForalls , Opt_PrintExplicitKinds@@ -2161,6 +2234,17 @@ , pkgDatabase = pkgDatabase dflags2 , packageFlags = packageFlags dflags2 } + let ld0length = length $ ldInputs dflags0+ fmrk0length = length $ cmdlineFrameworks dflags0++ newLdInputs = drop ld0length (ldInputs dflags2)+ newCLFrameworks = drop fmrk0length (cmdlineFrameworks dflags2)++ when (not (null newLdInputs && null newCLFrameworks)) $+ liftIO $ linkCmdLineLibs $+ dflags2 { ldInputs = newLdInputs+ , cmdlineFrameworks = newCLFrameworks }+ return () @@ -2182,6 +2266,7 @@ ] no_flag ('-':'f':rest) = return ("-fno-" ++ rest)+ no_flag ('-':'X':rest) = return ("-XNo" ++ rest) no_flag f = throwGhcException (ProgramError ("don't know how to reverse " ++ f)) in if (not (null rest3))@@ -2345,15 +2430,9 @@ showPackages = do dflags <- getDynFlags let pkg_flags = packageFlags dflags- liftIO $ putStrLn $ showSDoc dflags $ vcat $- text ("active package flags:"++if null pkg_flags then " none" else "")- : map showFlag pkg_flags- where showFlag (ExposePackage p) = text $ " -package " ++ p- showFlag (HidePackage p) = text $ " -hide-package " ++ p- showFlag (IgnorePackage p) = text $ " -ignore-package " ++ p- showFlag (ExposePackageId p) = text $ " -package-id " ++ p- showFlag (TrustPackage p) = text $ " -trust " ++ p- showFlag (DistrustPackage p) = text $ " -distrust " ++ p+ liftIO $ putStrLn $ showSDoc dflags $+ text ("active package flags:"++if null pkg_flags then " none" else "") $$+ nest 2 (vcat (map pprFlag pkg_flags)) showPaths :: GHCi () showPaths = do@@ -2387,11 +2466,13 @@ nest 2 (vcat (map (setting xopt) DynFlags.xFlags)) ] where- setting test (str, f, _)+ setting test flag | quiet = empty- | is_on = text "-X" <> text str- | otherwise = text "-XNo" <> text str- where is_on = test f dflags+ | is_on = text "-X" <> text name+ | otherwise = text "-XNo" <> text name+ where name = flagSpecName flag+ f = flagSpecFlag flag+ is_on = test f dflags quiet = not show_all && test f default_dflags == is_on default_dflags =@@ -2488,7 +2569,7 @@ completeModule = wrapIdentCompleter $ \w -> do dflags <- GHC.getSessionDynFlags- let pkg_mods = allExposedModules dflags+ let pkg_mods = allVisibleModules dflags loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules return $ filter (w `isPrefixOf`) $ map (showPpr dflags) $ loaded_mods ++ pkg_mods@@ -2500,7 +2581,7 @@ imports <- GHC.getContext return $ map iiModuleName imports _ -> do- let pkg_mods = allExposedModules dflags+ let pkg_mods = allVisibleModules dflags loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules return $ loaded_mods ++ pkg_mods return $ filter (w `isPrefixOf`) $ map (showPpr dflags) modules@@ -2545,22 +2626,21 @@ wrapCompleter :: String -> (String -> GHCi [String]) -> CompletionFunc GHCi wrapCompleter breakChars fun = completeWord Nothing breakChars- $ fmap (map simpleCompletion) . fmap sort . fun+ $ fmap (map simpleCompletion . nubSort) . fun wrapIdentCompleter :: (String -> GHCi [String]) -> CompletionFunc GHCi wrapIdentCompleter = wrapCompleter word_break_chars wrapIdentCompleterWithModifier :: String -> (Maybe Char -> String -> GHCi [String]) -> CompletionFunc GHCi wrapIdentCompleterWithModifier modifChars fun = completeWordWithPrev Nothing word_break_chars- $ \rest -> fmap (map simpleCompletion) . fmap sort . fun (getModifier rest)+ $ \rest -> fmap (map simpleCompletion . nubSort) . fun (getModifier rest) where getModifier = find (`elem` modifChars) -allExposedModules :: DynFlags -> [ModuleName]-allExposedModules dflags- = concat (map exposedModules (filter exposed (eltsUFM pkg_db)))- where- pkg_db = pkgIdMap (pkgState dflags)+-- | Return a list of visible module names for autocompletion.+-- (NB: exposed != visible)+allVisibleModules :: DynFlags -> [ModuleName]+allVisibleModules dflags = listVisibleModuleNames dflags completeExpression = completeQuotedWord (Just '\\') "\"" listFiles completeIdentifier@@ -2944,7 +3024,8 @@ listAround :: MonadIO m => RealSrcSpan -> Bool -> InputT m () listAround pan do_highlight = do contents <- liftIO $ BS.readFile (unpackFS file)- let ls = BS.split '\n' contents+ -- Drop carriage returns to avoid duplicates, see #9367.+ let ls = BS.split '\n' $ BS.filter (/= '\r') contents ls' = take (line2 - line1 + 1 + pad_before + pad_after) $ drop (line1 - 1 - pad_before) $ ls fst_line = max 1 (line1 - pad_before)@@ -3143,7 +3224,7 @@ lookupModuleName mName = GHC.lookupModule mName Nothing isHomeModule :: Module -> Bool-isHomeModule m = GHC.modulePackageId m == mainPackageId+isHomeModule m = GHC.modulePackageKey m == mainPackageKey -- TODO: won't work if home dir is encoded. -- (changeDirectory may not work either in that case.)@@ -3159,6 +3240,12 @@ other -> return other +sameFile :: FilePath -> FilePath -> IO Bool+sameFile path1 path2 = do+ absPath1 <- canonicalizePath path1+ absPath2 <- canonicalizePath path2+ return $ absPath1 == absPath2+ wantInterpretedModule :: GHC.GhcMonad m => String -> m Module wantInterpretedModule str = wantInterpretedModuleName (GHC.mkModuleName str) @@ -3167,7 +3254,7 @@ modl <- lookupModuleName modname let str = moduleNameString modname dflags <- getDynFlags- when (GHC.modulePackageId modl /= thisPackage dflags) $+ when (GHC.modulePackageKey modl /= thisPackage dflags) $ throwGhcException (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module")) is_interpreted <- GHC.moduleIsInterpreted modl when (not is_interpreted) $
src-bin/Main.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP, NondecreasingIndentation, TupleSections #-} {-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-} -----------------------------------------------------------------------------@@ -32,7 +33,7 @@ import Config import Constants import HscTypes-import Packages ( dumpPackages )+import Packages ( pprPackages, pprPackagesSimple, pprModuleMap ) import DriverPhases import BasicTypes ( failed ) import StaticFlags@@ -106,9 +107,7 @@ main :: IO () main = do-#if MIN_VERSION_ghc(7,8,3)- initGCStatistics-#endif+ initGCStatistics -- See Note [-Bsymbolic and hooks] hSetBuffering stdout LineBuffering hSetBuffering stderr LineBuffering GHC.defaultErrorHandler defaultFatalMessager defaultFlushOut $ do@@ -135,10 +134,10 @@ case mode of Left preStartupMode -> do case preStartupMode of- ShowSupportedExtensions -> showSupportedExtensions- ShowVersion -> showVersion- ShowNumVersion -> putStrLn (Data.Version.showVersion Paths_clash_ghc.version)- ShowOptions -> showOptions+ ShowSupportedExtensions -> showSupportedExtensions+ ShowVersion -> showVersion+ ShowNumVersion -> putStrLn (Data.Version.showVersion Paths_clash_ghc.version)+ ShowOptions isInteractive -> showOptions isInteractive Right postStartupMode -> -- start our GHC session GHC.runGhc (Just libDir) $ do@@ -154,21 +153,28 @@ , DynFlags.Opt_ConstraintKinds , DynFlags.Opt_TypeFamilies ]- dflagsExtra' = foldl DynFlags.xopt_unset dflagsExtra+ dflagsExtra1 = foldl DynFlags.xopt_unset dflagsExtra [ DynFlags.Opt_ImplicitPrelude , DynFlags.Opt_MonomorphismRestriction ] + ghcTyLitNormPlugin = GHC.mkModuleName "GHC.TypeLits.Normalise"+ dflagsExtra2 = dflagsExtra1+ { DynFlags.pluginModNames = nub $+ ghcTyLitNormPlugin : DynFlags.pluginModNames dflagsExtra1+ }++ case postStartupMode of Left preLoadMode -> liftIO $ do case preLoadMode of- ShowInfo -> showInfo dflags- ShowGhcUsage -> showGhcUsage dflags- ShowGhciUsage -> showGhciUsage dflags- PrintWithDynFlags f -> putStrLn (f dflags)+ ShowInfo -> showInfo dflagsExtra2+ ShowGhcUsage -> showGhcUsage dflagsExtra2+ ShowGhciUsage -> showGhciUsage dflagsExtra2+ PrintWithDynFlags f -> putStrLn (f dflagsExtra2) Right postLoadMode ->- main' postLoadMode dflagsExtra' argv3 flagWarnings+ main' postLoadMode dflagsExtra2 argv3 flagWarnings main' :: PostLoadMode -> DynFlags -> [Located String] -> [Located String] -> Ghc ()@@ -253,30 +259,36 @@ hsc_env <- GHC.getSession ---------------- Display configuration ------------ when (verbosity dflags6 >= 4) $- liftIO $ dumpPackages dflags6+ case verbosity dflags6 of+ v | v == 4 -> liftIO $ dumpPackagesSimple dflags6+ | v >= 5 -> liftIO $ dumpPackages dflags6+ | otherwise -> return () when (verbosity dflags6 >= 3) $ do liftIO $ hPutStrLn stderr ("Hsc static flags: " ++ unwords staticFlags) ++ when (dopt Opt_D_dump_mod_map dflags6) . liftIO $+ printInfoForUser (dflags6 { pprCols = 200 })+ (pkgQual dflags6) (pprModuleMap dflags6)+ ---------------- Final sanity checking ----------- liftIO $ checkOptions postLoadMode dflags6 srcs objs ---------------- Do the business ------------ handleSourceError- (\e -> do- GHC.printException e- liftIO $ exitWith (ExitFailure 1))- $ do- let clash fun = gcatch (fun srcs) (\(ErrorCall e) -> throwOneError $ mkPlainErrMsg dflags6 noSrcSpan (text ("CLaSH Error:\n" ++ e)))- case postLoadMode of+ handleSourceError (\e -> do+ GHC.printException e+ liftIO $ exitWith (ExitFailure 1)) $ do+ let clash fun = gcatch (fun srcs) (\(ErrorCall e) -> throwOneError $ mkPlainErrMsg dflags6 noSrcSpan (text ("CLaSH Error:\n" ++ e)))+ case postLoadMode of ShowInterface f -> liftIO $ doShowIface dflags6 f DoMake -> doMake srcs DoMkDependHS -> doMkDependHS (map fst srcs) StopBefore p -> liftIO (oneShot hsc_env p srcs) DoInteractive -> ghciUI srcs Nothing DoEval exprs -> ghciUI srcs $ Just $ reverse exprs- DoAbiHash -> abiHash srcs+ DoAbiHash -> abiHash (map fst srcs)+ ShowPackages -> liftIO $ showPackages dflags6 DoVHDL -> clash makeVHDL DoSystemVerilog -> clash makeSystemVerilog @@ -386,16 +398,16 @@ -- Compiler output options --- called to verify that the output files & directories--- point somewhere valid.+-- Called to verify that the output files point somewhere valid. -- -- The assumption is that the directory portion of these output -- options will have to exist by the time 'verifyOutputFiles' -- is invoked. --+-- We create the directories for -odir, -hidir, -outputdir etc. ourselves if+-- they don't exist, so don't check for those here (#2278). verifyOutputFiles :: DynFlags -> IO () verifyOutputFiles dflags = do- -- not -odir: we create the directory for -odir if it doesn't exist (#2278). let ofile = outputFile dflags when (isJust ofile) $ do let fn = fromJust ofile@@ -419,16 +431,16 @@ type PostStartupMode = Either PreLoadMode PostLoadMode data PreStartupMode- = ShowVersion -- ghc -V/--version- | ShowNumVersion -- ghc --numeric-version- | ShowSupportedExtensions -- ghc --supported-extensions- | ShowOptions -- ghc --show-options+ = ShowVersion -- ghc -V/--version+ | ShowNumVersion -- ghc --numeric-version+ | ShowSupportedExtensions -- ghc --supported-extensions+ | ShowOptions Bool {- isInteractive -} -- ghc --show-options showVersionMode, showNumVersionMode, showSupportedExtensionsMode, showOptionsMode :: Mode showVersionMode = mkPreStartupMode ShowVersion showNumVersionMode = mkPreStartupMode ShowNumVersion showSupportedExtensionsMode = mkPreStartupMode ShowSupportedExtensions-showOptionsMode = mkPreStartupMode ShowOptions+showOptionsMode = mkPreStartupMode (ShowOptions False) mkPreStartupMode :: PreStartupMode -> Mode mkPreStartupMode = Left@@ -477,14 +489,17 @@ | DoInteractive -- ghc --interactive | DoEval [String] -- ghc -e foo -e bar => DoEval ["bar", "foo"] | DoAbiHash -- ghc --abi-hash+ | ShowPackages -- ghc --show-packages | DoVHDL -- ghc --vhdl | DoSystemVerilog -- ghc --systemverilog -doMkDependHSMode, doMakeMode, doInteractiveMode, doAbiHashMode, doVHDLMode, doSystemVerilogMode :: Mode+doMkDependHSMode, doMakeMode, doInteractiveMode,+ doAbiHashMode, showPackagesMode, doVHDLMode, doSystemVerilogMode :: Mode doMkDependHSMode = mkPostLoadMode DoMkDependHS doMakeMode = mkPostLoadMode DoMake doInteractiveMode = mkPostLoadMode DoInteractive doAbiHashMode = mkPostLoadMode DoAbiHash+showPackagesMode = mkPostLoadMode ShowPackages doVHDLMode = mkPostLoadMode DoVHDL doSystemVerilogMode = mkPostLoadMode DoSystemVerilog @@ -544,12 +559,12 @@ isLinkMode _ = False isCompManagerMode :: PostLoadMode -> Bool-isCompManagerMode DoMake = True-isCompManagerMode DoInteractive = True-isCompManagerMode (DoEval _) = True+isCompManagerMode DoMake = True+isCompManagerMode DoInteractive = True+isCompManagerMode (DoEval _) = True isCompManagerMode DoVHDL = True isCompManagerMode DoSystemVerilog = True-isCompManagerMode _ = False+isCompManagerMode _ = False -- ----------------------------------------------------------------------------- -- Parsing the mode flag@@ -565,8 +580,11 @@ mode = case mModeFlag of Nothing -> doMakeMode Just (m, _) -> m- errs = errs1 ++ map (mkGeneralLocated "on the commandline") errs2- when (not (null errs)) $ throwGhcException $ errorsToGhcException errs++ -- See Note [Handling errors when parsing commandline flags]+ unless (null errs1 && null errs2) $ throwGhcException $ errorsToGhcException $+ map (("on the commandline", )) $ map unLoc errs1 ++ errs2+ return (mode, flags' ++ leftover, warns) type ModeM = CmdLineP (Maybe (Mode, String), [String], [Located String])@@ -576,18 +594,20 @@ mode_flags :: [Flag ModeM] mode_flags = [ ------- help / version ----------------------------------------------- Flag "?" (PassFlag (setMode showGhcUsageMode))- , Flag "-help" (PassFlag (setMode showGhcUsageMode))- , Flag "V" (PassFlag (setMode showVersionMode))- , Flag "-version" (PassFlag (setMode showVersionMode))- , Flag "-numeric-version" (PassFlag (setMode showNumVersionMode))- , Flag "-info" (PassFlag (setMode showInfoMode))- , Flag "-show-options" (PassFlag (setMode showOptionsMode))- , Flag "-supported-languages" (PassFlag (setMode showSupportedExtensionsMode))- , Flag "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode))+ defFlag "?" (PassFlag (setMode showGhcUsageMode))+ , defFlag "-help" (PassFlag (setMode showGhcUsageMode))+ , defFlag "V" (PassFlag (setMode showVersionMode))+ , defFlag "-version" (PassFlag (setMode showVersionMode))+ , defFlag "-numeric-version" (PassFlag (setMode showNumVersionMode))+ , defFlag "-info" (PassFlag (setMode showInfoMode))+ , defFlag "-show-options" (PassFlag (setMode showOptionsMode))+ , defFlag "-supported-languages" (PassFlag (setMode showSupportedExtensionsMode))+ , defFlag "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode))+ , defFlag "-show-packages" (PassFlag (setMode showPackagesMode)) ] ++- [ Flag k' (PassFlag (setMode (printSetting k)))+ [ defFlag k' (PassFlag (setMode (printSetting k))) | k <- ["Project version",+ "Project Git commit id", "Booter version", "Stage", "Build platform",@@ -612,26 +632,22 @@ replaceSpace c = c ] ++ ------- interfaces ----------------------------------------------------- [ Flag "-show-iface" (HasArg (\f -> setMode (showInterfaceMode f)+ [ defFlag "-show-iface" (HasArg (\f -> setMode (showInterfaceMode f) "--show-iface")) ------- primary modes ------------------------------------------------- , Flag "c" (PassFlag (\f -> do setMode (stopBeforeMode StopLn) f- addFlag "-no-link" f))- , Flag "M" (PassFlag (setMode doMkDependHSMode))- , Flag "E" (PassFlag (setMode (stopBeforeMode anyHsc)))- , Flag "C" (PassFlag (setMode (stopBeforeMode HCc)))-#if MIN_VERSION_ghc(7,8,3)- , Flag "S" (PassFlag (setMode (stopBeforeMode (As False))))-#else- , Flag "S" (PassFlag (setMode (stopBeforeMode As)))-#endif- , Flag "-make" (PassFlag (setMode doMakeMode))- , Flag "-interactive" (PassFlag (setMode doInteractiveMode))- , Flag "-abi-hash" (PassFlag (setMode doAbiHashMode))- , Flag "e" (SepArg (\s -> setMode (doEvalMode s) "-e"))- , Flag "-vhdl" (PassFlag (setMode doVHDLMode))- , Flag "-systemverilog" (PassFlag (setMode doSystemVerilogMode))+ , defFlag "c" (PassFlag (\f -> do setMode (stopBeforeMode StopLn) f+ addFlag "-no-link" f))+ , defFlag "M" (PassFlag (setMode doMkDependHSMode))+ , defFlag "E" (PassFlag (setMode (stopBeforeMode anyHsc)))+ , defFlag "C" (PassFlag (setMode (stopBeforeMode HCc)))+ , defFlag "S" (PassFlag (setMode (stopBeforeMode (As False))))+ , defFlag "-make" (PassFlag (setMode doMakeMode))+ , defFlag "-interactive" (PassFlag (setMode doInteractiveMode))+ , defFlag "-abi-hash" (PassFlag (setMode doAbiHashMode))+ , defFlag "e" (SepArg (\s -> setMode (doEvalMode s) "-e"))+ , defFlag "-vhdl" (PassFlag (setMode doVHDLMode))+ , defFlag "-systemverilog" (PassFlag (setMode doSystemVerilogMode)) ] setMode :: Mode -> String -> EwM ModeM ()@@ -665,6 +681,14 @@ errs) -- Saying e.g. --interactive --interactive is OK _ | oldFlag == newFlag -> ((oldMode, oldFlag), errs)++ -- --interactive and --show-options are used together+ (Right (Right DoInteractive), Left (ShowOptions _)) ->+ ((Left (ShowOptions True),+ "--interactive --show-options"), errs)+ (Left (ShowOptions _), (Right (Right DoInteractive))) ->+ ((Left (ShowOptions True),+ "--show-options --interactive"), errs) -- Otherwise, complain _ -> let err = flagMismatchErr oldFlag newFlag in ((oldMode, oldFlag), err : errs)@@ -694,12 +718,8 @@ haskellish (f,Nothing) = looksLikeModuleName f || isHaskellUserSrcFilename f || '.' `notElem` f haskellish (_,Just phase) =-#if MIN_VERSION_ghc(7,8,3) phase `notElem` [ As True, As False, Cc, Cobjc, Cobjcpp, CmmCpp, Cmm , StopLn]-#else- phase `notElem` [As, Cc, Cobjc, Cobjcpp, CmmCpp, Cmm, StopLn]-#endif hsc_env <- GHC.getSession @@ -773,20 +793,22 @@ , ")" ] -showOptions :: IO ()-showOptions = putStr (unlines availableOptions)+showOptions :: Bool -> IO ()+showOptions isInteractive = putStr (unlines availableOptions) where- availableOptions = map ((:) '-') $- getFlagNames mode_flags ++- getFlagNames flagsDynamic ++- (filterUnwantedStatic . getFlagNames $ flagsStatic) ++- flagsStaticNames- getFlagNames opts = map getFlagName opts- getFlagName (Flag name _) = name+ availableOptions = concat [+ flagsForCompletion isInteractive,+ map ('-':) (concat [+ getFlagNames mode_flags+ , (filterUnwantedStatic . getFlagNames $ flagsStatic)+ , flagsStaticNames+ ])+ ]+ getFlagNames opts = map flagName opts -- this is a hack to get rid of two unwanted entries that get listed -- as static flags. Hopefully this hack will disappear one day together -- with static flags- filterUnwantedStatic = filter (\x -> not (x `elem` ["f", "fno-"]))+ filterUnwantedStatic = filter (`notElem`["f", "fno-"]) showGhcUsage :: DynFlags -> IO () showGhcUsage = showUsage False@@ -839,6 +861,11 @@ in countFS entries' longest' (has_z + has_zs) bs +showPackages, dumpPackages, dumpPackagesSimple :: DynFlags -> IO ()+showPackages dflags = putStrLn (showSDoc dflags (pprPackages dflags))+dumpPackages dflags = putMsg dflags (pprPackages dflags)+dumpPackagesSimple dflags = putMsg dflags (pprPackagesSimple dflags)+ -- ----------------------------------------------------------------------------- -- ABI hash support @@ -855,7 +882,13 @@ to get a hash of the package's ABI. -} -abiHash :: [(String, Maybe Phase)] -> Ghc ()+-- | Print ABI hash of input modules.+--+-- The resulting hash is the MD5 of the GHC version used (Trac #5328,+-- see 'hiVersion') and of the existing ABI hash from each module (see+-- 'mi_mod_hash').+abiHash :: [String] -- ^ List of module names+ -> Ghc () abiHash strs = do hsc_env <- getSession let dflags = hsc_dflags hsc_env@@ -870,7 +903,7 @@ _error -> throwGhcException $ CmdLineError $ showSDoc dflags $ cannotFindInterface dflags modname r - mods <- mapM find_it (map fst strs)+ mods <- mapM find_it strs let get_iface modl = loadUserInterface False (text "abiHash") modl ifaces <- initIfaceCheck hsc_env $ mapM get_iface mods@@ -916,17 +949,18 @@ ld`). When dynamically linking, we don't use -Bsymbolic on the RTS package: that is because we want hooks to be overridden by the user, we don't want to constrain them to the RTS package.+ Unfortunately this seems to have broken somehow on OS X: as a result, defaultHooks (in hschooks.c) is not called, which does not initialize the GC stats. As a result, this breaks things like `:set +s` in GHCi (#8754). As a hacky workaround, we instead call 'defaultHooks' directly to initalize the flags in the RTS.-A biproduct of this, I believe, is that hooks are likely broken on OS++A byproduct of this, I believe, is that hooks are likely broken on OS X when dynamically linking. But this probably doesn't affect most people since we're linking GHC dynamically, but most things themselves link statically. -}-#if MIN_VERSION_ghc(7,8,3)+ foreign import ccall safe "initGCStatistics" initGCStatistics :: IO ()-#endif
src-bin/PosixSource.h view
@@ -20,7 +20,7 @@ #define _XOPEN_SOURCE 500 // FreeBSD takes a different approach to _ISOC99_SOURCE: on FreeBSD it // means "I want *just* C99 things", whereas on GNU libc and Solaris-// it means "I also want C99 things". +// it means "I also want C99 things". // // On both GNU libc and FreeBSD, _ISOC99_SOURCE is implied by // _XOPEN_SOURCE==600, but on Solaris it is an error to omit it.
src-bin/hschooks.c view
@@ -40,15 +40,12 @@ #endif RtsFlags.GcFlags.maxStkSize = 512*1024*1024 / sizeof(W_);- RtsFlags.GcFlags.giveStats = COLLECT_GC_STATS; + initGCStatistics();+ // See #3408: the default idle GC time of 0.3s is too short on // Windows where we receive console events once per second or so.-#if __GLASGOW_HASKELL__ >= 703 RtsFlags.GcFlags.idleGCDelayTime = SecondsToTime(5);-#else- RtsFlags.GcFlags.idleGCDelayTime = 5*1000;-#endif } void
− src-ghc/CLaSH/GHC/Compat/DynFlags.hs
@@ -1,37 +0,0 @@-{-# LANGUAGE CPP #-}-module CLaSH.GHC.Compat.DynFlags where--#if __GLASGOW_HASKELL__ >= 707-import DynFlags (DynFlags,GeneralFlag)-#else-import DynFlags (DynFlags,DynFlag)-#endif-import qualified DynFlags--dopt_unset ::- DynFlags-#if __GLASGOW_HASKELL__ >= 707- -> GeneralFlag-#else- -> DynFlag-#endif- -> DynFlags-#if __GLASGOW_HASKELL__ >= 707-dopt_unset = DynFlags.gopt_unset-#else-dopt_unset = DynFlags.dopt_unset-#endif--dopt_set ::- DynFlags-#if __GLASGOW_HASKELL__ >= 707- -> GeneralFlag-#else- -> DynFlag-#endif- -> DynFlags-#if __GLASGOW_HASKELL__ >= 707-dopt_set = DynFlags.gopt_set-#else-dopt_set = DynFlags.dopt_set-#endif
− src-ghc/CLaSH/GHC/Compat/FastString.hs
@@ -1,28 +0,0 @@-{-# LANGUAGE CPP #-}-module CLaSH.GHC.Compat.FastString- ( unpackFS- , unpackFB- )-where--import qualified FastString--#if __GLASGOW_HASKELL__ >= 707-import Data.ByteString-import Data.ByteString.Char8 as Char8 (unpack)-#endif--#if __GLASGOW_HASKELL__ == 706-unpackFS :: FastString.FastBytes -> String-unpackFS = FastString.unpackFS- . FastString.mkFastStringByteList- . FastString.bytesFB-#endif--#if __GLASGOW_HASKELL__ >= 707-unpackFS :: FastString.FastString -> String-unpackFS = FastString.unpackFS--unpackFB :: ByteString -> String-unpackFB = Char8.unpack-#endif
− src-ghc/CLaSH/GHC/Compat/GHC.hs
@@ -1,20 +0,0 @@-{-# LANGUAGE CPP #-}-module CLaSH.GHC.Compat.GHC- ( defaultErrorHandler- )-where--import qualified DynFlags-import qualified Exception-import qualified GHC-import qualified MonadUtils--defaultErrorHandler ::- (Exception.ExceptionMonad m, MonadUtils.MonadIO m)- => m a- -> m a-#if __GLASGOW_HASKELL__ >= 706-defaultErrorHandler = GHC.defaultErrorHandler DynFlags.defaultFatalMessager DynFlags.defaultFlushOut-#else-defaultErrorHandler = GHC.defaultErrorHandler DynFlags.defaultLogAction-#endif
− src-ghc/CLaSH/GHC/Compat/Outputable.hs
@@ -1,28 +0,0 @@-{-# LANGUAGE CPP #-}-module CLaSH.GHC.Compat.Outputable- ( showPpr, showSDoc, showPprDebug )-where--#if __GLASGOW_HASKELL__ >= 707-import qualified DynFlags (unsafeGlobalDynFlags)-#elif __GLASGOW_HASKELL__ >= 706-import qualified DynFlags (tracingDynFlags)-#endif-import qualified Outputable (Outputable (..), SDoc, showPpr, showSDoc, showSDocDebug)--showSDoc :: Outputable.SDoc -> String-#if __GLASGOW_HASKELL__ >= 707-showSDoc = Outputable.showSDoc DynFlags.unsafeGlobalDynFlags-#endif--showPprDebug :: Outputable.Outputable a => a -> String-showPprDebug = Outputable.showSDocDebug DynFlags.unsafeGlobalDynFlags . Outputable.ppr--showPpr :: (Outputable.Outputable a) => a -> String-#if __GLASGOW_HASKELL__ >= 707-showPpr = Outputable.showPpr DynFlags.unsafeGlobalDynFlags-#elif __GLASGOW_HASKELL__ >= 706-showPpr = Outputable.showPpr DynFlags.tracingDynFlags-#else-showPpr = Outputable.showPpr-#endif
− src-ghc/CLaSH/GHC/Compat/PrelNames.hs
@@ -1,15 +0,0 @@-{-# LANGUAGE CPP #-}-module CLaSH.GHC.Compat.PrelNames- ( tySuperKindTyConKey- )-where--import qualified Unique-import qualified PrelNames--tySuperKindTyConKey :: Unique.Unique-#if __GLASGOW_HASKELL__ >= 706-tySuperKindTyConKey = PrelNames.superKindTyConKey-#else-tySuperKindTyConKey = PrelNames.tySuperKindTyConKey-#endif
− src-ghc/CLaSH/GHC/Compat/TyCon.hs
@@ -1,17 +0,0 @@-{-# LANGUAGE CPP #-}-module CLaSH.GHC.Compat.TyCon- (isSuperKindTyCon- )-where--import qualified TyCon-#if __GLASGOW_HASKELL__ >= 706-import qualified Kind-#endif--isSuperKindTyCon :: TyCon.TyCon -> Bool-#if __GLASGOW_HASKELL__ >= 706-isSuperKindTyCon = Kind.isSuperKindTyCon-#else-isSuperKindTyCon = TyCon.isSuperKindTyCon-#endif
src-ghc/CLaSH/GHC/GHC2Core.hs view
@@ -19,6 +19,7 @@ import Control.Lens ((^.), (%~), (&), (%=)) import Control.Monad.State (State) import qualified Control.Monad.State.Lazy as State+import qualified Data.ByteString.Char8 as Char8 import Data.Hashable (Hashable (..)) import Data.HashMap.Lazy (HashMap) import qualified Data.HashMap.Lazy as HashMap@@ -33,46 +34,43 @@ import qualified Unbound.Generics.LocallyNameless as Unbound -- GHC API-import CLaSH.GHC.Compat.FastString (unpackFB, unpackFS)-import CLaSH.GHC.Compat.Outputable (showPpr)-import CLaSH.GHC.Compat.TyCon (isSuperKindTyCon)-#if __GLASGOW_HASKELL__ < 710-import Coercion (Coercion(..), coercionType)-#else-import Coercion (coercionType)-#endif-import CoreFVs (exprSomeFreeVars)-import CoreSyn (AltCon (..), Bind (..), CoreExpr,- Expr (..), rhssOfAlts)-import DataCon (DataCon, dataConExTyVars,- dataConName, dataConRepArgTys,- dataConTag, dataConTyCon,- dataConUnivTyVars, dataConWorkId,- dataConWrapId_maybe)-import FamInstEnv (FamInst (..), FamInstEnvs,- familyInstances)-import Id (isDataConId_maybe)-import IdInfo (IdDetails (..))-import Literal (Literal (..))-import Module (moduleName, moduleNameString)-import Name (Name, nameModule_maybe,- nameOccName, nameUnique)-import OccName (occNameString)-import TyCon (AlgTyConRhs (..), TyCon,- algTyConRhs, isAlgTyCon,- isFunTyCon, isNewTyCon,- isPrimTyCon,- isSynTyCon, isTupleTyCon,- tcExpandTyCon_maybe, tyConArity,- tyConDataCons, tyConKind,- tyConName, tyConUnique)-import Type (mkTopTvSubst, substTy, tcView)-import TypeRep (TyLit (..), Type (..))-import Unique (Uniquable (..), Unique, getKey)-import Var (Id, TyVar, Var, idDetails,- isTyVar, varName, varType,- varUnique)-import VarSet (isEmptyVarSet)+import Coercion (coercionType)+import CoreFVs (exprSomeFreeVars)+import CoreSyn (AltCon (..), Bind (..), CoreExpr,+ Expr (..), rhssOfAlts)+import DataCon (DataCon, dataConExTyVars,+ dataConName, dataConRepArgTys,+ dataConTag, dataConTyCon,+ dataConUnivTyVars, dataConWorkId,+ dataConWrapId_maybe)+import DynFlags (unsafeGlobalDynFlags)+import FamInstEnv (FamInst (..), FamInstEnvs,+ familyInstances)+import FastString (unpackFS)+import Id (isDataConId_maybe)+import IdInfo (IdDetails (..))+import Kind (isSuperKindTyCon)+import Literal (Literal (..))+import Module (moduleName, moduleNameString)+import Name (Name, nameModule_maybe,+ nameOccName, nameUnique)+import OccName (occNameString)+import Outputable (showPpr, showSDoc)+import PprCore (pprCoreExpr)+import TyCon (AlgTyConRhs (..), TyCon,+ algTyConRhs, isAlgTyCon, isFamilyTyCon,+ isFunTyCon, isNewTyCon,+ isPrimTyCon, isTupleTyCon,+ tcExpandTyCon_maybe, tyConArity,+ tyConDataCons, tyConKind,+ tyConName, tyConUnique)+import Type (mkTopTvSubst, substTy, tcView)+import TypeRep (TyLit (..), Type (..))+import Unique (Uniquable (..), Unique, getKey)+import Var (Id, TyVar, Var, idDetails,+ isTyVar, varName, varType,+ varUnique)+import VarSet (isEmptyVarSet) -- Local imports import qualified CLaSH.Core.DataCon as C@@ -119,9 +117,9 @@ makeTyCon fiEnvs tc = tycon where tycon+ | isFamilyTyCon tc = mkFunTyCon | isTupleTyCon tc = mkTupleTyCon | isAlgTyCon tc = mkAlgTyCon- | isSynTyCon tc = mkFunTyCon | isPrimTyCon tc = mkPrimTyCon | isSuperKindTyCon tc = mkSuperKindTyCon | otherwise = mkVoidTyCon@@ -303,7 +301,7 @@ coreToLiteral :: Literal -> C.Literal coreToLiteral l = case l of- MachStr fs -> C.StringLiteral (unpackFB fs)+ MachStr fs -> C.StringLiteral (Char8.unpack fs) MachChar c -> C.StringLiteral [c] MachInt i -> C.IntegerLiteral i MachInt64 i -> C.IntegerLiteral i@@ -313,7 +311,13 @@ MachFloat r -> C.RationalLiteral r MachDouble r -> C.RationalLiteral r MachNullAddr -> C.StringLiteral []- _ -> error $ $(curLoc) ++ "Can't convert literal: " ++ showPpr l ++ " in expression: " ++ showPpr coreExpr+ _ -> error $ concat [ $(curLoc)+ , "Can't convert literal: "+ , showPpr unsafeGlobalDynFlags l+ , " in expression: "+ , showSDoc unsafeGlobalDynFlags+ (pprCoreExpr coreExpr)+ ] coreToDataCon :: Bool -> DataCon@@ -323,7 +327,11 @@ dcTy <- if mkWrap then case dataConWrapId_maybe dc of Just wrapId -> coreToType (varType wrapId)- Nothing -> error $ $(curLoc) ++ "DataCon Wrapper: " ++ showPpr dc ++ " not found"+ Nothing -> error $ concat [ $(curLoc)+ , "DataCon Wrapper: "+ , showPpr unsafeGlobalDynFlags dc+ , " not found"+ ] else coreToType (varType $ dataConWorkId dc) mkDc dcTy repTys where
src-ghc/CLaSH/GHC/LoadInterfaceFiles.hs view
@@ -7,16 +7,16 @@ where -- External Modules-import Data.Either (partitionEithers)-import Data.List (elemIndex, partition)-import Data.Maybe (isJust, isNothing)+import Data.Either (partitionEithers)+import Data.List (elemIndex, partition)+import Data.Maybe (isJust, isNothing) -- GHC API import qualified BasicTypes-import CLaSH.GHC.Compat.Outputable (showPpr, showSDoc) import qualified Class import qualified CoreFVs import qualified CoreSyn+import DynFlags (unsafeGlobalDynFlags) import qualified GHC import qualified Id import qualified IdInfo@@ -26,7 +26,7 @@ import qualified MkCore import qualified MonadUtils import qualified Name-import Outputable (text)+import Outputable (showPpr, showSDoc, text) import qualified TcIface import qualified TcRnMonad import qualified TcRnTypes@@ -35,7 +35,7 @@ import qualified VarSet -- Internal Modules-import CLaSH.Util (curLoc, traceIf)+import CLaSH.Util (curLoc, traceIf) runIfl :: GHC.GhcMonad m => GHC.Module -> TcRnTypes.IfL a -> m a runIfl modName action = do@@ -54,7 +54,13 @@ ifaceFailM <- LoadIface.findAndReadIface (Outputable.text "loadIface") foundMod False case ifaceFailM of Maybes.Succeeded (modInfo,_) -> return (Just modInfo)- Maybes.Failed msg -> traceIf True ($(curLoc) ++ "Failed to load interface for module: " ++ showPpr foundMod ++ "\nReason: " ++ showSDoc msg) $ return Nothing+ Maybes.Failed msg -> let msg' = concat [ $(curLoc)+ , "Failed to load interface for module: "+ , showPpr unsafeGlobalDynFlags foundMod+ , "\nReason: "+ , showSDoc unsafeGlobalDynFlags msg+ ]+ in traceIf True msg' (return Nothing) loadExternalExprs :: GHC.GhcMonad m
src-ghc/CLaSH/GHC/LoadModules.hs view
@@ -12,10 +12,9 @@ import System.IO (hGetLine) import System.Process (runInteractiveCommand, waitForProcess)+import Data.List (nub) -- GHC API-import CLaSH.GHC.Compat.DynFlags (dopt_set, dopt_unset)-import CLaSH.GHC.Compat.GHC (defaultErrorHandler) import qualified CoreSyn import DynFlags (GeneralFlag (..)) import qualified DynFlags@@ -61,7 +60,8 @@ , [CoreSyn.CoreBndr] -- Unlocatable Expressions , FamInstEnv.FamInstEnvs )-loadModules modName dflagsM = defaultErrorHandler $ do+loadModules modName dflagsM = GHC.defaultErrorHandler DynFlags.defaultFatalMessager+ DynFlags.defaultFlushOut $ do libDir <- MonadUtils.liftIO ghcLibDir GHC.runGhc (Just libDir) $ do@@ -81,7 +81,12 @@ [ DynFlags.Opt_ImplicitPrelude , DynFlags.Opt_MonomorphismRestriction ]- return dfDis+ let ghcTyLitNormPlugin = GHC.mkModuleName "GHC.TypeLits.Normalise"+ let dfPlug = dfDis { DynFlags.pluginModNames = nub $+ ghcTyLitNormPlugin : DynFlags.pluginModNames dfDis+ }+ return dfPlug+ let dflags1 = dflags { DynFlags.ctxtStkDepth = 1000 , DynFlags.optLevel = 2 , DynFlags.ghcMode = GHC.CompManager@@ -130,11 +135,11 @@ parseModule :: GHC.GhcMonad m => GHC.ModSummary -> m GHC.ParsedModule parseModule modSum = do- (GHC.ParsedModule pmModSum pmParsedSource extraSrc) <-+ (GHC.ParsedModule pmModSum pmParsedSource extraSrc anns) <- GHC.parseModule modSum return (GHC.ParsedModule (disableOptimizationsFlags pmModSum)- pmParsedSource extraSrc)+ pmParsedSource extraSrc anns) disableOptimizationsFlags :: GHC.ModSummary -> GHC.ModSummary disableOptimizationsFlags ms@(GHC.ModSummary {..})@@ -144,7 +149,7 @@ {DynFlags.optLevel = 2, DynFlags.ctxtStkDepth = 1000}) wantedOptimizationFlags :: GHC.DynFlags -> GHC.DynFlags-wantedOptimizationFlags df = foldl dopt_unset (foldl dopt_set df wanted) unwanted+wantedOptimizationFlags df = foldl DynFlags.gopt_unset (foldl DynFlags.gopt_set df wanted) unwanted where wanted = [ Opt_CSE -- CSE , Opt_FullLaziness -- Floats let-bindings outside enclosing lambdas
src-ghc/CLaSH/GHC/NetlistTypes.hs view
@@ -4,22 +4,22 @@ (ghcTypeToHWType) where -import Data.HashMap.Strict (HashMap,(!))-import Control.Monad.Trans.Error (ErrorT(..))-import Unbound.Generics.LocallyNameless (name2String)+import Data.HashMap.Strict (HashMap,(!))+import Control.Monad.Trans.Except (ExceptT (..), runExceptT)+import Unbound.Generics.LocallyNameless (name2String) -import CLaSH.Core.Pretty (showDoc)-import CLaSH.Core.TyCon (TyCon (..), TyConName)-import CLaSH.Core.Type (LitTy (..), Type (..), TypeView (..),- findFunSubst, tyView)-import CLaSH.Netlist.Util (coreTypeToHWType)-import CLaSH.Netlist.Types (HWType(..))+import CLaSH.Core.Pretty (showDoc)+import CLaSH.Core.TyCon (TyCon (..), TyConName)+import CLaSH.Core.Type (LitTy (..), Type (..), TypeView (..),+ findFunSubst, tyView)+import CLaSH.Netlist.Util (coreTypeToHWType)+import CLaSH.Netlist.Types (HWType(..)) import CLaSH.Util ghcTypeToHWType :: HashMap TyConName TyCon -> Type -> Maybe (Either String HWType)-ghcTypeToHWType m ty@(tyView -> TyConApp tc args) = runErrorT $+ghcTypeToHWType m ty@(tyView -> TyConApp tc args) = runExceptT $ case name2String tc of "Int" -> return Integer "GHC.Integer.Type.Integer" -> return Integer@@ -33,7 +33,7 @@ fail $ "Can't translate type: " ++ showDoc ty "CLaSH.Signal.Internal.Signal'" ->- ErrorT $ return $ coreTypeToHWType ghcTypeToHWType m (args !! 1)+ ExceptT $ return $ coreTypeToHWType ghcTypeToHWType m (args !! 1) "CLaSH.Sized.Internal.BitVector.BitVector" -> BitVector <$> tyNatSize m (head args)@@ -50,7 +50,7 @@ "CLaSH.Sized.Vector.Vec" -> do let [szTy,elTy] = args sz <- tyNatSize m szTy- elHWTy <- ErrorT $ return $ coreTypeToHWType ghcTypeToHWType m elTy+ elHWTy <- ExceptT $ return $ coreTypeToHWType ghcTypeToHWType m elTy return $ Vector sz elHWTy _ -> case m ! tc of -- TODO: Remove this conversion@@ -58,15 +58,15 @@ -- transformation process, and so end up here. Once a fix has been found for -- this problem remove this dirty hack. FunTyCon {tyConSubst = tcSubst} -> case findFunSubst tcSubst args of- Just ty' -> ErrorT $ return $ coreTypeToHWType ghcTypeToHWType m ty'- _ -> ErrorT Nothing- _ -> ErrorT Nothing+ Just ty' -> ExceptT $ return $ coreTypeToHWType ghcTypeToHWType m ty'+ _ -> ExceptT Nothing+ _ -> ExceptT Nothing ghcTypeToHWType _ _ = Nothing tyNatSize :: HashMap TyConName TyCon -> Type- -> ErrorT String Maybe Int+ -> ExceptT String Maybe Int tyNatSize _ (LitTy (NumTy i)) = return i tyNatSize m (tyView -> TyConApp tc [ty1,ty2]) = case name2String tc of "GHC.TypeLits.+" -> (+) <$> tyNatSize m ty1 <*> tyNatSize m ty2