{-|
  Copyright   :  (C) 2012-2016, University of Twente,
                     2016-2017, Myrtle Software Ltd,
                     2017     , QBayLogic, Google Inc.
  License     :  BSD2 (see the file LICENSE)
  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>

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

{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskellQuotes #-}

module Clash.Driver where

import qualified Control.Concurrent.Supply        as Supply
import           Control.DeepSeq
import           Control.Exception                (tryJust, bracket, throw)
import           Control.Lens                     (view, _4)
import qualified Control.Monad                    as Monad
import           Control.Monad                    (guard, when, unless, foldM)
import           Control.Monad.Catch              (MonadMask)
import           Control.Monad.IO.Class           (MonadIO)
import           Control.Monad.State              (evalState, get)
import           Control.Monad.State.Strict       (State)
import           Data.Hashable                    (hash)
import           Data.HashMap.Strict              (HashMap)
import qualified Data.HashMap.Strict              as HashMap
import qualified Data.HashSet                     as HashSet
import           Data.IntMap                      (IntMap)
import           Data.List                        (intercalate)
import           Data.Maybe                       (fromMaybe)
import           Data.Semigroup.Monad
import qualified Data.Set                         as Set
import qualified Data.Text
import           Data.Text.Lazy                   (Text)
import qualified Data.Text.Lazy                   as Text
import qualified Data.Text.Lazy.IO                as Text
import           Data.Text.Prettyprint.Doc        (pretty)
import           Data.Text.Prettyprint.Doc.Extra
  (Doc, LayoutOptions (..), PageWidth (..) , layoutPretty, renderLazy,
   renderOneLine)
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.Environment               (getExecutablePath)
import           System.FilePath                  ((</>), (<.>))
import qualified System.FilePath                  as FilePath
import qualified System.IO                        as IO
import           System.IO.Error                  (isDoesNotExistError)
import           System.IO.Temp
  (getCanonicalTemporaryDirectory, withTempDirectory)
import           Text.Trifecta.Result
  (Result(Success, Failure), _errDoc)
import           Text.Read                        (readMaybe)

import           PrelNames               (eqTyConKey, ipClassKey)
import           Unique                  (getKey)

import           SrcLoc                           (SrcSpan)
import           Util                             (OverridingBool(Auto))
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
import           Clash.Core.Evaluator.Types       (PrimStep, PrimUnwind)
import           Clash.Core.Name                  (Name (..))
import           Clash.Core.Pretty                (PrettyOptions(..), showPpr')
import           Clash.Core.Term                  (Term)
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
  (VarEnv, elemVarEnv, eltsVarEnv, emptyVarEnv, lookupVarEnv, lookupVarEnv')
import           Clash.Debug                      (debugIsOn)
import           Clash.Driver.Types
import           Clash.Netlist                    (genNetlist)
import           Clash.Netlist.Util               (genComponentName, genTopComponentName)
import           Clash.Netlist.BlackBox.Parser    (runParse)
import           Clash.Netlist.BlackBox.Types     (BlackBoxTemplate, BlackBoxFunction)
import           Clash.Netlist.Types
  (BlackBox (..), Component (..), Identifier, FilteredHWType, HWMap,
   SomeBackend (..), TopEntityT(..), TemplateFunction, ComponentPrefix(..))
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           Clash.Primitives.Types
import           Clash.Primitives.Util            (hashCompiledPrimMap)
import           Clash.Unique                     (keysUniqMap, lookupUniqMap')
import           Clash.Util.Interpolate           (i)
import           Clash.Util
  (ClashException(..), HasCallStack, first, reportTimeDiff,
   wantedLanguageExtensions, unwantedLanguageExtensions)
import           Clash.Util.Graph                 (reverseTopSort)

-- | 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, [Type])
shouldSplit TyConMap
tcm Type
a of
      Just (Term
_,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) 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, [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 {})) Maybe Id
_) =
  case Id -> BindingMap -> Maybe Binding
forall b a. Var b -> VarEnv a -> Maybe a
lookupVarEnv Id
id_ BindingMap
bindingsMap of
    Just (Binding Id
_id SrcSpan
sp InlineSpec
_ 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
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

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

-- | Create a set of target HDL files for a set of functions
generateHDL
  :: forall backend . Backend backend
  => CustomReprs
  -> 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
  -> (PrimStep, PrimUnwind)
  -- ^ Hardcoded evaluator (delta-reduction)
  -> [TopEntityT]
  -- ^ All topentities and associated testbench
  -> 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
-> BindingMap
-> Maybe backend
-> CompiledPrimMap
-> TyConMap
-> IntMap TyConName
-> (CustomReprs
    -> TyConMap
    -> Type
    -> State HWMap (Maybe (Either String FilteredHWType)))
-> (PrimStep, PrimUnwind)
-> [TopEntityT]
-> Maybe (TopEntityT, [TopEntityT])
-> ClashOpts
-> (UTCTime, UTCTime)
-> IO ()
generateHDL CustomReprs
reprs BindingMap
bindingsMap Maybe backend
hdlState CompiledPrimMap
primMap TyConMap
tcm IntMap TyConName
tupTcm CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
typeTrans (PrimStep, PrimUnwind)
eval
  [TopEntityT]
topEntities0 Maybe (TopEntityT, [TopEntityT])
mainTopEntity ClashOpts
opts (UTCTime
startTime,UTCTime
prepTime) =
    let todo :: [TopEntityT]
todo = [TopEntityT]
-> ((TopEntityT, [TopEntityT]) -> [TopEntityT])
-> Maybe (TopEntityT, [TopEntityT])
-> [TopEntityT]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [TopEntityT]
topEntities2 ((TopEntityT -> [TopEntityT] -> [TopEntityT])
-> (TopEntityT, [TopEntityT]) -> [TopEntityT]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (:)) Maybe (TopEntityT, [TopEntityT])
mainTopEntity in
    UTCTime -> HashMap Text Word -> [TopEntityT] -> IO ()
go UTCTime
prepTime HashMap Text Word
forall k v. HashMap k v
HashMap.empty (BindingMap -> [TopEntityT] -> [TopEntityT]
sortTop BindingMap
bindingsMap [TopEntityT]
todo)
 where
  topEntities1 :: [TopEntityT]
topEntities1 = (TopEntityT -> TopEntityT) -> [TopEntityT] -> [TopEntityT]
forall a b. (a -> b) -> [a] -> [b]
map (HasCallStack => TyConMap -> BindingMap -> TopEntityT -> TopEntityT
TyConMap -> BindingMap -> TopEntityT -> TopEntityT
splitTopEntityT TyConMap
tcm BindingMap
bindingsMap) [TopEntityT]
topEntities0
  -- Remove forall's used in type equality constraints
  topEntities2 :: [TopEntityT]
topEntities2 = (TopEntityT -> TopEntityT) -> [TopEntityT] -> [TopEntityT]
forall a b. (a -> b) -> [a] -> [b]
map (\(TopEntityT Id
var Maybe TopEntity
annM Maybe Id
tbM) -> Id -> Maybe TopEntity -> Maybe Id -> TopEntityT
TopEntityT Id
var{varType :: Type
varType=Type -> Type
tvSubstWithTyEq (Id -> Type
forall a. Var a -> Type
varType Id
var)} Maybe TopEntity
annM Maybe Id
tbM) [TopEntityT]
topEntities1

  go :: UTCTime -> HashMap Text Word -> [TopEntityT] -> IO ()
go UTCTime
prevTime HashMap Text Word
_ [] = 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 HashMap Text Word
seen (TopEntityT Id
topEntity Maybe TopEntity
annM Maybe Id
benchM:[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 modName1 :: String
modName1 = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'.') String
topEntityS
      (String
modName,ComponentPrefix
prefixM) = case ClashOpts -> Maybe String
opt_componentPrefix ClashOpts
opts of
        Just 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. [a] -> [a] -> [a]
++ (Char
'_'Char -> String -> String
forall a. a -> [a] -> [a]
:TopEntity -> String
t_name TopEntity
ann)
              in  (String
nm,Maybe Text -> Maybe Text -> ComponentPrefix
ComponentPrefix (Text -> Maybe Text
forall a. a -> Maybe a
Just (String -> Text
Data.Text.pack String
p)) (Text -> Maybe Text
forall a. a -> Maybe a
Just (String -> Text
Data.Text.pack String
nm)))
            -- Prefix top names with 'p', prefix other with 'p'
            Maybe TopEntity
_ ->  (String
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char
'_'Char -> String -> String
forall a. a -> [a] -> [a]
:String
modName1,Maybe Text -> Maybe Text -> ComponentPrefix
ComponentPrefix (Text -> Maybe Text
forall a. a -> Maybe a
Just (String -> Text
Data.Text.pack String
p)) (Text -> Maybe Text
forall a. a -> Maybe a
Just (String -> Text
Data.Text.pack String
p)))
          | Just TopEntity
ann <- Maybe TopEntity
annM -> case backend -> HDL
forall state. Backend state => state -> HDL
hdlKind (backend
forall a. HasCallStack => a
undefined :: backend) of
              -- Prefix other with 't_name'
              HDL
VHDL -> (TopEntity -> String
t_name TopEntity
ann,Maybe Text -> Maybe Text -> ComponentPrefix
ComponentPrefix Maybe Text
forall a. Maybe a
Nothing (Text -> Maybe Text
forall a. a -> Maybe a
Just (String -> Text
Data.Text.pack (TopEntity -> String
t_name TopEntity
ann))))
              HDL
_    -> (TopEntity -> String
t_name TopEntity
ann,Maybe Text -> Maybe Text -> ComponentPrefix
ComponentPrefix Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing)
        Maybe String
_ -> 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 Text -> Maybe Text -> ComponentPrefix
ComponentPrefix Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing)
            -- Prefix other with 't_name'
            HDL
_    -> (TopEntity -> String
t_name TopEntity
ann, Maybe Text -> Maybe Text -> ComponentPrefix
ComponentPrefix Maybe Text
forall a. Maybe a
Nothing (Text -> Maybe Text
forall a. a -> Maybe a
Just (String -> Text
Data.Text.pack (TopEntity -> String
t_name TopEntity
ann))))
          Maybe TopEntity
_ -> (String
modName1, Maybe Text -> Maybe Text -> ComponentPrefix
ComponentPrefix Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing)
      iw :: Int
iw        = ClashOpts -> Int
opt_intWidth ClashOpts
opts
      hdlsyn :: HdlSyn
hdlsyn    = ClashOpts -> HdlSyn
opt_hdlSyn ClashOpts
opts
      escpIds :: Bool
escpIds   = ClashOpts -> Bool
opt_escapedIds ClashOpts
opts
      forceUnd :: Maybe (Maybe Int)
forceUnd  = ClashOpts -> Maybe (Maybe Int)
opt_forceUndefined ClashOpts
opts
      hdlState' :: backend
hdlState' = Text -> backend -> backend
forall state. Backend state => Text -> state -> state
setModName (String -> Text
Data.Text.pack String
modName)
                (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 -> Maybe (Maybe Int) -> backend
forall state.
Backend state =>
Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> state
initBackend Int
iw HdlSyn
hdlsyn Bool
escpIds Maybe (Maybe Int)
forceUnd :: backend) Maybe backend
hdlState
      hdlDir :: String
hdlDir    = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"." (ClashOpts -> Maybe String
opt_hdlDir ClashOpts
opts) String -> String -> String
</>
                        backend -> String
forall state. Backend state => state -> String
Clash.Backend.name backend
hdlState' String -> String -> String
</>
                        (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'.') String
topEntityS
      mkId :: IdType -> Text -> Text
mkId      = State backend (IdType -> Text -> Text)
-> backend -> IdType -> Text -> Text
forall s a. State s a -> s -> a
evalState State backend (IdType -> Text -> Text)
forall state. Backend state => State state (IdType -> Text -> Text)
mkIdentifier backend
hdlState'
      extId :: IdType -> Text -> Text -> Text
extId     = State backend (IdType -> Text -> Text -> Text)
-> backend -> IdType -> Text -> Text -> Text
forall s a. State s a -> s -> a
evalState State backend (IdType -> Text -> Text -> Text)
forall state.
Backend state =>
State state (IdType -> Text -> Text -> Text)
extendIdentifier backend
hdlState'
      ite :: Bool
ite       = backend -> Bool
forall state. Backend state => state -> Bool
ifThenElseExpr backend
hdlState'
      topNm :: Text
topNm     = Bool
-> (IdType -> Text -> Text)
-> ComponentPrefix
-> Maybe TopEntity
-> Id
-> Text
genTopComponentName (ClashOpts -> Bool
opt_newInlineStrat ClashOpts
opts) IdType -> Text -> Text
mkId ComponentPrefix
prefixM
                                      Maybe TopEntity
annM Id
topEntity
      topNmU :: String
topNmU    = Text -> String
Data.Text.unpack Text
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 .manifest files"

  -- Calculate the hash over the callgraph and the topEntity annotation
  (Bool
useCacheTop,Bool
useCacheBench,Manifest
manifest) <- do
    UTCTime
clashModDate <- IO UTCTime
getClashModificationDate

    let primMapHash :: Int
primMapHash = CompiledPrimMap -> Int
hashCompiledPrimMap CompiledPrimMap
primMap

    let optsHash :: Int
optsHash = ClashOpts -> Int
forall a. Hashable a => a -> Int
hash ClashOpts
opts { -- Ignore the following settings, they don't
                               -- affect the generated HDL:
                               -- 1. Debug
                               opt_dbgLevel :: DebugLevel
opt_dbgLevel           = DebugLevel
DebugNone
                             , opt_dbgTransformations :: Set String
opt_dbgTransformations = Set String
forall a. Set a
Set.empty
                               -- 2. Caching
                             , opt_cachehdl :: Bool
opt_cachehdl           = Bool
True
                               -- 3. Warnings
                             , opt_primWarn :: Bool
opt_primWarn           = Bool
True
                             , opt_color :: OverridingBool
opt_color              = OverridingBool
Auto
                             , opt_errorExtra :: Bool
opt_errorExtra         = Bool
False
                             , opt_checkIDir :: Bool
opt_checkIDir          = Bool
True
                               -- Ignore the following settings, they don't
                               -- affect the generated HDL. However, they do
                               -- influence whether HDL can be generated at all.
                               --
                               -- So later on we check whether the new flags
                               -- changed in such a way that they could affect
                               -- successful compilation, and use that information
                               -- to decide whether to use caching or not.
                               --
                               -- 1. termination measures
                             , opt_inlineLimit :: Int
opt_inlineLimit       = Int
20
                             , opt_specLimit :: Int
opt_specLimit         = Int
20
                               -- 2. Float support
                             , opt_floatSupport :: Bool
opt_floatSupport      = Bool
False
                               -- Finally, also ignore the HDL dir setting,
                               -- because when a user moves the entire dir
                               -- with generated HDL, they probably still want
                               -- to use that as a cache
                             , opt_hdlDir :: Maybe String
opt_hdlDir            = Maybe String
forall a. Maybe a
Nothing
                             }

    let
      topHash :: Int
topHash =
        (Maybe TopEntity, Int, String, [Term], Int) -> Int
forall a. Hashable a => a -> Int
hash ( Maybe TopEntity
annM
             , Int
primMapHash
             , UTCTime -> String
forall a. Show a => a -> String
show UTCTime
clashModDate
             , BindingMap -> Id -> [Term]
callGraphBindings BindingMap
bindingsMap Id
topEntity
             , Int
optsHash
             )

    let
      benchHashM :: Maybe Int
benchHashM =
        case Maybe Id
benchM of
          Maybe Id
Nothing -> Maybe Int
forall a. Maybe a
Nothing
          Just Id
bench ->
            let terms :: [Term]
terms = BindingMap -> Id -> [Term]
callGraphBindings BindingMap
bindingsMap Id
bench in
            Int -> Maybe Int
forall a. a -> Maybe a
Just ((Maybe TopEntity, Int, String, [Term], Int) -> Int
forall a. Hashable a => a -> Int
hash (Maybe TopEntity
annM, Int
primMapHash, UTCTime -> String
forall a. Show a => a -> String
show UTCTime
clashModDate, [Term]
terms, Int
optsHash))

    let successFlagsI :: (Int, Int, Bool)
successFlagsI = (ClashOpts -> Int
opt_inlineLimit ClashOpts
opts,ClashOpts -> Int
opt_specLimit ClashOpts
opts,ClashOpts -> Bool
opt_floatSupport ClashOpts
opts)
        manifestI :: Manifest
manifestI    = (Int, Maybe Int)
-> (Int, Int, Bool)
-> [Text]
-> [Text]
-> [Text]
-> [Text]
-> [Text]
-> Manifest
Manifest (Int
topHash,Maybe Int
benchHashM) (Int, Int, Bool)
successFlagsI [] [] [] [] []

    let
      manFile :: String
manFile =
        case Maybe TopEntity
annM of
          Maybe TopEntity
Nothing -> String
hdlDir String -> String -> String
</> String
topNmU String -> String -> String
<.> String
"manifest"
          Maybe TopEntity
_       -> String
hdlDir String -> String -> String
</> String
topNmU String -> String -> String
</> String
topNmU String -> String -> String
<.> String
"manifest"

    Maybe Manifest
manM <- if Bool -> Bool
not (ClashOpts -> Bool
opt_cachehdl ClashOpts
opts)
            then Maybe Manifest -> IO (Maybe Manifest)
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe Manifest
forall a. Maybe a
Nothing -- ignore manifest file because -fclash-nocache
            else (Maybe String -> (String -> Maybe Manifest) -> Maybe Manifest
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Maybe Manifest
forall a. Read a => String -> Maybe a
readMaybe) (Maybe String -> Maybe Manifest)
-> (Either () String -> Maybe String)
-> Either () String
-> Maybe Manifest
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (() -> Maybe String)
-> (String -> Maybe String) -> Either () String -> Maybe String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe String -> () -> Maybe String
forall a b. a -> b -> a
const Maybe String
forall a. Maybe a
Nothing) String -> Maybe String
forall a. a -> Maybe a
Just (Either () String -> Maybe Manifest)
-> IO (Either () String) -> IO (Maybe Manifest)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$>
              (IOError -> Maybe ()) -> IO String -> IO (Either () String)
forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> IO (Either b a)
tryJust (Bool -> Maybe ()
forall (f :: Type -> Type). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> (IOError -> Bool) -> IOError -> Maybe ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> Bool
isDoesNotExistError) (String -> IO String
readFile String
manFile)
    (Bool, Bool, Manifest) -> IO (Bool, Bool, Manifest)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((Bool, Bool, Manifest)
-> (Manifest -> (Bool, Bool, Manifest))
-> Maybe Manifest
-> (Bool, Bool, Manifest)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Bool
False,Bool
False,Manifest
manifestI)
                  (\Manifest
man ->
                    let allowCache :: (a, a, Bool) -> (a, a, Bool) -> Bool
allowCache (a
inl0,a
spec0,Bool
fl0) (a
inl1,a
spec1,Bool
fl1) =
                          a
inl0 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
inl1 Bool -> Bool -> Bool
&& a
spec0 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
spec1 Bool -> Bool -> Bool
&& (Bool -> Bool
not (Bool
fl0 Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
fl1))
                        flagsAllowCache :: Bool
flagsAllowCache = (Int, Int, Bool) -> (Int, Int, Bool) -> Bool
forall a a. (Ord a, Ord a) => (a, a, Bool) -> (a, a, Bool) -> Bool
allowCache (Manifest -> (Int, Int, Bool)
successFlags Manifest
man) (Int, Int, Bool)
successFlagsI
                    in  (Bool
flagsAllowCache Bool -> Bool -> Bool
&& (Int, Maybe Int) -> Int
forall a b. (a, b) -> a
fst (Manifest -> (Int, Maybe Int)
manifestHash Manifest
man) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
topHash
                        ,Bool
flagsAllowCache Bool -> Bool -> Bool
&& (Int, Maybe Int) -> Maybe Int
forall a b. (a, b) -> b
snd (Manifest -> (Int, Maybe Int)
manifestHash Manifest
man) Maybe Int -> Maybe Int -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Int
benchHashM
                        ,Manifest
man { manifestHash :: (Int, Maybe Int)
manifestHash = (Int
topHash,Maybe Int
benchHashM)
                             , successFlags :: (Int, Int, Bool)
successFlags  = if Bool
flagsAllowCache
                                                 then Manifest -> (Int, Int, Bool)
successFlags Manifest
man
                                                 else (Int, Int, Bool)
successFlagsI
                             }
                        ))
                  Maybe Manifest
manM)

  (Supply
supplyN,Supply
supplyTB) <- Supply -> (Supply, Supply)
Supply.splitSupply
                    (Supply -> (Supply, Supply))
-> (Supply -> Supply) -> Supply -> (Supply, Supply)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Supply) -> Supply
forall a b. (a, b) -> b
snd
                    ((Int, Supply) -> Supply)
