Apply Clash specific modifications to src-bin-9.12

Author: martijnbastiaan

clash-ghc/src-bin-9.12/Clash/GHCi/Leak.hs

@@ -1,16 +1,16 @@
 {-# LANGUAGE RecordWildCards, LambdaCase #-}
-module GHCi.Leak
+module Clash.GHCi.Leak
   ( LeakIndicators
   , getLeakIndicators
   , checkLeakIndicators
   ) where
 
+import Clash.GHCi.Util
 import Control.Monad
 import Data.Bits
 import Foreign.Ptr (ptrToIntPtr, intPtrToPtr)
 import GHC
 import GHC.Ptr (Ptr (..))
-import GHCi.Util
 import GHC.Driver.Env
 import GHC.Driver.Ppr
 import GHC.Utils.Outputable

clash-ghc/src-bin-9.12/Clash/GHCi/UI.hs

@@ -22,19 +22,20 @@
 --
 -----------------------------------------------------------------------------
 
-module GHCi.UI (
+module Clash.GHCi.UI (
         interactiveUI,
         GhciSettings(..),
         defaultGhciSettings,
         ghciCommands,
-        ghciWelcomeMsg
+        ghciWelcomeMsg,
+        makeHDL
     ) where
 
 -- GHCi
-import qualified GHCi.UI.Monad as GhciMonad ( args, runStmt, runDecls' )
-import GHCi.UI.Monad hiding ( args, runStmt )
-import GHCi.UI.Info
-import GHCi.UI.Exception
+import qualified Clash.GHCi.UI.Monad as GhciMonad ( args, runStmt, runDecls' )
+import Clash.GHCi.UI.Monad hiding ( args, runStmt )
+import Clash.GHCi.UI.Info
+import Clash.GHCi.UI.Exception
 import GHC.Runtime.Debugger
 import GHC.Runtime.Eval (mkTopLevEnv)
 
@@ -96,7 +97,6 @@ import GHC.Utils.Logger
 
 -- Other random utilities
 import GHC.Types.Basic hiding ( isTopLevel )
-import GHC.Settings.Config
 import GHC.Data.Graph.Directed
 import GHC.Utils.Encoding
 import GHC.Data.FastString
@@ -170,9 +170,27 @@ import GHC.IO.Exception ( IOErrorType(InvalidArgument) )
 import GHC.IO.Handle ( hFlushAll )
 import GHC.TopHandler ( topHandler )
 
-import GHCi.Leak
+import Clash.GHCi.Leak
 import qualified GHC.Unit.Module.Graph as GHC
 
+-- clash additions
+import           Clash.Backend (Backend(initBackend, hdlKind, primDirs))
+import           Clash.Backend.SystemVerilog (SystemVerilogState)
+import           Clash.Backend.VHDL (VHDLState)
+import           Clash.Backend.Verilog (VerilogState)
+import qualified Clash.Driver
+import           Clash.Driver.Bool (fromGhcOverridingBool)
+import           Clash.Driver.Types (ClashOpts(..), ClashEnv(..), ClashDesign(..))
+import           Clash.GHC.Evaluator
+import           Clash.GHC.GenerateBindings
+import           Clash.GHC.NetlistTypes
+import           Clash.GHC.PartialEval
+import           Clash.GHCi.Common
+import           Clash.Util (clashLibVersion, reportTimeDiff)
+import           Data.Proxy
+import qualified Data.Time.Clock as Clock
+import qualified Paths_clash_ghc
+
 -----------------------------------------------------------------------------
 
 data GhciSettings = GhciSettings {
@@ -183,22 +201,23 @@ data GhciSettings = GhciSettings {
         defPromptCont     :: PromptFunction
     }
 
-defaultGhciSettings :: GhciSettings
-defaultGhciSettings =
+defaultGhciSettings :: IORef ClashOpts -> GhciSettings
+defaultGhciSettings opts =
     GhciSettings {
-        availableCommands = ghciCommands,
+        availableCommands = ghciCommands opts,
         shortHelpText     = defShortHelpText,
         defPrompt         = default_prompt,
         defPromptCont     = default_prompt_cont,
         fullHelpText      = defFullHelpText
     }
 
 ghciWelcomeMsg :: String
-ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
-                 ": https://www.haskell.org/ghc/  :? for help"
+ghciWelcomeMsg = "Clashi, version " ++ Data.Version.showVersion Paths_clash_ghc.version ++
+                 " (using clash-lib, version " ++ Data.Version.showVersion clashLibVersion ++
+                 "):\nhttps://clash-lang.org/  :? for help"
 
-ghciCommands :: [Command]
-ghciCommands = map mkCmd [
+ghciCommands :: IORef ClashOpts -> [Command]
+ghciCommands opts = map mkCmd [
   -- Hugs users are accustomed to :e, so make sure it doesn't overlap
   ("?",         keepGoing help,                 noCompletion),
   ("add",       keepGoingPaths addModule,       completeFilename),
@@ -252,6 +271,9 @@ ghciCommands = map mkCmd [
   ("undef",     keepGoing undefineMacro,        completeMacro),
   ("unset",     keepGoing unsetOptions,         completeSetOptions),
   ("where",     keepGoing whereCmd,             noCompletion),
+  ("vhdl",      keepGoingPaths (makeVHDL opts), completeHomeModuleOrFile),
+  ("verilog",   keepGoingPaths (makeVerilog opts), completeHomeModuleOrFile),
+  ("systemverilog",keepGoingPaths (makeSystemVerilog opts), completeHomeModuleOrFile),
   ("instances", keepGoing' instancesCmd,        completeExpression)
   ] ++ map mkCmdHidden [ -- hidden commands
   ("all-types", keepGoing' allTypesCmd),
@@ -384,6 +406,12 @@ defFullHelpText =
   "   :undef <cmd>                undefine user-defined command :<cmd>\n" ++
   "   ::<cmd>                     run the builtin command\n" ++
   "   :!<command>                 run the shell command <command>\n" ++
+  "   :vhdl                       synthesize currently loaded module to vhdl\n" ++
+  "   :vhdl [<module>]            synthesize specified modules/files to vhdl\n" ++
+  "   :verilog                    synthesize currently loaded module to verilog\n" ++
+  "   :verilog [<module>]         synthesize specified modules/files to verilog\n" ++
+  "   :systemverilog              synthesize currently loaded module to systemverilog\n" ++
+  "   :systemverilog [<module>]   synthesize specified modules/files to systemverilog\n" ++
   "\n" ++
   " -- Commands for debugging:\n" ++
   "\n" ++
@@ -483,8 +511,8 @@ default_progname = "<interactive>"
 default_stop = ""
 
 default_prompt, default_prompt_cont :: PromptFunction
-default_prompt = generatePromptFunctionFromString "ghci> "
-default_prompt_cont = generatePromptFunctionFromString "ghci| "
+default_prompt = generatePromptFunctionFromString "clashi> "
+default_prompt_cont = generatePromptFunctionFromString "clashi| "
 
 default_args :: [String]
 default_args = []
@@ -649,31 +677,32 @@ ghciLogAction lastErrLocations old_log_action
 getAppDataFile :: XdgDirectory -> FilePath -> IO (Maybe FilePath)
 getAppDataFile xdgDir file = do
   xdgAppDir <-
-    tryIO (getXdgDirectory xdgDir "ghc") >>= \case
+    tryIO (getXdgDirectory xdgDir "clash") >>= \case
       Left _ -> pure Nothing
       Right dir -> flip catchIO (const $ pure Nothing) $ do
         createDirectoryIfMissing False dir
         pure $ Just dir
   appDir <-
-    tryIO (getAppUserDataDirectory "ghc") >>= \case
+    tryIO (getAppUserDataDirectory "clash") >>= \case
       Right dir ->
         doesDirectoryExist dir >>= \case
           True -> pure $ Just dir
           False -> pure xdgAppDir
       Left _ -> pure xdgAppDir
   pure $ appDir >>= \dir -> Just $ dir </> file
 
+
 runGHCi :: [(FilePath, Maybe UnitId, Maybe Phase)] -> Maybe [String] -> GHCi ()
 runGHCi paths maybe_exprs = do
   dflags <- getDynFlags
   let
    ignore_dot_ghci = gopt Opt_IgnoreDotGhci dflags
 
-   appDataCfg = liftIO $ getAppDataFile XdgConfig "ghci.conf"
+   appDataCfg = liftIO $ getAppDataFile XdgConfig "clashi.conf"
 
    homeCfg = do
     liftIO $ tryIO (getEnv "HOME") >>= \case
-      Right home -> pure $ Just $ home </> ".ghci"
+      Right home -> pure $ Just $ home </> ".clashi"
       _ -> pure Nothing
 
    canonicalizePath' :: FilePath -> IO (Maybe FilePath)
@@ -698,7 +727,7 @@ runGHCi paths maybe_exprs = do
                 -- Also, let the user silence the message with -v0
                 -- (the default verbosity in GHCi is 1).
                 when (isNothing maybe_exprs && verbosity dflags > 0) $
-                  liftIO $ putStrLn ("Loaded GHCi configuration from " ++ file)
+                  liftIO $ putStrLn ("Loaded Clashi configuration from " ++ file)
 
   --
 
@@ -713,7 +742,7 @@ runGHCi paths maybe_exprs = do
         liftIO . fmap (nub . catMaybes) $ mapM canonicalizePath' checkedPaths
 
       localCfg <- do
-        let path = ".ghci"
+        let path = ".clashi"
         ok <- liftIO $ checkFileAndDirPerms path
         if ok then liftIO $ canonicalizePath' path else pure Nothing
 
@@ -766,10 +795,21 @@ runGHCi paths maybe_exprs = do
   case maybe_exprs of
         Nothing ->
           do
+            -- Set different defaulting rules (See #280)
+            runGHCiExpressions
+              ["default ((), [], Prelude.Integer, Prelude.Int, Prelude.Double, Prelude.String)"]
+
             -- enter the interactive loop
             runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty
         Just exprs -> do
             -- just evaluate the expression we were given
+            runGHCiExpressions exprs
+
+  -- and finally, exit
+  liftIO $ when (verbosity dflags > 0) $ putStrLn "Leaving Clashi."
+
+runGHCiExpressions :: [String] -> GHCi ()
+runGHCiExpressions exprs = do
             enqueueCommands exprs
             let hdle e = do st <- getGHCiState
                             -- flush the interpreter's stdout/stderr on exit (#3890)
@@ -787,9 +827,6 @@ runGHCi paths maybe_exprs = do
                      (return Nothing)
                 return ()
 
-  -- and finally, exit
-  liftIO $ when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
-
 runGHCiInput :: InputT GHCi a -> GHCi a
 runGHCiInput f = do
     dflags <- getDynFlags
@@ -798,8 +835,8 @@ runGHCiInput f = do
     currentDirectory <- liftIO getCurrentDirectory
 
     histFile <- case (ghciHistory, localGhciHistory) of
-      (True, True) -> pure $ Just $ currentDirectory </> ".ghci_history"
-      (True, _) -> liftIO $ getAppDataFile XdgData "ghci_history"
+      (True, True) -> pure $ Just $ currentDirectory </> ".clashi_history"
+      (True, _) -> liftIO $ getAppDataFile XdgData "clashi_history"
       _ -> pure Nothing
 
     runInputT
@@ -2346,6 +2383,115 @@ runExceptGhciMonad act = handleSourceError printGhciException $
 exceptT :: Applicative m => Either e a -> ExceptT e m a
 exceptT = ExceptT . pure
 
+makeHDL'
+  :: forall backend
+   . Backend backend
+  => Proxy backend
+  -> IORef ClashOpts
+  -> [FilePath]
+  -> InputT GHCi ()
+makeHDL' backend opts lst = go =<< case lst of
+  srcs@(_:_) -> return srcs
+  []         -> do
+    modGraph <- GHC.getModuleGraph
+    let sortedGraph =
+          -- TODO: this might break backpack
+          filterToposortToModules $
+          GHC.topSortModuleGraph False modGraph Nothing
+    return $ case (reverse sortedGraph) of
+      ((AcyclicSCC top) : _) -> maybeToList $ (GHC.ml_hs_file . GHC.ms_location) top
+      _                      -> []
+ where
+  go srcs = do
+    dflags <- GHC.getSessionDynFlags
+    goX dflags srcs `MC.finally` recover dflags
+
+  goX dflags srcs = do
+    -- Issue #439 step 1
+    (dflagsX,_,_) <- parseDynamicFlagsCmdLine dflags
+                       [ noLoc "-fobject-code"   -- For #439
+                       , noLoc "-fforce-recomp"  -- Actually compile to object-code
+                       , noLoc "-keep-tmp-files" -- To prevent linker errors from
+                                                 -- multiple calls to :hdl command
+                       ]
+    _ <- GHC.setSessionDynFlags dflagsX
+    reloadModule ""
+    -- Issue #439 step 2
+    -- Unload any object files
+    -- This fixes: https://github.com/clash-lang/clash-compiler/issues/439#issuecomment-522015868
+    env <- GHC.getSession
+    liftIO (Loader.unload (hscInterp env) env [])
+    -- Finally generate the HDL
+    makeHDL backend (return ()) opts srcs
+
+  recover dflags = do
+    _ <- GHC.setSessionDynFlags dflags
+    reloadModule ""
+
+makeHDL
+  :: forall backend m
+   . (GHC.GhcMonad m, Backend backend)
+  => Proxy backend
+  -> Ghc ()
+  -> IORef ClashOpts
+  -> [FilePath]
+  -> m ()
+makeHDL Proxy startAction optsRef srcs = do
+  dflags <- GHC.getSessionDynFlags
+  liftIO $ do startTime <- Clock.getCurrentTime
+              opts0  <- readIORef optsRef
+              let opts1  = opts0 { opt_color = fromGhcOverridingBool (useColor dflags) }
+              let iw     = opt_intWidth opts1
+                  hdl    = hdlKind backend
+                  -- determine whether `-outputdir` was used
+                  outputDir = do odir <- objectDir dflags
+                                 hidir <- hiDir dflags
+                                 sdir <- stubDir dflags
+                                 ddir <- dumpDir dflags
+                                 if all (== odir) [hidir,sdir,ddir]
+                                    then Just odir
+                                    else Nothing
+                  idirs = importPaths dflags
+                  opts2 = opts1 { opt_hdlDir = maybe outputDir Just (opt_hdlDir opts1)
+                                , opt_importPaths = idirs}
+                  backend = initBackend @backend opts2
+
+              checkMonoLocalBinds dflags
+              checkImportDirs opts0 idirs
+
+              primDirs_ <- primDirs backend
+
+              forM_ srcs $ \src -> do
+                -- Generate bindings:
+                let dbs = reverse [p | PackageDB (PkgDbPath p) <- packageDBFlags dflags]
+                (clashEnv, clashDesign) <- generateBindings opts2 startAction primDirs_ idirs dbs hdl src (Just dflags)
+
+                let getMain = getMainTopEntity src clashDesign
+                mainTopEntity <- traverse getMain (GHC.mainFunIs dflags)
+                prepTime <- startTime `deepseq` designBindings clashDesign `deepseq` envTyConMap clashEnv `deepseq` Clock.getCurrentTime
+                let prepStartDiff = reportTimeDiff prepTime startTime
+                putStrLn $ "GHC+Clash: Loading modules cumulatively took " ++ prepStartDiff
+
+                -- Generate HDL:
+                Clash.Driver.generateHDL
+                  clashEnv
+                  clashDesign
+                  (Just backend)
+                  (ghcTypeToHWType iw)
+                  ghcEvaluator
+                  evaluator
+                  mainTopEntity
+                  startTime
+
+makeVHDL :: IORef ClashOpts -> [FilePath] -> InputT GHCi ()
+makeVHDL = makeHDL' (Proxy @VHDLState)
+
+makeVerilog :: IORef ClashOpts -> [FilePath] -> InputT GHCi ()
+makeVerilog = makeHDL' (Proxy @VerilogState)
+
+makeSystemVerilog :: IORef ClashOpts -> [FilePath] -> InputT GHCi ()
+makeSystemVerilog = makeHDL' (Proxy @SystemVerilogState)
+
 -----------------------------------------------------------------------------
 -- | @:type@ command. See also Note [TcRnExprMode] in GHC.Tc.Module.
 
@@ -2885,7 +3031,6 @@ setGHCContextFromGHCiState = do
 getImplicitPreludeImports :: GhciMonad m
                           => [InteractiveImport] -> m [InteractiveImport]
 getImplicitPreludeImports iidecls = do
-  dflags <- GHC.getInteractiveDynFlags
      -- allow :seti to override -XNoImplicitPrelude
   st <- getGHCiState
 
@@ -2894,7 +3039,7 @@ getImplicitPreludeImports iidecls = do
   -- of the same module.  This means that you can override the prelude import
   -- with "import Prelude hiding (map)", for example.
   let prel_iidecls =
-         if xopt LangExt.ImplicitPrelude dflags && not (any isIIModule iidecls)
+         if not (any isIIModule iidecls)
             then [ IIDecl imp
                  | imp <- prelude_imports st
                  , not (any (sameImpModule imp) iidecls) ]
@@ -2924,7 +3069,7 @@ iiModuleName (IIModule m) = m
 iiModuleName (IIDecl d)   = unLoc (ideclName d)
 
 preludeModuleName :: ModuleName
-preludeModuleName = GHC.mkModuleName "Prelude"
+preludeModuleName = GHC.mkModuleName "Clash.Prelude"
 
 sameImpModule :: ImportDecl GhcPs -> InteractiveImport -> Bool
 sameImpModule _ (IIModule _) = False -- we only care about imports here

clash-ghc/src-bin-9.12/Clash/GHCi/UI/Exception.hs

@@ -2,7 +2,8 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE LambdaCase #-}
-module GHCi.UI.Exception(printGhciException, GHCiMessage(..)) where
+{-# LANGUAGE NoImplicitPrelude #-}
+module Clash.GHCi.UI.Exception(printGhciException, GHCiMessage(..)) where
 
 import GHC.Prelude