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

  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 NamedFieldPuns #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module Clash.Driver where

import qualified Control.Concurrent.Supply        as Supply
import           Control.DeepSeq
import           Control.Exception                (throw)
import qualified Control.Monad                    as Monad
import           Control.Monad                    (unless, foldM, forM, filterM)
import           Control.Monad.Catch              (MonadMask)
import           Control.Monad.Extra              (whenM, ifM, unlessM)
import           Control.Monad.IO.Class           (MonadIO)
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.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.Coerce                      (coerce)
import           Data.Default
import           Data.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.IntMap                      (IntMap)
import           Data.List                        (intercalate)
import           Data.Maybe                       (fromMaybe, maybeToList, mapMaybe)
import qualified Data.Map.Ordered                 as OMap
import           Data.Map.Ordered.Extra           ()
import           Data.Semigroup.Monad
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 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)

#if MIN_VERSION_ghc(9,0,0)
import           GHC.Builtin.Names                 (eqTyConKey, ipClassKey)
import           GHC.Types.Unique                  (getKey)

import           GHC.Types.SrcLoc                  (SrcSpan)
#else
import           PrelNames               (eqTyConKey, ipClassKey)
import           Unique                  (getKey)

import           SrcLoc                           (SrcSpan)
#endif
import           GHC.BasicTypes.Extra             ()

import           Clash.Annotations.Primitive
  (HDL (..))
import           Clash.Annotations.BitRepresentation.Internal
  (CustomReprs)
import           Clash.Annotations.TopEntity
  (TopEntity (..), PortName(PortName, PortProduct))
import           Clash.Annotations.TopEntity.Extra ()
import           Clash.Backend

#if EXPERIMENTAL_EVALUATOR
import           Clash.Core.PartialEval           (Evaluator)
#else
import           Clash.Core.Evaluator.Types       (Evaluator)
#endif

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, TyConName)
import           Clash.Core.Util                  (shouldSplit)
import           Clash.Core.Var
  (Id, varName, varUniq, varType)
import           Clash.Core.VarEnv
  (elemVarEnv, emptyVarEnv, lookupVarEnv, lookupVarEnv', mkVarEnv, lookupVarEnvDirectly)
import           Clash.Debug                      (debugIsOn)
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.Normalize                  (checkNonRecursive, cleanupGraph,
                                                   normalize, runNormalization)
import           Clash.Normalize.Util             (callGraph, tvSubstWithTyEq)
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.Verification    as P
import           Clash.Primitives.Types
import           Clash.Signal.Internal
import           Clash.Unique                     (Unique, getUnique)
import           Clash.Util.Interpolate           (i)
import           Clash.Util
  (ClashException(..), HasCallStack, first, reportTimeDiff,
   wantedLanguageExtensions, unwantedLanguageExtensions, curLoc)
import           Clash.Util.Graph                 (reverseTopSort)
import qualified Clash.Util.Interpolate           as I

-- | 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 :: TopEntity -> [PortName]
t_inputs :: [PortName]
t_inputs} =
  TopEntity
t{t_inputs :: [PortName]
t_inputs=Type -> [PortName] -> [PortName]
go Type
typ [PortName]
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 (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 (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|
              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 -> Int
forall a. Name a -> Int
nameUniq -> Int
tcUniq) [Type]
tcArgs)
    | Int
tcUniq Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Unique -> Int
getKey Unique
eqTyConKey = Bool
True
    | Int
tcUniq Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Unique -> Int
getKey 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']
_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 :: 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
_) ->
      TopEntityT
tt{topAnnotation :: Maybe TopEntity
topAnnotation=TopEntity -> Maybe TopEntity
forall a. a -> Maybe a
Just (TyConMap -> SrcSpan -> Type -> TopEntity -> TopEntity
splitTopAnn TyConMap
tcm SrcSpan
sp (Id -> Type
forall a. Var a -> Type
varType Id
id_) TopEntity
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 :: Type
varType=Type -> Type
tvSubstWithTyEq (Id -> Type
forall a. Var a -> Type
varType Id
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 :: 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

-- | Create a set of target HDL files for a set of functions
generateHDL
  :: forall backend . Backend backend
  => CustomReprs
  -> HashMap Data.Text.Text VDomainConfiguration
  -- ^ Known domains to configurations
  -> BindingMap
  -- ^ Set of functions
  -> Maybe backend
  -> CompiledPrimMap
  -- ^ Primitive / BlackBox Definitions
  -> TyConMap
  -- ^ TyCon cache
  -> IntMap TyConName
  -- ^ Tuple TyCon cache
  -> (CustomReprs -> TyConMap -> Type ->
      State HWMap (Maybe (Either String FilteredHWType)))
  -- ^ Hardcoded 'Type' -> 'HWType' translator
  -> Evaluator
  -- ^ Hardcoded evaluator for partial evaluation
  -> [TopEntityT]
  -- ^ All topentities
  -> Maybe (TopEntityT, [TopEntityT])
  -- ^ Main top entity to compile. If Nothing, all top entities in previous
  -- argument will be compiled.
  -> ClashOpts
  -- ^ Debug information level for the normalization process
  -> (Clock.UTCTime,Clock.UTCTime)
  -> IO ()
generateHDL :: CustomReprs
-> HashMap Text VDomainConfiguration
-> BindingMap
-> Maybe backend
-> CompiledPrimMap
-> TyConMap
-> IntMap TyConName
-> (CustomReprs
    -> TyConMap
    -> Type
    -> State HWMap (Maybe (Either String FilteredHWType)))
-> Evaluator
-> [TopEntityT]
-> Maybe (TopEntityT, [TopEntityT])
-> ClashOpts
-> (UTCTime, UTCTime)
-> IO ()
generateHDL CustomReprs
reprs HashMap Text VDomainConfiguration
domainConfs BindingMap
bindingsMap Maybe backend
hdlState CompiledPrimMap
primMap TyConMap
tcm IntMap TyConName
tupTcm CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
typeTrans Evaluator
eval
  [TopEntityT]
topEntities0 Maybe (TopEntityT, [TopEntityT])
mainTopEntity ClashOpts
opts (UTCTime
startTime,UTCTime
prepTime) = do
    case ClashOpts -> Maybe String
opt_dbgRewriteHistoryFile ClashOpts
opts of
      Maybe String
Nothing -> () -> IO ()
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()
      Just String
histFile -> IO Bool -> IO () -> IO ()
forall (m :: Type -> Type). Monad m => m Bool -> m () -> m ()
whenM (String -> IO Bool
Directory.doesFileExist String
histFile) (String -> IO ()
Directory.removeFile String
histFile)
    let ([TopEntityT]
tes, HashMap Int [Int]
deps) = BindingMap -> [TopEntityT] -> ([TopEntityT], HashMap Int [Int])
sortTop BindingMap
bindingsMap [TopEntityT]
topEntities1
     in UTCTime
-> IdentifierSet
-> HashMap Int [EdamFile]
-> HashMap Int [Int]
-> [TopEntityT]
-> IO ()
go UTCTime
prepTime IdentifierSet
initIs HashMap Int [EdamFile]
forall k v. HashMap k v
HashMap.empty HashMap Int [Int]
deps [TopEntityT]
tes
 where
  (VarEnv Identifier
compNames, IdentifierSet
initIs) = Maybe Text
-> Bool
-> PreserveCase
-> HDL
-> [TopEntityT]
-> (VarEnv Identifier, IdentifierSet)
genTopNames Maybe Text
topPrefixM Bool
escpIds PreserveCase
lwIds HDL
hdl [TopEntityT]
topEntities1
  topEntityMap :: VarEnv TopEntityT
topEntityMap = [(Id, TopEntityT)] -> VarEnv TopEntityT
forall a b. [(Var a, b)] -> VarEnv b
mkVarEnv ((TopEntityT -> (Id, TopEntityT))
-> [TopEntityT] -> [(Id, TopEntityT)]
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)
  topPrefixM :: Maybe Text
topPrefixM = ClashOpts -> Maybe Text
opt_componentPrefix ClashOpts
opts
  hdl :: HDL
hdl = Proxy backend -> HDL
forall backend. Backend backend => Proxy backend -> HDL
hdlFromBackend (Proxy backend
forall k (t :: k). Proxy t
Proxy @backend)
  escpIds :: Bool
escpIds = ClashOpts -> Bool
opt_escapedIds ClashOpts
opts
  lwIds :: PreserveCase
lwIds = ClashOpts -> PreserveCase
opt_lowerCaseBasicIds ClashOpts
opts
  topEntities1 :: [TopEntityT]
topEntities1 =
    (TopEntityT -> TopEntityT) -> [TopEntityT] -> [TopEntityT]
forall a b. (a -> b) -> [a] -> [b]
map
      (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)

  go
    :: Clock.UTCTime
    -> Id.IdentifierSet
    -> HashMap Unique [EdamFile]
    -> HashMap Unique [Unique]
    -> [TopEntityT]
    -> IO ()
  go :: UTCTime
-> IdentifierSet
-> HashMap Int [EdamFile]
-> HashMap Int [Int]
-> [TopEntityT]
-> IO ()
go UTCTime
prevTime IdentifierSet
_ HashMap Int [EdamFile]
_ HashMap Int [Int]
_ [] =
    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]
++ UTCTime -> UTCTime -> String
reportTimeDiff UTCTime
prevTime UTCTime
startTime

  -- Process the next TopEntity
  go UTCTime
prevTime IdentifierSet
seen0 HashMap Int [EdamFile]
edamFiles0 HashMap Int [Int]
deps (TopEntityT Id
topEntity Maybe TopEntity
annM Bool
isTb:[TopEntityT]
topEntities') = do
  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))
  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Clash: Compiling " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
topEntityS

  -- Some initial setup
  let -- TODO: 'modName1' should be run through 'seen0'
      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)
      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 (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Text
Data.Text.pack -> Maybe Text
prefixM) = case Maybe Text
topPrefixM of
        Just (Text -> String
Data.Text.unpack -> String
p)
          | Bool -> Bool