-> (Supply -> (Int, Supply)) -> Supply -> Supply
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Supply -> (Int, Supply)
Supply.freshId
                   (Supply -> (Supply, Supply)) -> IO Supply -> IO (Supply, Supply)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Supply
Supply.newSupply
  let topEntityNames :: [Id]
topEntityNames = (TopEntityT -> Id) -> [TopEntityT] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map TopEntityT -> Id
topId [TopEntityT]
topEntities2

  (UTCTime
topTime,Manifest
manifest',HashMap Text Word
seen') <- if Bool
useCacheTop
    then do
      String -> IO ()
putStrLn (String
"Clash: Using cached result for: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ 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)))
      UTCTime
topTime <- IO UTCTime
Clock.getCurrentTime
      (UTCTime, Manifest, HashMap Text Word)
-> IO (UTCTime, Manifest, HashMap Text Word)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (UTCTime
topTime,Manifest
manifest,(Word -> Word -> Word)
-> HashMap Text Word -> HashMap Text Word -> HashMap Text Word
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v
HashMap.unionWith Word -> Word -> Word
forall a. Ord a => a -> a -> a
max ([(Text, Word)] -> HashMap Text Word
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList ((Text -> (Text, Word)) -> [Text] -> [(Text, Word)]
forall a b. (a -> b) -> [a] -> [b]
map (,Word
0) (Manifest -> [Text]
componentNames Manifest
manifest))) HashMap Text Word
seen)
    else do
      -- 1. Normalise topEntity
      let transformedBindings :: BindingMap
transformedBindings = CustomReprs
-> BindingMap
-> CompiledPrimMap
-> TyConMap
-> IntMap TyConName
-> (CustomReprs
    -> TyConMap
    -> Type
    -> State HWMap (Maybe (Either String FilteredHWType)))
-> (PrimStep, PrimUnwind)
-> [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 (PrimStep, PrimUnwind)
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: Normalisation took " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
prepNormDiff

      -- 2. Generate netlist for topEntity

      -- [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
      let dir :: String
dir = String
hdlDir String -> String -> String
</> String -> (TopEntity -> String) -> Maybe TopEntity -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (String -> TopEntity -> String
forall a b. a -> b -> a
const String
modName) Maybe TopEntity
annM
      Bool -> String -> String -> IO ()
prepareDir (ClashOpts -> Bool
opt_cleanhdl ClashOpts
opts) (backend -> String
forall state. Backend state => state -> String
extension backend
hdlState') String
dir
      -- Now start the netlist generation
      (VarEnv ([Bool], SrcSpan, HashMap Text Word, Component)
netlist,HashMap Text Word
seen') <-
        Bool
-> ClashOpts
-> CustomReprs
-> BindingMap
-> [TopEntityT]
-> CompiledPrimMap
-> TyConMap
-> (CustomReprs
    -> TyConMap
    -> Type
    -> State HWMap (Maybe (Either String FilteredHWType)))
-> Int
-> (IdType -> Text -> Text)
-> (IdType -> Text -> Text -> Text)
-> Bool
-> SomeBackend
-> HashMap Text Word
-> String
-> ComponentPrefix
-> Id
-> IO
     (VarEnv ([Bool], SrcSpan, HashMap Text Word, Component),
      HashMap Text Word)
genNetlist Bool
False ClashOpts
opts CustomReprs
reprs BindingMap
transformedBindings [TopEntityT]
topEntities2 CompiledPrimMap
primMap
                   TyConMap
tcm CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
typeTrans Int
iw IdType -> Text -> Text
mkId IdType -> Text -> Text -> Text
extId Bool
ite (backend -> SomeBackend
forall backend. Backend backend => backend -> SomeBackend
SomeBackend backend
hdlState') HashMap Text Word
seen String
hdlDir ComponentPrefix
prefixM Id
topEntity

      UTCTime
netlistTime <- VarEnv ([Bool], SrcSpan, HashMap Text Word, Component)
netlist VarEnv ([Bool], SrcSpan, HashMap Text Word, Component)
-> 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

      -- 3. Generate topEntity wrapper
      let topComponent :: Component
topComponent = Getting
  Component ([Bool], SrcSpan, HashMap Text Word, Component) Component
-> ([Bool], SrcSpan, HashMap Text Word, Component) -> Component
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
view Getting
  Component ([Bool], SrcSpan, HashMap Text Word, Component) Component
forall s t a b. Field4 s t a b => Lens s t a b
_4 (VarEnv ([Bool], SrcSpan, HashMap Text Word, Component)
-> Id -> ([Bool], SrcSpan, HashMap Text Word, Component)
forall a b. VarEnv a -> Var b -> a
lookupVarEnv' VarEnv ([Bool], SrcSpan, HashMap Text Word, Component)
netlist Id
topEntity)
          ([(String, Doc)]
hdlDocs,Manifest
manifest',[(String, String)]
dfiles,[(String, String)]
mfiles) = backend
-> Text
-> HashMap Text Word
-> VarEnv ([Bool], SrcSpan, HashMap Text Word, Component)
-> Component
-> (Text, Either Manifest Manifest)
-> ([(String, Doc)], Manifest, [(String, String)],
    [(String, String)])
forall backend.
Backend backend =>
backend
-> Text
-> HashMap Text Word
-> VarEnv ([Bool], SrcSpan, HashMap Text Word, Component)
-> Component
-> (Text, Either Manifest Manifest)
-> ([(String, Doc)], Manifest, [(String, String)],
    [(String, String)])
createHDL backend
hdlState' (String -> Text
Data.Text.pack String
modName) HashMap Text Word
seen' VarEnv ([Bool], SrcSpan, HashMap Text Word, Component)
netlist Component
topComponent
                                   (Text
topNm, Manifest -> Either Manifest Manifest
forall a b. b -> Either a b
Right Manifest
manifest)
      ((String, Doc) -> IO ()) -> [(String, Doc)] -> IO ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> (String, Doc) -> IO ()
writeHDL String
dir) [(String, Doc)]
hdlDocs
      [String] -> String -> [(String, String)] -> IO ()
copyDataFiles (ClashOpts -> [String]
opt_importPaths ClashOpts
opts) String
dir [(String, String)]
dfiles
      String -> [(String, String)] -> IO ()
writeMemoryDataFiles String
dir [(String, String)]
mfiles

      UTCTime
topTime <- [(String, Doc)]
hdlDocs [(String, Doc)] -> IO UTCTime -> IO UTCTime
`seq` IO UTCTime
Clock.getCurrentTime
      (UTCTime, Manifest, HashMap Text Word)
-> IO (UTCTime, Manifest, HashMap Text Word)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (UTCTime
topTime,Manifest
manifest',HashMap Text Word
seen')

  UTCTime
benchTime <- case Maybe Id
benchM of
    Just Id
tb | Bool -> Bool
not Bool
useCacheBench -> do
      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]
++ 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
tb))

      let modName' :: Text
modName'  = Bool
-> HashMap Text Word
-> (IdType -> Text -> Text)
-> ComponentPrefix
-> Id
-> Text
genComponentName (ClashOpts -> Bool
opt_newInlineStrat ClashOpts
opts) HashMap Text Word
forall k v. HashMap k v
HashMap.empty
                                       IdType -> Text -> Text
mkId ComponentPrefix
prefixM Id
tb
          hdlState2 :: backend
hdlState2 = Text -> backend -> backend
forall state. Backend state => Text -> state -> state
setModName Text
modName' backend
hdlState'

      -- 1. Normalise testBench
      let transformedBindings :: BindingMap
transformedBindings = CustomReprs
-> BindingMap
-> CompiledPrimMap
-> TyConMap
-> IntMap TyConName
-> (CustomReprs
    -> TyConMap
    -> Type
    -> State HWMap (Maybe (Either String FilteredHWType)))
-> (PrimStep, PrimUnwind)
-> [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 (PrimStep, PrimUnwind)
eval [Id]
topEntityNames ClashOpts
opts Supply
supplyTB Id
tb
      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
topTime
      String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Clash: Testbench normalization took " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
prepNormDiff

      -- 2. Generate netlist for topEntity

      -- See [Note] Create HDL dir before netlist generation
      let dir :: String
dir = String
hdlDir String -> String -> String
</> String -> (TopEntity -> String) -> Maybe TopEntity -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" TopEntity -> String
t_name Maybe TopEntity
annM String -> String -> String
</> Text -> String
Data.Text.unpack Text
modName'
      Bool -> String -> String -> IO ()
prepareDir (ClashOpts -> Bool
opt_cleanhdl ClashOpts
opts) (backend -> String
forall state. Backend state => state -> String
extension backend
hdlState2) String
dir
      -- Now start the netlist generation
      (VarEnv ([Bool], SrcSpan, HashMap Text Word, Component)
netlist,HashMap Text Word
seen'') <-
        Bool
-> ClashOpts
-> CustomReprs
-> BindingMap
-> [TopEntityT]
-> CompiledPrimMap
-> TyConMap
-> (CustomReprs
    -> TyConMap
    -> Type
    -> State HWMap (Maybe (Either String FilteredHWType)))
-> Int
-> (IdType -> Text -> Text)
-> (IdType -> Text -> Text -> Text)
-> Bool
-> SomeBackend
-> HashMap Text Word
-> String
-> ComponentPrefix
-> Id
-> IO
     (VarEnv ([Bool], SrcSpan, HashMap Text Word, Component),
      HashMap Text Word)
genNetlist Bool
True ClashOpts
opts CustomReprs
reprs BindingMap
transformedBindings [TopEntityT]
topEntities2 CompiledPrimMap
primMap
                   TyConMap
tcm CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
typeTrans Int
iw IdType -> Text -> Text
mkId IdType -> Text -> Text -> Text
extId Bool
ite (backend -> SomeBackend
forall backend. Backend backend => backend -> SomeBackend
SomeBackend backend
hdlState') HashMap Text Word
seen' String
hdlDir ComponentPrefix
prefixM Id
tb

      UTCTime
netlistTime <- VarEnv ([Bool], SrcSpan, HashMap Text Word, Component)
netlist VarEnv ([Bool], SrcSpan, HashMap Text Word, Component)
-> 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: Testbench netlist generation took " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
normNetDiff

      -- 3. Write HDL
      let ([(String, Doc)]
hdlDocs,Manifest
_,[(String, String)]
dfiles,[(String, String)]
mfiles) = backend
-> Text
-> HashMap Text Word
-> VarEnv ([Bool], SrcSpan, HashMap Text Word, Component)
-> Component
-> (Text, Either Manifest Manifest)
-> ([(String, Doc)], Manifest, [(String, String)],
    [(String, String)])
forall backend.
Backend backend =>
backend
-> Text
-> HashMap Text Word
-> VarEnv ([Bool], SrcSpan, HashMap Text Word, Component)
-> Component
-> (Text, Either Manifest Manifest)
-> ([(String, Doc)], Manifest, [(String, String)],
    [(String, String)])
createHDL backend
hdlState2 Text
modName' HashMap Text Word
seen'' VarEnv ([Bool], SrcSpan, HashMap Text Word, Component)
netlist Component
forall a. HasCallStack => a
undefined
                           (Text
topNm, Manifest -> Either Manifest Manifest
forall a b. a -> Either a b
Left Manifest
manifest')
      String -> (String, Doc) -> IO ()
writeHDL (String
hdlDir String -> String -> String
</> String -> (TopEntity -> String) -> Maybe TopEntity -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" TopEntity -> String
t_name Maybe TopEntity
annM) ([(String, Doc)] -> (String, Doc)
forall a. [a] -> a
head [(String, Doc)]
hdlDocs)
      ((String, Doc) -> IO ()) -> [(String, Doc)] -> IO ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> (String, Doc) -> IO ()
writeHDL String
dir) ([(String, Doc)] -> [(String, Doc)]
forall a. [a] -> [a]
tail [(String, Doc)]
hdlDocs)
      [String] -> String -> [(String, String)] -> IO ()
copyDataFiles (ClashOpts -> [String]
opt_importPaths ClashOpts
opts) String
dir [(String, String)]
dfiles
      String -> [(String, String)] -> IO ()
writeMemoryDataFiles String
dir [(String, String)]
mfiles

      [(String, Doc)]
hdlDocs [(String, Doc)] -> IO UTCTime -> IO UTCTime
`seq` IO UTCTime
Clock.getCurrentTime

    Just Id
tb -> do
      let tb' :: String
tb' = 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
tb))
      String -> IO ()
putStrLn (String
"Clash: Compiling: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tb')
      String -> IO ()
putStrLn (String
"Clash: Using cached result for: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tb')
      UTCTime -> IO UTCTime
forall (m :: Type -> Type) a. Monad m => a -> m a
return UTCTime
topTime

    Maybe Id
Nothing -> UTCTime -> IO UTCTime
forall (m :: Type -> Type) a. Monad m => a -> m a
return UTCTime
topTime

  UTCTime -> HashMap Text Word -> [TopEntityT] -> IO ()
go UTCTime
benchTime HashMap Text Word
seen' [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.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.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 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
-> BlackBoxFunctionName
-> (Int, BlackBoxFunction)
-> CompiledPrimitive
forall a b c d.
Text
-> WorkInfo
-> UsedArguments
-> BlackBoxFunctionName
-> d
-> Primitive a b c d
BlackBoxHaskell Text
bbName WorkInfo
wf UsedArguments
usedArgs 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 TemplateKind
tkind () Bool
oReg [Text]
libM [Text]
imps [(Int, Int)]
fPlural [((Text, Text),
  ((TemplateFormat, BlackBoxFunctionName), Maybe Text))]
incs Maybe ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
rM Maybe ((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
  Maybe BlackBox
rM'    <- (((TemplateFormat, BlackBoxFunctionName), Maybe Text)
 -> IO BlackBox)
-> Maybe ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
-> IO (Maybe 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 Maybe ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
rM
  Maybe BlackBox
riM'   <- (((TemplateFormat, BlackBoxFunctionName), Maybe Text)
 -> IO BlackBox)
-> Maybe ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
-> IO (Maybe 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 Maybe ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
riM
  CompiledPrimitive -> IO CompiledPrimitive
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Text
-> WorkInfo
-> RenderVoid
-> TemplateKind
-> ()
-> Bool
-> [BlackBoxTemplate]
-> [BlackBoxTemplate]
-> [(Int, Int)]
-> [((Text, Text), BlackBox)]
-> Maybe BlackBox
-> Maybe BlackBox
-> BlackBox
-> CompiledPrimitive
forall a b c d.
Text
-> WorkInfo
-> RenderVoid
-> TemplateKind
-> c
-> Bool
-> [a]
-> [a]
-> [(Int, Int)]
-> [((Text, Text), b)]
-> Maybe b
-> Maybe b
-> b
-> Primitive a b c d
BlackBox Text
pNm WorkInfo
wf RenderVoid
rVoid TemplateKind
tkind () Bool
oReg [BlackBoxTemplate]
libM' [BlackBoxTemplate]
imps' [(Int, Int)]
fPlural [((Text, Text), BlackBox)]
incs' Maybe BlackBox
rM' Maybe 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
  -> Identifier
  -- ^ Module hierarchy root
  -> HashMap Identifier Word
  -- ^ Component names
  -> VarEnv ([Bool],SrcSpan,HashMap Identifier Word,Component)
  -- ^ List of components
  -> Component
  -- ^ Top component
  -> (Identifier, Either Manifest Manifest)
  -- ^ Name of the manifest file
  -- + Either:
  --   * Left manifest:  Only write/update the hashes of the @manifest@
  --   * Right manifest: Update all fields of the @manifest@
  -> ([(String,Doc)],Manifest,[(String,FilePath)],[(String,String)])
  -- ^ The pretty-printed HDL documents
  -- + The update manifest file
  -- + The data files that need to be copied
createHDL :: backend
-> Text
-> HashMap Text Word
-> VarEnv ([Bool], SrcSpan, HashMap Text Word, Component)
-> Component
-> (Text, Either Manifest Manifest)
-> ([(String, Doc)], Manifest, [(String, String)],
    [(String, String)])
createHDL backend
backend Text
modName HashMap Text Word
seen VarEnv ([Bool], SrcSpan, HashMap Text Word, Component)
components Component
top (Text
topName,Either Manifest Manifest
manifestE) = (State
   backend
   ([(String, Doc)], Manifest, [(String, String)], [(String, String)])
 -> backend
 -> ([(String, Doc)], Manifest, [(String, String)],
     [(String, String)]))
-> backend
-> State
     backend
     ([(String, Doc)], Manifest, [(String, String)], [(String, String)])
-> ([(String, Doc)], Manifest, [(String, String)],
    [(String, String)])
forall a b c. (a -> b -> c) -> b -> a -> c
flip State
  backend
  ([(String, Doc)], Manifest, [(String, String)], [(String, String)])
-> backend
-> ([(String, Doc)], Manifest, [(String, String)],
    [(String, String)])
forall s a. State s a -> s -> a
evalState backend
backend (State
   backend
   ([(String, Doc)], Manifest, [(String, String)], [(String, String)])
 -> ([(String, Doc)], Manifest, [(String, String)],
     [(String, String)]))
-> State
     backend
     ([(String, Doc)], Manifest, [(String, String)], [(String, String)])
-> ([(String, Doc)], Manifest, [(String, String)],
    [(String, String)])
forall a b. (a -> b) -> a -> b
$ Mon
  (State backend)
  ([(String, Doc)], Manifest, [(String, String)], [(String, String)])
-> State
     backend
     ([(String, Doc)], Manifest, [(String, String)], [(String, String)])
forall (f :: Type -> Type) m. Mon f m -> f m
getMon (Mon
   (State backend)
   ([(String, Doc)], Manifest, [(String, String)], [(String, String)])
 -> State
      backend
      ([(String, Doc)], Manifest, [(String, String)],
       [(String, String)]))
-> Mon
     (State backend)
     ([(String, Doc)], Manifest, [(String, String)], [(String, String)])
-> State
     backend
     ([(String, Doc)], Manifest, [(String, String)], [(String, String)])
forall a b. (a -> b) -> a -> b
$ do
  let componentsL :: [([Bool], SrcSpan, HashMap Text Word, Component)]
componentsL = VarEnv ([Bool], SrcSpan, HashMap Text Word, Component)
-> [([Bool], SrcSpan, HashMap Text Word, Component)]
forall a. VarEnv a -> [a]
eltsVarEnv VarEnv ([Bool], SrcSpan, HashMap Text Word, Component)
components
  ([(String, Doc)]
hdlNmDocs,[[(String, Doc)]]
incs) <-
    [((String, Doc), [(String, Doc)])]
-> ([(String, Doc)], [[(String, Doc)]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([((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
<$> (([Bool], SrcSpan, HashMap Text Word, Component)
 -> Mon (State backend) ((String, Doc), [(String, Doc)]))
-> [([Bool], SrcSpan, HashMap Text Word, Component)]
-> Mon (State backend) [((String, Doc), [(String, Doc)])]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\([Bool]
_wereVoids,SrcSpan
sp,HashMap Text Word
ids,Component
comp) ->
                      Text
-> SrcSpan
-> HashMap Text Word
-> Component
-> Mon (State backend) ((String, Doc), [(String, Doc)])
forall state.
Backend state =>
Text
-> SrcSpan
-> HashMap Text Word
-> Component
-> Mon (State state) ((String, Doc), [(String, Doc)])
genHDL Text
modName SrcSpan
sp ((Word -> Word -> Word)
-> HashMap Text Word -> HashMap Text Word -> HashMap Text Word
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v
HashMap.unionWith Word -> Word -> Word
forall a. Ord a => a -> a -> a
max HashMap Text Word
seen HashMap Text Word
ids) Component
comp)
              [([Bool], SrcSpan, HashMap Text Word, Component)]
componentsL
  [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
  Manifest
manifest <- (Manifest -> Mon (State backend) Manifest)
-> (Manifest -> Mon (State backend) Manifest)
-> Either Manifest Manifest
-> Mon (State backend) Manifest
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Manifest -> Mon (State backend) Manifest
forall (m :: Type -> Type) a. Monad m => a -> m a
return (\Manifest
m -> do
      let topInNames :: [Text]
topInNames = ((Text, HWType) -> Text) -> [(Text, HWType)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text, HWType) -> Text
forall a b. (a, b) -> a
fst (Component -> [(Text, HWType)]
inputs Component
top)
      [Text]
topInTypes  <- ((Text, HWType) -> Mon (State backend) Text)
-> [(Text, HWType)] -> Mon (State backend) [Text]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Doc -> Text)
-> Mon (State backend) Doc -> Mon (State backend) Text
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Text
Text.toStrict (Text -> Text) -> (Doc -> Text) -> Doc -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Text
forall ann. Doc ann -> Text
renderOneLine) (Mon (State backend) Doc -> Mon (State backend) Text)
-> ((Text, HWType) -> Mon (State backend) Doc)
-> (Text, HWType)
-> Mon (State backend) Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                           Usage -> HWType -> Mon (State backend) Doc
forall state.
Backend state =>
Usage -> HWType -> Mon (State state) Doc
hdlType (Text -> Usage
External Text
topName) (HWType -> Mon (State backend) Doc)
-> ((Text, HWType) -> HWType)
-> (Text, HWType)
-> Mon (State backend) Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, HWType) -> HWType
forall a b. (a, b) -> b
snd) (Component -> [(Text, HWType)]
inputs Component
top)
      let topOutNames :: [Text]
topOutNames = ((WireOrReg, (Text, HWType), Maybe Expr) -> Text)
-> [(WireOrReg, (Text, HWType), Maybe Expr)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ((Text, HWType) -> Text
forall a b. (a, b) -> a
fst ((Text, HWType) -> Text)
-> ((WireOrReg, (Text, HWType), Maybe Expr) -> (Text, HWType))
-> (WireOrReg, (Text, HWType), Maybe Expr)
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\(WireOrReg
_,(Text, HWType)
x,Maybe Expr
_) -> (Text, HWType)
x)) (Component -> [(WireOrReg, (Text, HWType), Maybe Expr)]
outputs Component
top)
      [Text]
topOutTypes <- ((WireOrReg, (Text, HWType), Maybe Expr)
 -> Mon (State backend) Text)
-> [(WireOrReg, (Text, HWType), Maybe Expr)]
-> Mon (State backend) [Text]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Doc -> Text)
-> Mon (State backend) Doc -> Mon (State backend) Text
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Text
Text.toStrict (Text -> Text) -> (Doc -> Text) -> Doc -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Text
forall ann. Doc ann -> Text
renderOneLine) (Mon (State backend) Doc -> Mon (State backend) Text)
-> ((WireOrReg, (Text, HWType), Maybe Expr)
    -> Mon (State backend) Doc)
-> (WireOrReg, (Text, HWType), Maybe Expr)
-> Mon (State backend) Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                           Usage -> HWType -> Mon (State backend) Doc
forall state.
Backend state =>
Usage -> HWType -> Mon (State state) Doc
hdlType (Text -> Usage
External Text
topName) (HWType -> Mon (State backend) Doc)
-> ((WireOrReg, (Text, HWType), Maybe Expr) -> HWType)
-> (WireOrReg, (Text, HWType), Maybe Expr)
-> Mon (State backend) Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, HWType) -> HWType
forall a b. (a, b) -> b
snd ((Text, HWType) -> HWType)
-> ((WireOrReg, (Text, HWType), Maybe Expr) -> (Text, HWType))
-> (WireOrReg, (Text, HWType), Maybe Expr)
-> HWType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\(WireOrReg
_,(Text, HWType)
x,Maybe Expr
_) -> (Text, HWType)
x)) (Component -> [(WireOrReg, (Text, HWType), Maybe Expr)]
outputs Component
top)
      let compNames :: [Text]
compNames = (([Bool], SrcSpan, HashMap Text Word, Component) -> Text)
-> [([Bool], SrcSpan, HashMap Text Word, Component)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Component -> Text
componentName (Component -> Text)
-> (([Bool], SrcSpan, HashMap Text Word, Component) -> Component)
-> ([Bool], SrcSpan, HashMap Text Word, Component)
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting
  Component ([Bool], SrcSpan, HashMap Text Word, Component) Component
-> ([Bool], SrcSpan, HashMap Text Word, Component) -> Component
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
view Getting
  Component ([Bool], SrcSpan, HashMap Text Word, Component) Component
forall s t a b. Field4 s t a b => Lens s t a b
_4) [([Bool], SrcSpan, HashMap Text Word, Component)]
componentsL
      Manifest -> Mon (State backend) Manifest
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Manifest
m { portInNames :: [Text]
portInNames    = [Text]
topInNames
                , portInTypes :: [Text]
portInTypes    = [Text]
topInTypes
                , portOutNames :: [Text]
portOutNames   = [Text]
topOutNames
                , portOutTypes :: [Text]
portOutTypes   = [Text]
topOutTypes
                , componentNames :: [Text]
componentNames = [Text]
compNames
                })
    ) Either Manifest Manifest
manifestE
  let manDoc :: (String, Doc ann)
manDoc = ( Text -> String
Data.Text.unpack Text
topName String -> String -> String
<.> String
"manifest"
               , Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Text
Text.pack (Manifest -> String
forall a. Show a => a -> String
show Manifest
manifest)))
  ([(String, Doc)], Manifest, [(String, String)], [(String, String)])
-> Mon
     (State backend)
     ([(String, Doc)], Manifest, [(String, String)], [(String, String)])
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((String, Doc)
forall ann. (String, Doc ann)
manDoc(String, Doc) -> [(String, Doc)] -> [(String, Doc)]
forall a. a -> [a] -> [a]
:[(String, Doc)]
topFiles,Manifest
manifest,[(String, String)]
dataFiles,[(String, String)]
memFiles)

-- | Prepares the directory for writing HDL files. This means creating the
--   dir if it does not exist and removing all existing .hdl files from it.
prepareDir :: Bool -- ^ Remove existing HDL files
           -> String -- ^ File extension of the HDL files.
           -> String
           -> IO ()
prepareDir :: Bool -> String -> String -> IO ()
prepareDir Bool
cleanhdl String
ext String
dir = do
  -- Create the dir if needed
  Bool -> String -> IO ()
Directory.createDirectoryIfMissing Bool
True String
dir
  -- Clean the directory when needed
  Bool -> IO () -> IO ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when Bool
cleanhdl (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    -- Find all HDL files in the directory
    [String]
files <- String -> IO [String]
Directory.getDirectoryContents String
dir
    let to_remove :: [String]
to_remove = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==String
ext) (String -> Bool) -> (String -> String) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
FilePath.takeExtension) [String]
files
    -- Prepend the dirname to the filenames
    let abs_to_remove :: [String]
abs_to_remove = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> String
FilePath.combine String
dir) [String]
to_remove
    -- Remove the files
    (String -> IO ()) -> [String] -> IO ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
