{-# LANGUAGE CPP, GADTs, RankNTypes, FlexibleContexts #-}
module Clash.Clashilator.Setup
    ( clashToVerilog
    , buildVerilator
    , clashilate

    , clashilatorMain
    , clashilatorBuildHook
    ) where

import qualified Clash.Main as Clash
import qualified Clash.Clashilator as Clashilator
import Clash.Clashilator.Cabal
import Clash.Driver.Manifest (Manifest, readManifest)

import Distribution.Simple
import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.Setup
import Distribution.Simple.Program
import Distribution.Simple.Utils (infoNoWrap)
import Distribution.Verbosity
import Distribution.ModuleName
import Distribution.Types.UnqualComponentName
#if MIN_VERSION_Cabal(3,8,0)
import Distribution.Utils.Path
#endif

import Distribution.Types.Lens
import Control.Lens hiding ((<.>))
import Data.List (intercalate, sort, nub)
import Data.Maybe (fromMaybe)
import System.FilePath
import GHC (Ghc)
#if MIN_VERSION_ghc(9,4,0)
#elif MIN_VERSION_ghc(9,0,0)
#define RESET_LINKER
import GHC (getSession, setSession)
import GHC.Driver.Types (HscEnv(..))
import GHC.Runtime.Linker
#elif MIN_VERSION_ghc(8,10,0)
#define RESET_LINKER
import GHC (getSession, setSession)
import HscTypes (HscEnv(..))
import Linker
#endif

#if !MIN_VERSION_Cabal(3,8,0)
type SymbolicPath from to = FilePath

getSymbolicPath :: SymbolicPath from to -> FilePath
getSymbolicPath = id

unsafeMakeSymbolicPath :: FilePath -> SymbolicPath from to
unsafeMakeSymbolicPath = id
#endif

lookupX :: String -> BuildInfo -> Maybe String
lookupX :: String -> BuildInfo -> Maybe String
lookupX String
key BuildInfo
buildInfo = String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (String
"x-clashilator-" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
key) (Getting [(String, String)] BuildInfo [(String, String)]
-> BuildInfo -> [(String, String)]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [(String, String)] BuildInfo [(String, String)]
forall a. HasBuildInfo a => Lens' a [(String, String)]
Lens' BuildInfo [(String, String)]
customFieldsBI BuildInfo
buildInfo)

clashilatorBuildHook :: BuildHook
clashilatorBuildHook :: BuildHook
clashilatorBuildHook = ComponentHook -> BuildHook -> BuildHook
withComponentHook ComponentHook
clashilate (BuildHook -> BuildHook) -> BuildHook -> BuildHook
forall a b. (a -> b) -> a -> b
$ UserHooks -> BuildHook
buildHook UserHooks
simpleUserHooks

clashToVerilog :: Ghc () -> LocalBuildInfo -> BuildFlags -> [FilePath] -> BuildInfo -> ModuleName -> String -> FilePath -> IO (FilePath, Manifest)
clashToVerilog :: Ghc ()
-> LocalBuildInfo
-> BuildFlags
-> [String]
-> BuildInfo
-> ModuleName
-> String
-> String
-> IO (String, Manifest)
clashToVerilog Ghc ()
startAction LocalBuildInfo
lbi BuildFlags
flags [String]
srcDirs BuildInfo
buildInfo ModuleName
mod String
entity String
outDir = do
    [PackageDB]
pkgdbs <- LocalBuildInfo -> BuildFlags -> IO [PackageDB]
packageDBs LocalBuildInfo
lbi BuildFlags
flags
    let dbpaths :: [String]
dbpaths = [String] -> [String]
forall a. Eq a => [a] -> [a]
nub ([String] -> [String])
-> ([String] -> [String]) -> [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
forall a. Ord a => [a] -> [a]
sort ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [ String
path | SpecificPackageDB String
path <- [PackageDB]
pkgdbs ]
        dbflags :: [String]
dbflags = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [String
"-package-db", String
path] | String
path <- [String]
dbpaths ]
        iflags :: [String]
iflags = [ String
"-i" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
dir | String
dir <- [String]
srcDirs ]
        clashflags :: [String]
clashflags = [String] -> (String -> [String]) -> Maybe String -> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] String -> [String]
words (Maybe String -> [String]) -> Maybe String -> [String]
forall a b. (a -> b) -> a -> b
$ String -> BuildInfo -> Maybe String
lookupX String
"clash-flags" BuildInfo
buildInfo

    let args :: [String]
args = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ [ String
"--verilog"
              , String
"-outputdir", String
outDir
              , String
"-main-is", String
entity
              , String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"." (ModuleName -> [String]
components ModuleName
mod)
              ]
            , [String]
iflags
            , [String]
dbflags
            , [String]
clashflags
            ]
    Verbosity -> String -> IO ()
infoNoWrap Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String
"Clash.defaultMain" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
args
    Ghc () -> [String] -> IO ()
Clash.defaultMainWithAction Ghc ()
startAction [String]
args

    let modDir :: String
modDir = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"." (ModuleName -> [String]
components ModuleName
mod)
        verilogDir :: String
verilogDir = String
outDir String -> String -> String
</> String
modDir String -> String -> String
<.> String
entity
    Just Manifest
manifest <- String -> IO (Maybe Manifest)
forall a. FromJSON a => String -> IO (Maybe a)
readManifest (String
verilogDir String -> String -> String
</> String
"clash-manifest.json")

    (String, Manifest) -> IO (String, Manifest)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
verilogDir, Manifest
manifest)
  where
    verbosity :: Verbosity
verbosity = Verbosity -> Flag Verbosity -> Verbosity
forall a. a -> Flag a -> a
fromFlagOrDefault Verbosity
normal (BuildFlags -> Flag Verbosity
buildVerbosity BuildFlags
flags)

buildVerilator :: Ghc () -> LocalBuildInfo -> BuildFlags -> Maybe UnqualComponentName -> BuildInfo -> IO BuildInfo
buildVerilator :: Ghc ()
-> LocalBuildInfo
-> BuildFlags
-> Maybe UnqualComponentName
-> BuildInfo
-> IO BuildInfo
buildVerilator Ghc ()
startAction LocalBuildInfo
lbi BuildFlags
flags Maybe UnqualComponentName
compName BuildInfo
buildInfo = case Maybe String
top of
    Maybe String
Nothing -> BuildInfo -> IO BuildInfo
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return BuildInfo
buildInfo
    Just String
mod -> Ghc ()
-> LocalBuildInfo
-> BuildFlags
-> Maybe UnqualComponentName
-> BuildInfo
-> ModuleName
-> String
-> IO BuildInfo
buildVerilator' Ghc ()
startAction LocalBuildInfo
lbi BuildFlags
flags Maybe UnqualComponentName
compName BuildInfo
buildInfo (String -> ModuleName
forall a. IsString a => String -> a
fromString String
mod) String
entity
  where
    top :: Maybe String
top = String -> BuildInfo -> Maybe String
lookupX String
"top-is" BuildInfo
buildInfo
    entity :: String