not (String -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null String
p) -> case Maybe TopEntity
annM of
            -- Prefix top names with 'p', prefix other with 'p_tname'
            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)
            -- Prefix top names with 'p', prefix other with 'p'
            Maybe TopEntity
_ -> (String
p String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"_" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
modName1, String -> Maybe String
forall a. a -> Maybe a
Just String
p)
          | Just TopEntity
ann <- Maybe TopEntity
annM -> case HDL
hdl of
              -- Prefix other with 't_name'
              HDL
VHDL -> (TopEntity -> String
t_name TopEntity
ann, String -> Maybe String
forall a. a -> Maybe a
Just String
modNameS)
              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 backend -> HDL
forall state. Backend state => state -> HDL
hdlKind (backend
forall a. HasCallStack => a
undefined :: backend) of
            HDL
VHDL -> (TopEntity -> String
t_name TopEntity
ann, Maybe String
forall a. Maybe a
Nothing)
            -- Prefix other with 't_name'
            HDL
_ -> (TopEntity -> String
t_name TopEntity
ann, String -> Maybe String
forall a. a -> Maybe a
Just String
modNameS)
          Maybe TopEntity
_ -> (String
modName1, Maybe String
forall a. Maybe a
Nothing)
      modNameT :: Text
modNameT  = String -> Text
Data.Text.pack String
modNameS
      iw :: Int
iw        = ClashOpts -> Int
opt_intWidth ClashOpts
opts
      hdlsyn :: HdlSyn
hdlsyn    = ClashOpts -> HdlSyn
opt_hdlSyn ClashOpts
opts
      forceUnd :: Maybe (Maybe Int)
forceUnd  = ClashOpts -> Maybe (Maybe Int)
opt_forceUndefined ClashOpts
opts
      xOpt :: AggressiveXOptBB
xOpt      = Bool -> AggressiveXOptBB
coerce (ClashOpts -> Bool
opt_aggressiveXOptBB ClashOpts
opts)
      hdlState' :: backend
hdlState' = Text -> backend -> backend
forall state. Backend state => Text -> state -> state
setModName Text
modNameT
                (backend -> backend) -> backend -> backend
forall a b. (a -> b) -> a -> b
$ backend -> Maybe backend -> backend
forall a. a -> Maybe a -> a
fromMaybe (Int
-> HdlSyn
-> Bool
-> PreserveCase
-> Maybe (Maybe Int)
-> AggressiveXOptBB
-> backend
forall state.
Backend state =>
Int
-> HdlSyn
-> Bool
-> PreserveCase
-> Maybe (Maybe Int)
-> AggressiveXOptBB
-> state
initBackend Int
iw HdlSyn
hdlsyn Bool
escpIds PreserveCase
lwIds Maybe (Maybe Int)
forceUnd AggressiveXOptBB
xOpt :: backend) 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

  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"

  -- 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, Int
topHash) <-
    [TopEntityT]
-> (BindingMap, Id)
-> CompiledPrimMap
-> ClashOpts
-> UTCTime
-> String
-> IO (Maybe [UnexpectedModification], Maybe Manifest, Int)
readFreshManifest [TopEntityT]
topEntities0 (BindingMap
bindingsMap, Id
topEntity) CompiledPrimMap
primMap ClashOpts
opts UTCTime
clashModDate String
manPath

  Supply
supplyN <- IO Supply
Supply.newSupply
  let topEntityNames :: [Id]
topEntityNames = (TopEntityT -> Id) -> [TopEntityT] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map TopEntityT -> Id
topId [TopEntityT]
topEntities1

  (UTCTime
topTime, IdentifierSet
seen2, HashMap Int [EdamFile]
edamFiles2) <- case Maybe Manifest
maybeManifest of
    Just manifest0 :: Manifest
manifest0@Manifest{[(String, ByteString)]
fileNames :: Manifest -> [(String, ByteString)]
fileNames :: [(String, ByteString)]
fileNames} | Just [] <- Maybe [UnexpectedModification]
userModifications -> do
      -- Found a 'manifest' files. Use it to extend "seen" set. Generate EDAM
      -- files if necessary.
      String -> IO ()
putStrLn (String
"Clash: Using cached result for: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
topEntityS)
      UTCTime
topTime <- IO UTCTime
Clock.getCurrentTime
      let seen1 :: IdentifierSet