Directory.removeFile [String]
abs_to_remove

-- | Writes a HDL file to the given directory
writeHDL :: FilePath -> (String, Doc) -> IO ()
writeHDL :: String -> (String, Doc) -> IO ()
writeHDL String
dir (String
cname, Doc
hdl) = do
  let rendered :: Text
rendered = SimpleDocStream () -> Text
forall ann. SimpleDocStream ann -> Text
renderLazy (LayoutOptions -> Doc -> SimpleDocStream ()
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutPretty (PageWidth -> LayoutOptions
LayoutOptions (Int -> Double -> PageWidth
AvailablePerLine Int
120 Double
0.4)) Doc
hdl)
      -- remove blank lines to keep things clean
      clean :: Text -> Text
clean = [Text] -> Text
Text.unlines
            ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (\Text
t -> if (Char -> Bool) -> Text -> Bool
Text.all (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
' ') Text
t then Text
Text.empty else Text
t)
            ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
Text.lines
  IO Handle -> (Handle -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (String -> IOMode -> IO Handle
IO.openFile (String
dir String -> String -> String
</> String
cname) IOMode
IO.WriteMode) Handle -> IO ()
IO.hClose ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
    Handle -> Text -> IO ()
Text.hPutStr Handle
h (Text -> Text
clean Text
rendered)
    Handle -> Text -> IO ()
Text.hPutStr Handle
h (String -> Text
Text.pack String
"\n")

-- | Copy given files
writeMemoryDataFiles
    :: FilePath
    -- ^ Directory to copy  files to
    -> [(String, String)]
    -- ^ (filename, content)
    -> IO ()
writeMemoryDataFiles :: String -> [(String, String)] -> IO ()
writeMemoryDataFiles String
dir [(String, String)]
files =
    ((String, String) -> IO ()) -> [(String, String)] -> IO ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
      ((String -> String -> IO ()) -> (String, String) -> IO ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> String -> IO ()
writeFile)
      [(String
dir String -> String -> String
</> String
fname, String
content) | (String
fname, String
content) <- [(String, String)]
files]

copyDataFiles
    :: [FilePath]
    -> FilePath
    -> [(String,FilePath)]
    -> IO ()
copyDataFiles :: [String] -> String -> [(String, String)] -> IO ()
copyDataFiles [String]
idirs String
dir = ((String, String) -> IO ()) -> [(String, String)] -> IO ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([String] -> (String, String) -> IO ()
copyFile' [String]
idirs)
  where
    copyFile' :: [String] -> (String, String) -> IO ()
copyFile' [String]
dirs (String
nm,String
old) = do
      Bool
oldExists <- String -> IO Bool
Directory.doesFileExist String
old
      if Bool
oldExists
        then String -> String -> IO ()
Directory.copyFile String
old String
new
        else [String] -> IO ()
goImports [String]
dirs
      where
        new :: String
new = String
dir String -> String -> String
FilePath.</> String
nm

        goImports :: [String] -> IO ()
goImports [] = do
          Bool
oldExists <- String -> IO Bool
Directory.doesFileExist String
old
          if Bool
oldExists
            then String -> String -> IO ()
Directory.copyFile String
old String
new
            else Bool -> IO () -> IO ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
unless (String -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null String
old) (String -> IO ()
putStrLn (String
"WARNING: file " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
old String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" does not exist"))
        goImports (String
d:[String]
ds) = do
          let old2 :: String
old2 = String
d String -> String -> String
FilePath.</> String
old
          Bool
old2Exists <- String -> IO Bool
Directory.doesFileExist String
old2
          if Bool
old2Exists
            then String -> String -> IO ()
Directory.copyFile String
old2 String
new
            else [String] -> IO ()
goImports [String]
ds

-- | Get all the terms corresponding to a call graph
callGraphBindings
  :: BindingMap
  -- ^ All bindings
  -> Id
  -- ^ Root of the call graph
  -> [Term]
callGraphBindings :: BindingMap -> Id -> [Term]
callGraphBindings BindingMap
bindingsMap Id
tm =
  (Int -> Term) -> [Int] -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map (Binding -> Term
bindingTerm (Binding -> Term) -> (Int -> Binding) -> Int -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BindingMap
bindingsMap BindingMap -> Int -> Binding
forall a b. (HasCallStack, Uniquable a) => UniqMap b -> a -> b
`lookupUniqMap'`)) (UniqMap (VarEnv Word) -> [Int]
forall a. UniqMap a -> [Int]
keysUniqMap UniqMap (VarEnv Word)
cg)
  where
    cg :: UniqMap (VarEnv Word)
cg = BindingMap -> Id -> UniqMap (VarEnv Word)
callGraph BindingMap
bindingsMap Id
tm

-- | 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
  -> (PrimStep, PrimUnwind)
  -- ^ Hardcoded evaluator (delta-reduction)
  -> [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)))
-> (PrimStep, PrimUnwind)
-> [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 (PrimStep, PrimUnwind)
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
-> (PrimStep, PrimUnwind)
-> 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
-> (PrimStep, PrimUnwind)
-> 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 (PrimStep, PrimUnwind)
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]
sortTop :: BindingMap -> [TopEntityT] -> [TopEntityT]
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)
  in  case [(Int, TopEntityT)] -> [(Int, Int)] -> Either String [TopEntityT]
forall a. [(Int, a)] -> [(Int, Int)] -> Either String [a]
reverseTopSort [(Int, TopEntityT)]
nodes ([[(Int, Int)]] -> [(Int, Int)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(Int, Int)]]
edges) of
        Left String
msg   -> String -> [TopEntityT]
forall a. HasCallStack => String -> a
error String
msg
        Right [TopEntityT]
tops -> [TopEntityT]
tops
 where
  go :: TopEntityT -> ((Int, TopEntityT), [(Int, Int)])
go t :: TopEntityT
t@(TopEntityT Id
topE Maybe TopEntity
_ Maybe Id
tbM) =
    let topRefs :: [TopEntityT]
topRefs = Id -> Id -> [TopEntityT]
goRefs Id
topE Id
topE
        tbRefs :: [TopEntityT]
tbRefs  = [TopEntityT] -> (Id -> [TopEntityT]) -> Maybe Id -> [TopEntityT]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (Id -> Id -> [TopEntityT]
goRefs Id
topE) Maybe Id
tbM
    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]
tbRefs [TopEntityT] -> [TopEntityT] -> [TopEntityT]
forall a. [a] -> [a] -> [a]
++ [TopEntityT]
topRefs))

  goRefs :: Id -> Id -> [TopEntityT]
goRefs Id
top Id
i_ =
    let cg :: UniqMap (VarEnv Word)
cg = BindingMap -> Id -> UniqMap (VarEnv Word)
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 -> UniqMap (VarEnv Word) -> Bool
forall a b. Var a -> VarEnv b -> Bool
`elemVarEnv` UniqMap (VarEnv Word)
cg)
        [TopEntityT]
topEntities