entity = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"topEntity" (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ String -> BuildInfo -> Maybe String
lookupX String
"entity" BuildInfo
buildInfo

buildVerilator' :: Ghc () -> LocalBuildInfo -> BuildFlags -> Maybe UnqualComponentName -> BuildInfo -> ModuleName -> String -> IO BuildInfo
buildVerilator' :: Ghc ()
-> LocalBuildInfo
-> BuildFlags
-> Maybe UnqualComponentName
-> BuildInfo
-> ModuleName
-> String
-> IO BuildInfo
buildVerilator' Ghc ()
startAction LocalBuildInfo
lbi BuildFlags
flags Maybe UnqualComponentName
compName BuildInfo
buildInfo ModuleName
mod String
entity = do
    String
cflags <- do
        Maybe (ConfiguredProgram, ProgramDb)
mpkgConfig <- Verbosity
-> Program
-> ProgramDb
-> IO (Maybe (ConfiguredProgram, ProgramDb))
needProgram Verbosity
verbosity Program
pkgConfigProgram (LocalBuildInfo -> ProgramDb
withPrograms LocalBuildInfo
lbi)
        case Maybe (ConfiguredProgram, ProgramDb)
mpkgConfig of
            Maybe (ConfiguredProgram, ProgramDb)
Nothing -> String -> IO String
forall a. HasCallStack => String -> a
error String
"Cannot find pkg-config program"
            Just (ConfiguredProgram
pkgConfig, ProgramDb
_) -> Verbosity -> ConfiguredProgram -> [String] -> IO String
getProgramOutput Verbosity
verbosity ConfiguredProgram
pkgConfig [String
"--cflags", String
"verilator"]

    -- TODO: dependency tracking
    (String
verilogDir, Manifest
manifest) <- Ghc ()
-> LocalBuildInfo
-> BuildFlags
-> [String]
-> BuildInfo
-> ModuleName
-> String
-> String
-> IO (String, Manifest)
clashToVerilog Ghc ()
startAction LocalBuildInfo
lbi BuildFlags
flags [String]
srcDirs BuildInfo
buildInfo ModuleName
mod String
entity String
synDir
    Maybe String -> String -> String -> Maybe Text -> Manifest -> IO ()
Clashilator.generateFiles (String -> Maybe String
forall a. a -> Maybe a
Just String
cflags) String
verilogDir String
verilatorDir (String -> Text
forall a. IsString a => String -> a
fromString (String -> Text) -> Maybe String -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
clk) Manifest
manifest

    -- TODO: get `make` location from configuration
    String
_ <- Verbosity -> ProgramInvocation -> IO String
getProgramInvocationOutput Verbosity
verbosity (ProgramInvocation -> IO String) -> ProgramInvocation -> IO String
forall a b. (a -> b) -> a -> b
$
         String -> [String] -> ProgramInvocation
simpleProgramInvocation String
"make" [String
"-f", String
verilatorDir String -> String -> String
</> String
"Makefile"]

    let incDir :: String
incDir = String
verilatorDir String -> String -> String
</> String
"src"
        libDir :: String
libDir = String
verilatorDir String -> String -> String
</> String
"obj"
        lib :: String
lib = String
"VerilatorFFI"

    let fixupOptions :: (t -> v) -> PerCompilerFlavor t -> PerCompilerFlavor v
fixupOptions t -> v
f (PerCompilerFlavor t
x t
y) = v -> v -> PerCompilerFlavor v
forall v. v -> v -> PerCompilerFlavor v
PerCompilerFlavor (t -> v
f t
x) (t -> v
f t
y)

        compileFlags :: [String]
compileFlags =
            [ String
"-fPIC"
            ]

        ldFlags :: [String]
ldFlags =
            [ String
"-Wl,--whole-archive"
            , String
"-Wl,-Bstatic"
            , String
"-Wl,-l" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
lib
            , String
"-Wl,-Bdynamic"
            , String
"-Wl,--no-whole-archive"
            ]

    BuildInfo -> IO BuildInfo
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (BuildInfo -> IO BuildInfo) -> BuildInfo -> IO BuildInfo
forall a b. (a -> b) -> a -> b
$ BuildInfo
buildInfo
      BuildInfo -> (BuildInfo -> BuildInfo) -> BuildInfo
forall a b. a -> (a -> b) -> b
& LensLike Identity BuildInfo BuildInfo [String] [String]
forall a. HasBuildInfo a => Lens' a [String]
Lens' BuildInfo [String]
includeDirs LensLike Identity BuildInfo BuildInfo [String] [String]
-> ([String] -> [String]) -> BuildInfo -> BuildInfo
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (String
incDirString -> [String] -> [String]
forall a. a -> [a] -> [a]
:)
      BuildInfo -> (BuildInfo -> BuildInfo) -> BuildInfo
forall a b. a -> (a -> b) -> b
& LensLike Identity BuildInfo BuildInfo [String] [String]
forall a. HasBuildInfo a => Lens' a [String]
Lens' BuildInfo [String]
extraLibDirs LensLike Identity BuildInfo BuildInfo [String] [String]
-> ([String] -> [String]) -> BuildInfo -> BuildInfo
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (String
libDirString -> [String] -> [String]
forall a. a -> [a] -> [a]
:)
      BuildInfo -> (BuildInfo -> BuildInfo) -> BuildInfo
forall a b. a -> (a -> b) -> b
& LensLike Identity BuildInfo BuildInfo [String] [String]
forall a. HasBuildInfo a => Lens' a [String]
Lens' BuildInfo [String]
extraLibs LensLike Identity BuildInfo BuildInfo [String] [String]
-> ([String] -> [String]) -> BuildInfo -> BuildInfo
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (String
"stdc++"String -> [String] -> [String]
forall a. a -> [a] -> [a]
:)
      BuildInfo -> (BuildInfo -> BuildInfo) -> BuildInfo
forall a b. a -> (a -> b) -> b
& LensLike
  Identity
  BuildInfo
  BuildInfo
  (PerCompilerFlavor [String])
  (PerCompilerFlavor [String])
forall a. HasBuildInfo a => Lens' a (PerCompilerFlavor [String])
Lens' BuildInfo (PerCompilerFlavor [String])
options LensLike
  Identity
  BuildInfo
  BuildInfo
  (PerCompilerFlavor [String])
  (PerCompilerFlavor [String])
-> (PerCompilerFlavor [String] -> PerCompilerFlavor [String])
-> BuildInfo
-> BuildInfo
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ([String] -> [String])
-> PerCompilerFlavor [String] -> PerCompilerFlavor [String]
forall {t} {v}.
(t -> v) -> PerCompilerFlavor t -> PerCompilerFlavor v
fixupOptions ([String]
compileFlags[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++)
      BuildInfo -> (BuildInfo -> BuildInfo) -> BuildInfo
forall a b. a -> (a -> b) -> b
& LensLike Identity BuildInfo BuildInfo [String] [String]
forall a. HasBuildInfo a => Lens' a [String]
Lens' BuildInfo [String]
ldOptions LensLike Identity BuildInfo BuildInfo [String] [String]
-> ([String] -> [String]) -> BuildInfo -> BuildInfo
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ([String]
ldFlags[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++)
      BuildInfo -> (BuildInfo -> BuildInfo) -> BuildInfo
forall a b. a -> (a -> b) -> b
& LensLike
  Identity
  BuildInfo
  BuildInfo
  [SymbolicPath PackageDir SourceDir]
  [SymbolicPath PackageDir SourceDir]
forall a.
HasBuildInfo a =>
Lens' a [SymbolicPath PackageDir SourceDir]
Lens' BuildInfo [SymbolicPath PackageDir SourceDir]
hsSourceDirs LensLike
  Identity
  BuildInfo
  BuildInfo
  [SymbolicPath PackageDir SourceDir]
  [SymbolicPath PackageDir SourceDir]
-> ([SymbolicPath PackageDir SourceDir]
    -> [SymbolicPath PackageDir SourceDir])
-> BuildInfo
-> BuildInfo
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (String -> SymbolicPath PackageDir SourceDir
forall from to. String -> SymbolicPath from to
unsafeMakeSymbolicPath String
incDirSymbolicPath PackageDir SourceDir
-> [SymbolicPath PackageDir SourceDir]
-> [SymbolicPath PackageDir SourceDir]
forall a. a -> [a] -> [a]
:)
      BuildInfo -> (BuildInfo -> BuildInfo) -> BuildInfo
forall a b. a -> (a -> b) -> b
& LensLike Identity BuildInfo BuildInfo [ModuleName] [ModuleName]
forall a. HasBuildInfo a => Lens' a [ModuleName]
Lens' BuildInfo [ModuleName]
otherModules LensLike Identity BuildInfo BuildInfo [ModuleName] [ModuleName]
-> ([ModuleName] -> [ModuleName]) -> BuildInfo -> BuildInfo
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (String -> ModuleName
forall a. IsString a => String -> a
fromString String
"Clash.Clashilator.FFI"ModuleName -> [ModuleName] -> [ModuleName]
forall a. a -> [a] -> [a]
:)
  where
    verbosity :: Verbosity
verbosity = Verbosity -> Flag Verbosity -> Verbosity
forall a. a -> Flag a -> a
fromFlagOrDefault Verbosity
normal (BuildFlags -> Flag Verbosity
buildVerbosity BuildFlags
flags)

    clk :: Maybe String
clk = String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"x-clashilator-clock" ([(String, String)] -> Maybe String)
-> [(String, String)] -> Maybe String
forall a b. (a -> b) -> a -> b
$ Getting [(String, String)] BuildInfo [(String, String)]
-> BuildInfo -> [(String, String)]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [(String, String)] BuildInfo [(String, String)]
forall a. HasBuildInfo a => Lens' a [(String, String)]
Lens' BuildInfo [(String, String)]
customFieldsBI BuildInfo
buildInfo

    -- TODO: Maybe we could add extra source dirs from "x-clashilator-source-dirs"?
    srcDirs :: [String]
srcDirs = SymbolicPath PackageDir SourceDir -> String
forall from to. SymbolicPath from to -> String
getSymbolicPath (SymbolicPath PackageDir SourceDir -> String)
-> [SymbolicPath PackageDir SourceDir] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting
  [SymbolicPath PackageDir SourceDir]
  BuildInfo
  [SymbolicPath PackageDir SourceDir]
-> BuildInfo -> [SymbolicPath PackageDir SourceDir]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  [SymbolicPath PackageDir SourceDir]
  BuildInfo
  [SymbolicPath PackageDir SourceDir]
forall a.
HasBuildInfo a =>
Lens' a [SymbolicPath PackageDir SourceDir]
Lens' BuildInfo [SymbolicPath PackageDir SourceDir]
hsSourceDirs BuildInfo
buildInfo
    outDir :: String
outDir = case Maybe UnqualComponentName
compName of
        Maybe UnqualComponentName
Nothing -> LocalBuildInfo -> String
buildDir LocalBuildInfo
lbi
        Just UnqualComponentName
name -> LocalBuildInfo -> String
buildDir LocalBuildInfo
lbi String -> String -> String
</> UnqualComponentName -> String
unUnqualComponentName UnqualComponentName
name
    verilatorDir :: String
verilatorDir = String
outDir String -> String -> String
</> String
"_clashilator" String -> String -> String
</> String
"verilator"
    synDir :: String
synDir = String
outDir String -> String -> String
</> String
"_clashilator" String -> String -> String
</> String
"clash-syn"

clashilate :: LocalBuildInfo -> BuildFlags -> Component -> IO BuildInfo
clashilate :: ComponentHook
clashilate LocalBuildInfo
lbi BuildFlags
flags Component
c = do
#ifdef RESET_LINKER
    linker <- uninitializedLinker
    let startAction = do
            env <- getSession
            setSession (env {hsc_dynLinker = linker})
#else
    let startAction :: Ghc ()
startAction = () -> Ghc ()
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
#endif
    Ghc ()
-> LocalBuildInfo
-> BuildFlags
-> Maybe UnqualComponentName
-> BuildInfo
-> IO BuildInfo
buildVerilator Ghc ()
startAction LocalBuildInfo
lbi BuildFlags
flags (ComponentName -> Maybe UnqualComponentName
componentNameString (ComponentName -> Maybe UnqualComponentName)
-> ComponentName -> Maybe UnqualComponentName
forall a b. (a -> b) -> a -> b
$ Component -> ComponentName
componentName Component
c) (Component
c Component -> Getting BuildInfo Component BuildInfo -> BuildInfo
forall s a. s -> Getting a s a -> a
^. Getting BuildInfo Component BuildInfo
forall a. HasBuildInfo a => Lens' a BuildInfo
Lens' Component BuildInfo
buildInfo)

clashilatorMain :: IO ()
clashilatorMain :: IO ()
clashilatorMain = UserHooks -> IO ()
defaultMainWithHooks UserHooks
simpleUserHooks
    { buildHook = clashilatorBuildHook
    }