seen1 = State IdentifierSet () -> IdentifierSet -> IdentifierSet
forall s a. State s a -> s -> s
State.execState ((Text -> StateT IdentifierSet Identity 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 -> StateT IdentifierSet Identity Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Text -> m Identifier
Id.addRaw (Manifest -> [Text]
componentNames Manifest
manifest0)) IdentifierSet
seen0

      (HashMap Int [EdamFile]
edamFiles1, [(String, ByteString)]
fileNames1) <-
        if ClashOpts -> Bool
opt_edalize ClashOpts
opts
        then String
-> (Identifier, Int)
-> HashMap Int [Int]
-> HashMap Int [EdamFile]
-> [(String, ByteString)]
-> IO (HashMap Int [EdamFile], [(String, ByteString)])
writeEdam String
hdlDir (Identifier
topNm, Id -> Int
forall a. Var a -> Int
varUniq Id
topEntity) HashMap Int [Int]
deps HashMap Int [EdamFile]
edamFiles0 [(String, ByteString)]
fileNames
        else (HashMap Int [EdamFile], [(String, ByteString)])
-> IO (HashMap Int [EdamFile], [(String, ByteString)])
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (HashMap Int [EdamFile]
edamFiles0, [(String, ByteString)]
fileNames)

      String -> Manifest -> IO ()
writeManifest String
manPath Manifest
manifest0{fileNames :: [(String, ByteString)]
fileNames=[(String, ByteString)]
fileNames1}

      (UTCTime, IdentifierSet, HashMap Int [EdamFile])
-> IO (UTCTime, IdentifierSet, HashMap Int [EdamFile])
forall (m :: Type -> Type) a. Monad m => a -> m a
return
        ( UTCTime
topTime
        , IdentifierSet
seen1
        , HashMap Int [EdamFile]
edamFiles1
        )

    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. Normalize topEntity
      let transformedBindings :: BindingMap
transformedBindings = CustomReprs
-> BindingMap
-> CompiledPrimMap
-> TyConMap
-> IntMap TyConName
-> (CustomReprs
    -> TyConMap
    -> Type
    -> State HWMap (Maybe (Either String FilteredHWType)))
-> Evaluator
-> [Id]
-> ClashOpts
-> Supply
-> Id
-> BindingMap
normalizeEntity CustomReprs
reprs BindingMap
bindingsMap CompiledPrimMap
primMap TyConMap
tcm IntMap TyConName
tupTcm
                                  CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
typeTrans Evaluator
eval [Id]
topEntityNames ClashOpts
opts 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
      String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Clash: Normalization took " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
prepNormDiff

      -- 3. Generate netlist for topEntity
      (Component
topComponent, ComponentMap
netlist, IdentifierSet
seen2) <-
        Bool
-> ClashOpts
-> CustomReprs
-> BindingMap
-> VarEnv TopEntityT
-> VarEnv Identifier
-> CompiledPrimMap
-> TyConMap
-> (CustomReprs
    -> TyConMap
    -> Type
    -> State HWMap (Maybe (Either String FilteredHWType)))
-> Int
-> Bool
-> SomeBackend
-> IdentifierSet
-> String
-> Maybe Text
-> Id
-> IO (Component, ComponentMap, IdentifierSet)
genNetlist Bool
isTb ClashOpts
opts CustomReprs
reprs BindingMap
transformedBindings VarEnv TopEntityT
topEntityMap VarEnv Identifier
compNames CompiledPrimMap
primMap
                   TyConMap
tcm CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
typeTrans Int
iw Bool
ite (backend -> SomeBackend
forall backend. Backend backend => backend -> SomeBackend
SomeBackend backend
hdlState') IdentifierSet
seen0 String
hdlDir Maybe Text
prefixM Id
topEntity

      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
      String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Clash: Netlist generation took " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
normNetDiff

      -- 4. Generate topEntity wrapper
      let
        ([(String, Doc)]
hdlDocs, [(String, String)]
dfiles, [(String, String)]
mfiles) =
          backend
-> Text
-> IdentifierSet
-> ComponentMap
-> HashMap Text VDomainConfiguration
-> Component
-> Text
-> ([(String, Doc)], [(String, String)], [(String, String)])
forall backend.
Backend backend =>
backend
-> Text
-> IdentifierSet
-> ComponentMap
-> HashMap Text VDomainConfiguration
-> Component
-> Text
-> ([(String, Doc)], [(String, String)], [(String, String)])
createHDL backend
hdlState' Text
modNameT IdentifierSet
seen2 ComponentMap
netlist HashMap Text VDomainConfiguration
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)
mapM (String -> (String, Doc) -> IO ByteString
writeHDL String
hdlDir) [(String, Doc)]
hdlDocs
      [ByteString]
dataFilesDigests <- [String] -> String -> [(String, String)] -> IO [ByteString]
copyDataFiles (ClashOpts -> [String]
opt_importPaths ClashOpts
opts) String
hdlDir [(String, String)]
dfiles
      [ByteString]
memoryFilesDigests <- String -> [(String, String)] -> IO [ByteString]
writeMemoryDataFiles String
hdlDir [(String, String)]
mfiles

      let
        components :: [Component]
components = ((Int, (ComponentMeta, Component)) -> Component)
-> [(Int, (ComponentMeta, Component))] -> [Component]
forall a b. (a -> b) -> [a] -> [b]
map ((ComponentMeta, Component) -> Component
forall a b. (a, b) -> b
snd ((ComponentMeta, Component) -> Component)
-> ((Int, (ComponentMeta, Component))
    -> (ComponentMeta, Component))
-> (Int, (ComponentMeta, Component))
-> Component
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, (ComponentMeta, Component)) -> (ComponentMeta, Component)
forall a b. (a, b) -> b
snd) (ComponentMap -> [(Int, (ComponentMeta, Component))]
forall k v. OMap k v -> [(k, v)]
OMap.assocs ComponentMap
netlist)
        filesAndDigests0 :: [(String, ByteString)]
filesAndDigests0 =
             [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)]
