{-|
  Copyright   :  (C) 2012-2016, University of Twente,
                     2016-2017, Myrtle Software Ltd,
                     2017     , QBayLogic, Google Inc.
                     2020-2024, QBayLogic,
                     2022     , Google Inc.
                     2026     , Martijn Bastiaan

  License     :  BSD2 (see the file LICENSE)
  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>

  Module that connects all the parts of the Clash compiler library
-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# 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           Control.DeepSeq
import           Control.Exception                (evaluate, throw, Exception)
import qualified Control.Monad                    as Monad
import           Control.Monad                    (unless, foldM, forM)
import           Control.Monad.Catch              (MonadThrow (throwM), try)
import           Control.Monad.Extra              (whenM, ifM, unlessM)
import           Control.Monad.State              (evalState, get)
import           Control.Monad.State.Strict       (State)
import qualified Control.Monad.State.Strict       as State
import qualified Crypto.Hash.SHA256               as Sha256
import           Data.Bifunctor                   (first, second)
import           Data.ByteString                  (ByteString)
import qualified Data.ByteString                  as ByteString
import qualified Data.ByteString.Lazy             as ByteStringLazy
import qualified Data.ByteString.Lazy.Char8       as ByteStringLazyChar8
import           Data.Char                        (isAscii, isAlphaNum)
import           Data.Default
import           Data.Hashable                    (Hashable, hash)
import           Data.HashMap.Strict              (HashMap)
import qualified Data.HashMap.Strict              as HashMap
import qualified Data.HashSet                     as HashSet
import           Data.Proxy                       (Proxy(..))
import           Data.List                        (intercalate)
import qualified Data.List                        as List
import qualified Data.List.Extra                  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           ()
import           Data.Monoid                      (Ap(..))
import qualified Data.Text
import           Data.Text.Lazy                   (Text)
import qualified Data.Text.Lazy                   as Text
import           Data.Text.Lazy.Encoding          as Text
import qualified Data.Text.Lazy.IO                as Text
import           Data.Text.Prettyprint.Doc.Extra
  (Doc, LayoutOptions (..), PageWidth (..) , layoutPretty, renderLazy)
import qualified Data.Time.Clock                  as Clock
import           GHC.Generics                     (Generic)
import           GHC.Stack                        (HasCallStack)
import qualified Language.Haskell.Interpreter     as Hint
import qualified Language.Haskell.Interpreter.Extension as Hint
import qualified Language.Haskell.Interpreter.Unsafe as Hint
import qualified System.Directory                 as Directory
import           System.Directory
  (doesPathExist, listDirectory, doesDirectoryExist, createDirectoryIfMissing,
   removeDirectoryRecursive, doesFileExist)
import           System.Environment               (getExecutablePath)
import           System.FilePath                  ((</>), (<.>), takeDirectory, takeFileName, isAbsolute)
import qualified System.FilePath                  as FilePath
import qualified System.IO                        as IO
import           System.IO.Temp
  (getCanonicalTemporaryDirectory, withTempDirectory)
import           Text.Trifecta.Result
  (Result(Success, Failure), _errDoc)

import           GHC.Builtin.Names                 (eqTyConKey, ipClassKey)

import           GHC.Types.SrcLoc                  (SrcSpan)
import           GHC.BasicTypes.Extra             ()

import           Clash.Annotations.Primitive
  (HDL (..), extractPrim)
import           Clash.Annotations.BitRepresentation.Internal
  (CustomReprs)
import           Clash.Annotations.TopEntity
  (TopEntity (..), PortName(PortName, PortProduct))
import           Clash.Annotations.TopEntity.Extra ()
import           Clash.Backend
import           Clash.Core.PartialEval as PE     (Evaluator)
import           Clash.Core.Evaluator.Types as WHNF (Evaluator)
import           Clash.Core.HasType
import           Clash.Core.Name                  (Name (..))
import           Clash.Core.Pretty                (PrettyOptions(..), showPpr')
import           Clash.Core.Type
  (Type(ForAllTy, LitTy, AnnType), TypeView(..), tyView, mkFunTy, LitTy(SymTy))
import           Clash.Core.TyCon                 (TyConMap)
import           Clash.Core.Util                  (shouldSplit)
import           Clash.Core.Var
  (Id, varName, varUniq, varType)
import           Clash.Core.VarEnv
  (elemVarEnv, emptyVarEnv, lookupVarEnv, lookupVarEnv', mkVarEnv, lookupVarEnvDirectly, eltsVarEnv, VarEnv)
import           Clash.Debug                      (debugIsOn)
import qualified Clash.Driver.BrokenGhcs          as BrokenGhcs
import           Clash.Driver.Types
import           Clash.Driver.Manifest
  (Manifest(..), readFreshManifest, UnexpectedModification, pprintUnexpectedModifications,
   mkManifest, writeManifest, manifestFilename)
import           Clash.Edalize.Edam
import           Clash.Netlist                    (genNetlist, genTopNames)
import           Clash.Netlist.BlackBox.Parser    (runParse)
import           Clash.Netlist.BlackBox.Types     (BlackBoxTemplate, BlackBoxFunction)
import qualified Clash.Netlist.Id                 as Id
import           Clash.Netlist.Types
  (IdentifierText, BlackBox (..), Component (..), FilteredHWType, HWMap, SomeBackend (..),
   TopEntityT(..), TemplateFunction, ComponentMap, findClocks, ComponentMeta(..))
import           Clash.Netlist.Util               (checkTopEntityPorts)
import           Clash.Normalize                  (checkNonRecursive, cleanupGraph,
                                                   normalize, runNormalization)
import           Clash.Normalize.Util             (callGraph, tvSubstWithTyEq)
import qualified Clash.Primitives.Sized.Signed    as P
import qualified Clash.Primitives.Sized.ToInteger as P
import qualified Clash.Primitives.Sized.Vector    as P
import qualified Clash.Primitives.GHC.Int         as P
import qualified Clash.Primitives.GHC.Word        as P
import qualified Clash.Primitives.Intel.ClockGen  as P
import qualified Clash.Primitives.Magic           as P
import qualified Clash.Primitives.Verification    as P
import qualified Clash.Primitives.Xilinx.ClockGen as P
import           Clash.Primitives.Types
import           Clash.Signal.Internal
import           Clash.Unique                     (Unique, getUnique, fromGhcUnique)
import           Clash.Util
  (ClashException(..), reportTimeDiff,
   wantedLanguageExtensions, unwantedLanguageExtensions, curLoc)
import           Clash.Util.Graph                 (reverseTopSort)
import qualified Clash.Util.Interpolate           as I
import qualified Clash.Util.Supply                as Supply

-- | Worker function of 'splitTopEntityT'
splitTopAnn
  :: TyConMap
  -> SrcSpan
  -- ^ Source location of top entity (for error reporting)
  -> Type
  -- ^ Top entity body
  -> TopEntity
  -- ^ Port annotations for top entity
  -> TopEntity
  -- ^ New top entity with split ports (or the old one if not applicable)
splitTopAnn :: TyConMap -> SrcSpan -> Type -> TopEntity -> TopEntity
splitTopAnn TyConMap
tcm SrcSpan
sp typ :: Type
typ@(Type -> TypeView
tyView -> FunTy {}) t :: TopEntity
t@Synthesize{[PortName]
t_inputs :: [PortName]
t_inputs :: TopEntity -> [PortName]
t_inputs} =
  TopEntity
t{t_inputs=go typ t_inputs}
 where
  go :: Type -> [PortName] -> [PortName]
  go :: Type -> [PortName] -> [PortName]
go Type
_ [] = []
  go (Type -> TypeView
tyView -> FunTy Type
a Type
res) (PortName
p:[PortName]
ps)
   | Type -> Bool
shouldNotHavePortName Type
a
     -- Insert dummy PortName for args for which the user shouldn't have
     -- to provide a name.
     -- Ideally this would be any (non Hidden{Clock,Reset,Enable}) constraint.
     -- But because we can't properly detect constraints,
     -- we only skip some specific one. see "shouldNotHavePortName"
     = String -> PortName
PortName String
"" PortName -> [PortName] -> [PortName]
forall a. a -> [a] -> [a]
: Type -> [PortName] -> [PortName]
go Type
res (PortName
pPortName -> [PortName] -> [PortName]
forall a. a -> [a] -> [a]
:[PortName]
ps)
   | Bool
otherwise =
    case TyConMap -> Type -> Maybe ([Term] -> Term, Projections, [Type])
shouldSplit TyConMap
tcm Type
a of
      Just ([Term] -> Term
_,Projections
_,argTys :: [Type]
argTys@(Type
_:Type
_:[Type]
_)) ->
        -- Port must be split up into 'n' pieces.. can it?
        case PortName
p of
          PortProduct String
nm [PortName]
portNames0 ->
            let
              n :: Int
n = [Type] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Type]
argTys
              newPortNames :: [PortName]
newPortNames = (Int -> PortName) -> [Int] -> [PortName]
forall a b. (a -> b) -> [a] -> [b]
map (String -> PortName
PortName (String -> PortName) -> (Int -> String) -> Int -> PortName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show) [(Int
0::Int)..]
              portNames1 :: [PortName]
portNames1 = (PortName -> PortName) -> [PortName] -> [PortName]
forall a b. (a -> b) -> [a] -> [b]
map (String -> PortName -> PortName
prependName String
nm) ([PortName]
portNames0 [PortName] -> [PortName] -> [PortName]
forall a. [a] -> [a] -> [a]
++ [PortName]
newPortNames)
              newLam :: Type
newLam = (Type -> Type -> Type) -> [Type] -> Type
forall a. (a -> a -> a) -> [a] -> a
forall (t :: Type -> Type) a.
Foldable t =>
(a -> a -> a) -> t a -> a
foldr1 Type -> Type -> Type
mkFunTy ([Type]
argTys [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
res])
            in
              Type -> [PortName] -> [PortName]
go Type
newLam (Int -> [PortName] -> [PortName]
forall a. Int -> [a] -> [a]
take Int
n [PortName]
portNames1 [PortName] -> [PortName] -> [PortName]
forall a. [a] -> [a] -> [a]
++ [PortName]
ps)
          PortName String
nm ->
            ClashException -> [PortName]
forall a e. Exception e => e -> a
throw ((String -> Maybe String -> ClashException)
-> Maybe String -> String -> ClashException
forall a b c. (a -> b -> c) -> b -> a -> c
flip (SrcSpan -> String -> Maybe String -> ClashException
ClashException SrcSpan
sp) Maybe String
forall a. Maybe a
Nothing (String -> ClashException) -> String -> ClashException
forall a b. (a -> b) -> a -> b
$ [I.i|
              Couldn't separate clock, reset, or enable from a product type due
              to a malformed Synthesize annotation. All clocks, resets, and
              enables should be given a unique port name. Type to be split:

                #{showPpr' (PrettyOptions False True False False) a}

              Given port annotation: #{p}. You might want to use the
              following instead: PortProduct #{show nm} []. This allows Clash to
              autogenerate names based on the name #{show nm}.
            |])
      Maybe ([Term] -> Term, Projections, [Type])
_ ->
        -- No need to split the port, carrying on..
        PortName
p PortName -> [PortName] -> [PortName]
forall a. a -> [a] -> [a]
: Type -> [PortName] -> [PortName]
go Type
res [PortName]
ps
  go (ForAllTy TyVar
_tyVar Type
ty) [PortName]
ps = Type -> [PortName] -> [PortName]
go Type
ty [PortName]
ps
  go Type
_ty [PortName]
ps = [PortName]
ps

  prependName :: String -> PortName -> PortName
  prependName :: String -> PortName -> PortName
prependName String
"" PortName
pn = PortName
pn
  prependName String
p (PortProduct String
nm [PortName]
ps) = String -> [PortName] -> PortName
PortProduct (String
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nm) [PortName]
ps
  prependName String
p (PortName String
nm) = String -> PortName
PortName (String
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nm)

  -- Returns True for
  --   * type equality constraints (~)
  --   * HasCallStack
  shouldNotHavePortName :: Type -> Bool
  shouldNotHavePortName :: Type -> Bool
shouldNotHavePortName (Type -> TypeView
tyView -> TyConApp (TyConName -> Unique
forall a. Name a -> Unique
nameUniq -> Unique
tcUniq) [Type]
tcArgs)
    | Unique
tcUniq Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique -> Unique
fromGhcUnique Unique
eqTyConKey = Bool
True
    | Unique
tcUniq Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique -> Unique
fromGhcUnique Unique
ipClassKey
    , [LitTy (SymTy String
"callStack"), Type
_] <- [Type]
tcArgs = Bool
True
  shouldNotHavePortName Type
_ = Bool
False

splitTopAnn TyConMap
tcm SrcSpan
sp (ForAllTy TyVar
_tyVar Type
typ) TopEntity
t = TyConMap -> SrcSpan -> Type -> TopEntity -> TopEntity
splitTopAnn TyConMap
tcm SrcSpan
sp Type
typ TopEntity
t
splitTopAnn TyConMap
tcm SrcSpan
sp (AnnType [Attr Text]
_anns Type
typ) TopEntity
t = TyConMap -> SrcSpan -> Type -> TopEntity -> TopEntity
splitTopAnn TyConMap
tcm SrcSpan
sp Type
typ TopEntity
t
splitTopAnn TyConMap
_tcm SrcSpan
_sp Type
_typ TopEntity
t = TopEntity
t

-- When splitting up a single argument into multiple arguments (see docs of
-- 'separateArguments') we should make sure to update TopEntity annotations
-- accordingly. See: https://github.com/clash-lang/clash-compiler/issues/1033
splitTopEntityT
  :: HasCallStack
  => TyConMap
  -> BindingMap
  -> TopEntityT
  -> TopEntityT
splitTopEntityT :: HasCallStack => TyConMap -> BindingMap -> TopEntityT -> TopEntityT
splitTopEntityT TyConMap
tcm BindingMap
bindingsMap tt :: TopEntityT
tt@(TopEntityT Id
id_ (Just t :: TopEntity
t@(Synthesize {})) Bool
_) =
  case Id -> BindingMap -> Maybe (Binding Term)
forall b a. Var b -> VarEnv a -> Maybe a
lookupVarEnv Id
id_ BindingMap
bindingsMap of
    Just (Binding Id
_id SrcSpan
sp InlineSpec
_ IsPrim
_ Term
_ Bool
_) ->
      TopEntityT
tt{topAnnotation=Just (splitTopAnn tcm sp (coreTypeOf id_) t)}
    Maybe (Binding Term)
Nothing ->
      String -> TopEntityT
forall a. HasCallStack => String -> a
error String
"Internal error in 'splitTopEntityT'. Please report as a bug."
splitTopEntityT TyConMap
_ BindingMap
_ TopEntityT
t = TopEntityT
t

-- | Remove constraints such as 'a ~ 3'.
removeForAll :: TopEntityT -> TopEntityT
removeForAll :: TopEntityT -> TopEntityT
removeForAll (TopEntityT Id
var Maybe TopEntity
annM Bool
isTb) =
  Id -> Maybe TopEntity -> Bool -> TopEntityT
TopEntityT Id
var{varType=tvSubstWithTyEq (coreTypeOf var)} Maybe TopEntity
annM Bool
isTb

-- | Given a list of all found top entities and _maybe_ a top entity (+dependencies)
-- passed in by '-main-is', return the list of top entities Clash needs to
-- compile.
selectTopEntities :: [TopEntityT] -> Maybe (TopEntityT, [TopEntityT]) -> [TopEntityT]
selectTopEntities :: [TopEntityT] -> Maybe (TopEntityT, [TopEntityT]) -> [TopEntityT]
selectTopEntities [TopEntityT]
topEntities Maybe (TopEntityT, [TopEntityT])
mainTopEntity =
  [TopEntityT]
-> ((TopEntityT, [TopEntityT]) -> [TopEntityT])
-> Maybe (TopEntityT, [TopEntityT])
-> [TopEntityT]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [TopEntityT]
topEntities ((TopEntityT -> [TopEntityT] -> [TopEntityT])
-> (TopEntityT, [TopEntityT]) -> [TopEntityT]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (:)) Maybe (TopEntityT, [TopEntityT])
mainTopEntity

-- | Get modification data of current clash binary.
getClashModificationDate :: IO Clock.UTCTime
getClashModificationDate :: IO UTCTime
getClashModificationDate = String -> IO UTCTime
Directory.getModificationTime (String -> IO UTCTime) -> IO String -> IO UTCTime
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO String
getExecutablePath

hdlFromBackend :: forall backend. Backend backend => Proxy backend -> HDL
hdlFromBackend :: forall backend. Backend backend => Proxy backend -> HDL
hdlFromBackend Proxy backend
_ = backend -> HDL
forall state. Backend state => state -> HDL
hdlKind (backend
forall a. HasCallStack => a
undefined :: backend)

replaceChar :: Char -> Char -> String -> String
replaceChar :: Char -> Char -> String -> String
replaceChar Char
a Char
b = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
go
 where
  go :: Char -> Char
go Char
c
    | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
a = Char
b
    | Bool
otherwise = Char
c

removeHistoryFile :: Maybe FilePath -> IO ()
removeHistoryFile :: Maybe String -> IO ()
removeHistoryFile =
  IO () -> (String -> IO ()) -> Maybe String -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()) String -> IO ()
removeHistory
 where
  removeHistory :: String -> IO ()
removeHistory String
path =
    IO Bool -> IO () -> IO ()
forall (m :: Type -> Type). Monad m => m Bool -> m () -> m ()
whenM (String -> IO Bool
Directory.doesFileExist String
path) (String -> IO ()
Directory.removeFile String
path)

prefixModuleName
  :: HDL
  -> Maybe Data.Text.Text
  -> Maybe TopEntity
  -> String
  -> (String, Maybe String)
prefixModuleName :: HDL
-> Maybe Text
-> Maybe TopEntity
-> String
-> (String, Maybe String)
prefixModuleName HDL
hdl Maybe Text
compPrefix Maybe TopEntity
annM String
modName =
  case Maybe Text
compPrefix of
    Just (Text -> String
Data.Text.unpack -> String
p)
      | Bool -> Bool
not (String -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null String
p) -> case Maybe TopEntity
annM of
          Just TopEntity
ann ->
            let nm :: String
nm = String
p String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"_" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TopEntity -> String
t_name TopEntity
ann
             in (String
nm, String -> Maybe String
forall a. a -> Maybe a
Just String
nm)

          Maybe TopEntity
Nothing ->
            (String
p String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"_" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
modName, String -> Maybe String
forall a. a -> Maybe a
Just String
p)

      | Just TopEntity
ann <- Maybe TopEntity
annM -> case HDL
hdl of
          HDL
VHDL -> (TopEntity -> String
t_name TopEntity
ann, String -> Maybe String
forall a. a -> Maybe a
Just String
modName)
          HDL
_ -> (TopEntity -> String
t_name TopEntity
ann, Maybe String
forall a. Maybe a
Nothing)

    Maybe Text
_ -> case Maybe TopEntity
annM of
      Just TopEntity
ann -> case HDL
hdl of
        HDL
VHDL -> (TopEntity -> String
t_name TopEntity
ann, String -> Maybe String
forall a. a -> Maybe a
Just String
modName)
        HDL
_ -> (TopEntity -> String
t_name TopEntity
ann, String -> Maybe String
forall a. a -> Maybe a
Just String
modName)
      Maybe TopEntity
_ -> (String
modName, Maybe String
forall a. Maybe a
Nothing)

-- | Create a set of target HDL files for a set of functions
generateHDL
  :: forall backend . Backend backend
  => ClashEnv
  -> ClashDesign
  -> Maybe backend
  -> (CustomReprs -> TyConMap -> Type ->
      State HWMap (Maybe (Either String FilteredHWType)))
  -- ^ Hardcoded 'Type' -> 'HWType' translator
  -> PE.Evaluator
  -- ^ Hardcoded evaluator for partial evaluation
  -> WHNF.Evaluator
  -- ^ Hardcoded evaluator for WHNF (old evaluator)
  -> Maybe (TopEntityT, [TopEntityT])
  -- ^ Main top entity to compile. If Nothing, all top entities in the
  -- 'ClashDesign' argument will be compiled.
  -> Clock.UTCTime
  -> IO ()
generateHDL :: forall backend.
Backend backend =>
ClashEnv
-> ClashDesign
-> Maybe backend
-> (CustomReprs
    -> TyConMap
    -> Type
    -> State HWMap (Maybe (Either String FilteredHWType)))
-> Evaluator
-> Evaluator
-> Maybe (TopEntityT, [TopEntityT])
-> UTCTime
-> IO ()
generateHDL ClashEnv
env ClashDesign
design Maybe backend
hdlState CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
typeTrans Evaluator
peEval Evaluator
eval Maybe (TopEntityT, [TopEntityT])
mainTopEntity UTCTime
startTime = do
    let bindingsMap :: BindingMap
bindingsMap = ClashDesign -> BindingMap
designBindings ClashDesign
design
    let tcm :: TyConMap
tcm = ClashEnv -> TyConMap
envTyConMap ClashEnv
env
    let topEntities0 :: [TopEntityT]
topEntities0 = ClashDesign -> [TopEntityT]
designEntities ClashDesign
design
    let opts :: ClashOpts
opts = ClashEnv -> ClashOpts
envOpts ClashEnv
env

    -- Detect "broken" GHCs and throw an error (unless silenced)
    Bool -> IO () -> IO ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
unless (ClashOpts -> Bool
opt_ignoreBrokenGhcs ClashOpts
opts) IO ()
BrokenGhcs.assertWorking

    Maybe String -> IO ()
removeHistoryFile (DebugOpts -> Maybe String
dbg_historyFile (ClashOpts -> DebugOpts
opt_debug ClashOpts
opts))

    Bool -> IO () -> IO ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
unless (ClashOpts -> Bool
opt_cachehdl ClashOpts
opts) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      String -> IO ()
putStrLn String
"Clash: Ignoring previously made caches"

    let topEntities1 :: [TopEntityT]
topEntities1 = (TopEntityT -> TopEntityT) -> [TopEntityT] -> [TopEntityT]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (TopEntityT -> TopEntityT
removeForAll (TopEntityT -> TopEntityT)
-> (TopEntityT -> TopEntityT) -> TopEntityT -> TopEntityT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => TyConMap -> BindingMap -> TopEntityT -> TopEntityT
TyConMap -> BindingMap -> TopEntityT -> TopEntityT
splitTopEntityT TyConMap
tcm BindingMap
bindingsMap)
                         ([TopEntityT] -> Maybe (TopEntityT, [TopEntityT]) -> [TopEntityT]
selectTopEntities [TopEntityT]
topEntities0 Maybe (TopEntityT, [TopEntityT])
mainTopEntity)
        hdl :: HDL
hdl = Proxy backend -> HDL
forall backend. Backend backend => Proxy backend -> HDL
hdlFromBackend (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @backend)
        (VarEnv Identifier
compNames, IdentifierSet
initIs) = ClashOpts
-> HDL -> [TopEntityT] -> (VarEnv Identifier, IdentifierSet)
genTopNames ClashOpts
opts HDL
hdl [TopEntityT]
topEntities1
        ([TopEntityT]
tes, HashMap Unique [Unique]
deps) = BindingMap
-> [TopEntityT] -> ([TopEntityT], HashMap Unique [Unique])
sortTop BindingMap
bindingsMap [TopEntityT]
topEntities1

    -- TODO This is here because of some minimal effort refactoring. At some
    -- point generateHDL should be better laid out so this can be closer to
    -- the few places it is needed.
    let topEntityMap :: VarEnv TopEntityT
topEntityMap = [(Id, TopEntityT)] -> VarEnv TopEntityT
forall a b. [(Var a, b)] -> VarEnv b
mkVarEnv ((TopEntityT -> (Id, TopEntityT))
-> [TopEntityT] -> [(Id, TopEntityT)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (\TopEntityT
x -> (TopEntityT -> Id
topId TopEntityT
x, TopEntityT
x)) [TopEntityT]
topEntities1)

    -- Data which is updated and used when updating the different top entities
    -- is kept in an MVar.
    MVar IdentifierSet
idSet <- IdentifierSet -> IO (MVar IdentifierSet)
forall a. a -> IO (MVar a)
newMVar IdentifierSet
initIs
    MVar (HashMap Unique [EdamFile])
edamFiles <- HashMap Unique [EdamFile] -> IO (MVar (HashMap Unique [EdamFile]))
forall a. a -> IO (MVar a)
newMVar HashMap Unique [EdamFile]
forall k v. HashMap k v
HashMap.empty
    MVar ()
ioLock <- () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()

    let
      maybeMapConcurrently_ :: (a -> IO b) -> [a] -> IO ()
maybeMapConcurrently_
        | ClashOpts -> Bool
opt_concurrentTopEntities ClashOpts
opts = (a -> IO b) -> [a] -> IO ()
forall (f :: Type -> Type) a b.
Foldable f =>
(a -> IO b) -> f a -> IO ()
mapConcurrently_
        | Bool
otherwise = (a -> IO b) -> [a] -> IO ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_

    (TopEntityT -> IO ()) -> [TopEntityT] -> IO ()
forall {a} {b}. (a -> IO b) -> [a] -> IO ()
maybeMapConcurrently_ (VarEnv Identifier
-> MVar IdentifierSet
-> MVar (HashMap Unique [EdamFile])
-> MVar ()
-> HashMap Unique [Unique]
-> VarEnv TopEntityT
-> TopEntityT
-> IO ()
go VarEnv Identifier
compNames MVar IdentifierSet
idSet MVar (HashMap Unique [EdamFile])
edamFiles MVar ()
ioLock HashMap Unique [Unique]
deps VarEnv TopEntityT
topEntityMap) [TopEntityT]
tes

    UTCTime
time <- IO UTCTime
Clock.getCurrentTime
    let diff :: String
diff = UTCTime -> UTCTime -> String
reportTimeDiff UTCTime
time UTCTime
startTime
    String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Clash: Total compilation took " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
diff
 where
  go
    :: VarEnv Id.Identifier
    -> MVar Id.IdentifierSet
    -> MVar (HashMap Unique [EdamFile])
    -> MVar ()
    -> HashMap Unique [Unique]
    -> VarEnv TopEntityT
    -> TopEntityT
    -> IO ()
  go :: VarEnv Identifier
-> MVar IdentifierSet
-> MVar (HashMap Unique [EdamFile])
-> MVar ()
-> HashMap Unique [Unique]
-> VarEnv TopEntityT
-> TopEntityT
-> IO ()
go VarEnv Identifier
compNames MVar IdentifierSet
seenV MVar (HashMap Unique [EdamFile])
edamFilesV MVar ()
ioLockV HashMap Unique [Unique]
deps VarEnv TopEntityT
topEntityMap (TopEntityT Id
topEntity Maybe TopEntity
annM Bool
isTb) = do
  let domainConfs :: DomainMap
domainConfs = ClashEnv -> DomainMap
envDomains ClashEnv
env
  let bindingsMap :: BindingMap
bindingsMap = ClashDesign -> BindingMap
designBindings ClashDesign
design
  let primMap :: CompiledPrimMap
primMap = ClashEnv -> CompiledPrimMap
envPrimitives ClashEnv
env
  let topEntities0 :: [TopEntityT]
topEntities0 = ClashDesign -> [TopEntityT]
designEntities ClashDesign
design
  let opts :: ClashOpts
opts = ClashEnv -> ClashOpts
envOpts ClashEnv
env
  UTCTime
prevTime <- IO UTCTime
Clock.getCurrentTime
  let topEntityS :: String
topEntityS = Text -> String
Data.Text.unpack (Name Term -> Text
forall a. Name a -> Text
nameOcc (Id -> Name Term
forall a. Var a -> Name a
varName Id
topEntity))

  MVar () -> (() -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
ioLockV ((() -> IO ()) -> IO ())
-> (IO () -> () -> IO ()) -> IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> () -> IO ()
forall a b. a -> b -> a
const (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    String -> IO ()
putStrLn (String
"Clash: Compiling " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
topEntityS)

  let modName1 :: String
modName1 = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter (\Char
c -> Char -> Bool
isAscii Char
c Bool -> Bool -> Bool
&& (Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_')) (Char -> Char -> String -> String
replaceChar Char
'.' Char
'_' String
topEntityS)

  MVar IdentifierSet -> (IdentifierSet -> IO IdentifierSet) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar IdentifierSet
seenV ((IdentifierSet -> IO IdentifierSet) -> IO ())
-> (IdentifierSet -> IO IdentifierSet) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IdentifierSet
seen ->
    IdentifierSet -> IO IdentifierSet
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (IdentifierSet -> IO IdentifierSet)
-> IdentifierSet -> IO IdentifierSet
forall a b. (a -> b) -> a -> b
$! State IdentifierSet Identifier -> IdentifierSet -> IdentifierSet
forall s a. State s a -> s -> s
State.execState (Text -> State IdentifierSet Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Text -> m Identifier
Id.addRaw (String -> Text
Data.Text.pack String
modName1)) IdentifierSet
seen

  let topNm :: Identifier
topNm = VarEnv Identifier -> Id -> Identifier
forall a b. HasCallStack => VarEnv a -> Var b -> a
lookupVarEnv' VarEnv Identifier
compNames Id
topEntity
      (String
modNameS, (String -> Text) -> Maybe String -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Text
Data.Text.pack -> Maybe Text
prefixM) = HDL
-> Maybe Text
-> Maybe TopEntity
-> String
-> (String, Maybe String)
prefixModuleName (backend -> HDL
forall state. Backend state => state -> HDL
hdlKind (backend
forall a. HasCallStack => a
undefined :: backend)) (ClashOpts -> Maybe Text
opt_componentPrefix ClashOpts
opts) Maybe TopEntity
annM String
modName1
      modNameT :: Text
modNameT  = String -> Text
Data.Text.pack String
modNameS
      hdlState' :: backend
hdlState' = DomainMap -> backend -> backend
forall state. Backend state => DomainMap -> state -> state
setDomainConfigurations DomainMap
domainConfs
                (backend -> backend) -> backend -> backend
forall a b. (a -> b) -> a -> b
$ Text -> backend -> backend
forall state. Backend state => Text -> state -> state
setModName Text
modNameT
                (backend -> backend) -> backend -> backend
forall a b. (a -> b) -> a -> b
$ Identifier -> backend -> backend
forall state. Backend state => Identifier -> state -> state
setTopName Identifier
topNm
                (backend -> backend) -> backend -> backend
forall a b. (a -> b) -> a -> b
$ backend -> Maybe backend -> backend
forall a. a -> Maybe a -> a
fromMaybe (forall state. Backend state => ClashOpts -> state
initBackend @backend ClashOpts
opts) Maybe backend
hdlState
      hdlDir :: String
hdlDir    = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe (backend -> String
forall state. Backend state => state -> String
Clash.Backend.name backend
hdlState') (ClashOpts -> Maybe String
opt_hdlDir ClashOpts
opts) String -> String -> String
</> String
topEntityS
      manPath :: String
manPath   = String
hdlDir String -> String -> String
</> String
forall a. IsString a => a
manifestFilename
      ite :: Bool
ite       = backend -> Bool
forall state. Backend state => state -> Bool
ifThenElseExpr backend
hdlState'
      topNmT :: Text
topNmT    = Identifier -> Text
Id.toText Identifier
topNm

  -- Get manifest file if cache is not stale and caching is enabled. This is used
  -- to prevent unnecessary recompilation.
  UTCTime
clashModDate <- IO UTCTime
getClashModificationDate
  (Maybe [UnexpectedModification]
userModifications, Maybe Manifest
maybeManifest, (ByteString, DebugSubHashes)
topHashWithSubHashes) <-
    [TopEntityT]
-> (BindingMap, Id)
-> CompiledPrimMap
-> ClashOpts
-> UTCTime
-> String
-> IO
     (Maybe [UnexpectedModification], Maybe Manifest,
      (ByteString, DebugSubHashes))
readFreshManifest [TopEntityT]
topEntities0 (BindingMap
bindingsMap, Id
topEntity) CompiledPrimMap
primMap ClashOpts
opts UTCTime
clashModDate String
manPath

  let topEntityNames :: [Id]
topEntityNames = (TopEntityT -> Id) -> [TopEntityT] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map TopEntityT -> Id
topId (VarEnv TopEntityT -> [TopEntityT]
forall a. VarEnv a -> [a]
eltsVarEnv VarEnv TopEntityT
topEntityMap)

  case Maybe Manifest
maybeManifest of
    Just manifest0 :: Manifest
manifest0@Manifest{[(String, ByteString)]
fileNames :: [(String, ByteString)]
fileNames :: Manifest -> [(String, ByteString)]
fileNames} | Just [] <- Maybe [UnexpectedModification]
userModifications -> do
      -- Found a 'manifest' files. Use it to extend "seen" set. Generate EDAM
      -- files if necessary.
      MVar () -> (() -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
ioLockV ((() -> IO ()) -> IO ())
-> (IO () -> () -> IO ()) -> IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> () -> IO ()
forall a b. a -> b -> a
const (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        String -> IO ()
putStrLn (String
"Clash: Using cached result for: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
topEntityS)

      MVar IdentifierSet -> (IdentifierSet -> IO IdentifierSet) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar IdentifierSet
seenV ((IdentifierSet -> IO IdentifierSet) -> IO ())
-> (IdentifierSet -> IO IdentifierSet) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IdentifierSet
seen ->
        IdentifierSet -> IO IdentifierSet
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (IdentifierSet -> IO IdentifierSet)
-> IdentifierSet -> IO IdentifierSet
forall a b. (a -> b) -> a -> b
$! State IdentifierSet () -> IdentifierSet -> IdentifierSet
forall s a. State s a -> s -> s
State.execState ((Text -> State IdentifierSet Identifier)
-> [Text] -> State IdentifierSet ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Text -> State IdentifierSet Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Text -> m Identifier
Id.addRaw (Manifest -> [Text]
componentNames Manifest
manifest0)) IdentifierSet
seen

      [(String, ByteString)]
fileNames1 <- MVar (HashMap Unique [EdamFile])
-> (HashMap Unique [EdamFile]
    -> IO (HashMap Unique [EdamFile], [(String, ByteString)]))
-> IO [(String, ByteString)]
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar (HashMap Unique [EdamFile])
edamFilesV ((HashMap Unique [EdamFile]
  -> IO (HashMap Unique [EdamFile], [(String, ByteString)]))
 -> IO [(String, ByteString)])
-> (HashMap Unique [EdamFile]
    -> IO (HashMap Unique [EdamFile], [(String, ByteString)]))
-> IO [(String, ByteString)]
forall a b. (a -> b) -> a -> b
$ \HashMap Unique [EdamFile]
edamFiles ->
        if ClashOpts -> Bool
opt_edalize ClashOpts
opts
          then String
-> (Identifier, Unique)
-> HashMap Unique [Unique]
-> HashMap Unique [EdamFile]
-> [(String, ByteString)]
-> IO (HashMap Unique [EdamFile], [(String, ByteString)])
writeEdam String
hdlDir (Identifier
topNm, Id -> Unique
forall a. Var a -> Unique
varUniq Id
topEntity) HashMap Unique [Unique]
deps HashMap Unique [EdamFile]
edamFiles [(String, ByteString)]
fileNames
          else (HashMap Unique [EdamFile], [(String, ByteString)])
-> IO (HashMap Unique [EdamFile], [(String, ByteString)])
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (HashMap Unique [EdamFile]
edamFiles, [(String, ByteString)]
fileNames)

      String -> Manifest -> IO ()
writeManifest String
manPath Manifest
manifest0{fileNames=fileNames1}

      UTCTime
topTime <- IO UTCTime
Clock.getCurrentTime
      let topDiff :: String
topDiff = UTCTime -> UTCTime -> String
reportTimeDiff UTCTime
topTime UTCTime
prevTime

      MVar () -> (() -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
ioLockV ((() -> IO ()) -> IO ())
-> (IO () -> () -> IO ()) -> IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> () -> IO ()
forall a b. a -> b -> a
const (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        String -> IO ()
putStrLn (String
"Clash: Compiling " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
topEntityS String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" took " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
topDiff)

      () -> IO ()
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()

    Maybe Manifest
_ -> do
      -- 1. Prepare HDL directory
      --
      -- [Note] Create HDL dir before netlist generation
      --
      -- Already create the directory where the HDL ends up being generated, as
      -- we use directories relative to this final directory to find manifest
      -- files belonging to other top entities. Failing to do so leads to #463
      String -> ClashOpts -> Maybe [UnexpectedModification] -> IO ()
prepareDir String
hdlDir ClashOpts
opts Maybe [UnexpectedModification]
userModifications

      -- 2. Validate the top entity's 'Synthesize' port annotation. This is done
      -- before normalization so that "trivial" port errors are reported quickly,
      -- instead of only after a (potentially long) normalization (#3305).
      --
      -- 'annM' is already split (by 'splitTopEntityT') and 'topEntity' has been
      -- through 'removeForAll', so the types and ports line up; see
      -- 'checkTopEntityPorts' for how the check is kept equivalent to the one in
      -- 'mkUniqueNormalized'.
      --
      -- XXX: Because the types are split to match, reported errors may refer to
      --      ports the user didn't directly write.
      () -> IO ()
forall a. a -> IO a
evaluate
        (HasCallStack =>
(CustomReprs
 -> TyConMap
 -> Type
 -> State HWMap (Maybe (Either String FilteredHWType)))
-> CustomReprs -> TyConMap -> Id -> Maybe TopEntity -> ()
(CustomReprs
 -> TyConMap
 -> Type
 -> State HWMap (Maybe (Either String FilteredHWType)))
-> CustomReprs -> TyConMap -> Id -> Maybe TopEntity -> ()
checkTopEntityPorts CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
typeTrans (ClashEnv -> CustomReprs
envCustomReprs ClashEnv
env) (ClashEnv -> TyConMap
envTyConMap ClashEnv
env)
           Id
topEntity Maybe TopEntity
annM)

      -- 3. Normalize topEntity
      Supply
supplyN <- IO Supply
Supply.newSupply
      BindingMap
transformedBindings <- ClashEnv
-> BindingMap
-> (CustomReprs
    -> TyConMap
    -> Type
    -> State HWMap (Maybe (Either String FilteredHWType)))
-> Evaluator
-> Evaluator
-> [Id]
-> Supply
-> Id
-> IO BindingMap
normalizeEntity ClashEnv
env BindingMap
bindingsMap CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
typeTrans Evaluator
peEval
                               Evaluator
eval [Id]
topEntityNames Supply
supplyN Id
topEntity

      UTCTime
normTime <- BindingMap
transformedBindings BindingMap -> IO UTCTime -> IO UTCTime
forall a b. NFData a => a -> b -> b
`deepseq` IO UTCTime
Clock.getCurrentTime
      let prepNormDiff :: String
prepNormDiff = UTCTime -> UTCTime -> String
reportTimeDiff UTCTime
normTime UTCTime
prevTime

      MVar () -> (() -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
ioLockV ((() -> IO ()) -> IO ())
-> (IO () -> () -> IO ()) -> IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> () -> IO ()
forall a b. a -> b -> a
const (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        String -> IO ()
putStrLn (String
"Clash: Normalization took " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
prepNormDiff)

      -- 4. Generate netlist for topEntity
      (Component
topComponent, ComponentMap
netlist) <- MVar IdentifierSet
-> (IdentifierSet -> IO (IdentifierSet, (Component, ComponentMap)))
-> IO (Component, ComponentMap)
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar IdentifierSet
seenV ((IdentifierSet -> IO (IdentifierSet, (Component, ComponentMap)))
 -> IO (Component, ComponentMap))
-> (IdentifierSet -> IO (IdentifierSet, (Component, ComponentMap)))
-> IO (Component, ComponentMap)
forall a b. (a -> b) -> a -> b
$ \IdentifierSet
seen -> do
        (Component
topComponent, ComponentMap
netlist, IdentifierSet
seen') <-
          -- TODO My word, this has far too many arguments.
          ClashEnv
-> Evaluator
-> Bool
-> BindingMap
-> VarEnv TopEntityT
-> VarEnv Identifier
-> (CustomReprs
    -> TyConMap
    -> Type
    -> State HWMap (Maybe (Either String FilteredHWType)))
-> Bool
-> SomeBackend
-> IdentifierSet
-> String
-> Maybe Text
-> Id
-> IO (Component, ComponentMap, IdentifierSet)
genNetlist ClashEnv
env Evaluator
peEval Bool
isTb BindingMap
transformedBindings VarEnv TopEntityT
topEntityMap VarEnv Identifier
compNames
            CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
typeTrans Bool
ite (backend -> SomeBackend
forall backend. Backend backend => backend -> SomeBackend
SomeBackend backend
hdlState') IdentifierSet
seen String
hdlDir Maybe Text
prefixM Id
topEntity

        (IdentifierSet, (Component, ComponentMap))
-> IO (IdentifierSet, (Component, ComponentMap))
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (IdentifierSet
seen', (Component
topComponent, ComponentMap
netlist))

      UTCTime
netlistTime <- ComponentMap
netlist ComponentMap -> IO UTCTime -> IO UTCTime
forall a b. NFData a => a -> b -> b
`deepseq` IO UTCTime
Clock.getCurrentTime
      let normNetDiff :: String
normNetDiff = UTCTime -> UTCTime -> String
reportTimeDiff UTCTime
netlistTime UTCTime
normTime

      MVar () -> (() -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
ioLockV ((() -> IO ()) -> IO ())
-> (IO () -> () -> IO ()) -> IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> () -> IO ()
forall a b. a -> b -> a
const (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        String -> IO ()
putStrLn (String
"Clash: Netlist generation took " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
normNetDiff)

      -- 5. Generate topEntity wrapper
      ([(String, Doc)]
hdlDocs, [(String, String)]
dfiles, [(String, String)]
mfiles) <- MVar IdentifierSet
-> (IdentifierSet
    -> IO ([(String, Doc)], [(String, String)], [(String, String)]))
-> IO ([(String, Doc)], [(String, String)], [(String, String)])
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar IdentifierSet
seenV ((IdentifierSet
  -> IO ([(String, Doc)], [(String, String)], [(String, String)]))
 -> IO ([(String, Doc)], [(String, String)], [(String, String)]))
-> (IdentifierSet
    -> IO ([(String, Doc)], [(String, String)], [(String, String)]))
-> IO ([(String, Doc)], [(String, String)], [(String, String)])
forall a b. (a -> b) -> a -> b
$ \IdentifierSet
seen ->
        ([(String, Doc)], [(String, String)], [(String, String)])
-> IO ([(String, Doc)], [(String, String)], [(String, String)])
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (([(String, Doc)], [(String, String)], [(String, String)])
 -> IO ([(String, Doc)], [(String, String)], [(String, String)]))
-> ([(String, Doc)], [(String, String)], [(String, String)])
-> IO ([(String, Doc)], [(String, String)], [(String, String)])
forall a b. (a -> b) -> a -> b
$! backend
-> ClashOpts
-> Text
-> IdentifierSet
-> ComponentMap
-> DomainMap
-> Component
-> Text
-> ([(String, Doc)], [(String, String)], [(String, String)])
forall backend.
Backend backend =>
backend
-> ClashOpts
-> Text
-> IdentifierSet
-> ComponentMap
-> DomainMap
-> Component
-> Text
-> ([(String, Doc)], [(String, String)], [(String, String)])
createHDL backend
hdlState' ClashOpts
opts Text
modNameT IdentifierSet
seen ComponentMap
netlist DomainMap
domainConfs Component
topComponent Text
topNmT

      -- TODO: Data files should go into their own directory
      -- FIXME: Files can silently overwrite each other
      [ByteString]
hdlDocDigests <- ((String, Doc) -> IO ByteString)
-> [(String, Doc)] -> IO [ByteString]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> [a] -> m [b]
mapM (String -> (String, Doc) -> IO ByteString
writeHDL String
hdlDir) [(String, Doc)]
hdlDocs
      [ByteString]
dataFilesDigests <- String -> [(String, String)] -> IO [ByteString]
copyDataFiles String
hdlDir [(String, String)]
dfiles
      [ByteString]
memoryFilesDigests <- String -> [(String, String)] -> IO [ByteString]
writeMemoryDataFiles String
hdlDir [(String, String)]
mfiles

      let
        components :: [Component]
components = ((Unique, (ComponentMeta, Component)) -> Component)
-> [(Unique, (ComponentMeta, Component))] -> [Component]
forall a b. (a -> b) -> [a] -> [b]
map ((ComponentMeta, Component) -> Component
forall a b. (a, b) -> b
snd ((ComponentMeta, Component) -> Component)
-> ((Unique, (ComponentMeta, Component))
    -> (ComponentMeta, Component))
-> (Unique, (ComponentMeta, Component))
-> Component
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Unique, (ComponentMeta, Component)) -> (ComponentMeta, Component)
forall a b. (a, b) -> b
snd) (ComponentMap -> [(Unique, (ComponentMeta, Component))]
forall k v. OMap k v -> [(k, v)]
OMap.assocs ComponentMap
netlist)
        filesAndDigests0 :: [(String, ByteString)]
filesAndDigests0 =
          -- FIXME: We should track dependencies of `mfiles` and `dfiles` and
          -- maintain the proper topological sort of all these.
             [String] -> [ByteString] -> [(String, ByteString)]
forall a b. [a] -> [b] -> [(a, b)]
zip (((String, String) -> String) -> [(String, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, String) -> String
forall a b. (a, b) -> a
fst [(String, String)]
mfiles) [ByteString]
memoryFilesDigests
          [(String, ByteString)]
-> [(String, ByteString)] -> [(String, ByteString)]
forall a. Semigroup a => a -> a -> a
<> [String] -> [ByteString] -> [(String, ByteString)]
forall a b. [a] -> [b] -> [(a, b)]
zip (((String, String) -> String) -> [(String, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, String) -> String
forall a b. (a, b) -> a
fst [(String, String)]
dfiles) [ByteString]
dataFilesDigests
          [(String, ByteString)]
-> [(String, ByteString)] -> [(String, ByteString)]
forall a. Semigroup a => a -> a -> a
<> [String] -> [ByteString] -> [(String, ByteString)]
forall a b. [a] -> [b] -> [(a, b)]
zip (((String, Doc) -> String) -> [(String, Doc)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, Doc) -> String
forall a b. (a, b) -> a
fst [(String, Doc)]
hdlDocs) [ByteString]
hdlDocDigests

      [(String, ByteString)]
filesAndDigests1 <- MVar (HashMap Unique [EdamFile])
-> (HashMap Unique [EdamFile]
    -> IO (HashMap Unique [EdamFile], [(String, ByteString)]))
-> IO [(String, ByteString)]
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar (HashMap Unique [EdamFile])
edamFilesV ((HashMap Unique [EdamFile]
  -> IO (HashMap Unique [EdamFile], [(String, ByteString)]))
 -> IO [(String, ByteString)])
-> (HashMap Unique [EdamFile]
    -> IO (HashMap Unique [EdamFile], [(String, ByteString)]))
-> IO [(String, ByteString)]
forall a b. (a -> b) -> a -> b
$ \HashMap Unique [EdamFile]
edamFiles ->
        if ClashOpts -> Bool
opt_edalize ClashOpts
opts
          then String
-> (Identifier, Unique)
-> HashMap Unique [Unique]
-> HashMap Unique [EdamFile]
-> [(String, ByteString)]
-> IO (HashMap Unique [EdamFile], [(String, ByteString)])
writeEdam String
hdlDir (Identifier
topNm, Id -> Unique
forall a. Var a -> Unique
varUniq Id
topEntity) HashMap Unique [Unique]
deps HashMap Unique [EdamFile]
edamFiles [(String, ByteString)]
filesAndDigests0
          else (HashMap Unique [EdamFile], [(String, ByteString)])
-> IO (HashMap Unique [EdamFile], [(String, ByteString)])
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (HashMap Unique [EdamFile]
edamFiles, [(String, ByteString)]
filesAndDigests0)

      let
        depUniques :: [Unique]
depUniques = [Unique] -> Maybe [Unique] -> [Unique]
forall a. a -> Maybe a -> a
fromMaybe [] (Unique -> HashMap Unique [Unique] -> Maybe [Unique]
forall k v. Hashable k => k -> HashMap k v -> Maybe v
HashMap.lookup (Id -> Unique
forall a. Uniquable a => a -> Unique
getUnique Id
topEntity) HashMap Unique [Unique]
deps)
        depBindings :: [Binding Term]
depBindings = (Unique -> Maybe (Binding Term)) -> [Unique] -> [Binding Term]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((Unique -> BindingMap -> Maybe (Binding Term))
-> BindingMap -> Unique -> Maybe (Binding Term)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Unique -> BindingMap -> Maybe (Binding Term)
forall a. Unique -> VarEnv a -> Maybe a
lookupVarEnvDirectly BindingMap
bindingsMap) [Unique]
depUniques
        depIds :: [Id]
depIds = (Binding Term -> Id) -> [Binding Term] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map Binding Term -> Id
forall a. Binding a -> Id
bindingId [Binding Term]
depBindings

        manifest :: Manifest
manifest =
          backend
-> DomainMap
-> ClashOpts
-> Component
-> [Component]
-> [Id]
-> [(String, ByteString)]
-> (ByteString, DebugSubHashes)
-> Manifest
forall backend.
Backend backend =>
backend
-> DomainMap
-> ClashOpts
-> Component
-> [Component]
-> [Id]
-> [(String, ByteString)]
-> (ByteString, DebugSubHashes)
-> Manifest
mkManifest
            backend
hdlState' DomainMap
domainConfs ClashOpts
opts Component
topComponent [Component]
components [Id]
depIds
            [(String, ByteString)]
filesAndDigests1 (ByteString, DebugSubHashes)
topHashWithSubHashes
      String -> Manifest -> IO ()
writeManifest String
manPath Manifest
manifest

      UTCTime
topTime <- [(String, Doc)]
hdlDocs [(String, Doc)] -> IO UTCTime -> IO UTCTime
forall a b. a -> b -> b
`seq` IO UTCTime
Clock.getCurrentTime
      let topDiff :: String
topDiff = UTCTime -> UTCTime -> String
reportTimeDiff UTCTime
topTime UTCTime
prevTime

      MVar () -> (() -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
ioLockV ((() -> IO ()) -> IO ())
-> (IO () -> () -> IO ()) -> IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> () -> IO ()
forall a b. a -> b -> a
const (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        String -> IO ()
putStrLn (String
"Clash: Compiling " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
topEntityS String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" took " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
topDiff)

-- | Whether a function should be interpreted as a 'BlackBoxFunction' or a
-- 'TemplateFunction'.
data InterpretFunctionType
  = InterpretBlackBoxFunction
  | InterpretTemplateFunction
  deriving (InterpretFunctionType -> InterpretFunctionType -> Bool
(InterpretFunctionType -> InterpretFunctionType -> Bool)
-> (InterpretFunctionType -> InterpretFunctionType -> Bool)
-> Eq InterpretFunctionType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: InterpretFunctionType -> InterpretFunctionType -> Bool
== :: InterpretFunctionType -> InterpretFunctionType -> Bool
$c/= :: InterpretFunctionType -> InterpretFunctionType -> Bool
/= :: InterpretFunctionType -> InterpretFunctionType -> Bool
Eq, Eq InterpretFunctionType
Eq InterpretFunctionType =>
(InterpretFunctionType -> InterpretFunctionType -> Ordering)
-> (InterpretFunctionType -> InterpretFunctionType -> Bool)
-> (InterpretFunctionType -> InterpretFunctionType -> Bool)
-> (InterpretFunctionType -> InterpretFunctionType -> Bool)
-> (InterpretFunctionType -> InterpretFunctionType -> Bool)
-> (InterpretFunctionType
    -> InterpretFunctionType -> InterpretFunctionType)
-> (InterpretFunctionType
    -> InterpretFunctionType -> InterpretFunctionType)
-> Ord InterpretFunctionType
InterpretFunctionType -> InterpretFunctionType -> Bool
InterpretFunctionType -> InterpretFunctionType -> Ordering
InterpretFunctionType
-> InterpretFunctionType -> InterpretFunctionType
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: InterpretFunctionType -> InterpretFunctionType -> Ordering
compare :: InterpretFunctionType -> InterpretFunctionType -> Ordering
$c< :: InterpretFunctionType -> InterpretFunctionType -> Bool
< :: InterpretFunctionType -> InterpretFunctionType -> Bool
$c<= :: InterpretFunctionType -> InterpretFunctionType -> Bool
<= :: InterpretFunctionType -> InterpretFunctionType -> Bool
$c> :: InterpretFunctionType -> InterpretFunctionType -> Bool
> :: InterpretFunctionType -> InterpretFunctionType -> Bool
$c>= :: InterpretFunctionType -> InterpretFunctionType -> Bool
>= :: InterpretFunctionType -> InterpretFunctionType -> Bool
$cmax :: InterpretFunctionType
-> InterpretFunctionType -> InterpretFunctionType
max :: InterpretFunctionType
-> InterpretFunctionType -> InterpretFunctionType
$cmin :: InterpretFunctionType
-> InterpretFunctionType -> InterpretFunctionType
min :: InterpretFunctionType
-> InterpretFunctionType -> InterpretFunctionType
Ord, Int -> InterpretFunctionType -> String -> String
[InterpretFunctionType] -> String -> String
InterpretFunctionType -> String
(Int -> InterpretFunctionType -> String -> String)
-> (InterpretFunctionType -> String)
-> ([InterpretFunctionType] -> String -> String)
-> Show InterpretFunctionType
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> InterpretFunctionType -> String -> String
showsPrec :: Int -> InterpretFunctionType -> String -> String
$cshow :: InterpretFunctionType -> String
show :: InterpretFunctionType -> String
$cshowList :: [InterpretFunctionType] -> String -> String
showList :: [InterpretFunctionType] -> String -> String
Show, (forall x. InterpretFunctionType -> Rep InterpretFunctionType x)
-> (forall x. Rep InterpretFunctionType x -> InterpretFunctionType)
-> Generic InterpretFunctionType
forall x. Rep InterpretFunctionType x -> InterpretFunctionType
forall x. InterpretFunctionType -> Rep InterpretFunctionType x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. InterpretFunctionType -> Rep InterpretFunctionType x
from :: forall x. InterpretFunctionType -> Rep InterpretFunctionType x
$cto :: forall x. Rep InterpretFunctionType x -> InterpretFunctionType
to :: forall x. Rep InterpretFunctionType x -> InterpretFunctionType
Generic, Eq InterpretFunctionType
Eq InterpretFunctionType =>
(Int -> InterpretFunctionType -> Int)
-> (InterpretFunctionType -> Int) -> Hashable InterpretFunctionType
Int -> InterpretFunctionType -> Int
InterpretFunctionType -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
$chashWithSalt :: Int -> InterpretFunctionType -> Int
hashWithSalt :: Int -> InterpretFunctionType -> Int
$chash :: InterpretFunctionType -> Int
hash :: InterpretFunctionType -> Int
Hashable)

-- | A single function that needs to be interpreted with Hint in order to
-- compile a primitive. Multiple primitives referencing the same function map
-- to the same request, so interpreting the distinct requests of a primitive
-- map compiles each function exactly once.
data InterpretFunctionRequest = InterpretFunctionRequest
  { InterpretFunctionRequest -> [String]
ifrModNames :: [String]
    -- ^ Module the function lives in, one entry per module name component
  , InterpretFunctionRequest -> String
ifrFuncName :: String
    -- ^ Function name
  , InterpretFunctionRequest -> InterpretFunctionType
ifrType :: InterpretFunctionType
    -- ^ Type to interpret the function at
  , InterpretFunctionRequest -> Maybe Text
ifrSource :: Maybe Text
    -- ^ Inline Haskell source of the module, if the primitive provided one
  } deriving (InterpretFunctionRequest -> InterpretFunctionRequest -> Bool
(InterpretFunctionRequest -> InterpretFunctionRequest -> Bool)
-> (InterpretFunctionRequest -> InterpretFunctionRequest -> Bool)
-> Eq InterpretFunctionRequest
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: InterpretFunctionRequest -> InterpretFunctionRequest -> Bool
== :: InterpretFunctionRequest -> InterpretFunctionRequest -> Bool
$c/= :: InterpretFunctionRequest -> InterpretFunctionRequest -> Bool
/= :: InterpretFunctionRequest -> InterpretFunctionRequest -> Bool
Eq, Eq InterpretFunctionRequest
Eq InterpretFunctionRequest =>
(InterpretFunctionRequest -> InterpretFunctionRequest -> Ordering)
-> (InterpretFunctionRequest -> InterpretFunctionRequest -> Bool)
-> (InterpretFunctionRequest -> InterpretFunctionRequest -> Bool)
-> (InterpretFunctionRequest -> InterpretFunctionRequest -> Bool)
-> (InterpretFunctionRequest -> InterpretFunctionRequest -> Bool)
-> (InterpretFunctionRequest
    -> InterpretFunctionRequest -> InterpretFunctionRequest)
-> (InterpretFunctionRequest
    -> InterpretFunctionRequest -> InterpretFunctionRequest)
-> Ord InterpretFunctionRequest
InterpretFunctionRequest -> InterpretFunctionRequest -> Bool
InterpretFunctionRequest -> InterpretFunctionRequest -> Ordering
InterpretFunctionRequest
-> InterpretFunctionRequest -> InterpretFunctionRequest
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: InterpretFunctionRequest -> InterpretFunctionRequest -> Ordering
compare :: InterpretFunctionRequest -> InterpretFunctionRequest -> Ordering
$c< :: InterpretFunctionRequest -> InterpretFunctionRequest -> Bool
< :: InterpretFunctionRequest -> InterpretFunctionRequest -> Bool
$c<= :: InterpretFunctionRequest -> InterpretFunctionRequest -> Bool
<= :: InterpretFunctionRequest -> InterpretFunctionRequest -> Bool
$c> :: InterpretFunctionRequest -> InterpretFunctionRequest -> Bool
> :: InterpretFunctionRequest -> InterpretFunctionRequest -> Bool
$c>= :: InterpretFunctionRequest -> InterpretFunctionRequest -> Bool
>= :: InterpretFunctionRequest -> InterpretFunctionRequest -> Bool
$cmax :: InterpretFunctionRequest
-> InterpretFunctionRequest -> InterpretFunctionRequest
max :: InterpretFunctionRequest
-> InterpretFunctionRequest -> InterpretFunctionRequest
$cmin :: InterpretFunctionRequest
-> InterpretFunctionRequest -> InterpretFunctionRequest
min :: InterpretFunctionRequest
-> InterpretFunctionRequest -> InterpretFunctionRequest
Ord, Int -> InterpretFunctionRequest -> String -> String
[InterpretFunctionRequest] -> String -> String
InterpretFunctionRequest -> String
(Int -> InterpretFunctionRequest -> String -> String)
-> (InterpretFunctionRequest -> String)
-> ([InterpretFunctionRequest] -> String -> String)
-> Show InterpretFunctionRequest
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> InterpretFunctionRequest -> String -> String
showsPrec :: Int -> InterpretFunctionRequest -> String -> String
$cshow :: InterpretFunctionRequest -> String
show :: InterpretFunctionRequest -> String
$cshowList :: [InterpretFunctionRequest] -> String -> String
showList :: [InterpretFunctionRequest] -> String -> String
Show, (forall x.
 InterpretFunctionRequest -> Rep InterpretFunctionRequest x)
-> (forall x.
    Rep InterpretFunctionRequest x -> InterpretFunctionRequest)
-> Generic InterpretFunctionRequest
forall x.
Rep InterpretFunctionRequest x -> InterpretFunctionRequest
forall x.
InterpretFunctionRequest -> Rep InterpretFunctionRequest x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x.
InterpretFunctionRequest -> Rep InterpretFunctionRequest x
from :: forall x.
InterpretFunctionRequest -> Rep InterpretFunctionRequest x
$cto :: forall x.
Rep InterpretFunctionRequest x -> InterpretFunctionRequest
to :: forall x.
Rep InterpretFunctionRequest x -> InterpretFunctionRequest
Generic, Eq InterpretFunctionRequest
Eq InterpretFunctionRequest =>
(Int -> InterpretFunctionRequest -> Int)
-> (InterpretFunctionRequest -> Int)
-> Hashable InterpretFunctionRequest
Int -> InterpretFunctionRequest -> Int
InterpretFunctionRequest -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
$chashWithSalt :: Int -> InterpretFunctionRequest -> Int
hashWithSalt :: Int -> InterpretFunctionRequest -> Int
$chash :: InterpretFunctionRequest -> Int
hash :: InterpretFunctionRequest -> Int
Hashable)

-- | Module the function of an 'InterpretFunctionRequest' lives in, as a
-- qualified module name
interpretFunctionRequestToModuleName :: InterpretFunctionRequest -> Hint.ModuleName
interpretFunctionRequestToModuleName :: InterpretFunctionRequest -> String
interpretFunctionRequestToModuleName = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"." ([String] -> String)
-> (InterpretFunctionRequest -> [String])
-> InterpretFunctionRequest
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InterpretFunctionRequest -> [String]
ifrModNames

-- | The result of interpreting an 'InterpretFunctionRequest'
data InterpretFunctionResult
  = InterpretBBF BlackBoxFunction
  | InterpretTF TemplateFunction

type InterpretResults =
  HashMap InterpretFunctionRequest
          (Either (NonEmpty Hint.InterpreterError) InterpretFunctionResult)

-- | Language extensions in effect when interpreting inline primitive sources
hintLanguageExtensions :: [Hint.Extension]
hintLanguageExtensions :: [Extension]
hintLanguageExtensions =
  (String -> Extension) -> [String] -> [Extension]
forall a b. (a -> b) -> [a] -> [b]
map String -> Extension
Hint.asExtension ([String] -> [Extension]) -> [String] -> [Extension]
forall a b. (a -> b) -> a -> b
$
    (Extension -> String) -> [Extension] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Extension -> String
forall a. Show a => a -> String
show [Extension]
wantedLanguageExtensions [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
    (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"No" ++ ) ((Extension -> String) -> [Extension] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Extension -> String
forall a. Show a => a -> String
show [Extension]
unwantedLanguageExtensions)

-- | The functions a primitive needs interpreted before it can be compiled by
-- 'compilePrimitiveWith'. Functions in 'knownBlackBoxFunctions' or
-- 'knownTemplateFunctions' need no interpretation and yield no request.
neededInterpRequests :: ResolvedPrimitive -> [InterpretFunctionRequest]
neededInterpRequests :: ResolvedPrimitive -> [InterpretFunctionRequest]
neededInterpRequests (BlackBoxHaskell Text
_ WorkInfo
_ UsedArguments
_ Bool
_ BlackBoxFunctionName
bbGenName Maybe Text
source)
  | String -> HashMap String BlackBoxFunction -> Bool
forall k a. Hashable k => k -> HashMap k a -> Bool
HashMap.member String
fullName HashMap String BlackBoxFunction
knownBlackBoxFunctions = []
  | Bool
otherwise =
      [[String]
-> String
-> InterpretFunctionType
-> Maybe Text
-> InterpretFunctionRequest
InterpretFunctionRequest [String]
modNames String
funcName InterpretFunctionType
InterpretBlackBoxFunction Maybe Text
source]
 where
  fullName :: String
fullName = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"." [String]
modNames String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
funcName
  BlackBoxFunctionName [String]
modNames String
funcName = BlackBoxFunctionName
bbGenName
neededInterpRequests (BlackBox Text
_ WorkInfo
_ RenderVoid
_ Bool
_ TemplateKind
_ ()
_ Usage
_ [Text]
_ [Text]
_ [(Int, Int)]
_ [((Text, Text),
  ((TemplateFormat, BlackBoxFunctionName), Maybe Text))]
incs [((TemplateFormat, BlackBoxFunctionName), Maybe Text)]
rM [((TemplateFormat, BlackBoxFunctionName), Maybe Text)]
riM ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
templ) =
  (((TemplateFormat, BlackBoxFunctionName), Maybe Text)
 -> [InterpretFunctionRequest])
-> [((TemplateFormat, BlackBoxFunctionName), Maybe Text)]
-> [InterpretFunctionRequest]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
-> [InterpretFunctionRequest]
go (((TemplateFormat, BlackBoxFunctionName), Maybe Text)
templ ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
-> [((TemplateFormat, BlackBoxFunctionName), Maybe Text)]
-> [((TemplateFormat, BlackBoxFunctionName), Maybe Text)]
forall a. a -> [a] -> [a]
: [((TemplateFormat, BlackBoxFunctionName), Maybe Text)]
rM [((TemplateFormat, BlackBoxFunctionName), Maybe Text)]
-> [((TemplateFormat, BlackBoxFunctionName), Maybe Text)]
-> [((TemplateFormat, BlackBoxFunctionName), Maybe Text)]
forall a. [a] -> [a] -> [a]
++ [((TemplateFormat, BlackBoxFunctionName), Maybe Text)]
riM [((TemplateFormat, BlackBoxFunctionName), Maybe Text)]
-> [((TemplateFormat, BlackBoxFunctionName), Maybe Text)]
-> [((TemplateFormat, BlackBoxFunctionName), Maybe Text)]
forall a. [a] -> [a] -> [a]
++ (((Text, Text),
  ((TemplateFormat, BlackBoxFunctionName), Maybe Text))
 -> ((TemplateFormat, BlackBoxFunctionName), Maybe Text))
-> [((Text, Text),
     ((TemplateFormat, BlackBoxFunctionName), Maybe Text))]
-> [((TemplateFormat, BlackBoxFunctionName), Maybe Text)]
forall a b. (a -> b) -> [a] -> [b]
map ((Text, Text),
 ((TemplateFormat, BlackBoxFunctionName), Maybe Text))
-> ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
forall a b. (a, b) -> b
snd [((Text, Text),
  ((TemplateFormat, BlackBoxFunctionName), Maybe Text))]
incs)
 where
  go :: ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
-> [InterpretFunctionRequest]
go ((TemplateFormat
TTemplate, BlackBoxFunctionName
_), Maybe Text
_) = []
  go ((TemplateFormat
THaskell, BlackBoxFunctionName [String]
modNames String
funcName), source :: Maybe Text
source@(Just Text
_)) =
    [[String]
-> String
-> InterpretFunctionType
-> Maybe Text
-> InterpretFunctionRequest
InterpretFunctionRequest [String]
modNames String
funcName InterpretFunctionType
InterpretTemplateFunction Maybe Text
source]
  go ((TemplateFormat
THaskell, BlackBoxFunctionName [String]
modNames String
funcName), Maybe Text
Nothing)
    | String -> HashMap String TemplateFunction -> Bool
forall k a. Hashable k => k -> HashMap k a -> Bool
HashMap.member String
fullName HashMap String TemplateFunction
knownTemplateFunctions = []
    | Bool
otherwise =
        [[String]
-> String
-> InterpretFunctionType
-> Maybe Text
-> InterpretFunctionRequest
InterpretFunctionRequest [String]
modNames String
funcName InterpretFunctionType
InterpretTemplateFunction Maybe Text
forall a. Maybe a
Nothing]
   where
    fullName :: String
fullName = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"." [String]
modNames String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
funcName
neededInterpRequests (Primitive {}) = []

-- | Interpret the given functions in a single shared Hint session. Starting a
-- session is expensive (it initializes a full GHC session, including reading
-- all package databases), so sharing one session over all requests is much
-- faster than a session per function. For each request this action tries two
-- things:
--
--   1. Interpret without explicitly loading the module. This will succeed if
--      the module can be found in the package databases (passed in as
--      @-package-db@ interpreter arguments).
--
--   2. If (1) fails, try to load the module explicitly: either from the
--      inline source a primitive provided, or from the import directories.
--      If this also fails, an error is recorded for the request.
--
-- All (1) attempts run before the first (2) attempt, so that interpreting
-- against the package databases is never influenced by locally loaded
-- modules. Note that 'Hint.loadModules' resets previously loaded modules, so
-- (2) attempts cannot see each other's modules either.
interpretFunctions
  :: [FilePath]
  -- ^ Import directories (-i flag)
  -> [FilePath]
  -- ^ Package databases
  -> FilePath
  -- ^ The folder in which the GHC bootstrap libraries (base, containers, etc.)
  -- can be found
  -> [InterpretFunctionRequest]
  -- ^ Functions to interpret
  -> IO InterpretResults
interpretFunctions :: [String]
-> [String]
-> String
-> [InterpretFunctionRequest]
-> IO InterpretResults
interpretFunctions [String]
_ [String]
_ String
_ [] = InterpretResults -> IO InterpretResults
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure InterpretResults
forall k v. HashMap k v
HashMap.empty
interpretFunctions [String]
idirs [String]
pkgDbs String
topDir [InterpretFunctionRequest]
reqs = do
  Either
  InterpreterError
  [(InterpretFunctionRequest,
    Either (NonEmpty InterpreterError) InterpretFunctionResult)]
sessionRes <- [String]
-> String
-> InterpreterT
     IO
     [(InterpretFunctionRequest,
       Either (NonEmpty InterpreterError) InterpretFunctionResult)]
-> IO
     (Either
        InterpreterError
        [(InterpretFunctionRequest,
          Either (NonEmpty InterpreterError) InterpretFunctionResult)])
forall (m :: Type -> Type) a.
(MonadIO m, MonadMask m) =>
[String]
-> String -> InterpreterT m a -> m (Either InterpreterError a)
Hint.unsafeRunInterpreterWithArgsLibdir [String]
interpreterArgs String
topDir (InterpreterT
   IO
   [(InterpretFunctionRequest,
     Either (NonEmpty InterpreterError) InterpretFunctionResult)]
 -> IO
      (Either
         InterpreterError
         [(InterpretFunctionRequest,
           Either (NonEmpty InterpreterError) InterpretFunctionResult)]))
-> InterpreterT
     IO
     [(InterpretFunctionRequest,
       Either (NonEmpty InterpreterError) InterpretFunctionResult)]
-> IO
     (Either
        InterpreterError
        [(InterpretFunctionRequest,
          Either (NonEmpty InterpreterError) InterpretFunctionResult)])
forall a b. (a -> b) -> a -> b
$ do
    -- NB: capture the pristine search path once; 'Hint.get' returns the
    -- current (possibly already extended) value in a shared session.
    [String]
defaultPath <- Option (InterpreterT IO) [String] -> InterpreterT IO [String]
forall (m :: Type -> Type) a.
MonadInterpreter m =>
Option m a -> m a
Hint.get Option (InterpreterT IO) [String]
forall (m :: Type -> Type). MonadInterpreter m => Option m [String]
Hint.searchPath
    [OptionVal (InterpreterT IO)] -> InterpreterT IO ()
forall (m :: Type -> Type).
MonadInterpreter m =>
[OptionVal m] -> m ()
Hint.set [Option (InterpreterT IO) [String]
forall (m :: Type -> Type). MonadInterpreter m => Option m [String]
Hint.searchPath Option (InterpreterT IO) [String]
-> [String] -> OptionVal (InterpreterT IO)
forall (m :: Type -> Type) a. Option m a -> a -> OptionVal m
Hint.:= ([String]
defaultPath [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
idirs)]

    -- Phase 1: try to interpret all functions from the package databases
    [(InterpretFunctionRequest,
  Either InterpreterError InterpretFunctionResult)]
globalResults <- [InterpretFunctionRequest]
-> (InterpretFunctionRequest
    -> InterpreterT
         IO
         (InterpretFunctionRequest,
          Either InterpreterError InterpretFunctionResult))
-> InterpreterT
     IO
     [(InterpretFunctionRequest,
       Either InterpreterError InterpretFunctionResult)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [InterpretFunctionRequest]
reqs ((InterpretFunctionRequest
  -> InterpreterT
       IO
       (InterpretFunctionRequest,
        Either InterpreterError InterpretFunctionResult))
 -> InterpreterT
      IO
      [(InterpretFunctionRequest,
        Either InterpreterError InterpretFunctionResult)])
-> (InterpretFunctionRequest
    -> InterpreterT
         IO
         (InterpretFunctionRequest,
          Either InterpreterError InterpretFunctionResult))
-> InterpreterT
     IO
     [(InterpretFunctionRequest,
       Either InterpreterError InterpretFunctionResult)]
forall a b. (a -> b) -> a -> b
$ \InterpretFunctionRequest
req -> do
      IO () -> InterpreterT IO ()
forall a. IO a -> InterpreterT IO a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
Hint.liftIO (IO () -> InterpreterT IO ()) -> IO () -> InterpreterT IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> IO () -> IO ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
Monad.when Bool
debugIsOn (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        String -> IO ()
putStr String
"Hint: Interpreting " IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> String -> IO ()
putStrLn (InterpretFunctionRequest -> String
interpretFunctionRequestToModuleName InterpretFunctionRequest
req String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++ InterpretFunctionRequest -> String
ifrFuncName InterpretFunctionRequest
req)
      Either InterpreterError InterpretFunctionResult
res <- InterpreterT IO InterpretFunctionResult
-> InterpreterT
     IO (Either InterpreterError InterpretFunctionResult)
tryInterp (InterpretFunctionRequest -> InterpreterT IO InterpretFunctionResult
forall {m :: Type -> Type}.
MonadInterpreter m =>
InterpretFunctionRequest -> m InterpretFunctionResult
interpretGlobal InterpretFunctionRequest
req)
      (InterpretFunctionRequest,
 Either InterpreterError InterpretFunctionResult)
-> InterpreterT
     IO
     (InterpretFunctionRequest,
      Either InterpreterError InterpretFunctionResult)
forall a. a -> InterpreterT IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (InterpretFunctionRequest
req, Either InterpreterError InterpretFunctionResult
res)

    -- Phase 2: functions that failed phase 1 are interpreted as local
    -- modules, compiled from inline source or the import directories
    Bool -> InterpreterT IO () -> InterpreterT IO ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
Monad.unless ([()] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [() | (InterpretFunctionRequest
_, Left InterpreterError
_) <- [(InterpretFunctionRequest,
  Either InterpreterError InterpretFunctionResult)]
globalResults]) (InterpreterT IO () -> InterpreterT IO ())
-> InterpreterT IO () -> InterpreterT IO ()
forall a b. (a -> b) -> a -> b
$
      [OptionVal (InterpreterT IO)] -> InterpreterT IO ()
forall (m :: Type -> Type).
MonadInterpreter m =>
[OptionVal m] -> m ()
Hint.set [Option (InterpreterT IO) [Extension]
forall (m :: Type -> Type).
MonadInterpreter m =>
Option m [Extension]
Hint.languageExtensions Option (InterpreterT IO) [Extension]
-> [Extension] -> OptionVal (InterpreterT IO)
forall (m :: Type -> Type) a. Option m a -> a -> OptionVal m
Hint.:= [Extension]
hintLanguageExtensions]
    [(InterpretFunctionRequest,
  Either InterpreterError InterpretFunctionResult)]
-> ((InterpretFunctionRequest,
     Either InterpreterError InterpretFunctionResult)
    -> InterpreterT
         IO
         (InterpretFunctionRequest,
          Either (NonEmpty InterpreterError) InterpretFunctionResult))
-> InterpreterT
     IO
     [(InterpretFunctionRequest,
       Either (NonEmpty InterpreterError) InterpretFunctionResult)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(InterpretFunctionRequest,
  Either InterpreterError InterpretFunctionResult)]
globalResults (((InterpretFunctionRequest,
   Either InterpreterError InterpretFunctionResult)
  -> InterpreterT
       IO
       (InterpretFunctionRequest,
        Either (NonEmpty InterpreterError) InterpretFunctionResult))
 -> InterpreterT
      IO
      [(InterpretFunctionRequest,
        Either (NonEmpty InterpreterError) InterpretFunctionResult)])
-> ((InterpretFunctionRequest,
     Either InterpreterError InterpretFunctionResult)
    -> InterpreterT
         IO
         (InterpretFunctionRequest,
          Either (NonEmpty InterpreterError) InterpretFunctionResult))
-> InterpreterT
     IO
     [(InterpretFunctionRequest,
       Either (NonEmpty InterpreterError) InterpretFunctionResult)]
forall a b. (a -> b) -> a -> b
$ \(InterpretFunctionRequest
req, Either InterpreterError InterpretFunctionResult
globalRes) ->
      case Either InterpreterError InterpretFunctionResult
globalRes of
        Right InterpretFunctionResult
res -> (InterpretFunctionRequest,
 Either (NonEmpty InterpreterError) InterpretFunctionResult)
-> InterpreterT
     IO
     (InterpretFunctionRequest,
      Either (NonEmpty InterpreterError) InterpretFunctionResult)
forall a. a -> InterpreterT IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (InterpretFunctionRequest
req, InterpretFunctionResult
-> Either (NonEmpty InterpreterError) InterpretFunctionResult
forall a b. b -> Either a b
Right InterpretFunctionResult
res)
        Left InterpreterError
globalException -> do
          Either InterpreterError InterpretFunctionResult
localRes <- InterpreterT IO InterpretFunctionResult
-> InterpreterT
     IO (Either InterpreterError InterpretFunctionResult)
tryInterp ([String]
-> InterpretFunctionRequest
-> InterpreterT IO InterpretFunctionResult
forall {m :: Type -> Type}.
MonadInterpreter m =>
[String] -> InterpretFunctionRequest -> m InterpretFunctionResult
interpretLocal [String]
defaultPath InterpretFunctionRequest
req)
          case Either InterpreterError InterpretFunctionResult
localRes of
            Left InterpreterError
localException ->
              (InterpretFunctionRequest,
 Either (NonEmpty InterpreterError) InterpretFunctionResult)
-> InterpreterT
     IO
     (InterpretFunctionRequest,
      Either (NonEmpty InterpreterError) InterpretFunctionResult)
forall a. a -> InterpreterT IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (InterpretFunctionRequest
req, NonEmpty InterpreterError
-> Either (NonEmpty InterpreterError) InterpretFunctionResult
forall a b. a -> Either a b
Left (InterpreterError
globalException InterpreterError -> [InterpreterError] -> NonEmpty InterpreterError
forall a. a -> [a] -> NonEmpty a
:| [InterpreterError
localException]))
            Right InterpretFunctionResult
res -> (InterpretFunctionRequest,
 Either (NonEmpty InterpreterError) InterpretFunctionResult)
-> InterpreterT
     IO
     (InterpretFunctionRequest,
      Either (NonEmpty InterpreterError) InterpretFunctionResult)
forall a. a -> InterpreterT IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (InterpretFunctionRequest
req, InterpretFunctionResult
-> Either (NonEmpty InterpreterError) InterpretFunctionResult
forall a b. b -> Either a b
Right InterpretFunctionResult
res)

  case Either
  InterpreterError
  [(InterpretFunctionRequest,
    Either (NonEmpty InterpreterError) InterpretFunctionResult)]
sessionRes of
    -- The session itself failed to initialize; attribute the error to every
    -- request.
    Left InterpreterError
e -> InterpretResults -> IO InterpretResults
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([(InterpretFunctionRequest,
  Either (NonEmpty InterpreterError) InterpretFunctionResult)]
-> InterpretResults
forall k v. Hashable k => [(k, v)] -> HashMap k v
HashMap.fromList [(InterpretFunctionRequest
req, NonEmpty InterpreterError
-> Either (NonEmpty InterpreterError) InterpretFunctionResult
forall a b. a -> Either a b
Left (InterpreterError
e InterpreterError -> [InterpreterError] -> NonEmpty InterpreterError
forall a. a -> [a] -> NonEmpty a
:| [])) | InterpretFunctionRequest
req <- [InterpretFunctionRequest]
reqs])
    Right [(InterpretFunctionRequest,
  Either (NonEmpty InterpreterError) InterpretFunctionResult)]
results -> InterpretResults -> IO InterpretResults
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([(InterpretFunctionRequest,
  Either (NonEmpty InterpreterError) InterpretFunctionResult)]
-> InterpretResults
forall k v. Hashable k => [(k, v)] -> HashMap k v
HashMap.fromList [(InterpretFunctionRequest,
  Either (NonEmpty InterpreterError) InterpretFunctionResult)]
results)
 where
  interpreterArgs :: [String]
interpreterArgs = (String -> [String]) -> [String] -> [String]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap ((String
"-package-db":) ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[])) [String]
pkgDbs

  tryInterp
    :: Hint.InterpreterT IO InterpretFunctionResult
    -> Hint.InterpreterT IO (Either Hint.InterpreterError InterpretFunctionResult)
  tryInterp :: InterpreterT IO InterpretFunctionResult
-> InterpreterT
     IO (Either InterpreterError InterpretFunctionResult)
tryInterp = InterpreterT IO InterpretFunctionResult
-> InterpreterT
     IO (Either InterpreterError InterpretFunctionResult)
forall (m :: Type -> Type) e a.
(HasCallStack, MonadCatch m, Exception e) =>
m a -> m (Either e a)
try

  interpret :: InterpretFunctionRequest -> f InterpretFunctionResult
interpret InterpretFunctionRequest
req = case InterpretFunctionRequest -> InterpretFunctionType
ifrType InterpretFunctionRequest
req of
    InterpretFunctionType
InterpretBlackBoxFunction ->
      BlackBoxFunction -> InterpretFunctionResult
InterpretBBF (BlackBoxFunction -> InterpretFunctionResult)
-> f BlackBoxFunction -> f InterpretFunctionResult
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> String -> f BlackBoxFunction
forall (m :: Type -> Type) a.
MonadInterpreter m =>
String -> String -> m a
Hint.unsafeInterpret (InterpretFunctionRequest -> String
ifrFuncName InterpretFunctionRequest
req) String
"BlackBoxFunction"
    InterpretFunctionType
InterpretTemplateFunction ->
      TemplateFunction -> InterpretFunctionResult
InterpretTF (TemplateFunction -> InterpretFunctionResult)
-> f TemplateFunction -> f InterpretFunctionResult
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> String -> f TemplateFunction
forall (m :: Type -> Type) a.
MonadInterpreter m =>
String -> String -> m a
Hint.unsafeInterpret (InterpretFunctionRequest -> String
ifrFuncName InterpretFunctionRequest
req) String
"TemplateFunction"

  interpretGlobal :: InterpretFunctionRequest -> m InterpretFunctionResult
interpretGlobal InterpretFunctionRequest
req = do
    [String] -> m ()
forall (m :: Type -> Type). MonadInterpreter m => [String] -> m ()
Hint.setImports
      [String
"Clash.Netlist.Types", String
"Clash.Netlist.BlackBox.Types", InterpretFunctionRequest -> String
interpretFunctionRequestToModuleName InterpretFunctionRequest
req]
    InterpretFunctionRequest -> m InterpretFunctionResult
forall {m :: Type -> Type}.
MonadInterpreter m =>
InterpretFunctionRequest -> m InterpretFunctionResult
interpret InterpretFunctionRequest
req

  interpretLocal :: [String] -> InterpretFunctionRequest -> m InterpretFunctionResult
interpretLocal [String]
defaultPath InterpretFunctionRequest
req = ([String] -> m InterpretFunctionResult)
-> m InterpretFunctionResult
forall {m :: Type -> Type} {b}.
(MonadIO m, MonadMask m) =>
([String] -> m b) -> m b
withSourceDir (([String] -> m InterpretFunctionResult)
 -> m InterpretFunctionResult)
-> ([String] -> m InterpretFunctionResult)
-> m InterpretFunctionResult
forall a b. (a -> b) -> a -> b
$ \[String]
extraDirs -> do
    [OptionVal m] -> m ()
forall (m :: Type -> Type).
MonadInterpreter m =>
[OptionVal m] -> m ()
Hint.set [Option m [String]
forall (m :: Type -> Type). MonadInterpreter m => Option m [String]
Hint.searchPath Option m [String] -> [String] -> OptionVal m
forall (m :: Type -> Type) a. Option m a -> a -> OptionVal m
Hint.:= ([String]
extraDirs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
idirs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
defaultPath)]
    [String] -> m ()
forall (m :: Type -> Type). MonadInterpreter m => [String] -> m ()
Hint.loadModules [InterpretFunctionRequest -> String
interpretFunctionRequestToModuleName InterpretFunctionRequest
req]
    [String] -> m ()
forall (m :: Type -> Type). MonadInterpreter m => [String] -> m ()
Hint.setImports
      [String
"Clash.Netlist.BlackBox.Types", String
"Clash.Netlist.Types", InterpretFunctionRequest -> String
interpretFunctionRequestToModuleName InterpretFunctionRequest
req]
    InterpretFunctionRequest -> m InterpretFunctionResult
forall {m :: Type -> Type}.
MonadInterpreter m =>
InterpretFunctionRequest -> m InterpretFunctionResult
interpret InterpretFunctionRequest
req
   where
    -- Write the inline source (if any) of a request to a temporary
    -- directory, and pass that directory as an extra search path
    withSourceDir :: ([String] -> m b) -> m b
withSourceDir [String] -> m b
act = case InterpretFunctionRequest -> Maybe Text
ifrSource InterpretFunctionRequest
req of
      Maybe Text
Nothing -> [String] -> m b
act []
      Just Text
source -> do
        String
tmpDir0 <- IO String -> m String
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
Hint.liftIO IO String
getCanonicalTemporaryDirectory
        String -> String -> (String -> m b) -> m b
forall (m :: Type -> Type) a.
(MonadMask m, MonadIO m) =>
String -> String -> (String -> m a) -> m a
withTempDirectory String
tmpDir0 String
"clash-prim-compile" ((String -> m b) -> m b) -> (String -> m b) -> m b
forall a b. (a -> b) -> a -> b
$ \String
tmpDir1 -> do
          let modDir :: String
modDir = (String -> String -> String) -> String -> [String] -> String
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl String -> String -> String
(</>) String
tmpDir1 ([String] -> [String]
forall a. HasCallStack => [a] -> [a]
init (InterpretFunctionRequest -> [String]
ifrModNames InterpretFunctionRequest
req))
          IO () -> m ()
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
Hint.liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
            Bool -> String -> IO ()
Directory.createDirectoryIfMissing Bool
True String
modDir
            String -> Text -> IO ()
Text.writeFile (String
modDir String -> String -> String
</> [String] -> String
forall a. HasCallStack => [a] -> a
last (InterpretFunctionRequest -> [String]
ifrModNames InterpretFunctionRequest
req) String -> String -> String
<.> String
"hs") Text
source
          [String] -> m b
act [String
tmpDir1]

-- | List of known BlackBoxFunctions used to prevent Hint from firing. This
--  improves Clash startup times.
knownBlackBoxFunctions :: HashMap String BlackBoxFunction
knownBlackBoxFunctions :: HashMap String BlackBoxFunction
knownBlackBoxFunctions =
  [(String, BlackBoxFunction)] -> HashMap String BlackBoxFunction
forall k v. Hashable k => [(k, v)] -> HashMap k v
HashMap.fromList ([(String, BlackBoxFunction)] -> HashMap String BlackBoxFunction)
-> [(String, BlackBoxFunction)] -> HashMap String BlackBoxFunction
forall a b. (a -> b) -> a -> b
$ ((Name, BlackBoxFunction) -> (String, BlackBoxFunction))
-> [(Name, BlackBoxFunction)] -> [(String, BlackBoxFunction)]
forall a b. (a -> b) -> [a] -> [b]
map ((Name -> String)
-> (Name, BlackBoxFunction) -> (String, BlackBoxFunction)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: Type -> Type -> Type) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Name -> String
forall a. Show a => a -> String
show) ([(Name, BlackBoxFunction)] -> [(String, BlackBoxFunction)])
-> [(Name, BlackBoxFunction)] -> [(String, BlackBoxFunction)]
forall a b. (a -> b) -> a -> b
$
    [ ('P.checkBBF, BlackBoxFunction
P.checkBBF)
    , ('P.bvToIntegerVHDL, BlackBoxFunction
P.bvToIntegerVHDL)
    , ('P.bvToIntegerVerilog, BlackBoxFunction
P.bvToIntegerVerilog)
    , ('P.clashCompileErrorBBF, HasCallStack => BlackBoxFunction
BlackBoxFunction
P.clashCompileErrorBBF)
    , ('P.foldBBF, HasCallStack => BlackBoxFunction
BlackBoxFunction
P.foldBBF)
    , ('P.indexIntVerilog, BlackBoxFunction
P.indexIntVerilog)
    , ('P.indexToIntegerVerilog, BlackBoxFunction
P.indexToIntegerVerilog)
    , ('P.indexToIntegerVHDL, BlackBoxFunction
P.indexToIntegerVHDL)
    , ('P.intTF, BlackBoxFunction
P.intTF)
    , ('P.iterateBBF, HasCallStack => BlackBoxFunction
BlackBoxFunction
P.iterateBBF)
    , ('P.signedToIntegerVerilog, BlackBoxFunction
P.signedToIntegerVerilog)
    , ('P.signedToIntegerVHDL, BlackBoxFunction
P.signedToIntegerVHDL)
    , ('P.unsignedToIntegerVerilog, BlackBoxFunction
P.unsignedToIntegerVerilog)
    , ('P.unsignedToIntegerVHDL, BlackBoxFunction
P.unsignedToIntegerVHDL)
    , ('P.wordTF, BlackBoxFunction
P.wordTF)
    ]

-- | List of known TemplateFunctions used to prevent Hint from firing. This
--  improves Clash startup times.
knownTemplateFunctions :: HashMap String TemplateFunction
knownTemplateFunctions :: HashMap String TemplateFunction
knownTemplateFunctions =
  [(String, TemplateFunction)] -> HashMap String TemplateFunction
forall k v. Hashable k => [(k, v)] -> HashMap k v
HashMap.fromList ([(String, TemplateFunction)] -> HashMap String TemplateFunction)
-> [(String, TemplateFunction)] -> HashMap String TemplateFunction
forall a b. (a -> b) -> a -> b
$ ((Name, TemplateFunction) -> (String, TemplateFunction))
-> [(Name, TemplateFunction)] -> [(String, TemplateFunction)]
forall a b. (a -> b) -> [a] -> [b]
map ((Name -> String)
-> (Name, TemplateFunction) -> (String, TemplateFunction)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: Type -> Type -> Type) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Name -> String
forall a. Show a => a -> String
show) ([(Name, TemplateFunction)] -> [(String, TemplateFunction)])
-> [(Name, TemplateFunction)] -> [(String, TemplateFunction)]
forall a b. (a -> b) -> a -> b
$
    [ ('P.altpllQsysTF, TemplateFunction
P.altpllQsysTF)
    , ('P.alteraPllQsysTF, TemplateFunction
P.alteraPllQsysTF)
    , ('P.alteraPllTF, TemplateFunction
P.alteraPllTF)
    , ('P.altpllTF, TemplateFunction
P.altpllTF)
    , ('P.fromIntegerTFvhdl, TemplateFunction
P.fromIntegerTFvhdl)
    , ('P.clockWizardTF, TemplateFunction
P.clockWizardTF)
    , ('P.clockWizardDifferentialTF, TemplateFunction
P.clockWizardDifferentialTF)
    , ('P.clockWizardTclTF, TemplateFunction
P.clockWizardTclTF)
    , ('P.clockWizardDifferentialTclTF, TemplateFunction
P.clockWizardDifferentialTclTF)
    ]

-- | Compiles the blackbox functions of and parses the blackbox templates in
-- a primitive map. All blackbox functions are interpreted in a single shared
-- Hint session (see 'interpretFunctions'), and every distinct function is
-- interpreted exactly once, no matter how many primitives reference it.
compilePrimitives
  :: [FilePath]
  -- ^ Import directories (-i flag)
  -> [FilePath]
  -- ^ Package databases
  -> FilePath
  -- ^ The folder in which the GHC bootstrap libraries (base, containers, etc.)
  -- can be found
  -> ResolvedPrimMap
  -- ^ Primitives to compile
  -> IO CompiledPrimMap
compilePrimitives :: [String]
-> [String] -> String -> ResolvedPrimMap -> IO CompiledPrimMap
compilePrimitives [String]
idirs [String]
pkgDbs String
topDir ResolvedPrimMap
primMapR = do
  let reqs :: [InterpretFunctionRequest]
reqs =
        [InterpretFunctionRequest] -> [InterpretFunctionRequest]
forall a. Ord a => [a] -> [a]
List.nubOrd ([InterpretFunctionRequest] -> [InterpretFunctionRequest])
-> [InterpretFunctionRequest] -> [InterpretFunctionRequest]
forall a b. (a -> b) -> a -> b
$
        (ResolvedPrimitive -> [InterpretFunctionRequest])
-> [ResolvedPrimitive] -> [InterpretFunctionRequest]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap
          ResolvedPrimitive -> [InterpretFunctionRequest]
neededInterpRequests
          ((PrimitiveGuard ResolvedPrimitive -> Maybe ResolvedPrimitive)
-> [PrimitiveGuard ResolvedPrimitive] -> [ResolvedPrimitive]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe PrimitiveGuard ResolvedPrimitive -> Maybe ResolvedPrimitive
forall a. PrimitiveGuard a -> Maybe a
extractPrim (ResolvedPrimMap -> [PrimitiveGuard ResolvedPrimitive]
forall k v. HashMap k v -> [v]
HashMap.elems ResolvedPrimMap
primMapR))
  InterpretResults
results <- [String]
-> [String]
-> String
-> [InterpretFunctionRequest]
-> IO InterpretResults
interpretFunctions [String]
idirs [String]
pkgDbs String
topDir [InterpretFunctionRequest]
reqs
  (PrimitiveGuard ResolvedPrimitive -> IO GuardedCompiledPrimitive)
-> ResolvedPrimMap -> IO CompiledPrimMap
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> HashMap Text a -> f (HashMap Text b)
traverse ((ResolvedPrimitive -> IO CompiledPrimitive)
-> PrimitiveGuard ResolvedPrimitive -> IO GuardedCompiledPrimitive
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> PrimitiveGuard a -> f (PrimitiveGuard b)
traverse ((InterpretFunctionRequest
 -> IO (Either (NonEmpty InterpreterError) InterpretFunctionResult))
-> ResolvedPrimitive -> IO CompiledPrimitive
compilePrimitiveWith (InterpretResults
-> InterpretFunctionRequest
-> IO (Either (NonEmpty InterpreterError) InterpretFunctionResult)
lookupInterpResult InterpretResults
results))) ResolvedPrimMap
primMapR

-- | Compiles a single primitive. Provided for backwards compatibility; when
-- compiling multiple primitives, 'compilePrimitives' only pays the cost of
-- starting a Hint session once.
compilePrimitive
  :: [FilePath]
  -- ^ Import directories (-i flag)
  -> [FilePath]
  -- ^ Package databases
  -> FilePath
  -- ^ The folder in which the GHC bootstrap libraries (base, containers, etc.)
  -- can be found
  -> ResolvedPrimitive
  -- ^ Primitive to compile
  -> IO CompiledPrimitive
compilePrimitive :: [String]
-> [String] -> String -> ResolvedPrimitive -> IO CompiledPrimitive
compilePrimitive [String]
idirs [String]
pkgDbs String
topDir ResolvedPrimitive
prim = do
  let reqs :: [InterpretFunctionRequest]
reqs = HashSet InterpretFunctionRequest -> [InterpretFunctionRequest]
forall a. HashSet a -> [a]
HashSet.toList ([InterpretFunctionRequest] -> HashSet InterpretFunctionRequest
forall a. Hashable a => [a] -> HashSet a
HashSet.fromList (ResolvedPrimitive -> [InterpretFunctionRequest]
neededInterpRequests ResolvedPrimitive
prim))
  InterpretResults
results <- [String]
-> [String]
-> String
-> [InterpretFunctionRequest]
-> IO InterpretResults
interpretFunctions [String]
idirs [String]
pkgDbs String
topDir [InterpretFunctionRequest]
reqs
  (InterpretFunctionRequest
 -> IO (Either (NonEmpty InterpreterError) InterpretFunctionResult))
-> ResolvedPrimitive -> IO CompiledPrimitive
compilePrimitiveWith (InterpretResults
-> InterpretFunctionRequest
-> IO (Either (NonEmpty InterpreterError) InterpretFunctionResult)
lookupInterpResult InterpretResults
results) ResolvedPrimitive
prim

-- | Look up the interpreter result of a request. All requests are
-- interpreted before primitives are compiled, so a missing result is an
-- internal error: 'neededInterpRequests' diverged from the requests
-- 'compilePrimitiveWith' consumes.
lookupInterpResult
  :: InterpretResults
  -> InterpretFunctionRequest
  -> IO (Either (NonEmpty Hint.InterpreterError) InterpretFunctionResult)
lookupInterpResult :: InterpretResults
-> InterpretFunctionRequest
-> IO (Either (NonEmpty InterpreterError) InterpretFunctionResult)
lookupInterpResult InterpretResults
results InterpretFunctionRequest
req =
  case InterpretFunctionRequest
-> InterpretResults
-> Maybe
     (Either (NonEmpty InterpreterError) InterpretFunctionResult)
forall k v. Hashable k => k -> HashMap k v -> Maybe v
HashMap.lookup InterpretFunctionRequest
req InterpretResults
results of
    Just Either (NonEmpty InterpreterError) InterpretFunctionResult
res -> Either (NonEmpty InterpreterError) InterpretFunctionResult
-> IO (Either (NonEmpty InterpreterError) InterpretFunctionResult)
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Either (NonEmpty InterpreterError) InterpretFunctionResult
res
    Maybe (Either (NonEmpty InterpreterError) InterpretFunctionResult)
Nothing -> String
-> IO (Either (NonEmpty InterpreterError) InterpretFunctionResult)
forall a. HasCallStack => String -> a
error ($(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Internal error: no interpreter result for "
                             String -> String -> String
forall a. [a] -> [a] -> [a]
++ InterpretFunctionRequest -> String
forall a. Show a => a -> String
show InterpretFunctionRequest
req)

-- | Compiles the blackbox functions of and parses the blackbox templates in
-- a primitive, given an action that produces the interpreted functions the
-- primitive needs (see 'neededInterpRequests').
compilePrimitiveWith
  :: (InterpretFunctionRequest -> IO (Either (NonEmpty Hint.InterpreterError) InterpretFunctionResult))
  -- ^ Look up the interpreter result for a request
  -> ResolvedPrimitive
  -- ^ Primitive to compile
  -> IO CompiledPrimitive
compilePrimitiveWith :: (InterpretFunctionRequest
 -> IO (Either (NonEmpty InterpreterError) InterpretFunctionResult))
-> ResolvedPrimitive -> IO CompiledPrimitive
compilePrimitiveWith InterpretFunctionRequest
-> IO (Either (NonEmpty InterpreterError) InterpretFunctionResult)
lookupInterp (BlackBoxHaskell Text
bbName WorkInfo
wf UsedArguments
usedArgs Bool
multiRes BlackBoxFunctionName
bbGenName Maybe Text
source) = do
  BlackBoxFunction
bbFunc <-
    case String -> HashMap String BlackBoxFunction -> Maybe BlackBoxFunction
forall k v. Hashable k => k -> HashMap k v -> Maybe v
HashMap.lookup String
fullName HashMap String BlackBoxFunction
knownBlackBoxFunctions of
      Just BlackBoxFunction
f -> BlackBoxFunction -> IO BlackBoxFunction
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure BlackBoxFunction
f
      Maybe BlackBoxFunction
Nothing -> do
        Either (NonEmpty InterpreterError) InterpretFunctionResult
r <- InterpretFunctionRequest
-> IO (Either (NonEmpty InterpreterError) InterpretFunctionResult)
lookupInterp ([String]
-> String
-> InterpretFunctionType
-> Maybe Text
-> InterpretFunctionRequest
InterpretFunctionRequest [String]
modNames String
funcName InterpretFunctionType
InterpretBlackBoxFunction Maybe Text
source)
        InterpretFunctionResult -> IO BlackBoxFunction
expectBBF (InterpretFunctionResult -> IO BlackBoxFunction)
-> IO InterpretFunctionResult -> IO BlackBoxFunction
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< String
-> Text
-> Either (NonEmpty InterpreterError) InterpretFunctionResult
-> IO InterpretFunctionResult
forall (m :: Type -> Type) t.
(MonadThrow m, Monad m) =>
String -> Text -> Either (NonEmpty InterpreterError) t -> m t
processHintErrors (BlackBoxFunctionName -> String
forall a. Show a => a -> String
show BlackBoxFunctionName
bbGenName) Text
bbName Either (NonEmpty InterpreterError) InterpretFunctionResult
r

  CompiledPrimitive -> IO CompiledPrimitive
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Text
-> WorkInfo
-> UsedArguments
-> Bool
-> BlackBoxFunctionName
-> (Int, BlackBoxFunction)
-> CompiledPrimitive
forall a b c d.
Text
-> WorkInfo
-> UsedArguments
-> Bool
-> BlackBoxFunctionName
-> d
-> Primitive a b c d
BlackBoxHaskell Text
bbName WorkInfo
wf UsedArguments
usedArgs Bool
multiRes BlackBoxFunctionName
bbGenName (Maybe Text -> Int
forall a. Hashable a => a -> Int
hash Maybe Text
source, BlackBoxFunction
bbFunc))
 where
    fullName :: String
fullName = String
qualMod String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
funcName
    qualMod :: String
qualMod = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"." [String]
modNames
    BlackBoxFunctionName [String]
modNames String
funcName = BlackBoxFunctionName
bbGenName

    expectBBF :: InterpretFunctionResult -> IO BlackBoxFunction
    expectBBF :: InterpretFunctionResult -> IO BlackBoxFunction
expectBBF (InterpretBBF BlackBoxFunction
f) = BlackBoxFunction -> IO BlackBoxFunction
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure BlackBoxFunction
f
    expectBBF InterpretFunctionResult
_ = String -> IO BlackBoxFunction
forall a. HasCallStack => String -> a
error ($(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Internal error: expected a BlackBoxFunction for "
                                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fullName)

compilePrimitiveWith InterpretFunctionRequest
-> IO (Either (NonEmpty InterpreterError) InterpretFunctionResult)
lookupInterp
  (BlackBox Text
pNm WorkInfo
wf RenderVoid
rVoid Bool
multiRes TemplateKind
tkind () Usage
outputUsage [Text]
libM [Text]
imps [(Int, Int)]
fPlural [((Text, Text),
  ((TemplateFormat, BlackBoxFunctionName), Maybe Text))]
incs [((TemplateFormat, BlackBoxFunctionName), Maybe Text)]
rM [((TemplateFormat, BlackBoxFunctionName), Maybe Text)]
riM ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
templ) = do
  [BlackBoxTemplate]
libM'  <- (Text -> IO BlackBoxTemplate) -> [Text] -> IO [BlackBoxTemplate]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> [a] -> m [b]
mapM Text -> IO BlackBoxTemplate
forall (m :: Type -> Type).
Applicative m =>
Text -> m BlackBoxTemplate
parseTempl [Text]
libM
  [BlackBoxTemplate]
imps'  <- (Text -> IO BlackBoxTemplate) -> [Text] -> IO [BlackBoxTemplate]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> [a] -> m [b]
mapM Text -> IO BlackBoxTemplate
forall (m :: Type -> Type).
Applicative m =>
Text -> m BlackBoxTemplate
parseTempl [Text]
imps
  [((Text, Text), BlackBox)]
incs'  <- (((Text, Text),
  ((TemplateFormat, BlackBoxFunctionName), Maybe Text))
 -> IO ((Text, Text), BlackBox))
-> [((Text, Text),
     ((TemplateFormat, BlackBoxFunctionName), Maybe Text))]
-> IO [((Text, Text), BlackBox)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> [a] -> m [b]
mapM ((((TemplateFormat, BlackBoxFunctionName), Maybe Text)
 -> IO BlackBox)
-> ((Text, Text),
    ((TemplateFormat, BlackBoxFunctionName), Maybe Text))
-> IO ((Text, Text), BlackBox)
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> ((Text, Text), a) -> f ((Text, Text), b)
traverse ((TemplateFormat, BlackBoxFunctionName), Maybe Text) -> IO BlackBox
parseBB) [((Text, Text),
  ((TemplateFormat, BlackBoxFunctionName), Maybe Text))]
incs
  BlackBox
templ' <- ((TemplateFormat, BlackBoxFunctionName), Maybe Text) -> IO BlackBox
parseBB ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
templ
  [BlackBox]
rM'    <- (((TemplateFormat, BlackBoxFunctionName), Maybe Text)
 -> IO BlackBox)
-> [((TemplateFormat, BlackBoxFunctionName), Maybe Text)]
-> IO [BlackBox]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((TemplateFormat, BlackBoxFunctionName), Maybe Text) -> IO BlackBox
parseBB [((TemplateFormat, BlackBoxFunctionName), Maybe Text)]
rM
  [BlackBox]
riM'   <- (((TemplateFormat, BlackBoxFunctionName), Maybe Text)
 -> IO BlackBox)
-> [((TemplateFormat, BlackBoxFunctionName), Maybe Text)]
-> IO [BlackBox]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((TemplateFormat, BlackBoxFunctionName), Maybe Text) -> IO BlackBox
parseBB [((TemplateFormat, BlackBoxFunctionName), Maybe Text)]
riM
  CompiledPrimitive -> IO CompiledPrimitive
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Text
-> WorkInfo
-> RenderVoid
-> Bool
-> TemplateKind
-> ()
-> Usage
-> [BlackBoxTemplate]
-> [BlackBoxTemplate]
-> [(Int, Int)]
-> [((Text, Text), BlackBox)]
-> [BlackBox]
-> [BlackBox]
-> BlackBox
-> CompiledPrimitive
forall a b c d.
Text
-> WorkInfo
-> RenderVoid
-> Bool
-> TemplateKind
-> c
-> Usage
-> [a]
-> [a]
-> [(Int, Int)]
-> [((Text, Text), b)]
-> [b]
-> [b]
-> b
-> Primitive a b c d
BlackBox Text
pNm WorkInfo
wf RenderVoid
rVoid Bool
multiRes TemplateKind
tkind () Usage
outputUsage [BlackBoxTemplate]
libM' [BlackBoxTemplate]
imps' [(Int, Int)]
fPlural [((Text, Text), BlackBox)]
incs' [BlackBox]
rM' [BlackBox]
riM' BlackBox
templ')
 where
  parseTempl
    :: Applicative m
    => Text
    -> m BlackBoxTemplate
  parseTempl :: forall (m :: Type -> Type).
Applicative m =>
Text -> m BlackBoxTemplate
parseTempl Text
t = case Text -> Result BlackBoxTemplate
runParse Text
t of
    Failure ErrInfo
errInfo
      -> String -> m BlackBoxTemplate
forall a. HasCallStack => String -> a
error (String
"Parsing template for blackbox " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
Data.Text.unpack Text
pNm String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" failed:\n"
               String -> String -> String
forall a. [a] -> [a] -> [a]
++ Doc AnsiStyle -> String
forall a. Show a => a -> String
show (ErrInfo -> Doc AnsiStyle
_errDoc ErrInfo
errInfo))
    Success BlackBoxTemplate
t'
      -> BlackBoxTemplate -> m BlackBoxTemplate
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure BlackBoxTemplate
t'

  interpretTF :: InterpretFunctionRequest -> IO TemplateFunction
  interpretTF :: InterpretFunctionRequest -> IO TemplateFunction
interpretTF InterpretFunctionRequest
req = do
    Either (NonEmpty InterpreterError) InterpretFunctionResult
r <- InterpretFunctionRequest
-> IO (Either (NonEmpty InterpreterError) InterpretFunctionResult)
lookupInterp InterpretFunctionRequest
req
    InterpretFunctionResult
res <- String
-> Text
-> Either (NonEmpty InterpreterError) InterpretFunctionResult
-> IO InterpretFunctionResult
forall (m :: Type -> Type) t.
(MonadThrow m, Monad m) =>
String -> Text -> Either (NonEmpty InterpreterError) t -> m t
processHintErrors (BlackBoxFunctionName -> String
forall a. Show a => a -> String
show ([String] -> String -> BlackBoxFunctionName
BlackBoxFunctionName (InterpretFunctionRequest -> [String]
ifrModNames InterpretFunctionRequest
req) (InterpretFunctionRequest -> String
ifrFuncName InterpretFunctionRequest
req))) Text
pNm Either (NonEmpty InterpreterError) InterpretFunctionResult
r
    case InterpretFunctionResult
res of
      InterpretTF TemplateFunction
f -> TemplateFunction -> IO TemplateFunction
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TemplateFunction
f
      InterpretFunctionResult
_ -> String -> IO TemplateFunction
forall a. HasCallStack => String -> a
error ($(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Internal error: expected a TemplateFunction for "
                         String -> String -> String
forall a. [a] -> [a] -> [a]
++ InterpretFunctionRequest -> String
interpretFunctionRequestToModuleName InterpretFunctionRequest
req String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++ InterpretFunctionRequest -> String
ifrFuncName InterpretFunctionRequest
req)

  parseBB
    :: ((TemplateFormat,BlackBoxFunctionName), Maybe Text)
    -> IO BlackBox
  parseBB :: ((TemplateFormat, BlackBoxFunctionName), Maybe Text) -> IO BlackBox
parseBB ((TemplateFormat
TTemplate,BlackBoxFunctionName
_),Just Text
t)     = BlackBoxTemplate -> BlackBox
BBTemplate (BlackBoxTemplate -> BlackBox)
-> IO BlackBoxTemplate -> IO BlackBox
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> IO BlackBoxTemplate
forall (m :: Type -> Type).
Applicative m =>
Text -> m BlackBoxTemplate
parseTempl Text
t
  parseBB ((TemplateFormat
TTemplate,BlackBoxFunctionName
_),Maybe Text
Nothing)    =
    String -> IO BlackBox
forall a. HasCallStack => String -> a
error (String
"No template specified for blackbox: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
pNm)
  parseBB ((TemplateFormat
THaskell,BlackBoxFunctionName
bbGenName),source :: Maybe Text
source@(Just Text
source')) = do
    let BlackBoxFunctionName [String]
modNames String
funcName = BlackBoxFunctionName
bbGenName
        qualMod :: String
qualMod = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"." [String]
modNames
        hsh :: Int
hsh = (String, Text) -> Int
forall a. Hashable a => a -> Int
hash (String
qualMod, Text
source')
    String -> Int -> TemplateFunction -> BlackBox
BBFunction (Text -> String
Data.Text.unpack Text
pNm) Int
hsh (TemplateFunction -> BlackBox)
-> IO TemplateFunction -> IO BlackBox
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$>
      InterpretFunctionRequest -> IO TemplateFunction
interpretTF ([String]
-> String
-> InterpretFunctionType
-> Maybe Text
-> InterpretFunctionRequest
InterpretFunctionRequest [String]
modNames String
funcName InterpretFunctionType
InterpretTemplateFunction Maybe Text
source)
  parseBB ((TemplateFormat
THaskell,BlackBoxFunctionName
bbGenName),Maybe Text
Nothing) = do
    let BlackBoxFunctionName [String]
modNames String
funcName = BlackBoxFunctionName
bbGenName
        qualMod :: String
qualMod = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"." [String]
modNames
        hsh :: Int
hsh     = String -> Int
forall a. Hashable a => a -> Int
hash String
qualMod
        fullName :: String
fullName = String
qualMod String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
funcName
    TemplateFunction
tf <-
      case String -> HashMap String TemplateFunction -> Maybe TemplateFunction
forall k v. Hashable k => k -> HashMap k v -> Maybe v
HashMap.lookup String
fullName HashMap String TemplateFunction
knownTemplateFunctions of
        Just TemplateFunction
f -> TemplateFunction -> IO TemplateFunction
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TemplateFunction
f
        Maybe TemplateFunction
Nothing ->
          InterpretFunctionRequest -> IO TemplateFunction
interpretTF ([String]
-> String
-> InterpretFunctionType
-> Maybe Text
-> InterpretFunctionRequest
InterpretFunctionRequest [String]
modNames String
funcName InterpretFunctionType
InterpretTemplateFunction Maybe Text
forall a. Maybe a
Nothing)
    BlackBox -> IO BlackBox
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (String -> Int -> TemplateFunction -> BlackBox
BBFunction (Text -> String
Data.Text.unpack Text
pNm) Int
hsh TemplateFunction
tf)

compilePrimitiveWith InterpretFunctionRequest
-> IO (Either (NonEmpty InterpreterError) InterpretFunctionResult)
_ (Primitive Text
pNm WorkInfo
wf Text
typ) =
  CompiledPrimitive -> IO CompiledPrimitive
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Text -> WorkInfo -> Text -> CompiledPrimitive
forall a b c d. Text -> WorkInfo -> Text -> Primitive a b c d
Primitive Text
pNm WorkInfo
wf Text
typ)
{-# SCC compilePrimitiveWith #-}

newtype HintError = HintError String deriving (Show HintError
Typeable HintError
(Typeable HintError, Show HintError) =>
(HintError -> SomeException)
-> (SomeException -> Maybe HintError)
-> (HintError -> String)
-> Exception HintError
SomeException -> Maybe HintError
HintError -> String
HintError -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> String) -> Exception e
$ctoException :: HintError -> SomeException
toException :: HintError -> SomeException
$cfromException :: SomeException -> Maybe HintError
fromException :: SomeException -> Maybe HintError
$cdisplayException :: HintError -> String
displayException :: HintError -> String
Exception)

instance Show HintError where
  showsPrec :: Int -> HintError -> ShowS
  showsPrec :: Int -> HintError -> String -> String
showsPrec Int
_ (HintError String
e) = String -> String -> String
showString String
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 :: forall (m :: Type -> Type) t.
(MonadThrow m, Monad m) =>
String -> Text -> Either (NonEmpty InterpreterError) t -> m t
processHintErrors String
fun Text
bb Either (NonEmpty InterpreterError) t
r = case Either (NonEmpty InterpreterError) t
r of
  Left NonEmpty InterpreterError
es -> HintError -> m t
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: Type -> Type) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (HintError -> m t) -> HintError -> m t
forall a b. (a -> b) -> a -> b
$ String -> HintError
HintError ([InterpreterError] -> String
forall {a}. Show a => [a] -> String
formatExceptions (NonEmpty InterpreterError -> [InterpreterError]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty InterpreterError
es))
  Right t
f -> t -> m t
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure t
f
 where
  formatExceptions :: [a] -> String
formatExceptions [a]
es = [I.i|
    Encountered one or more exceptions when compiling blackbox template function
    '#{fun}' for function '#{bb}'.
  |] String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n\n" ((a -> String) -> [a] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map a -> String
forall a. Show a => a -> String
formatException [a]
es)

  formatException :: a -> String
formatException a
e = [I.i|
    Encountered:

      #{e}
  |]

-- | Pretty print Components to HDL Documents
createHDL
  :: Backend backend
  => backend
  -- ^ Backend
  -> ClashOpts
  -- ^ Global Clash options
  -> IdentifierText
  -- ^ Module hierarchy root
  -> Id.IdentifierSet
  -- ^ Component names
  -> ComponentMap
  -- ^ List of components
  -> HashMap Data.Text.Text VDomainConfiguration
  -- ^ Known domains to configurations
  -> Component
  -- ^ Top component
  -> IdentifierText
  -- ^ Name of the manifest file
  -> ([(String,Doc)],[(String,FilePath)],[(String,String)])
  -- ^ The pretty-printed HDL documents
  -- + The data files that need to be copied
createHDL :: forall backend.
Backend backend =>
backend
-> ClashOpts
-> Text
-> IdentifierSet
-> ComponentMap
-> DomainMap
-> Component
-> Text
-> ([(String, Doc)], [(String, String)], [(String, String)])
createHDL backend
backend ClashOpts
opts Text
modName IdentifierSet
seen ComponentMap
components DomainMap
domainConfs Component
top Text
topName = (State
   backend ([(String, Doc)], [(String, String)], [(String, String)])
 -> backend
 -> ([(String, Doc)], [(String, String)], [(String, String)]))
-> backend
-> State
     backend ([(String, Doc)], [(String, String)], [(String, String)])
-> ([(String, Doc)], [(String, String)], [(String, String)])
forall a b c. (a -> b -> c) -> b -> a -> c
flip State
  backend ([(String, Doc)], [(String, String)], [(String, String)])
-> backend
-> ([(String, Doc)], [(String, String)], [(String, String)])
forall s a. State s a -> s -> a
evalState backend
backend (State
   backend ([(String, Doc)], [(String, String)], [(String, String)])
 -> ([(String, Doc)], [(String, String)], [(String, String)]))
-> State
     backend ([(String, Doc)], [(String, String)], [(String, String)])
-> ([(String, Doc)], [(String, String)], [(String, String)])
forall a b. (a -> b) -> a -> b
$ Ap
  (StateT backend Identity)
  ([(String, Doc)], [(String, String)], [(String, String)])
-> State
     backend ([(String, Doc)], [(String, String)], [(String, String)])
forall {k} (f :: k -> Type) (a :: k). Ap f a -> f a
getAp (Ap
   (StateT backend Identity)
   ([(String, Doc)], [(String, String)], [(String, String)])
 -> State
      backend ([(String, Doc)], [(String, String)], [(String, String)]))
-> Ap
     (StateT backend Identity)
     ([(String, Doc)], [(String, String)], [(String, String)])
-> State
     backend ([(String, Doc)], [(String, String)], [(String, String)])
forall a b. (a -> b) -> a -> b
$ do
  let componentsL :: [(ComponentMeta, Component)]
componentsL = ((Unique, (ComponentMeta, Component))
 -> (ComponentMeta, Component))
-> [(Unique, (ComponentMeta, Component))]
-> [(ComponentMeta, Component)]
forall a b. (a -> b) -> [a] -> [b]
map (Unique, (ComponentMeta, Component)) -> (ComponentMeta, Component)
forall a b. (a, b) -> b
snd (ComponentMap -> [(Unique, (ComponentMeta, Component))]
forall k v. OMap k v -> [(k, v)]
OMap.assocs ComponentMap
components)
  ([(String, Doc)]
hdlNmDocs0,[[(String, Doc)]]
incs) <-
    ([((String, Doc), [(String, Doc)])]
 -> ([(String, Doc)], [[(String, Doc)]]))
-> Ap (StateT backend Identity) [((String, Doc), [(String, Doc)])]
-> Ap
     (StateT backend Identity) ([(String, Doc)], [[(String, Doc)]])
forall a b.
(a -> b)
-> Ap (StateT backend Identity) a -> Ap (StateT backend Identity) b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap [((String, Doc), [(String, Doc)])]
-> ([(String, Doc)], [[(String, Doc)]])
forall a b. [(a, b)] -> ([a], [b])
unzip (Ap (StateT backend Identity) [((String, Doc), [(String, Doc)])]
 -> Ap
      (StateT backend Identity) ([(String, Doc)], [[(String, Doc)]]))
-> Ap (StateT backend Identity) [((String, Doc), [(String, Doc)])]
-> Ap
     (StateT backend Identity) ([(String, Doc)], [[(String, Doc)]])
forall a b. (a -> b) -> a -> b
$
      [(ComponentMeta, Component)]
-> ((ComponentMeta, Component)
    -> Ap (StateT backend Identity) ((String, Doc), [(String, Doc)]))
-> Ap (StateT backend Identity) [((String, Doc), [(String, Doc)])]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(ComponentMeta, Component)]
componentsL (((ComponentMeta, Component)
  -> Ap (StateT backend Identity) ((String, Doc), [(String, Doc)]))
 -> Ap (StateT backend Identity) [((String, Doc), [(String, Doc)])])
-> ((ComponentMeta, Component)
    -> Ap (StateT backend Identity) ((String, Doc), [(String, Doc)]))
-> Ap (StateT backend Identity) [((String, Doc), [(String, Doc)])]
forall a b. (a -> b) -> a -> b
$ \(ComponentMeta{SrcSpan
cmLoc :: SrcSpan
cmLoc :: ComponentMeta -> SrcSpan
cmLoc, IdentifierSet
cmScope :: IdentifierSet
cmScope :: ComponentMeta -> IdentifierSet
cmScope,UsageMap
cmUsage :: UsageMap
cmUsage :: ComponentMeta -> UsageMap
cmUsage}, Component
comp) ->
         ClashOpts
-> Text
-> SrcSpan
-> IdentifierSet
-> UsageMap
-> Component
-> Ap (StateT backend Identity) ((String, Doc), [(String, Doc)])
forall state.
Backend state =>
ClashOpts
-> Text
-> SrcSpan
-> IdentifierSet
-> UsageMap
-> Component
-> Ap (State state) ((String, Doc), [(String, Doc)])
genHDL ClashOpts
opts Text
modName SrcSpan
cmLoc (HasCallStack => IdentifierSet -> IdentifierSet -> IdentifierSet
IdentifierSet -> IdentifierSet -> IdentifierSet
Id.union IdentifierSet
seen IdentifierSet
cmScope) UsageMap
cmUsage Component
comp

  [HWType]
hwtys <- HashSet HWType -> [HWType]
forall a. HashSet a -> [a]
HashSet.toList (HashSet HWType -> [HWType])
-> (backend -> HashSet HWType) -> backend -> [HWType]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> backend -> HashSet HWType
forall state. Backend state => state -> HashSet HWType
extractTypes (backend -> [HWType])
-> Ap (StateT backend Identity) backend
-> Ap (StateT backend Identity) [HWType]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT backend Identity backend
-> Ap (StateT backend Identity) backend
forall {k} (f :: k -> Type) (a :: k). f a -> Ap f a
Ap StateT backend Identity backend
forall s (m :: Type -> Type). MonadState s m => m s
get
  [(String, Doc)]
typesPkg0 <- Text -> [HWType] -> Ap (StateT backend Identity) [(String, Doc)]
forall state.
Backend state =>
Text -> [HWType] -> Ap (State state) [(String, Doc)]
mkTyPackage Text
modName [HWType]
hwtys
  [(String, String)]
dataFiles <- StateT backend Identity [(String, String)]
-> Ap (StateT backend Identity) [(String, String)]
forall {k} (f :: k -> Type) (a :: k). f a -> Ap f a
Ap StateT backend Identity [(String, String)]
forall state. Backend state => State state [(String, String)]
getDataFiles
  [(String, String)]
memFiles  <- StateT backend Identity [(String, String)]
-> Ap (StateT backend Identity) [(String, String)]
forall {k} (f :: k -> Type) (a :: k). f a -> Ap f a
Ap StateT backend Identity [(String, String)]
forall state. Backend state => State state [(String, String)]
getMemoryDataFiles
  let
    typesPkg1 :: [(String, Doc)]
typesPkg1 = ((String, Doc) -> (String, Doc))
-> [(String, Doc)] -> [(String, Doc)]
forall a b. (a -> b) -> [a] -> [b]
map ((String -> String) -> (String, Doc) -> (String, Doc)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: Type -> Type -> Type) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (String -> String -> String
<.> backend -> String
forall state. Backend state => state -> String
Clash.Backend.extension backend
backend)) [(String, Doc)]
typesPkg0
    hdlNmDocs1 :: [(String, Doc)]
hdlNmDocs1 = ((String, Doc) -> (String, Doc))
-> [(String, Doc)] -> [(String, Doc)]
forall a b. (a -> b) -> [a] -> [b]
map ((String -> String) -> (String, Doc) -> (String, Doc)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: Type -> Type -> Type) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (String -> String -> String
<.> backend -> String
forall state. Backend state => state -> String
Clash.Backend.extension backend
backend)) [(String, Doc)]
hdlNmDocs0
    topFiles :: [(String, Doc)]
topFiles = [[(String, Doc)]] -> [(String, Doc)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(String, Doc)]]
incs [(String, Doc)] -> [(String, Doc)] -> [(String, Doc)]
forall a. [a] -> [a] -> [a]
++ [(String, Doc)]
typesPkg1 [(String, Doc)] -> [(String, Doc)] -> [(String, Doc)]
forall a. [a] -> [a] -> [a]
++ [(String, Doc)]
hdlNmDocs1

    topClks :: [(Text, Text)]
topClks = Component -> [(Text, Text)]
findClocks Component
top
    sdcInfo :: [(Text, VDomainConfiguration)]
sdcInfo = (Text -> VDomainConfiguration)
-> (Text, Text) -> (Text, VDomainConfiguration)
forall a b. (a -> b) -> (Text, a) -> (Text, b)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> VDomainConfiguration
findDomainConfig ((Text, Text) -> (Text, VDomainConfiguration))
-> [(Text, Text)] -> [(Text, VDomainConfiguration)]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, Text)]
topClks
    sdcFile :: String
sdcFile = Text -> String
Data.Text.unpack Text
topName String -> String -> String
<.> String
"sdc"
    sdcDoc :: (String, Doc)
sdcDoc  = (String
sdcFile, SdcInfo -> Doc
pprSDC ([(Text, VDomainConfiguration)] -> SdcInfo
SdcInfo [(Text, VDomainConfiguration)]
sdcInfo))
    sdc :: Maybe (String, Doc)
sdc = if [(Text, VDomainConfiguration)] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [(Text, VDomainConfiguration)]
sdcInfo then Maybe (String, Doc)
forall a. Maybe a
Nothing else (String, Doc) -> Maybe (String, Doc)
forall a. a -> Maybe a
Just (String, Doc)
sdcDoc

  ([(String, Doc)], [(String, String)], [(String, String)])
-> Ap
     (StateT backend Identity)
     ([(String, Doc)], [(String, String)], [(String, String)])
forall a. a -> Ap (StateT backend Identity) a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Maybe (String, Doc) -> [(String, Doc)]
forall a. Maybe a -> [a]
maybeToList Maybe (String, Doc)
sdc [(String, Doc)] -> [(String, Doc)] -> [(String, Doc)]
forall a. Semigroup a => a -> a -> a
<> [(String, Doc)]
topFiles, [(String, String)]
dataFiles, [(String, String)]
memFiles)
 where
  findDomainConfig :: Text -> VDomainConfiguration
findDomainConfig Text
dom =
    VDomainConfiguration -> Text -> DomainMap -> VDomainConfiguration
forall k v. Hashable k => v -> k -> HashMap k v -> v
HashMap.lookupDefault
      (String -> VDomainConfiguration
forall a. HasCallStack => String -> a
error (String -> VDomainConfiguration) -> String -> VDomainConfiguration
forall a b. (a -> b) -> a -> b
$ $(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Unknown synthesis domain: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
dom)
      Text
dom
      DomainMap
domainConfs

writeEdam ::
  FilePath ->
  (Id.Identifier, Unique) ->
  HashMap Unique [Unique] ->
  HashMap Unique [EdamFile] ->
  [(FilePath, ByteString)] ->
  IO (HashMap Unique [EdamFile], [(FilePath, ByteString)])
writeEdam :: String
-> (Identifier, Unique)
-> HashMap Unique [Unique]
-> HashMap Unique [EdamFile]
-> [(String, ByteString)]
-> IO (HashMap Unique [EdamFile], [(String, ByteString)])
writeEdam String
hdlDir (Identifier
topNm, Unique
topEntity) HashMap Unique [Unique]
deps HashMap Unique [EdamFile]
edamFiles0 [(String, ByteString)]
filesAndDigests = do
  let
    (HashMap Unique [EdamFile]
edamFiles1, Edam
edamInfo) =
      (Identifier, Unique)
-> HashMap Unique [Unique]
-> HashMap Unique [EdamFile]
-> [String]
-> (HashMap Unique [EdamFile], Edam)
createEDAM (Identifier
topNm, Unique
topEntity) HashMap Unique [Unique]
deps HashMap Unique [EdamFile]
edamFiles0 (((String, ByteString) -> String)
-> [(String, ByteString)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, ByteString) -> String
forall a b. (a, b) -> a
fst [(String, ByteString)]
filesAndDigests)
  ByteString
edamDigest <- String -> (String, Doc) -> IO ByteString
writeHDL String
hdlDir (String
"edam.py", Edam -> Doc
forall ann. Edam -> Doc ann
pprEdam Edam
edamInfo)
  (HashMap Unique [EdamFile], [(String, ByteString)])
-> IO (HashMap Unique [EdamFile], [(String, ByteString)])
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (HashMap Unique [EdamFile]
edamFiles1, (String
"edam.py", ByteString
edamDigest) (String, ByteString)
-> [(String, ByteString)] -> [(String, ByteString)]
forall a. a -> [a] -> [a]
: [(String, ByteString)]
filesAndDigests)

-- | Create an Edalize metadata file for using Edalize to build the project.
--
-- TODO: Handle libraries. Also see: https://github.com/olofk/edalize/issues/220
createEDAM ::
  -- Top entity name and unique
  (Id.Identifier, Unique) ->
  -- | Top entity dependency map
  HashMap Unique [Unique] ->
  -- | Edam files of each top entity
  HashMap Unique [EdamFile] ->
  -- | Files to include in Edam file
  [FilePath] ->
  -- | (updated map, edam)
  (HashMap Unique [EdamFile], Edam)
createEDAM :: (Identifier, Unique)
-> HashMap Unique [Unique]
-> HashMap Unique [EdamFile]
-> [String]
-> (HashMap Unique [EdamFile], Edam)
createEDAM (Identifier
topName, Unique
topUnique) HashMap Unique [Unique]
deps HashMap Unique [EdamFile]
edamFileMap [String]
files =
  (Unique
-> [EdamFile]
-> HashMap Unique [EdamFile]
-> HashMap Unique [EdamFile]
forall k v. Hashable k => k -> v -> HashMap k v -> HashMap k v
HashMap.insert Unique
topUnique (Edam -> [EdamFile]
edamFiles Edam
edam) HashMap Unique [EdamFile]
edamFileMap, Edam
edam)
 where
  edam :: Edam
edam = Edam
    { edamProjectName :: Text
edamProjectName = Identifier -> Text
Id.toText Identifier
topName
    , edamTopEntity :: Text
edamTopEntity   = Identifier -> Text
Id.toText Identifier
topName
    , edamFiles :: [EdamFile]
edamFiles       = (String -> EdamFile) -> [String] -> [EdamFile]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (Identifier -> String -> EdamFile
asEdamFile Identifier
topName) [String]
files [EdamFile] -> [EdamFile] -> [EdamFile]
forall a. Semigroup a => a -> a -> a
<> (EdamFile -> EdamFile) -> [EdamFile] -> [EdamFile]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap EdamFile -> EdamFile
asIncFile [EdamFile]
incFiles
    , edamToolOptions :: EdamTools
edamToolOptions = EdamTools
forall a. Default a => a
def
    }

  incFiles :: [EdamFile]
incFiles =
    (Unique -> [EdamFile]) -> [Unique] -> [EdamFile]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap
      (\Unique
u -> [EdamFile] -> Unique -> HashMap Unique [EdamFile] -> [EdamFile]
forall k v. Hashable k => v -> k -> HashMap k v -> v
HashMap.lookupDefault [] Unique
u HashMap Unique [EdamFile]
edamFileMap)
      ([Unique] -> Unique -> HashMap Unique [Unique] -> [Unique]
forall k v. Hashable k => v -> k -> HashMap k v -> v
HashMap.lookupDefault [] Unique
topUnique HashMap Unique [Unique]
deps)

  asIncFile :: EdamFile -> EdamFile
asIncFile EdamFile
f =
    EdamFile
f { efName = ".." </> Data.Text.unpack (efLogicalName f) </> efName f }

asEdamFile :: Id.Identifier -> FilePath -> EdamFile
asEdamFile :: Identifier -> String -> EdamFile
asEdamFile Identifier
topName String
path =
  String -> EdamFileType -> Text -> EdamFile
EdamFile String
path EdamFileType
edamFileType (Identifier -> Text
Id.toText Identifier
topName)
 where
  edamFileType :: EdamFileType
edamFileType =
    case String -> String
FilePath.takeExtension String
path of
      String
".vhdl" -> EdamFileType
VhdlSource
      String
".v" -> EdamFileType
VerilogSource
      String
".sv" -> EdamFileType
SystemVerilogSource
      String
".tcl" -> EdamFileType
TclSource
      String
".qsys" -> EdamFileType
QSYS
      String
".sdc" -> EdamFileType
SDC
      String
_ -> EdamFileType
Clash.Edalize.Edam.Unknown

-- | Prepares directory for writing HDL files.
prepareDir ::
  -- | HDL directory to prepare
  FilePath ->
  -- | Relevant options: @-fclash-no-clean@
  ClashOpts ->
  -- | Did directory contain unexpected modifications? See 'readFreshManifest'
  Maybe [UnexpectedModification] ->
  IO ()
prepareDir :: String -> ClashOpts -> Maybe [UnexpectedModification] -> IO ()
prepareDir String
hdlDir ClashOpts{Bool
opt_clear :: Bool
opt_clear :: ClashOpts -> Bool
opt_clear} Maybe [UnexpectedModification]
mods = do
  IO Bool -> IO () -> IO () -> IO ()
forall (m :: Type -> Type) a.
Monad m =>
m Bool -> m a -> m a -> m a
ifM
    (String -> IO Bool
doesPathExist String
hdlDir)
    (IO Bool -> IO () -> IO () -> IO ()
forall (m :: Type -> Type) a.
Monad m =>
m Bool -> m a -> m a -> m a
ifM
      (String -> IO Bool
doesDirectoryExist String
hdlDir)
      (IO ()
detectCaseIssues IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> IO ()
clearOrError IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> IO ()
createDir)
      (String -> IO ()
forall a. HasCallStack => String -> a
error [I.i|Tried to write HDL files to #{hdlDir}, but it wasn't a directory.|]))
    IO ()
createDir

 where
  createDir :: IO ()
createDir = Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
hdlDir

  -- Windows considers 'foo' and 'FOO' the same directory. Error if users tries
  -- to synthesize two top entities with conflicting (in this sense) names.
  detectCaseIssues :: IO ()
detectCaseIssues = do
    [String]
allPaths <- String -> IO [String]
listDirectory (String -> String
takeDirectory String
hdlDir)
    Bool -> IO () -> IO ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
unless (String -> String
takeFileName String
hdlDir String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [String]
allPaths) (String -> IO ()
forall a. HasCallStack => String -> a
error [I.i|
      OS indicated #{hdlDir} existed, but Clash could not find it among the
      list of existing directories in #{takeDirectory hdlDir}:

        #{allPaths}

      This probably means your OS or filesystem is case-insensitive. Rename your
      top level binders in order to prevent this error message.
    |])

  clearOrError :: IO ()
clearOrError =
    case Maybe [UnexpectedModification]
mods of
      Just [] ->
        -- No unexpected changes, so no user work will get lost
        String -> IO ()
removeDirectoryRecursive String
hdlDir
      Maybe [UnexpectedModification]
_ | Bool
opt_clear ->
        -- Unexpected changes / non-empty directory, but @-fclash-clear@ was
        -- set, so remove directory anyway.
        String -> IO ()
removeDirectoryRecursive String
hdlDir
      Just [UnexpectedModification]
unexpected ->
        -- Unexpected changes; i.e. modifications were made after last Clash run
        String -> IO ()
forall a. HasCallStack => String -> a
error [I.i|
          Changes were made to #{hdlDir} after last Clash run:

            #{pprintUnexpectedModifications 5 unexpected}

          Use '-fclash-clear' if you want Clash to clear out the directory.
          Warning: this will remove the complete directory, be cautious of data
          loss.
        |]
      Maybe [UnexpectedModification]
Nothing ->
        -- No manifest file was found. Refuse to write if directory isn't empty.
        IO Bool -> IO () -> IO ()
forall (m :: Type -> Type). Monad m => m Bool -> m () -> m ()
unlessM
          ([String] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null ([String] -> Bool) -> IO [String] -> IO Bool
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO [String]
listDirectory String
hdlDir)
          (String -> IO ()
forall a. HasCallStack => String -> a
error [I.i|
            Tried to write HDL files to #{hdlDir}, but directory wasn't empty. This
            message will be supressed if Clash can detect that no files have
            changed since it was last run. If you're seeing this message even
            though you haven't modified any files, Clash encountered a problem
            reading "#{manifestFilename :: String}". This can happen when upgrading
            Clash.

            Use '-fclash-clear' if you want Clash to clear out the directory.
            Warning: this will remove the complete directory, be cautious of data
            loss.
          |])

-- | Write a file to disk in chunks. Returns SHA256 sum of file contents.
writeAndHash :: FilePath -> ByteStringLazy.ByteString -> IO ByteString
writeAndHash :: String -> ByteString -> IO ByteString
writeAndHash String
path ByteString
bs =
  String -> IOMode -> (Handle -> IO ByteString) -> IO ByteString
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
IO.withFile String
path IOMode
IO.WriteMode ((Handle -> IO ByteString) -> IO ByteString)
-> (Handle -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Handle
handle ->
      (Ctx -> ByteString) -> IO Ctx -> IO ByteString
forall a b. (a -> b) -> IO a -> IO b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Ctx -> ByteString
Sha256.finalize
    (IO Ctx -> IO ByteString) -> IO Ctx -> IO ByteString
forall a b. (a -> b) -> a -> b
$ (Ctx -> ByteString -> IO Ctx) -> Ctx -> [ByteString] -> IO Ctx
forall (t :: Type -> Type) (m :: Type -> Type) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Handle -> Ctx -> ByteString -> IO Ctx
writeChunk Handle
handle) Ctx
Sha256.init
    ([ByteString] -> IO Ctx) -> [ByteString] -> IO Ctx
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
ByteStringLazy.toChunks ByteString
bs
 where
  writeChunk :: IO.Handle -> Sha256.Ctx -> ByteString -> IO Sha256.Ctx
  writeChunk :: Handle -> Ctx -> ByteString -> IO Ctx
writeChunk Handle
h !Ctx
ctx ByteString
chunk = do
    Handle -> ByteString -> IO ()
ByteString.hPut Handle
h ByteString
chunk
    Ctx -> IO Ctx
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Ctx -> ByteString -> Ctx
Sha256.update Ctx
ctx ByteString
chunk)

-- | Writes a HDL file to the given directory. Returns SHA256 hash of written
-- file.
writeHDL :: FilePath -> (FilePath, Doc) -> IO ByteString
writeHDL :: String -> (String, Doc) -> IO ByteString
writeHDL String
dir (String
cname, Doc
hdl) = do
  let
    layout :: LayoutOptions
layout = PageWidth -> LayoutOptions
LayoutOptions (Int -> Double -> PageWidth
AvailablePerLine Int
120 Double
0.4)
    rendered0 :: Text
rendered0 = SimpleDocStream () -> Text
forall ann. SimpleDocStream ann -> Text
renderLazy (LayoutOptions -> Doc -> SimpleDocStream ()
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutPretty LayoutOptions
layout Doc
hdl)
    rendered1 :: Text
rendered1 = [Text] -> Text
Text.unlines ((Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
Text.stripEnd (Text -> [Text]
Text.lines Text
rendered0))
  String -> ByteString -> IO ByteString
writeAndHash (String
dir String -> String -> String
</> String
cname) (Text -> ByteString
Text.encodeUtf8 (Text
rendered1 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"))

-- | Copy given files
writeMemoryDataFiles
    :: FilePath
    -- ^ Directory to copy  files to
    -> [(FilePath, String)]
    -- ^ (filename, content)
    -> IO [ByteString]
writeMemoryDataFiles :: String -> [(String, String)] -> IO [ByteString]
writeMemoryDataFiles String
dir [(String, String)]
files =
  [(String, String)]
-> ((String, String) -> IO ByteString) -> IO [ByteString]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(String, String)]
files (((String, String) -> IO ByteString) -> IO [ByteString])
-> ((String, String) -> IO ByteString) -> IO [ByteString]
forall a b. (a -> b) -> a -> b
$ \(String
fname, String
content) ->
    String -> ByteString -> IO ByteString
writeAndHash (String
dir String -> String -> String
</> String
fname) (String -> ByteString
ByteStringLazyChar8.pack String
content)

-- | Copy data files added with ~FILE, assumes the files are canonicalized already.
-- Throws an error on relative paths as sanity check.
copyDataFiles
  :: FilePath
  -- ^ Directory to copy to
  -> [(FilePath,FilePath)]
  -- ^ [(name of newly made file in HDL output dir, file to copy)]
  -> IO [ByteString]
  -- ^ SHA256 hashes of written files
copyDataFiles :: String -> [(String, String)] -> IO [ByteString]
copyDataFiles String
targetDir = ((String, String) -> IO ByteString)
-> [(String, String)] -> IO [ByteString]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> [a] -> m [b]
mapM (String, String) -> IO ByteString
copyDataFile
 where
  copyDataFile :: (FilePath, FilePath) -> IO ByteString
  copyDataFile :: (String, String) -> IO ByteString
copyDataFile (String
newName, String
toCopy)
    | String -> Bool
isAbsolute String
toCopy = do
      IO Bool -> IO ByteString -> IO ByteString -> IO ByteString
forall (m :: Type -> Type) a.
Monad m =>
m Bool -> m a -> m a -> m a
ifM
        (String -> IO Bool
doesFileExist String
toCopy)
        (String -> String -> IO ByteString
copyAndHash String
toCopy (String
targetDir String -> String -> String
</> String
newName))
        (String -> IO ByteString
forall a. HasCallStack => String -> a
error [I.i|Could not find data file #{show toCopy}. Does it exist?|])
    | Bool
otherwise = String -> IO ByteString
forall a. HasCallStack => String -> a
error [I.i|copyDataFiles received a relative path #{show toCopy}. This is a bug in Clash, please report it.|]

  copyAndHash :: String -> String -> IO ByteString
copyAndHash String
src String
dst = do
    IO Bool -> IO ByteString -> IO ByteString -> IO ByteString
forall (m :: Type -> Type) a.
Monad m =>
m Bool -> m a -> m a -> m a
ifM
      (String -> IO Bool
doesPathExist String
dst)
      (String -> IO ByteString
forall a. HasCallStack => String -> a
error [I.i|
        Tried to copy data file #{src} to #{dst} but a file or directory with
        that name already existed. This is a bug in Clash, please report it.
      |])
      (String -> IO ByteString
ByteStringLazy.readFile String
src IO ByteString -> (ByteString -> IO ByteString) -> IO ByteString
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> ByteString -> IO ByteString
writeAndHash String
dst)

-- | Normalize a complete hierarchy
normalizeEntity
  :: ClashEnv
  -> BindingMap
  -- ^ All bindings
  -> (CustomReprs -> TyConMap -> Type ->
      State HWMap (Maybe (Either String FilteredHWType)))
  -- ^ Hardcoded 'Type' -> 'HWType' translator
  -> PE.Evaluator
  -- ^ Hardcoded evaluator for partial evaluation
  -> WHNF.Evaluator
  -- ^ Hardcoded evaluator for WHNF (old evaluator)
  -> [Id]
  -- ^ TopEntities
  -> Supply.Supply
  -- ^ Unique supply
  -> Id
  -- ^ root of the hierarchy
  -> IO BindingMap
normalizeEntity :: ClashEnv
-> BindingMap
-> (CustomReprs
    -> TyConMap
    -> Type
    -> State HWMap (Maybe (Either String FilteredHWType)))
-> Evaluator
-> Evaluator
-> [Id]
-> Supply
-> Id
-> IO BindingMap
normalizeEntity ClashEnv
env BindingMap
bindingsMap CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
typeTrans Evaluator
peEval Evaluator
eval [Id]
topEntities Supply
supply Id
tm = IO BindingMap
transformedBindings
  where
    doNorm :: RewriteMonad NormalizeState BindingMap
doNorm = do BindingMap
norm <- [Id] -> RewriteMonad NormalizeState BindingMap
normalize [Id
tm]
                let normChecked :: BindingMap
normChecked = BindingMap -> BindingMap
checkNonRecursive BindingMap
norm
                BindingMap
cleaned <- Id -> BindingMap -> RewriteMonad NormalizeState BindingMap
cleanupGraph Id
tm BindingMap
normChecked
                BindingMap -> RewriteMonad NormalizeState BindingMap
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return BindingMap
cleaned
    transformedBindings :: IO BindingMap
transformedBindings = ClashEnv
-> Supply
-> BindingMap
-> (CustomReprs
    -> TyConMap
    -> Type
    -> State HWMap (Maybe (Either String FilteredHWType)))
-> Evaluator
-> Evaluator
-> VarEnv Bool
-> [Id]
-> RewriteMonad NormalizeState BindingMap
-> IO BindingMap
forall a.
ClashEnv
-> Supply
-> BindingMap
-> (CustomReprs
    -> TyConMap
    -> Type
    -> State HWMap (Maybe (Either String FilteredHWType)))
-> Evaluator
-> Evaluator
-> VarEnv Bool
-> [Id]
-> NormalizeSession a
-> IO a
runNormalization ClashEnv
env Supply
supply BindingMap
bindingsMap
                            CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
typeTrans Evaluator
peEval Evaluator
eval VarEnv Bool
forall a. VarEnv a
emptyVarEnv
                            [Id]
topEntities RewriteMonad NormalizeState BindingMap
doNorm

-- | Reverse topologically sort given top entities. Also returns a mapping that
-- maps a top entity to its reverse topologically sorted transitive dependencies.
sortTop ::
  BindingMap ->
  [TopEntityT] ->
  ( [TopEntityT]
  , HashMap Unique [Unique]
  )
sortTop :: BindingMap
-> [TopEntityT] -> ([TopEntityT], HashMap Unique [Unique])
sortTop BindingMap
bindingsMap [TopEntityT]
topEntities =
  case [(Unique, TopEntityT)]
-> [(Unique, Unique)] -> Either String [TopEntityT]
forall a. [(Unique, a)] -> [(Unique, Unique)] -> Either String [a]
reverseTopSort [(Unique, TopEntityT)]
nodes [(Unique, Unique)]
edges of
    Left String
msg   -> String -> ([TopEntityT], HashMap Unique [Unique])
forall a. HasCallStack => String -> a
error String
msg
    Right [TopEntityT]
tops -> ([TopEntityT]
tops, [TopEntityT] -> HashMap Unique [Unique]
mapFrom [TopEntityT]
tops)
 where
  nodes :: [(Unique, TopEntityT)]
nodes = [(Id -> Unique
forall a. Var a -> Unique
varUniq Id
topE, TopEntityT
t) | t :: TopEntityT
t@(TopEntityT Id
topE Maybe TopEntity
_ Bool
_) <- [TopEntityT]
topEntities]
  edges :: [(Unique, Unique)]
edges = (TopEntityT -> [(Unique, Unique)])
-> [TopEntityT] -> [(Unique, Unique)]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap TopEntityT -> [(Unique, Unique)]
getEdges [TopEntityT]
topEntities

  getEdges :: TopEntityT -> [(Unique, Unique)]
getEdges (TopEntityT Id
topE Maybe TopEntity
_ Bool
_) =
    (TopEntityT -> (Unique, Unique))
-> [TopEntityT] -> [(Unique, Unique)]
forall a b. (a -> b) -> [a] -> [b]
map
      (\TopEntityT
top -> (Id -> Unique
forall a. Var a -> Unique
varUniq Id
topE, TopEntityT -> Unique
topToUnique TopEntityT
top))
      (Id -> [TopEntityT]
getTransitiveRefs Id
topE)

  getTransitiveRefs :: Id -> [TopEntityT]
getTransitiveRefs Id
top =
    let allDeps :: CallGraph
allDeps = BindingMap -> Id -> CallGraph
callGraph BindingMap
bindingsMap Id
top
    in  (TopEntityT -> Bool) -> [TopEntityT] -> [TopEntityT]
forall a. (a -> Bool) -> [a] -> [a]
filter (\TopEntityT
t -> TopEntityT -> Id
topId TopEntityT
t Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
/= Id
top Bool -> Bool -> Bool
&& TopEntityT -> Id
topId TopEntityT
t Id -> CallGraph -> Bool
forall a b. Var a -> VarEnv b -> Bool
`elemVarEnv` CallGraph
allDeps) [TopEntityT]
topEntities

  topToUnique :: TopEntityT -> Unique
topToUnique = Id -> Unique
forall a. Var a -> Unique
varUniq (Id -> Unique) -> (TopEntityT -> Id) -> TopEntityT -> Unique
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TopEntityT -> Id
topId

  mapFrom :: [TopEntityT] -> HashMap Unique [Unique]
mapFrom [TopEntityT]
tops =
    let
      topIndices :: HashMap Unique Unique
topIndices = [(Unique, Unique)] -> HashMap Unique Unique
forall k v. Hashable k => [(k, v)] -> HashMap k v
HashMap.fromList ([Unique] -> [Unique] -> [(Unique, Unique)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((TopEntityT -> Unique) -> [TopEntityT] -> [Unique]
forall a b. (a -> b) -> [a] -> [b]
map TopEntityT -> Unique
topToUnique [TopEntityT]
tops) [(Unique
0 :: Unique)..])
      nonOrdered :: HashMap Unique [Unique]
nonOrdered = ([Unique] -> [Unique] -> [Unique])
-> [(Unique, [Unique])] -> HashMap Unique [Unique]
forall k v. Hashable k => (v -> v -> v) -> [(k, v)] -> HashMap k v
HashMap.fromListWith [Unique] -> [Unique] -> [Unique]
forall a. Semigroup a => a -> a -> a
(<>) (((Unique, Unique) -> (Unique, [Unique]))
-> [(Unique, Unique)] -> [(Unique, [Unique])]
forall a b. (a -> b) -> [a] -> [b]
map ((Unique -> [Unique]) -> (Unique, Unique) -> (Unique, [Unique])
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: Type -> Type -> Type) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Unique -> [Unique]
forall a. a -> [a]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure) [(Unique, Unique)]
edges)
      orderFunc :: Unique -> Maybe Unique
orderFunc Unique
k = Unique -> HashMap Unique Unique -> Maybe Unique
forall k v. Hashable k => k -> HashMap k v -> Maybe v
HashMap.lookup Unique
k HashMap Unique Unique
topIndices
    in
      ([Unique] -> [Unique])
-> HashMap Unique [Unique] -> HashMap Unique [Unique]
forall v1 v2 k. (v1 -> v2) -> HashMap k v1 -> HashMap k v2
HashMap.map ((Unique -> Maybe Unique) -> [Unique] -> [Unique]
forall b a. Ord b => (a -> b) -> [a] -> [a]
List.sortOn Unique -> Maybe Unique
orderFunc) HashMap Unique [Unique]
nonOrdered