diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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) diff --git a/clash-ghc.cabal b/clash-ghc.cabal --- a/clash-ghc.cabal +++ b/clash-ghc.cabal @@ -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 diff --git a/src-bin/GhciMonad.hs b/src-bin/GhciMonad.hs --- a/src-bin/GhciMonad.hs +++ b/src-bin/GhciMonad.hs @@ -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 diff --git a/src-bin/InteractiveUI.hs b/src-bin/InteractiveUI.hs --- a/src-bin/InteractiveUI.hs +++ b/src-bin/InteractiveUI.hs @@ -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 @@ " :! run the shell command \n" ++ " :vhdl synthesize currently loaded module to vhdl\n" ++ " :vhdl [] synthesize specified modules/files to vhdl\n" ++ + " :systemverilog synthesize currently loaded module to systemverilog\n" ++ + " :systemverilog [] 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 show the source code for \n" ++ " :list [] show the source code around line number \n" ++ - " :print [ ...] prints a value without forcing its computation\n" ++ - " :sprint [ ...] simplifed version of :print\n" ++ + " :print [ ...] show a value without forcing its computation\n" ++ + " :sprint [ ...] simplified version of :print\n" ++ " :step single-step after stopping at a breakpoint\n"++ " :step single-step into \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 : or Haskell code) +-- | Evaluate a single line of user input (either : 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) $ diff --git a/src-bin/Main.hs b/src-bin/Main.hs --- a/src-bin/Main.hs +++ b/src-bin/Main.hs @@ -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 diff --git a/src-bin/PosixSource.h b/src-bin/PosixSource.h --- a/src-bin/PosixSource.h +++ b/src-bin/PosixSource.h @@ -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. diff --git a/src-bin/hschooks.c b/src-bin/hschooks.c --- a/src-bin/hschooks.c +++ b/src-bin/hschooks.c @@ -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 diff --git a/src-ghc/CLaSH/GHC/Compat/DynFlags.hs b/src-ghc/CLaSH/GHC/Compat/DynFlags.hs deleted file mode 100644 --- a/src-ghc/CLaSH/GHC/Compat/DynFlags.hs +++ /dev/null @@ -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 diff --git a/src-ghc/CLaSH/GHC/Compat/FastString.hs b/src-ghc/CLaSH/GHC/Compat/FastString.hs deleted file mode 100644 --- a/src-ghc/CLaSH/GHC/Compat/FastString.hs +++ /dev/null @@ -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 diff --git a/src-ghc/CLaSH/GHC/Compat/GHC.hs b/src-ghc/CLaSH/GHC/Compat/GHC.hs deleted file mode 100644 --- a/src-ghc/CLaSH/GHC/Compat/GHC.hs +++ /dev/null @@ -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 diff --git a/src-ghc/CLaSH/GHC/Compat/Outputable.hs b/src-ghc/CLaSH/GHC/Compat/Outputable.hs deleted file mode 100644 --- a/src-ghc/CLaSH/GHC/Compat/Outputable.hs +++ /dev/null @@ -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 diff --git a/src-ghc/CLaSH/GHC/Compat/PrelNames.hs b/src-ghc/CLaSH/GHC/Compat/PrelNames.hs deleted file mode 100644 --- a/src-ghc/CLaSH/GHC/Compat/PrelNames.hs +++ /dev/null @@ -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 diff --git a/src-ghc/CLaSH/GHC/Compat/TyCon.hs b/src-ghc/CLaSH/GHC/Compat/TyCon.hs deleted file mode 100644 --- a/src-ghc/CLaSH/GHC/Compat/TyCon.hs +++ /dev/null @@ -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 diff --git a/src-ghc/CLaSH/GHC/GHC2Core.hs b/src-ghc/CLaSH/GHC/GHC2Core.hs --- a/src-ghc/CLaSH/GHC/GHC2Core.hs +++ b/src-ghc/CLaSH/GHC/GHC2Core.hs @@ -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 diff --git a/src-ghc/CLaSH/GHC/LoadInterfaceFiles.hs b/src-ghc/CLaSH/GHC/LoadInterfaceFiles.hs --- a/src-ghc/CLaSH/GHC/LoadInterfaceFiles.hs +++ b/src-ghc/CLaSH/GHC/LoadInterfaceFiles.hs @@ -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 diff --git a/src-ghc/CLaSH/GHC/LoadModules.hs b/src-ghc/CLaSH/GHC/LoadModules.hs --- a/src-ghc/CLaSH/GHC/LoadModules.hs +++ b/src-ghc/CLaSH/GHC/LoadModules.hs @@ -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 diff --git a/src-ghc/CLaSH/GHC/NetlistTypes.hs b/src-ghc/CLaSH/GHC/NetlistTypes.hs --- a/src-ghc/CLaSH/GHC/NetlistTypes.hs +++ b/src-ghc/CLaSH/GHC/NetlistTypes.hs @@ -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