-> [(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, 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

      (HashMap Int [EdamFile]
edamFiles1, [(String, ByteString)]
filesAndDigests1) <-
        if ClashOpts -> Bool
opt_edalize ClashOpts
opts
        then String
-> (Identifier, Int)
-> HashMap Int [Int]
-> HashMap Int [EdamFile]
-> [(String, ByteString)]
-> IO (HashMap Int [EdamFile], [(String, ByteString)])
writeEdam String
hdlDir (Identifier
topNm, Id -> Int
forall a. Var a -> Int
varUniq Id
topEntity) HashMap Int [Int]
deps HashMap Int [EdamFile]
edamFiles0 [(String, ByteString)]
filesAndDigests0
        else (HashMap Int [EdamFile], [(String, ByteString)])
-> IO (HashMap Int [EdamFile], [(String, ByteString)])
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (HashMap Int [EdamFile]
edamFiles0, [(String, ByteString)]
filesAndDigests0)

      let
        depUniques :: [Int]
depUniques = [Int] -> Maybe [Int] -> [Int]
forall a. a -> Maybe a -> a
fromMaybe [] (Int -> HashMap Int [Int] -> Maybe [Int]
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup (Id -> Int
forall a. Uniquable a => a -> Int
getUnique Id
topEntity) HashMap Int [Int]
deps)
        depBindings :: [Binding Term]
depBindings = (Int -> Maybe (Binding Term)) -> [Int] -> [Binding Term]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((Int -> BindingMap -> Maybe (Binding Term))
-> BindingMap -> Int -> Maybe (Binding Term)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> BindingMap -> Maybe (Binding Term)
forall a. Int -> VarEnv a -> Maybe a
lookupVarEnvDirectly BindingMap
bindingsMap) [Int]
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
-> HashMap Text VDomainConfiguration
-> ClashOpts
-> Component
-> [Component]
-> [Id]
-> [(String, ByteString)]
-> Int
-> Manifest
forall backend.
Backend backend =>
backend
-> HashMap Text VDomainConfiguration
-> ClashOpts
-> Component
-> [Component]
-> [Id]
-> [(String, ByteString)]
-> Int
-> Manifest
mkManifest
            backend
hdlState' HashMap Text VDomainConfiguration
domainConfs ClashOpts
opts Component
topComponent [Component]
components [Id]
depIds
            [(String, ByteString)]
filesAndDigests1 Int
topHash
      String -> Manifest -> IO ()
writeManifest String
manPath Manifest
manifest

      UTCTime
topTime <- [(String, Doc)]
hdlDocs [(String, Doc)] -> IO UTCTime -> IO UTCTime
`seq` IO UTCTime
Clock.getCurrentTime
      (UTCTime, IdentifierSet, HashMap Int [EdamFile])
-> IO (UTCTime, IdentifierSet, HashMap Int [EdamFile])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (UTCTime
topTime, IdentifierSet
seen2, HashMap Int [EdamFile]
edamFiles1)

  UTCTime
-> IdentifierSet
-> HashMap Int [EdamFile]
-> HashMap Int [Int]
-> [TopEntityT]
-> IO ()
go UTCTime
topTime IdentifierSet
seen2 HashMap Int [EdamFile]
edamFiles2 HashMap Int [Int]
deps [TopEntityT]
topEntities'

-- | Interpret a specific function from a specific module. This action tries
-- two things:
--
--   1. Interpret without explicitly loading the module. This will succeed if
--      the module was already loaded through a package database (set using
--      'interpreterArgs').
--
--   2. If (1) fails, it does try to load it explicitly. If this also fails,
--      an error is returned.
--
loadImportAndInterpret
  :: (MonadIO m, MonadMask m)
  => [String]
  -- ^ Extra search path (usually passed as -i)
  -> [String]
  -- ^ Interpreter args
  -> String
  -- ^ The folder in which the GHC bootstrap libraries (base, containers, etc.)
  -- can be found
  -> Hint.ModuleName
  -- ^ Module function lives in
  -> String
  -- ^ Function name
  -> String
  -- ^ Type name ('BlackBoxFunction' or 'TemplateFunction')
  -> m (Either Hint.InterpreterError a)
loadImportAndInterpret :: [String]
-> [String]
-> String
-> String
-> String
-> String
-> m (Either InterpreterError a)
loadImportAndInterpret [String]
iPaths0 [String]
interpreterArgs String
topDir String
qualMod String
funcName String
typ = do
  IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
Hint.liftIO (IO () -> m ()) -> IO () -> m ()
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 (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> String -> IO ()
putStrLn (String
qualMod String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
funcName)
  -- Try to interpret function *without* loading module explicitly. If this
  -- succeeds, the module was already in the global package database(s).
  Either InterpreterError a
bbfE <- [String]
-> String -> InterpreterT m a -> m (Either InterpreterError a)
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 m a -> m (Either InterpreterError a))
-> InterpreterT m a -> m (Either InterpreterError a)
forall a b. (a -> b) -> a -> b
$ do
    [String]
iPaths1 <- ([String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++[String]
iPaths0) ([String] -> [String])
-> InterpreterT m [String] -> InterpreterT m [String]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Option (InterpreterT m) [String] -> InterpreterT m [String]
forall (m :: Type -> Type) a.
MonadInterpreter m =>
Option m a -> m a
Hint.get Option (InterpreterT m) [String]
forall (m :: Type -> Type). MonadInterpreter m => Option m [String]
Hint.searchPath
    [OptionVal (InterpreterT m)] -> InterpreterT m ()
forall (m :: Type -> Type).
MonadInterpreter m =>
[OptionVal m] -> m ()
Hint.set [Option (InterpreterT m) [String]
forall (m :: Type -> Type). MonadInterpreter m => Option m [String]
Hint.searchPath Option (InterpreterT m) [String]
-> [String] -> OptionVal (InterpreterT m)
forall (m :: Type -> Type) a. Option m a -> a -> OptionVal m
Hint.:= [String]
iPaths1]
    [String] -> InterpreterT m ()
forall (m :: Type -> Type). MonadInterpreter m => [String] -> m ()
Hint.setImports [ String
"Clash.Netlist.Types", String
"Clash.Netlist.BlackBox.Types", String
qualMod]
    String -> String -> InterpreterT m a
forall (m :: Type -> Type) a.
MonadInterpreter m =>
String -> String -> m a
Hint.unsafeInterpret String
funcName String
typ

  case Either InterpreterError a
bbfE of
    Left InterpreterError
_ -> do
      -- Try to interpret module as a local module, not yet present in the
      -- global package database(s).
      [String]
-> String -> InterpreterT m a -> m (Either InterpreterError a)
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 m a -> m (Either InterpreterError a))
-> InterpreterT m a -> m (Either InterpreterError a)
forall a b. (a -> b) -> a -> b
$ do
        InterpreterT m ()
forall (m :: Type -> Type). MonadInterpreter m => m ()
Hint.reset
        [String]
iPaths1 <- ([String]
iPaths0[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++) ([String] -> [String])
-> InterpreterT m [String] -> InterpreterT m [String]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Option (InterpreterT m) [String] -> InterpreterT m [String]
forall (m :: Type -> Type) a.
MonadInterpreter m =>
Option m a -> m a
Hint.get Option (InterpreterT m) [String]
forall (m :: Type -> Type). MonadInterpreter m => Option m [String]
Hint.searchPath
        [OptionVal (InterpreterT m)] -> InterpreterT m ()
forall (m :: Type -> Type).
MonadInterpreter m =>
[OptionVal m] -> m ()
Hint.set [ Option (InterpreterT m) [String]
forall (m :: Type -> Type). MonadInterpreter m => Option m [String]
Hint.searchPath Option (InterpreterT m) [String]
-> [String] -> OptionVal (InterpreterT m)
forall (m :: Type -> Type) a. Option m a -> a -> OptionVal m
Hint.:= [String]
iPaths1
                 , Option (InterpreterT m) [Extension]
forall (m :: Type -> Type).
MonadInterpreter m =>
Option m [Extension]
Hint.languageExtensions Option (InterpreterT m) [Extension]
-> [Extension] -> OptionVal (InterpreterT m)
forall (m :: Type -> Type) a. Option m a -> a -> OptionVal m
Hint.:= [Extension]
langExts]
        [String] -> InterpreterT m ()
forall (m :: Type -> Type). MonadInterpreter m => [String] -> m ()
Hint.loadModules [String
qualMod]
        [String] -> InterpreterT m ()
forall (m :: Type -> Type). MonadInterpreter m => [String] -> m ()
Hint.setImports [ String
"Clash.Netlist.BlackBox.Types", String
"Clash.Netlist.Types", String
qualMod]
        String -> String -> InterpreterT m a
forall (m :: Type -> Type) a.
MonadInterpreter m =>
String -> String -> m a
Hint.unsafeInterpret String
funcName String
typ
    Right a
_ -> do
      Either InterpreterError a -> m (Either InterpreterError a)
forall (m :: Type -> Type) a. Monad m => a -> m a
return Either InterpreterError a
bbfE
 where
   langExts :: [Extension]
langExts = (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" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ) ((Extension -> String) -> [Extension] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Extension -> String
forall a. Show a => a -> String
show [Extension]
unwantedLanguageExtensions)

-- | 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. (Eq k, 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 :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
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.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. (Eq k, 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 :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
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)
    ]

-- | Compiles blackbox functions and parses blackbox templates.
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 (BlackBoxHaskell Text
bbName WorkInfo
wf UsedArguments
usedArgs Bool
multiRes BlackBoxFunctionName
bbGenName Maybe Text
source) = do
  BlackBoxFunction
bbFunc <-
    -- TODO: Use cache for hint targets. Right now Hint will fire multiple times
    -- TODO: if multiple functions use the same blackbox haskell function.
    case String -> HashMap String BlackBoxFunction -> Maybe BlackBoxFunction
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup String
fullName HashMap String BlackBoxFunction
knownBlackBoxFunctions of
      Just BlackBoxFunction
f -> BlackBoxFunction -> IO BlackBoxFunction
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure BlackBoxFunction
f
      Maybe BlackBoxFunction
Nothing -> do
        Bool -> IO () -> IO ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
Monad.when Bool
debugIsOn (String -> IO ()
putStr String
"Hint: interpreting " IO () -> IO () -> IO ()
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> String -> IO ()
putStrLn (String -> String
forall a. Show a => a -> String
show String
fullName))
        let 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]
forall a. a -> [a] -> [a]
:) ([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
        -- Compile a blackbox template function or fetch it from an already compiled file.
        Either InterpreterError BlackBoxFunction
r <- [String]
-> Maybe Text -> IO (Either InterpreterError BlackBoxFunction)
go [String]
interpreterArgs Maybe Text
source
        String
-> Text
-> (BlackBoxFunction -> BlackBoxFunction)
-> Either InterpreterError BlackBoxFunction
-> IO BlackBoxFunction
forall (m :: Type -> Type) t r.
Monad m =>
String -> Text -> (t -> r) -> Either InterpreterError t -> m r
processHintError
          (BlackBoxFunctionName -> String
forall a. Show a => a -> String
show BlackBoxFunctionName
bbGenName)
          Text
bbName
          BlackBoxFunction -> BlackBoxFunction
forall a. a -> a
id
          Either InterpreterError BlackBoxFunction
r

  CompiledPrimitive -> IO CompiledPrimitive
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

    -- | Create directory based on base name and directory. Return path
    -- of directory just created.
    createDirectory'
      :: FilePath
      -> FilePath
      -> IO FilePath
    createDirectory' :: String -> String -> IO String
createDirectory' String
base String
sub =
      let new :: String
new = String
base String -> String -> String
</> String
sub in
      String -> IO ()
Directory.createDirectory String
new IO () -> IO String -> IO String
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> String -> IO String
forall (m :: Type -> Type) a. Monad m => a -> m a
return String
new

    go
      :: [String]
      -> Maybe Text
      -> IO (Either Hint.InterpreterError BlackBoxFunction)
    go :: [String]
-> Maybe Text -> IO (Either InterpreterError BlackBoxFunction)
go [String]
args (Just Text
source') = do
      -- Create a temporary directory with user module in it, add it to the
      -- list of import direcotries, and run as if it were a "normal" compiled
      -- module.
      String
tmpDir0 <- IO String
getCanonicalTemporaryDirectory
      String
-> String
-> (String -> IO (Either InterpreterError BlackBoxFunction))
-> IO (Either InterpreterError BlackBoxFunction)
forall (m :: Type -> Type) a.
(MonadMask m, MonadIO m) =>
String -> String -> (String -> m a) -> m a
withTempDirectory String
tmpDir0 String
"clash-prim-compile" ((String -> IO (Either InterpreterError BlackBoxFunction))
 -> IO (Either InterpreterError BlackBoxFunction))
-> (String -> IO (Either InterpreterError BlackBoxFunction))
-> IO (Either InterpreterError BlackBoxFunction)
forall a b. (a -> b) -> a -> b
$ \String
tmpDir1 -> do
        String
modDir <- (String -> String -> IO String) -> String -> [String] -> IO String
forall (t :: Type -> Type) (m :: Type -> Type) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM String -> String -> IO String
createDirectory' String
tmpDir1 ([String] -> [String]
forall a. [a] -> [a]
init [String]
modNames)
        String -> Text -> IO ()
Text.writeFile (String
modDir String -> String -> String
</> ([String] -> String
forall a. [a] -> a
last [String]
modNames String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".hs")) Text
source'
        [String]
-> [String]
-> String
-> String
-> String
-> String
-> IO (Either InterpreterError BlackBoxFunction)
forall (m :: Type -> Type) a.
(MonadIO m, MonadMask m) =>
[String]
-> [String]
-> String
-> String
-> String
-> String
-> m (Either InterpreterError a)
loadImportAndInterpret (String
tmpDir1String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
idirs) [String]
args String
topDir String
qualMod String
funcName String
"BlackBoxFunction"

    go [String]
args Maybe Text
Nothing = do
      [String]
-> [String]
-> String
-> String
-> String
-> String
-> IO (Either InterpreterError BlackBoxFunction)
forall (m :: Type -> Type) a.
(MonadIO m, MonadMask m) =>
[String]
-> [String]
-> String
-> String
-> String
-> String
-> m (Either InterpreterError a)
loadImportAndInterpret [String]
idirs [String]
args String
topDir String
qualMod String
funcName String
"BlackBoxFunction"

compilePrimitive [String]
idirs [String]
pkgDbs String
topDir
  (BlackBox Text
pNm WorkInfo
wf RenderVoid
rVoid Bool
multiRes TemplateKind
tkind () Bool
oReg [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)
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)
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)
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)
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)
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)
traverse ((TemplateFormat, BlackBoxFunctionName), Maybe Text) -> IO BlackBox
parseBB [((TemplateFormat, BlackBoxFunctionName), Maybe Text)]
riM
  CompiledPrimitive -> IO CompiledPrimitive
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Text
-> WorkInfo
-> RenderVoid
-> Bool
-> TemplateKind
-> ()
-> Bool
-> [BlackBoxTemplate]
-> [BlackBoxTemplate]
-> [(Int, Int)]
-> [((Text, Text), BlackBox)]
-> [BlackBox]
-> [BlackBox]
-> BlackBox
-> CompiledPrimitive
forall a b c d.
Text
-> WorkInfo
-> RenderVoid
-> Bool
-> TemplateKind
-> c
-> Bool
-> [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 () Bool
oReg [BlackBoxTemplate]
libM' [BlackBoxTemplate]
imps' [(Int, Int)]
fPlural [((Text, Text), BlackBox)]
incs' [BlackBox]
rM' [BlackBox]
riM' BlackBox
templ')
 where
  iArgs :: [String]
iArgs = (String -> [String]) -> [String] -> [String]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap ((String
"-package-db"String -> [String] -> [String]
forall a. a -> [a] -> [a]
:) ([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

  parseTempl
    :: Applicative m
    => Text
    -> m BlackBoxTemplate
  parseTempl :: 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 (f :: Type -> Type) a. Applicative f => a -> f a
pure BlackBoxTemplate
t'

  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),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
    String
tmpDir <- IO String
getCanonicalTemporaryDirectory
    Either InterpreterError TemplateFunction
r <- String
-> String
-> (String -> IO (Either InterpreterError TemplateFunction))
-> IO (Either InterpreterError TemplateFunction)
forall (m :: Type -> Type) a.
(MonadMask m, MonadIO m) =>
String -> String -> (String -> m a) -> m a
withTempDirectory String
tmpDir String
"clash-prim-compile" ((String -> IO (Either InterpreterError TemplateFunction))
 -> IO (Either InterpreterError TemplateFunction))
-> (String -> IO (Either InterpreterError TemplateFunction))
-> IO (Either InterpreterError TemplateFunction)
forall a b. (a -> b) -> a -> b
$ \String
tmpDir' -> do
      let modDir :: String
modDir = (String -> String -> String) -> String -> [String] -> String
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl String -> String -> String
(</>) String
tmpDir' ([String] -> [String]
forall a. [a] -> [a]
init [String]
modNames)
      Bool -> String -> IO ()
Directory.createDirectoryIfMissing Bool
True String
modDir
      String -> Text -> IO ()
Text.writeFile (String
modDir String -> String -> String
</> [String] -> String
forall a. [a] -> a
last [String]
modNames String -> String -> String
<.>  String
"hs") Text
source
      [String]
-> [String]
-> String
-> String
-> String
-> String
-> IO (Either InterpreterError TemplateFunction)
forall (m :: Type -> Type) a.
(MonadIO m, MonadMask m) =>
[String]
-> [String]
-> String
-> String
-> String
-> String
-> m (Either InterpreterError a)
loadImportAndInterpret (String
tmpDir'String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
idirs) [String]
iArgs String
topDir String
qualMod String
funcName String
"TemplateFunction"
    let hsh :: Int
hsh = (String, Text) -> Int
forall a. Hashable a => a -> Int
hash (String
qualMod, Text
source)
    String
-> Text
-> (TemplateFunction -> BlackBox)
-> Either InterpreterError TemplateFunction
-> IO BlackBox
forall (m :: Type -> Type) t r.
Monad m =>
String -> Text -> (t -> r) -> Either InterpreterError t -> m r
processHintError (BlackBoxFunctionName -> String
forall a. Show a => a -> String
show BlackBoxFunctionName
bbGenName) Text
pNm (String -> Int -> TemplateFunction -> BlackBox
BBFunction (Text -> String
Data.Text.unpack Text
pNm) Int
hsh) Either InterpreterError TemplateFunction
r
  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. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup String
fullName HashMap String TemplateFunction
knownTemplateFunctions of
        Just TemplateFunction
f -> TemplateFunction -> IO TemplateFunction
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TemplateFunction
f
        Maybe TemplateFunction
Nothing -> do
          Either InterpreterError TemplateFunction
r <- [String]
-> [String]
-> String
-> String
-> String
-> String
-> IO (Either InterpreterError TemplateFunction)
forall (m :: Type -> Type) a.
(MonadIO m, MonadMask m) =>
[String]
-> [String]
-> String
-> String
-> String
-> String
-> m (Either InterpreterError a)
loadImportAndInterpret [String]
idirs [String]
iArgs String
topDir String
qualMod String
funcName String
"TemplateFunction"
          String
-> Text
-> (TemplateFunction -> TemplateFunction)
-> Either InterpreterError TemplateFunction
-> IO TemplateFunction
forall (m :: Type -> Type) t r.
Monad m =>
String -> Text -> (t -> r) -> Either InterpreterError t -> m r
processHintError (BlackBoxFunctionName -> String
forall a. Show a => a -> String
show BlackBoxFunctionName
bbGenName) Text
pNm TemplateFunction -> TemplateFunction
forall a. a -> a
id Either InterpreterError TemplateFunction
r
    BlackBox -> IO BlackBox
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)

compilePrimitive [String]
_ [String]
_ String
_ (Primitive Text
pNm WorkInfo
wf Text
typ) =
  CompiledPrimitive -> IO CompiledPrimitive
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 compilePrimitive #-}

processHintError
  :: Monad m
  => String
  -> Data.Text.Text
  -> (t -> r)
  -> Either Hint.InterpreterError t
  -> m r
processHintError :: String -> Text -> (t -> r) -> Either InterpreterError t -> m r
processHintError String
fun Text
bb t -> r
go Either InterpreterError t
r = case Either InterpreterError t
r of
  Left (Hint.GhcException String
err) ->
    String -> String -> m r
forall a. String -> String -> a
error' String
"GHC Exception" String
err
  Left (Hint.NotAllowed String
err) ->
    String -> String -> m r
forall a. String -> String -> a
error' String
"NotAllowed error" String
err
  Left (Hint.UnknownError String
err) ->
    String -> String -> m r
forall a. String -> String -> a
error' String
"an unknown error" String
err
  Left (Hint.WontCompile [GhcError]
ghcErrs) ->
    String -> String -> m r
forall a. String -> String -> a
error' String
"compilation errors" (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (GhcError -> String) -> [GhcError] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map GhcError -> String
Hint.errMsg [GhcError]
ghcErrs)
  Right t
f ->
    r -> m r
forall (m :: Type -> Type) a. Monad m => a -> m a
return (r -> m r) -> r -> m r
forall a b. (a -> b) -> a -> b
$ t -> r
go t
f
 where
  error' :: String -> String -> a
error' String
errType String
report =
    String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [ String
"Encountered", String
errType, String
"while compiling blackbox template"
                    , String
"function", String -> String
forall a. Show a => a -> String
show String
fun, String
"for function", Text -> String
forall a. Show a => a -> String
show Text
bb String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."
                    , String
"Compilation reported: \n\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
report ]

-- | Pretty print Components to HDL Documents
createHDL
  :: Backend backend
  => backend
  -- ^ Backend
  -> 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 :: backend
-> Text
-> IdentifierSet
-> ComponentMap
-> HashMap Text VDomainConfiguration
-> Component
-> Text
-> ([(String, Doc)], [(String, String)], [(String, String)])
createHDL backend
backend Text
modName IdentifierSet
seen ComponentMap
components HashMap Text VDomainConfiguration
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
$ Mon
  (State backend)
  ([(String, Doc)], [(String, String)], [(String, String)])
-> State
     backend ([(String, Doc)], [(String, String)], [(String, String)])
forall (f :: Type -> Type) m. Mon f m -> f m
getMon (Mon
   (State backend)
   ([(String, Doc)], [(String, String)], [(String, String)])
 -> State
      backend ([(String, Doc)], [(String, String)], [(String, String)]))
-> Mon
     (State backend)
     ([(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 = ((Int, (ComponentMeta, Component)) -> (ComponentMeta, Component))
-> [(Int, (ComponentMeta, Component))]
-> [(ComponentMeta, Component)]
forall a b. (a -> b) -> [a] -> [b]
map (Int, (ComponentMeta, Component)) -> (ComponentMeta, Component)
forall a b. (a, b) -> b
snd (ComponentMap -> [(Int, (ComponentMeta, Component))]
forall k v. OMap k v -> [(k, v)]
OMap.assocs ComponentMap
components)
  ([(String, Doc)]
hdlNmDocs,[[(String, Doc)]]
incs) <-
    ([((String, Doc), [(String, Doc)])]
 -> ([(String, Doc)], [[(String, Doc)]]))
-> Mon (State backend) [((String, Doc), [(String, Doc)])]
-> Mon (State backend) ([(String, Doc)], [[(String, Doc)]])
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 (Mon (State backend) [((String, Doc), [(String, Doc)])]
 -> Mon (State backend) ([(String, Doc)], [[(String, Doc)]]))
-> Mon (State backend) [((String, Doc), [(String, Doc)])]
-> Mon (State backend) ([(String, Doc)], [[(String, Doc)]])
forall a b. (a -> b) -> a -> b
$
      [(ComponentMeta, Component)]
-> ((ComponentMeta, Component)
    -> Mon (State backend) ((String, Doc), [(String, Doc)]))
-> Mon (State backend) [((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)
  -> Mon (State backend) ((String, Doc), [(String, Doc)]))
 -> Mon (State backend) [((String, Doc), [(String, Doc)])])
-> ((ComponentMeta, Component)
    -> Mon (State backend) ((String, Doc), [(String, Doc)]))
-> Mon (State backend) [((String, Doc), [(String, Doc)])]
forall a b. (a -> b) -> a -> b
$ \(ComponentMeta{SrcSpan
cmLoc :: ComponentMeta -> SrcSpan
cmLoc :: SrcSpan
cmLoc, IdentifierSet
cmScope :: ComponentMeta -> IdentifierSet
cmScope :: IdentifierSet
cmScope}, Component
comp) ->
         Text
-> SrcSpan
-> IdentifierSet
-> Component
-> Mon (State backend) ((String, Doc), [(String, Doc)])
forall state.
Backend state =>
Text
-> SrcSpan
-> IdentifierSet
-> Component
-> Mon (State state) ((String, Doc), [(String, Doc)])
genHDL Text
modName SrcSpan
cmLoc (HasCallStack => IdentifierSet -> IdentifierSet -> IdentifierSet
IdentifierSet -> IdentifierSet -> IdentifierSet
Id.union IdentifierSet
seen IdentifierSet
cmScope) 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])
-> Mon (State backend) backend -> Mon (State backend) [HWType]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> State backend backend -> Mon (State backend) backend
forall (f :: Type -> Type) m. f m -> Mon f m
Mon State backend backend
forall s (m :: Type -> Type). MonadState s m => m s
get
  [(String, Doc)]
typesPkg <- Text -> [HWType] -> Mon (State backend) [(String, Doc)]
forall state.
Backend state =>
Text -> [HWType] -> Mon (State state) [(String, Doc)]
mkTyPackage Text
modName [HWType]
hwtys
  [(String, String)]
dataFiles <- StateT backend Identity [(String, String)]
-> Mon (State backend) [(String, String)]
forall (f :: Type -> Type) m. f m -> Mon f m
Mon StateT backend Identity [(String, String)]
forall state. Backend state => State state [(String, String)]
getDataFiles
  [(String, String)]
memFiles  <- StateT backend Identity [(String, String)]
-> Mon (State backend) [(String, String)]
forall (f :: Type -> Type) m. f m -> Mon f m
Mon StateT backend Identity [(String, String)]
forall state. Backend state => State state [(String, String)]
getMemoryDataFiles
  let
    hdl :: [(String, Doc)]
hdl = ((String, Doc) -> (String, Doc))
-> [(String, Doc)] -> [(String, Doc)]
forall a b. (a -> b) -> [a] -> [b]
map ((String -> String) -> (String, Doc) -> (String, Doc)
forall (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (String -> String -> String
<.> backend -> String
forall state. Backend state => state -> String
Clash.Backend.extension backend
backend)) ([(String, Doc)]
typesPkg [(String, Doc)] -> [(String, Doc)] -> [(String, Doc)]
forall a. [a] -> [a] -> [a]
++ [(String, Doc)]
hdlNmDocs)
    qincs :: [(String, Doc)]
qincs = [[(String, Doc)]] -> [(String, Doc)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(String, Doc)]]
incs
    topFiles :: [(String, Doc)]
topFiles = [(String, Doc)]
hdl [(String, Doc)] -> [(String, Doc)] -> [(String, Doc)]
forall a. [a] -> [a] -> [a]
++ [(String, Doc)]
qincs

    topClks :: [(Text, Text)]
topClks = Component -> [(Text, Text)]
findClocks Component
top
    sdcInfo :: [(Text, VDomainConfiguration)]
sdcInfo = (Text -> VDomainConfiguration)
-> (Text, Text) -> (Text, VDomainConfiguration)
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 (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)])
-> Mon
     (State backend)
     ([(String, Doc)], [(String, String)], [(String, String)])
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
-> HashMap Text VDomainConfiguration
-> VDomainConfiguration
forall k v. (Eq k, 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
$ $(String
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
      HashMap Text VDomainConfiguration
domainConfs

writeEdam ::
  FilePath ->
  (Id.Identifier, Unique) ->
  HashMap Unique [Unique] ->
  HashMap Unique [EdamFile] ->
  [(FilePath, ByteString)] ->
  IO (HashMap Unique [EdamFile], [(FilePath, ByteString)])
writeEdam :: String
-> (Identifier, Int)
-> HashMap Int [Int]
-> HashMap Int [EdamFile]
-> [(String, ByteString)]
-> IO (HashMap Int [EdamFile], [(String, ByteString)])
writeEdam String
hdlDir (Identifier
topNm, Int
topEntity) HashMap Int [Int]
deps HashMap Int [EdamFile]
edamFiles0 [(String, ByteString)]
filesAndDigests = do
  let
    (HashMap Int [EdamFile]
edamFiles1, Edam
edamInfo) =
      (Identifier, Int)
-> HashMap Int [Int]
-> HashMap Int [EdamFile]
-> [String]
-> (HashMap Int [EdamFile], Edam)
createEDAM (Identifier
topNm, Int
topEntity) HashMap Int [Int]
deps HashMap Int [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 Int [EdamFile], [(String, ByteString)])
-> IO (HashMap Int [EdamFile], [(String, ByteString)])
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (HashMap Int [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, Int)
-> HashMap Int [Int]
-> HashMap Int [EdamFile]
-> [String]
-> (HashMap Int [EdamFile], Edam)
createEDAM (Identifier
topName, Int
topUnique) HashMap Int [Int]
deps HashMap Int [EdamFile]
edamFileMap [String]
files =
  (Int
-> [EdamFile] -> HashMap Int [EdamFile] -> HashMap Int [EdamFile]
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert Int
topUnique (Edam -> [EdamFile]
edamFiles Edam
edam) HashMap Int [EdamFile]
edamFileMap, Edam
edam)
 where
  edam :: Edam
edam = Edam :: Text -> Text -> [EdamFile] -> EdamTools -> 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 (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 (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 =
    (Int -> [EdamFile]) -> [Int] -> [EdamFile]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap
      (\Int
u -> [EdamFile] -> Int -> HashMap Int [EdamFile] -> [EdamFile]
forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
HashMap.lookupDefault [] Int
u HashMap Int [EdamFile]
edamFileMap)
      ([Int] -> Int -> HashMap Int [Int] -> [Int]
forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
HashMap.lookupDefault [] Int
topUnique HashMap Int [Int]
deps)

  asIncFile :: EdamFile -> EdamFile
asIncFile EdamFile
f =
    EdamFile
f { efName :: String
efName = String
".." String -> String -> String
</> Text -> String
Data.Text.unpack (EdamFile -> Text
efLogicalName EdamFile
f) String -> String -> String
</> EdamFile -> String
efName EdamFile
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 :: ClashOpts -> Bool
opt_clear :: 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 (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> IO ()
clearOrError IO () -> IO () -> IO ()
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 (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 (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 (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 (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 ~FILEPATH
copyDataFiles
  :: [FilePath]
  -- ^ Import directories passed in with @-i@
  -> 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, String)] -> IO [ByteString]
copyDataFiles [String]
idirs 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)
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 = do
      let candidates :: [String]
candidates = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> String
</> String
toCopy) [String]
idirs
      [String]
found <- (String -> IO Bool) -> [String] -> IO [String]
forall (m :: Type -> Type) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM String -> IO Bool
doesFileExist [String]
candidates
      case [String]
found of
        [] -> String -> IO ByteString
forall a. HasCallStack => String -> a
error [I.i|
          Could not find data file #{show toCopy}. The following directories were
          searched:

            #{idirs}

          You can add directories Clash will look in using `-i`.
        |]
        (String
_:String
_:[String]
_) -> String -> IO ByteString
forall a. HasCallStack => String -> a
error [I.i|
          Multiple data files for #{show toCopy} found. The following candidates
          were found:

            #{found}

          Please disambiguate data files.
        |]
        [String
c] ->
          String -> String -> IO ByteString
copyAndHash String
c (String
targetDir String -> String -> String
</> String
newName)

  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 (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
  :: CustomReprs
  -> BindingMap
  -- ^ All bindings
  -> CompiledPrimMap
  -- ^ BlackBox HDL templates
  -> TyConMap
  -- ^ TyCon cache
  -> IntMap TyConName
  -- ^ Tuple TyCon cache
  -> (CustomReprs -> TyConMap -> Type ->
      State HWMap (Maybe (Either String FilteredHWType)))
  -- ^ Hardcoded 'Type' -> 'HWType' translator
  -> Evaluator
  -- ^ Hardcoded evaluator for partial evaluation
  -> [Id]
  -- ^ TopEntities
  -> ClashOpts
  -- ^ Debug information level for the normalization process
  -> Supply.Supply
  -- ^ Unique supply
  -> Id
  -- ^ root of the hierarchy
  -> BindingMap
normalizeEntity :: CustomReprs
-> BindingMap
-> CompiledPrimMap
-> TyConMap
-> IntMap TyConName
-> (CustomReprs
    -> TyConMap
    -> Type
    -> State HWMap (Maybe (Either String FilteredHWType)))
-> Evaluator
-> [Id]
-> ClashOpts
-> Supply
-> Id
-> BindingMap
normalizeEntity CustomReprs
reprs BindingMap
bindingsMap CompiledPrimMap
primMap TyConMap
tcm IntMap TyConName
tupTcm CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
typeTrans Evaluator
eval [Id]
topEntities
  ClashOpts
opts Supply
supply Id
tm = 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 (m :: Type -> Type) a. Monad m => a -> m a
return BindingMap
cleaned
    transformedBindings :: BindingMap
transformedBindings = ClashOpts
-> Supply
-> BindingMap
-> (CustomReprs
    -> TyConMap
    -> Type
    -> State HWMap (Maybe (Either String FilteredHWType)))
-> CustomReprs
-> TyConMap
-> IntMap TyConName
-> Evaluator
-> CompiledPrimMap
-> VarEnv Bool
-> [Id]
-> RewriteMonad NormalizeState BindingMap
-> BindingMap
forall a.
ClashOpts
-> Supply
-> BindingMap
-> (CustomReprs
    -> TyConMap
    -> Type
    -> State HWMap (Maybe (Either String FilteredHWType)))
-> CustomReprs
-> TyConMap
-> IntMap TyConName
-> Evaluator
-> CompiledPrimMap
-> VarEnv Bool
-> [Id]
-> NormalizeSession a
-> a
runNormalization ClashOpts
opts Supply
supply BindingMap
bindingsMap
                            CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
typeTrans CustomReprs
reprs TyConMap
tcm IntMap TyConName
tupTcm Evaluator
eval CompiledPrimMap
primMap VarEnv Bool
forall a. VarEnv a
emptyVarEnv
                            [Id]
topEntities RewriteMonad NormalizeState BindingMap
doNorm

-- | topologically sort the top entities
sortTop
  :: BindingMap
  -> [TopEntityT]
  -> ([TopEntityT], HashMap Unique [Unique])
sortTop :: BindingMap -> [TopEntityT] -> ([TopEntityT], HashMap Int [Int])
sortTop BindingMap
bindingsMap [TopEntityT]
topEntities =
  let ([(Int, TopEntityT)]
nodes,[[(Int, Int)]]
edges) = [((Int, TopEntityT), [(Int, Int)])]
-> ([(Int, TopEntityT)], [[(Int, Int)]])
forall a b. [(a, b)] -> ([a], [b])
unzip ((TopEntityT -> ((Int, TopEntityT), [(Int, Int)]))
-> [TopEntityT] -> [((Int, TopEntityT), [(Int, Int)])]
forall a b. (a -> b) -> [a] -> [b]
map TopEntityT -> ((Int, TopEntityT), [(Int, Int)])
go [TopEntityT]
topEntities)
      edges' :: [(Int, Int)]
edges' = [[(Int, Int)]] -> [(Int, Int)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(Int, Int)]]
edges
  in  case [(Int, TopEntityT)] -> [(Int, Int)] -> Either String [TopEntityT]
forall a. [(Int, a)] -> [(Int, Int)] -> Either String [a]
reverseTopSort [(Int, TopEntityT)]
nodes [(Int, Int)]
edges' of
        Left String
msg   -> String -> ([TopEntityT], HashMap Int [Int])
forall a. HasCallStack => String -> a
error String
msg
        Right [TopEntityT]
tops -> ([TopEntityT]
tops, [(Int, Int)] -> HashMap Int [Int]
mapFrom [(Int, Int)]
edges')
 where
  go :: TopEntityT -> ((Int, TopEntityT), [(Int, Int)])
go t :: TopEntityT
t@(TopEntityT Id
topE Maybe TopEntity
_ Bool
_) =
    let topRefs :: [TopEntityT]
topRefs = Id -> Id -> [TopEntityT]
goRefs Id
topE Id
topE
    in  ((Id -> Int
forall a. Var a -> Int
varUniq Id
topE,TopEntityT
t)
         ,(TopEntityT -> (Int, Int)) -> [TopEntityT] -> [(Int, Int)]
forall a b. (a -> b) -> [a] -> [b]
map ((\TopEntityT
top -> (Id -> Int
forall a. Var a -> Int
varUniq Id
topE, Id -> Int
forall a. Var a -> Int
varUniq (TopEntityT -> Id
topId TopEntityT
top)))) [TopEntityT]
topRefs)

  goRefs :: Id -> Id -> [TopEntityT]
goRefs Id
top Id
i_ =
    let cg :: CallGraph
cg = BindingMap -> Id -> CallGraph
callGraph BindingMap
bindingsMap Id
i_
    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 -> Id -> Bool
forall a. Eq a => a -> a -> Bool
/= Id
i_ Bool -> Bool -> Bool
&& TopEntityT -> Id
topId TopEntityT
t Id -> CallGraph -> Bool
forall a b. Var a -> VarEnv b -> Bool
`elemVarEnv` CallGraph
cg)
        [TopEntityT]
topEntities

  mapFrom :: [(Int, Int)] -> HashMap Int [Int]
mapFrom = ([Int] -> [Int] -> [Int]) -> [(Int, [Int])] -> HashMap Int [Int]
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> [(k, v)] -> HashMap k v
HashMap.fromListWith [Int] -> [Int] -> [Int]
forall a. Monoid a => a -> a -> a
mappend ([(Int, [Int])] -> HashMap Int [Int])
-> ([(Int, Int)] -> [(Int, [Int])])
-> [(Int, Int)]
-> HashMap Int [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Int) -> (Int, [Int])) -> [(Int, Int)] -> [(Int, [Int])]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Int -> [Int]) -> (Int, Int) -> (Int, [Int])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> [Int]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure)