From 5764486660a2bacaef1c5e8cf5a277b0b90a76d9 Mon Sep 17 00:00:00 2001 From: Martijn Bastiaan Date: Thu, 8 Feb 2024 11:27:18 +0100 Subject: [PATCH] Print previous errors if local module fails to load Fixes #2365 --- changelog/2024-02-08T11_27_48+01_00_fix_2365 | 1 + clash-ghc/src-ghc/Clash/GHC/LoadModules.hs | 36 +++++++- clash-lib/src/Clash/Driver.hs | 89 +++++++++++--------- 3 files changed, 84 insertions(+), 42 deletions(-) create mode 100644 changelog/2024-02-08T11_27_48+01_00_fix_2365 diff --git a/changelog/2024-02-08T11_27_48+01_00_fix_2365 b/changelog/2024-02-08T11_27_48+01_00_fix_2365 new file mode 100644 index 0000000000..ae61ae8f3d --- /dev/null +++ b/changelog/2024-02-08T11_27_48+01_00_fix_2365 @@ -0,0 +1 @@ +FIXED: Clash no longer hides error messages if it fails to load external (precompiled) modules. See [#2365](https://github.com/clash-lang/clash-compiler/issues/2365) diff --git a/clash-ghc/src-ghc/Clash/GHC/LoadModules.hs b/clash-ghc/src-ghc/Clash/GHC/LoadModules.hs index 89a7f0bea4..b7ddbd0bbf 100644 --- a/clash-ghc/src-ghc/Clash/GHC/LoadModules.hs +++ b/clash-ghc/src-ghc/Clash/GHC/LoadModules.hs @@ -1,13 +1,14 @@ {-| Copyright : (C) 2013-2016, University of Twente, 2016-2017, Myrtle Software Ltd, - 2017 , Google Inc. + 2017-2024, Google Inc. 2021-2023, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. -} {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} @@ -38,8 +39,9 @@ import Control.Arrow (first) import Control.Exception (SomeException, throw) import Control.Monad (forM, join, when) import Data.List.Extra (nubSort) -import Control.Exception (throwIO) +import Control.Exception (Exception, throwIO) import Control.Monad (foldM) +import Control.Monad.Catch (catch, throwM) #if MIN_VERSION_ghc(9,0,0) import Control.Monad.Catch as MC (try) #endif @@ -527,6 +529,26 @@ nameString = OccName.occNameString . Name.nameOccName varNameString :: Var.Var -> String varNameString = nameString . Var.varName +data LoadModulesException = LoadModulesException + { moduleName :: String + , externalError :: String + , localError :: String + } deriving (Exception) + +instance Show LoadModulesException where + showsPrec :: Int -> LoadModulesException -> ShowS + showsPrec _ LoadModulesException{moduleName, externalError, localError} = showString [I.i| + Failed to load module '#{moduleName}'. + + Tried to load it from precompiled sources, error was: + + #{externalError} + + Tried to load it from local sources, error was: + + #{localError} + |] + loadModules :: GHC.Ghc () -- ^ Allows us to have some initial action, such as sharing a linker state @@ -573,7 +595,15 @@ loadModules startAction useColor hdl modName dflagsM idirs = do -- We need to try and load external modules first, because we can't -- recover from errors in 'loadLocalModule'. loadExternalModule hdl modName >>= \case - Left _loadExternalErr -> loadLocalModule hdl modName + Left loadExternalErr -> do + liftIO $ print loadExternalErr + catch @_ @SomeException + (loadLocalModule hdl modName) + (\localError -> throwM (LoadModulesException{ + moduleName = modName + , externalError = show loadExternalErr + , localError = show localError + })) Right res -> pure res let allBinderIds = map fst (CoreSyn.flattenBinds allBinders) diff --git a/clash-lib/src/Clash/Driver.hs b/clash-lib/src/Clash/Driver.hs index b9b588af5b..c15a24a981 100644 --- a/clash-lib/src/Clash/Driver.hs +++ b/clash-lib/src/Clash/Driver.hs @@ -12,12 +12,13 @@ -} {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NondecreasingIndentation #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} module Clash.Driver where @@ -25,10 +26,10 @@ import Control.Concurrent (MVar, modifyMVar, modifyMVar_ import Control.Concurrent.Async (mapConcurrently_) import qualified Control.Concurrent.Supply as Supply import Control.DeepSeq -import Control.Exception (throw) +import Control.Exception (throw, Exception) import qualified Control.Monad as Monad import Control.Monad (unless, foldM, forM, filterM) -import Control.Monad.Catch (MonadMask) +import Control.Monad.Catch (MonadMask, MonadThrow (throwM)) import Control.Monad.Extra (whenM, ifM, unlessM) import Control.Monad.IO.Class (MonadIO) import Control.Monad.State (evalState, get) @@ -49,6 +50,8 @@ import qualified Data.HashSet as HashSet import Data.Proxy (Proxy(..)) import Data.List (intercalate) import qualified Data.List as List +import Data.List.NonEmpty (NonEmpty((:|))) +import qualified Data.List.NonEmpty as NonEmpty import Data.Maybe (fromMaybe, maybeToList, mapMaybe) import qualified Data.Map.Ordered as OMap import Data.Map.Ordered.Extra () @@ -539,7 +542,7 @@ loadImportAndInterpret -- ^ Function name -> String -- ^ Type name ('BlackBoxFunction' or 'TemplateFunction') - -> m (Either Hint.InterpreterError a) + -> m (Either (NonEmpty Hint.InterpreterError) a) loadImportAndInterpret iPaths0 interpreterArgs topDir qualMod funcName typ = do Hint.liftIO $ Monad.when debugIsOn $ putStr "Hint: Interpreting " >> putStrLn (qualMod ++ "." ++ funcName) @@ -552,10 +555,10 @@ loadImportAndInterpret iPaths0 interpreterArgs topDir qualMod funcName typ = do Hint.unsafeInterpret funcName typ case bbfE of - Left _ -> do + Left globalException -> do -- Try to interpret module as a local module, not yet present in the -- global package database(s). - Hint.unsafeRunInterpreterWithArgsLibdir interpreterArgs topDir $ do + localRes <- Hint.unsafeRunInterpreterWithArgsLibdir interpreterArgs topDir $ do Hint.reset iPaths1 <- (iPaths0++) <$> Hint.get Hint.searchPath Hint.set [ Hint.searchPath Hint.:= iPaths1 @@ -563,8 +566,13 @@ loadImportAndInterpret iPaths0 interpreterArgs topDir qualMod funcName typ = do Hint.loadModules [qualMod] Hint.setImports [ "Clash.Netlist.BlackBox.Types", "Clash.Netlist.Types", qualMod] Hint.unsafeInterpret funcName typ - Right _ -> do - return bbfE + + case localRes of + Left localException -> pure (Left (globalException :| [localException])) + Right res -> pure (Right res) + + Right res -> do + return (Right res) where langExts = map Hint.asExtension $ map show wantedLanguageExtensions ++ @@ -631,11 +639,7 @@ compilePrimitive idirs pkgDbs topDir (BlackBoxHaskell bbName wf usedArgs multiRe let interpreterArgs = concatMap (("-package-db":) . (:[])) pkgDbs -- Compile a blackbox template function or fetch it from an already compiled file. r <- go interpreterArgs source - processHintError - (show bbGenName) - bbName - id - r + processHintErrors (show bbGenName) bbName r pure (BlackBoxHaskell bbName wf usedArgs multiRes bbGenName (hash source, bbFunc)) where @@ -656,7 +660,7 @@ compilePrimitive idirs pkgDbs topDir (BlackBoxHaskell bbName wf usedArgs multiRe go :: [String] -> Maybe Text - -> IO (Either Hint.InterpreterError BlackBoxFunction) + -> IO (Either (NonEmpty Hint.InterpreterError) BlackBoxFunction) go args (Just source') = do -- Create a temporary directory with user module in it, add it to the -- list of import direcotries, and run as if it were a "normal" compiled @@ -709,7 +713,8 @@ compilePrimitive idirs pkgDbs topDir Text.writeFile (modDir last modNames <.> "hs") source loadImportAndInterpret (tmpDir':idirs) iArgs topDir qualMod funcName "TemplateFunction" let hsh = hash (qualMod, source) - processHintError (show bbGenName) pNm (BBFunction (Data.Text.unpack pNm) hsh) r + BBFunction (Data.Text.unpack pNm) hsh <$> + processHintErrors (show bbGenName) pNm r parseBB ((THaskell,bbGenName),Nothing) = do let BlackBoxFunctionName modNames funcName = bbGenName qualMod = intercalate "." modNames @@ -720,36 +725,42 @@ compilePrimitive idirs pkgDbs topDir Just f -> pure f Nothing -> do r <- loadImportAndInterpret idirs iArgs topDir qualMod funcName "TemplateFunction" - processHintError (show bbGenName) pNm id r + processHintErrors (show bbGenName) pNm r pure (BBFunction (Data.Text.unpack pNm) hsh tf) compilePrimitive _ _ _ (Primitive pNm wf typ) = return (Primitive pNm wf typ) {-# SCC compilePrimitive #-} -processHintError - :: Monad m - => String - -> Data.Text.Text - -> (t -> r) - -> Either Hint.InterpreterError t - -> m r -processHintError fun bb go r = case r of - Left (Hint.GhcException err) -> - error' "GHC Exception" err - Left (Hint.NotAllowed err) -> - error' "NotAllowed error" err - Left (Hint.UnknownError err) -> - error' "an unknown error" err - Left (Hint.WontCompile ghcErrs) -> - error' "compilation errors" (intercalate "\n\n" $ map Hint.errMsg ghcErrs) - Right f -> - return $ go f +newtype HintError = HintError String deriving (Exception) + +instance Show HintError where + showsPrec :: Int -> HintError -> ShowS + showsPrec _ (HintError e) = showString e + +processHintErrors :: + (MonadThrow m, Monad m) => + -- | Function to interpret + String -> + -- | BlackBox function name + Data.Text.Text -> + -- | Hint result + Either (NonEmpty Hint.InterpreterError) t -> + m t +processHintErrors fun bb r = case r of + Left es -> throwM $ HintError (formatExceptions (NonEmpty.toList es)) + Right f -> pure f where - error' errType report = - error $ unwords [ "Encountered", errType, "while compiling blackbox template" - , "function", show fun, "for function", show bb ++ "." - , "Compilation reported: \n\n" ++ report ] + formatExceptions es = [I.i| + Encountered one or more exceptions when compiling blackbox template function + '#{fun}' for function '#{bb}'. + |] <> "\n\n" <> intercalate "\n\n" (map formatException es) + + formatException e = [I.i| + Encountered: + + #{e} + |] -- | Pretty print Components to HDL Documents createHDL