Print previous errors if local module fails to load (#2663) (#2666)

Fixes #2365 (cherry picked from commit 2b76b07) Co-authored-by: Martijn Bastiaan <[email protected]>
clash-lang · Feb 13, 2024 · 1f33914 · 1f33914
1 parent 4db6dbf
commit 1f33914
Show file tree

Hide file tree

Showing 3 changed files with 90 additions and 42 deletions.
diff --git a/changelog/2024-02-08T11_27_48+01_00_fix_2365 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. Note: this fix only works from GHC 9.0 on. 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
@@ -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. <[email protected]>
 -}
 
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
@@ -38,9 +39,10 @@ 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)
 #if MIN_VERSION_ghc(9,0,0)
+import           Control.Monad.Catch             (catch, throwM)
 import           Control.Monad.Catch             as MC (try)
 #endif
 import           Control.Monad.IO.Class          (liftIO)
@@ -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,21 @@ 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
+#if MIN_VERSION_ghc(9,0,0)
+        Left loadExternalErr -> do
+          catch @_ @SomeException
+            (loadLocalModule hdl modName)
+            (\localError ->
+              throwM
+                (LoadModulesException
+                  { moduleName = modName
+                  , externalError = show loadExternalErr
+                  , localError = show localError
+                  }))
+#else
+        Left _loadExternalErr -> do
+          loadLocalModule hdl modName
+#endif
         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
@@ -12,23 +12,24 @@
 -}
 
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE NondecreasingIndentation #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
 
 module Clash.Driver where
 
 import           Control.Concurrent               (MVar, modifyMVar, modifyMVar_, newMVar, withMVar)
 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,19 +555,24 @@ 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
                  , Hint.languageExtensions Hint.:= langExts]
         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
Original file line number	Diff line number	Diff line change
		@@ -0,0 +1 @@
		FIXED: Clash no longer hides error messages if it fails to load external (precompiled) modules. Note: this fix only works from GHC 9.0 on. See [#2365](https://github.com/clash-lang/clash-compiler/issues/2365)