{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Clash.Primitives.Util
( generatePrimMap
, hashCompiledPrimMap
, constantArgs
, decodeOrErrJson
, decodeOrErrYaml
, getFunctionPlurality
) where
import Control.DeepSeq (force)
import Control.Monad (forM)
import Data.Aeson.Extra (decodeOrErrJson, decodeOrErrYaml)
import qualified Data.ByteString.Lazy as LZ
import qualified Data.HashMap.Lazy as HashMap
import qualified Data.HashMap.Strict as HashMapStrict
import qualified Data.Set as Set
import Data.Hashable (hash)
import Data.List (isSuffixOf, sort, find)
import Data.Maybe (fromMaybe)
import qualified Data.Text as TS
import Data.Text.Lazy (Text)
import qualified Data.Text.Lazy.IO as T
import GHC.Stack (HasCallStack)
import qualified System.Directory as Directory
import qualified System.FilePath as FilePath
import System.IO.Error (tryIOError)
import Clash.Annotations.Primitive
( PrimitiveGuard(HasBlackBox, DontTranslate)
, PrimitiveWarning(WarnNonSynthesizable)
, extractPrim, extractWarnings)
import Clash.Core.Term (Term)
import Clash.Core.Type (Type)
import Clash.Primitives.Types
( Primitive(BlackBox), CompiledPrimitive, ResolvedPrimitive, ResolvedPrimMap
, includes, template, TemplateSource(TFile, TInline), Primitive(..)
, UnresolvedPrimitive, CompiledPrimMap, GuardedResolvedPrimitive)
import Clash.Netlist.Types (BlackBox(..), NetlistMonad)
import Clash.Netlist.Util (preserveState)
import Clash.Netlist.BlackBox.Util
(walkElement)
import Clash.Netlist.BlackBox.Types
(Element(Const, Lit), BlackBoxMeta(..))
hashCompiledPrimitive :: CompiledPrimitive -> Int
hashCompiledPrimitive :: CompiledPrimitive -> Int
hashCompiledPrimitive (Primitive {Text
name :: forall a b c d. Primitive a b c d -> Text
name :: Text
name, Text
primSort :: forall a b c d. Primitive a b c d -> Text
primSort :: Text
primSort}) = (Text, Text) -> Int
forall a. Hashable a => a -> Int
hash (Text
name, Text
primSort)
hashCompiledPrimitive (BlackBoxHaskell {(Int, BlackBoxFunction)
function :: forall a b c d. Primitive a b c d -> d
function :: (Int, BlackBoxFunction)
function}) = (Int, BlackBoxFunction) -> Int
forall a b. (a, b) -> a
fst (Int, BlackBoxFunction)
function
hashCompiledPrimitive (BlackBox {Text
name :: Text
name :: forall a b c d. Primitive a b c d -> Text
name, TemplateKind
kind :: forall a b c d. Primitive a b c d -> TemplateKind
kind :: TemplateKind
kind, Bool
outputReg :: forall a b c d. Primitive a b c d -> Bool
outputReg :: Bool
outputReg, [BlackBoxTemplate]
libraries :: forall a b c d. Primitive a b c d -> [a]
libraries :: [BlackBoxTemplate]
libraries, [BlackBoxTemplate]
imports :: forall a b c d. Primitive a b c d -> [a]
imports :: [BlackBoxTemplate]
imports, [((Text, Text), BlackBox)]
includes :: [((Text, Text), BlackBox)]
includes :: forall a b c d. Primitive a b c d -> [((Text, Text), b)]
includes, BlackBox
template :: BlackBox
template :: forall a b c d. Primitive a b c d -> b
template}) =
(Text, TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
[((Text, Text), Int)], Int)
-> Int
forall a. Hashable a => a -> Int
hash (Text
name, TemplateKind
kind, Bool
outputReg, [BlackBoxTemplate]
libraries, [BlackBoxTemplate]
imports, [((Text, Text), Int)]
includes', BlackBox -> Int
hashBlackbox BlackBox
template)
where
includes' :: [((Text, Text), Int)]
includes' = (((Text, Text), BlackBox) -> ((Text, Text), Int))
-> [((Text, Text), BlackBox)] -> [((Text, Text), Int)]
forall a b. (a -> b) -> [a] -> [b]
map (\((Text, Text)
nms, BlackBox
bb) -> ((Text, Text)
nms, BlackBox -> Int
hashBlackbox BlackBox
bb)) [((Text, Text), BlackBox)]
includes
hashBlackbox :: BlackBox -> Int
hashBlackbox (BBTemplate BlackBoxTemplate
bbTemplate) = BlackBoxTemplate -> Int
forall a. Hashable a => a -> Int
hash BlackBoxTemplate
bbTemplate
hashBlackbox (BBFunction BBName
bbName Int
bbHash TemplateFunction
_bbFunc) = (BBName, Int) -> Int
forall a. Hashable a => a -> Int
hash (BBName
bbName, Int
bbHash)
hashCompiledPrimMap :: CompiledPrimMap -> Int
hashCompiledPrimMap :: CompiledPrimMap -> Int
hashCompiledPrimMap CompiledPrimMap
cpm = [PrimitiveGuard Int] -> Int
forall a. Hashable a => a -> Int
hash ((PrimitiveGuard CompiledPrimitive -> PrimitiveGuard Int)
-> [PrimitiveGuard CompiledPrimitive] -> [PrimitiveGuard Int]
forall a b. (a -> b) -> [a] -> [b]
map ((CompiledPrimitive -> Int)
-> PrimitiveGuard CompiledPrimitive -> PrimitiveGuard Int
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap CompiledPrimitive -> Int
hashCompiledPrimitive) [PrimitiveGuard CompiledPrimitive]
orderedValues)
where
orderedKeys :: [Text]
orderedKeys = [Text] -> [Text]
forall a. Ord a => [a] -> [a]
sort (CompiledPrimMap -> [Text]
forall k v. HashMap k v -> [k]
HashMap.keys CompiledPrimMap
cpm)
orderedValues :: [PrimitiveGuard CompiledPrimitive]
orderedValues = (Text -> PrimitiveGuard CompiledPrimitive)
-> [Text] -> [PrimitiveGuard CompiledPrimitive]
forall a b. (a -> b) -> [a] -> [b]
map (CompiledPrimMap
cpm CompiledPrimMap -> Text -> PrimitiveGuard CompiledPrimitive
forall k v.
(Eq k, Hashable k, HasCallStack) =>
HashMap k v -> k -> v
HashMapStrict.!) [Text]
orderedKeys
resolveTemplateSource
:: HasCallStack
=> FilePath
-> TemplateSource
-> IO Text
resolveTemplateSource :: BBName -> TemplateSource -> IO Text
resolveTemplateSource BBName
_metaPath (TInline Text
text) =
Text -> IO Text
forall (m :: Type -> Type) a. Monad m => a -> m a
return Text
text
resolveTemplateSource BBName
metaPath (TFile BBName
path) =
let path' :: BBName
path' = BBName -> BBName -> BBName
FilePath.replaceFileName BBName
metaPath BBName
path in
(IOError -> Text) -> (Text -> Text) -> Either IOError Text -> Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (BBName -> Text
forall a. HasCallStack => BBName -> a
error (BBName -> Text) -> (IOError -> BBName) -> IOError -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> BBName
forall a. Show a => a -> BBName
show) Text -> Text
forall a. a -> a
id (Either IOError Text -> Text)
-> IO (Either IOError Text) -> IO Text
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (IO Text -> IO (Either IOError Text)
forall a. IO a -> IO (Either IOError a)
tryIOError (IO Text -> IO (Either IOError Text))
-> IO Text -> IO (Either IOError Text)
forall a b. (a -> b) -> a -> b
$ BBName -> IO Text
T.readFile BBName
path')
resolvePrimitive'
:: HasCallStack
=> FilePath
-> UnresolvedPrimitive
-> IO (TS.Text, GuardedResolvedPrimitive)
resolvePrimitive' :: BBName
-> UnresolvedPrimitive -> IO (Text, GuardedResolvedPrimitive)
resolvePrimitive' BBName
_metaPath (Primitive Text
name WorkInfo
wf Text
primType) =
(Text, GuardedResolvedPrimitive)
-> IO (Text, GuardedResolvedPrimitive)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Text
name, [PrimitiveWarning]
-> Primitive
Text
((TemplateFormat, BlackBoxFunctionName), Maybe Text)
()
(Maybe Text)
-> GuardedResolvedPrimitive
forall a. [PrimitiveWarning] -> a -> PrimitiveGuard a
HasBlackBox [] (Text
-> WorkInfo
-> Text
-> Primitive
Text
((TemplateFormat, BlackBoxFunctionName), Maybe Text)
()
(Maybe Text)
forall a b c d. Text -> WorkInfo -> Text -> Primitive a b c d
Primitive Text
name WorkInfo
wf Text
primType))
resolvePrimitive' BBName
metaPath BlackBox{template :: forall a b c d. Primitive a b c d -> b
template=((TemplateFormat, BlackBoxFunctionName), Maybe TemplateSource)
t, includes :: forall a b c d. Primitive a b c d -> [((Text, Text), b)]
includes=[((Text, Text),
((TemplateFormat, BlackBoxFunctionName), Maybe TemplateSource))]
i, resultNames :: forall a b c d. Primitive a b c d -> [b]
resultNames=[((TemplateFormat, BlackBoxFunctionName), Maybe TemplateSource)]
r, resultInits :: forall a b c d. Primitive a b c d -> [b]
resultInits=[((TemplateFormat, BlackBoxFunctionName), Maybe TemplateSource)]
ri, Bool
[(Int, Int)]
[Text]
Maybe Text
Text
WorkInfo
TemplateKind
RenderVoid
functionPlurality :: forall a b c d. Primitive a b c d -> [(Int, Int)]
warning :: forall a b c d. Primitive a b c d -> c
multiResult :: forall a b c d. Primitive a b c d -> Bool
renderVoid :: forall a b c d. Primitive a b c d -> RenderVoid
workInfo :: forall a b c d. Primitive a b c d -> WorkInfo
functionPlurality :: [(Int, Int)]
imports :: [Text]
libraries :: [Text]
outputReg :: Bool
warning :: Maybe Text
kind :: TemplateKind
multiResult :: Bool
renderVoid :: RenderVoid
workInfo :: WorkInfo
name :: Text
imports :: forall a b c d. Primitive a b c d -> [a]
libraries :: forall a b c d. Primitive a b c d -> [a]
outputReg :: forall a b c d. Primitive a b c d -> Bool
kind :: forall a b c d. Primitive a b c d -> TemplateKind
name :: forall a b c d. Primitive a b c d -> Text
..} = do
let resolveSourceM :: ((TemplateFormat, BlackBoxFunctionName), Maybe TemplateSource)
-> IO ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
resolveSourceM = (Maybe TemplateSource -> IO (Maybe Text))
-> ((TemplateFormat, BlackBoxFunctionName), Maybe TemplateSource)
-> IO ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((TemplateSource -> IO Text)
-> Maybe TemplateSource -> IO (Maybe Text)
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (HasCallStack => BBName -> TemplateSource -> IO Text
BBName -> TemplateSource -> IO Text
resolveTemplateSource BBName
metaPath))
Primitive
Text
((TemplateFormat, BlackBoxFunctionName), Maybe Text)
()
(Maybe Text)
bb <- Text
-> WorkInfo
-> RenderVoid
-> Bool
-> TemplateKind
-> ()
-> Bool
-> [Text]
-> [Text]
-> [(Int, Int)]
-> [((Text, Text),
((TemplateFormat, BlackBoxFunctionName), Maybe Text))]
-> [((TemplateFormat, BlackBoxFunctionName), Maybe Text)]
-> [((TemplateFormat, BlackBoxFunctionName), Maybe Text)]
-> ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
-> Primitive
Text
((TemplateFormat, BlackBoxFunctionName), Maybe Text)
()
(Maybe Text)
forall a b c d.
Text
-> WorkInfo
-> RenderVoid
-> Bool
-> TemplateKind
-> c
-> Bool
-> [a]
-> [a]
-> [(Int, Int)]
-> [((Text, Text), b)]
-> [b]
-> [b]
-> b
-> Primitive a b c d
BlackBox Text
name WorkInfo
workInfo RenderVoid
renderVoid Bool
multiResult TemplateKind
kind () Bool
outputReg [Text]
libraries [Text]
imports [(Int, Int)]
functionPlurality
([((Text, Text),
((TemplateFormat, BlackBoxFunctionName), Maybe Text))]
-> [((TemplateFormat, BlackBoxFunctionName), Maybe Text)]
-> [((TemplateFormat, BlackBoxFunctionName), Maybe Text)]
-> ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
-> Primitive
Text
((TemplateFormat, BlackBoxFunctionName), Maybe Text)
()
(Maybe Text))
-> IO
[((Text, Text),
((TemplateFormat, BlackBoxFunctionName), Maybe Text))]
-> IO
([((TemplateFormat, BlackBoxFunctionName), Maybe Text)]
-> [((TemplateFormat, BlackBoxFunctionName), Maybe Text)]
-> ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
-> Primitive
Text
((TemplateFormat, BlackBoxFunctionName), Maybe Text)
()
(Maybe Text))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (((Text, Text),
((TemplateFormat, BlackBoxFunctionName), Maybe TemplateSource))
-> IO
((Text, Text),
((TemplateFormat, BlackBoxFunctionName), Maybe Text)))
-> [((Text, Text),
((TemplateFormat, BlackBoxFunctionName), Maybe TemplateSource))]
-> IO
[((Text, Text),
((TemplateFormat, BlackBoxFunctionName), Maybe Text))]
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 TemplateSource)
-> IO ((TemplateFormat, BlackBoxFunctionName), Maybe Text))
-> ((Text, Text),
((TemplateFormat, BlackBoxFunctionName), Maybe TemplateSource))
-> IO
((Text, Text),
((TemplateFormat, BlackBoxFunctionName), Maybe Text))
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 TemplateSource)
-> IO ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
resolveSourceM) [((Text, Text),
((TemplateFormat, BlackBoxFunctionName), Maybe TemplateSource))]
i
IO
([((TemplateFormat, BlackBoxFunctionName), Maybe Text)]
-> [((TemplateFormat, BlackBoxFunctionName), Maybe Text)]
-> ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
-> Primitive
Text
((TemplateFormat, BlackBoxFunctionName), Maybe Text)
()
(Maybe Text))
-> IO [((TemplateFormat, BlackBoxFunctionName), Maybe Text)]
-> IO
([((TemplateFormat, BlackBoxFunctionName), Maybe Text)]
-> ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
-> Primitive
Text
((TemplateFormat, BlackBoxFunctionName), Maybe Text)
()
(Maybe Text))
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> (((TemplateFormat, BlackBoxFunctionName), Maybe TemplateSource)
-> IO ((TemplateFormat, BlackBoxFunctionName), Maybe Text))
-> [((TemplateFormat, BlackBoxFunctionName), Maybe TemplateSource)]
-> IO [((TemplateFormat, BlackBoxFunctionName), Maybe Text)]
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 TemplateSource)
-> IO ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
resolveSourceM [((TemplateFormat, BlackBoxFunctionName), Maybe TemplateSource)]
r
IO
([((TemplateFormat, BlackBoxFunctionName), Maybe Text)]
-> ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
-> Primitive
Text
((TemplateFormat, BlackBoxFunctionName), Maybe Text)
()
(Maybe Text))
-> IO [((TemplateFormat, BlackBoxFunctionName), Maybe Text)]
-> IO
(((TemplateFormat, BlackBoxFunctionName), Maybe Text)
-> Primitive
Text
((TemplateFormat, BlackBoxFunctionName), Maybe Text)
()
(Maybe Text))
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> (((TemplateFormat, BlackBoxFunctionName), Maybe TemplateSource)
-> IO ((TemplateFormat, BlackBoxFunctionName), Maybe Text))
-> [((TemplateFormat, BlackBoxFunctionName), Maybe TemplateSource)]
-> IO [((TemplateFormat, BlackBoxFunctionName), Maybe Text)]
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 TemplateSource)
-> IO ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
resolveSourceM [((TemplateFormat, BlackBoxFunctionName), Maybe TemplateSource)]
ri
IO
(((TemplateFormat, BlackBoxFunctionName), Maybe Text)
-> Primitive
Text
((TemplateFormat, BlackBoxFunctionName), Maybe Text)
()
(Maybe Text))
-> IO ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
-> IO
(Primitive
Text
((TemplateFormat, BlackBoxFunctionName), Maybe Text)
()
(Maybe Text))
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> ((TemplateFormat, BlackBoxFunctionName), Maybe TemplateSource)
-> IO ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
resolveSourceM ((TemplateFormat, BlackBoxFunctionName), Maybe TemplateSource)
t
case Maybe Text
warning of
Just Text
w -> (Text, GuardedResolvedPrimitive)
-> IO (Text, GuardedResolvedPrimitive)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Text
name, [PrimitiveWarning]
-> Primitive
Text
((TemplateFormat, BlackBoxFunctionName), Maybe Text)
()
(Maybe Text)
-> GuardedResolvedPrimitive
forall a. [PrimitiveWarning] -> a -> PrimitiveGuard a
HasBlackBox [BBName -> PrimitiveWarning
WarnNonSynthesizable (Text -> BBName
TS.unpack Text
w)] Primitive
Text
((TemplateFormat, BlackBoxFunctionName), Maybe Text)
()
(Maybe Text)
bb)
Maybe Text
Nothing -> (Text, GuardedResolvedPrimitive)
-> IO (Text, GuardedResolvedPrimitive)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Text
name, [PrimitiveWarning]
-> Primitive
Text
((TemplateFormat, BlackBoxFunctionName), Maybe Text)
()
(Maybe Text)
-> GuardedResolvedPrimitive
forall a. [PrimitiveWarning] -> a -> PrimitiveGuard a
HasBlackBox [] Primitive
Text
((TemplateFormat, BlackBoxFunctionName), Maybe Text)
()
(Maybe Text)
bb)
resolvePrimitive' BBName
metaPath (BlackBoxHaskell Text
bbName WorkInfo
wf UsedArguments
usedArgs Bool
multiRes BlackBoxFunctionName
funcName Maybe TemplateSource
t) =
(Text
bbName,) (GuardedResolvedPrimitive -> (Text, GuardedResolvedPrimitive))
-> (Maybe Text -> GuardedResolvedPrimitive)
-> Maybe Text
-> (Text, GuardedResolvedPrimitive)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PrimitiveWarning]
-> Primitive
Text
((TemplateFormat, BlackBoxFunctionName), Maybe Text)
()
(Maybe Text)
-> GuardedResolvedPrimitive
forall a. [PrimitiveWarning] -> a -> PrimitiveGuard a
HasBlackBox [] (Primitive
Text
((TemplateFormat, BlackBoxFunctionName), Maybe Text)
()
(Maybe Text)
-> GuardedResolvedPrimitive)
-> (Maybe Text
-> Primitive
Text
((TemplateFormat, BlackBoxFunctionName), Maybe Text)
()
(Maybe Text))
-> Maybe Text
-> GuardedResolvedPrimitive
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text
-> WorkInfo
-> UsedArguments
-> Bool
-> BlackBoxFunctionName
-> Maybe Text
-> Primitive
Text
((TemplateFormat, BlackBoxFunctionName), Maybe Text)
()
(Maybe Text)
forall a b c d.
Text
-> WorkInfo
-> UsedArguments
-> Bool
-> BlackBoxFunctionName
-> d
-> Primitive a b c d
BlackBoxHaskell Text
bbName WorkInfo
wf UsedArguments
usedArgs Bool
multiRes BlackBoxFunctionName
funcName (Maybe Text -> (Text, GuardedResolvedPrimitive))
-> IO (Maybe Text) -> IO (Text, GuardedResolvedPrimitive)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$>
((TemplateSource -> IO Text)
-> Maybe TemplateSource -> IO (Maybe Text)
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (HasCallStack => BBName -> TemplateSource -> IO Text
BBName -> TemplateSource -> IO Text
resolveTemplateSource BBName
metaPath) Maybe TemplateSource
t)
resolvePrimitive
:: HasCallStack
=> FilePath
-> IO [(TS.Text, GuardedResolvedPrimitive)]
resolvePrimitive :: BBName -> IO [(Text, GuardedResolvedPrimitive)]
resolvePrimitive BBName
fileName = do
[UnresolvedPrimitive]
prims <- BBName -> ByteString -> [UnresolvedPrimitive]
decoder BBName
fileName (ByteString -> [UnresolvedPrimitive])
-> IO ByteString -> IO [UnresolvedPrimitive]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> BBName -> IO ByteString
LZ.readFile BBName
fileName
(UnresolvedPrimitive -> IO (Text, GuardedResolvedPrimitive))
-> [UnresolvedPrimitive] -> IO [(Text, GuardedResolvedPrimitive)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (HasCallStack =>
BBName
-> UnresolvedPrimitive -> IO (Text, GuardedResolvedPrimitive)
BBName
-> UnresolvedPrimitive -> IO (Text, GuardedResolvedPrimitive)
resolvePrimitive' BBName
fileName) [UnresolvedPrimitive]
prims
where
decoder :: BBName -> ByteString -> [UnresolvedPrimitive]
decoder
| BBName
".primitives.yaml" BBName -> BBName -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` BBName
fileName = BBName -> ByteString -> [UnresolvedPrimitive]
forall a. (HasCallStack, FromJSON a) => BBName -> ByteString -> a
decodeOrErrYaml
| BBName
".primitives" BBName -> BBName -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` BBName
fileName = BBName -> ByteString -> [UnresolvedPrimitive]
forall a. (HasCallStack, FromJSON a) => BBName -> ByteString -> a
decodeOrErrJson
| Bool
otherwise = BBName -> BBName -> ByteString -> [UnresolvedPrimitive]
forall a. HasCallStack => BBName -> a
error (BBName
"Unexpected filename extension in: " BBName -> BBName -> BBName
forall a. Semigroup a => a -> a -> a
<> BBName
fileName)
addGuards
:: ResolvedPrimMap
-> [(TS.Text, PrimitiveGuard ())]
-> ResolvedPrimMap
addGuards :: ResolvedPrimMap -> [(Text, PrimitiveGuard ())] -> ResolvedPrimMap
addGuards = (ResolvedPrimMap -> (Text, PrimitiveGuard ()) -> ResolvedPrimMap)
-> ResolvedPrimMap
-> [(Text, PrimitiveGuard ())]
-> ResolvedPrimMap
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ResolvedPrimMap -> (Text, PrimitiveGuard ()) -> ResolvedPrimMap
go
where
lookupPrim
:: TS.Text
-> ResolvedPrimMap
-> Maybe ([PrimitiveWarning], ResolvedPrimitive)
lookupPrim :: Text
-> ResolvedPrimMap
-> Maybe
([PrimitiveWarning],
Primitive
Text
((TemplateFormat, BlackBoxFunctionName), Maybe Text)
()
(Maybe Text))
lookupPrim Text
nm ResolvedPrimMap
primMap = do
GuardedResolvedPrimitive
guardedPrim <- Text -> ResolvedPrimMap -> Maybe GuardedResolvedPrimitive
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMapStrict.lookup Text
nm ResolvedPrimMap
primMap
Primitive
Text
((TemplateFormat, BlackBoxFunctionName), Maybe Text)
()
(Maybe Text)
prim <- GuardedResolvedPrimitive
-> Maybe
(Primitive
Text
((TemplateFormat, BlackBoxFunctionName), Maybe Text)
()
(Maybe Text))
forall a. PrimitiveGuard a -> Maybe a
extractPrim GuardedResolvedPrimitive
guardedPrim
([PrimitiveWarning],
Primitive
Text
((TemplateFormat, BlackBoxFunctionName), Maybe Text)
()
(Maybe Text))
-> Maybe
([PrimitiveWarning],
Primitive
Text
((TemplateFormat, BlackBoxFunctionName), Maybe Text)
()
(Maybe Text))
forall (m :: Type -> Type) a. Monad m => a -> m a
return (GuardedResolvedPrimitive -> [PrimitiveWarning]
forall a. PrimitiveGuard a -> [PrimitiveWarning]
extractWarnings GuardedResolvedPrimitive
guardedPrim, Primitive
Text
((TemplateFormat, BlackBoxFunctionName), Maybe Text)
()
(Maybe Text)
prim)
go :: ResolvedPrimMap -> (Text, PrimitiveGuard ()) -> ResolvedPrimMap
go ResolvedPrimMap
primMap (Text
nm, PrimitiveGuard ()
guard) =
Text
-> GuardedResolvedPrimitive -> ResolvedPrimMap -> ResolvedPrimMap
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMapStrict.insert
Text
nm
(case (Text
-> ResolvedPrimMap
-> Maybe
([PrimitiveWarning],
Primitive
Text
((TemplateFormat, BlackBoxFunctionName), Maybe Text)
()
(Maybe Text))
lookupPrim Text
nm ResolvedPrimMap
primMap, PrimitiveGuard ()
guard) of
(Maybe
([PrimitiveWarning],
Primitive
Text
((TemplateFormat, BlackBoxFunctionName), Maybe Text)
()
(Maybe Text))
Nothing, PrimitiveGuard ()
DontTranslate) -> GuardedResolvedPrimitive
forall a. PrimitiveGuard a
DontTranslate
(Maybe
([PrimitiveWarning],
Primitive
Text
((TemplateFormat, BlackBoxFunctionName), Maybe Text)
()
(Maybe Text))
Nothing, HasBlackBox [PrimitiveWarning]
_ ()) ->
BBName -> GuardedResolvedPrimitive
forall a. HasCallStack => BBName -> a
error (BBName -> GuardedResolvedPrimitive)
-> BBName -> GuardedResolvedPrimitive
forall a b. (a -> b) -> a -> b
$ BBName
"No BlackBox definition for '" BBName -> BBName -> BBName
forall a. [a] -> [a] -> [a]
++ Text -> BBName
TS.unpack Text
nm BBName -> BBName -> BBName
forall a. [a] -> [a] -> [a]
++ BBName
"' even"
BBName -> BBName -> BBName
forall a. [a] -> [a] -> [a]
++ BBName
" though this value was annotated with 'HasBlackBox'."
(Just ([PrimitiveWarning],
Primitive
Text
((TemplateFormat, BlackBoxFunctionName), Maybe Text)
()
(Maybe Text))
_, PrimitiveGuard ()
DontTranslate) ->
BBName -> GuardedResolvedPrimitive
forall a. HasCallStack => BBName -> a
error (Text -> BBName
TS.unpack Text
nm BBName -> BBName -> BBName
forall a. [a] -> [a] -> [a]
++ BBName
" was annotated with DontTranslate, but a "
BBName -> BBName -> BBName
forall a. [a] -> [a] -> [a]
++ BBName
"BlackBox definition was found anyway.")
(Just ([PrimitiveWarning]
ws1, Primitive
Text
((TemplateFormat, BlackBoxFunctionName), Maybe Text)
()
(Maybe Text)
p), HasBlackBox [PrimitiveWarning]
ws2 ()) ->
[PrimitiveWarning]
-> Primitive
Text
((TemplateFormat, BlackBoxFunctionName), Maybe Text)
()
(Maybe Text)
-> GuardedResolvedPrimitive
forall a. [PrimitiveWarning] -> a -> PrimitiveGuard a
HasBlackBox ([PrimitiveWarning]
ws1 [PrimitiveWarning] -> [PrimitiveWarning] -> [PrimitiveWarning]
forall a. [a] -> [a] -> [a]
++ [PrimitiveWarning]
ws2) Primitive
Text
((TemplateFormat, BlackBoxFunctionName), Maybe Text)
()
(Maybe Text)
p
)
ResolvedPrimMap
primMap
generatePrimMap
:: HasCallStack
=> [UnresolvedPrimitive]
-> [(TS.Text, PrimitiveGuard ())]
-> [FilePath]
-> IO ResolvedPrimMap
generatePrimMap :: [UnresolvedPrimitive]
-> [(Text, PrimitiveGuard ())] -> [BBName] -> IO ResolvedPrimMap
generatePrimMap [UnresolvedPrimitive]
unresolvedPrims [(Text, PrimitiveGuard ())]
primGuards [BBName]
filePaths = do
[BBName]
primitiveFiles <- ([[BBName]] -> [BBName]) -> IO [[BBName]] -> IO [BBName]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap [[BBName]] -> [BBName]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat (IO [[BBName]] -> IO [BBName]) -> IO [[BBName]] -> IO [BBName]
forall a b. (a -> b) -> a -> b
$ [BBName] -> (BBName -> IO [BBName]) -> IO [[BBName]]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [BBName]
filePaths ((BBName -> IO [BBName]) -> IO [[BBName]])
-> (BBName -> IO [BBName]) -> IO [[BBName]]
forall a b. (a -> b) -> a -> b
$ \BBName
filePath -> do
Bool
fpExists <- BBName -> IO Bool
Directory.doesDirectoryExist BBName
filePath
if Bool
fpExists then do
[BBName]
contents <- BBName -> IO [BBName]
Directory.getDirectoryContents BBName
filePath
let
jsonPrims :: [BBName]
jsonPrims = (BBName -> Bool) -> [BBName] -> [BBName]
forall a. (a -> Bool) -> [a] -> [a]
filter (BBName
".primitives" BBName -> BBName -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf`) [BBName]
contents
yamlPrims :: [BBName]
yamlPrims = (BBName -> Bool) -> [BBName] -> [BBName]
forall a. (a -> Bool) -> [a] -> [a]
filter (BBName
".primitives.yaml" BBName -> BBName -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf`) [BBName]
contents
relPrims :: [BBName]
relPrims = [BBName]
jsonPrims [BBName] -> [BBName] -> [BBName]
forall a. Semigroup a => a -> a -> a
<> [BBName]
yamlPrims
absPrims :: [BBName]
absPrims = (BBName -> BBName) -> [BBName] -> [BBName]
forall a b. (a -> b) -> [a] -> [b]
map (BBName -> BBName -> BBName
FilePath.combine BBName
filePath) [BBName]
relPrims
[BBName] -> IO [BBName]
forall (m :: Type -> Type) a. Monad m => a -> m a
return [BBName]
absPrims
else
[BBName] -> IO [BBName]
forall (m :: Type -> Type) a. Monad m => a -> m a
return []
[(Text, GuardedResolvedPrimitive)]
primitives0 <- [[(Text, GuardedResolvedPrimitive)]]
-> [(Text, GuardedResolvedPrimitive)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat ([[(Text, GuardedResolvedPrimitive)]]
-> [(Text, GuardedResolvedPrimitive)])
-> IO [[(Text, GuardedResolvedPrimitive)]]
-> IO [(Text, GuardedResolvedPrimitive)]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (BBName -> IO [(Text, GuardedResolvedPrimitive)])
-> [BBName] -> IO [[(Text, GuardedResolvedPrimitive)]]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM HasCallStack => BBName -> IO [(Text, GuardedResolvedPrimitive)]
BBName -> IO [(Text, GuardedResolvedPrimitive)]
resolvePrimitive [BBName]
primitiveFiles
let metapaths :: [BBName]
metapaths = (UnresolvedPrimitive -> BBName)
-> [UnresolvedPrimitive] -> [BBName]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> BBName
TS.unpack (Text -> BBName)
-> (UnresolvedPrimitive -> Text) -> UnresolvedPrimitive -> BBName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnresolvedPrimitive -> Text
forall a b c d. Primitive a b c d -> Text
name) [UnresolvedPrimitive]
unresolvedPrims
[(Text, GuardedResolvedPrimitive)]
primitives1 <- [IO (Text, GuardedResolvedPrimitive)]
-> IO [(Text, GuardedResolvedPrimitive)]
forall (t :: Type -> Type) (m :: Type -> Type) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([IO (Text, GuardedResolvedPrimitive)]
-> IO [(Text, GuardedResolvedPrimitive)])
-> [IO (Text, GuardedResolvedPrimitive)]
-> IO [(Text, GuardedResolvedPrimitive)]
forall a b. (a -> b) -> a -> b
$ (BBName
-> UnresolvedPrimitive -> IO (Text, GuardedResolvedPrimitive))
-> [BBName]
-> [UnresolvedPrimitive]
-> [IO (Text, GuardedResolvedPrimitive)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith HasCallStack =>
BBName
-> UnresolvedPrimitive -> IO (Text, GuardedResolvedPrimitive)
BBName
-> UnresolvedPrimitive -> IO (Text, GuardedResolvedPrimitive)
resolvePrimitive' [BBName]
metapaths [UnresolvedPrimitive]
unresolvedPrims
let primMap :: ResolvedPrimMap
primMap = [(Text, GuardedResolvedPrimitive)] -> ResolvedPrimMap
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList ([(Text, GuardedResolvedPrimitive)]
primitives0 [(Text, GuardedResolvedPrimitive)]
-> [(Text, GuardedResolvedPrimitive)]
-> [(Text, GuardedResolvedPrimitive)]
forall a. [a] -> [a] -> [a]
++ [(Text, GuardedResolvedPrimitive)]
primitives1)
ResolvedPrimMap -> IO ResolvedPrimMap
forall (m :: Type -> Type) a. Monad m => a -> m a
return (ResolvedPrimMap -> ResolvedPrimMap
forall a. NFData a => a -> a
force (ResolvedPrimMap -> [(Text, PrimitiveGuard ())] -> ResolvedPrimMap
addGuards ResolvedPrimMap
primMap [(Text, PrimitiveGuard ())]
primGuards))
{-# SCC generatePrimMap #-}
constantArgs :: TS.Text -> CompiledPrimitive -> Set.Set Int
constantArgs :: Text -> CompiledPrimitive -> Set Int
constantArgs Text
nm BlackBox {template :: forall a b c d. Primitive a b c d -> b
template = templ :: BlackBox
templ@(BBTemplate BlackBoxTemplate
_), resultInits :: forall a b c d. Primitive a b c d -> [b]
resultInits = [BlackBox]
tRIM} =
[Int] -> Set Int
forall a. Ord a => [a] -> Set a
Set.fromList ([[Int]] -> [Int]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [ [Int]
fromIntForce
, (BlackBox -> [Int]) -> [BlackBox] -> [Int]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap BlackBox -> [Int]
walkTemplate [BlackBox]
tRIM
, BlackBox -> [Int]
walkTemplate BlackBox
templ
])
where
walkTemplate :: BlackBox -> [Int]
walkTemplate (BBTemplate BlackBoxTemplate
t) = (Element -> [Int]) -> BlackBoxTemplate -> [Int]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap ((Element -> Maybe Int) -> Element -> [Int]
forall a. (Element -> Maybe a) -> Element -> [a]
walkElement Element -> Maybe Int
getConstant) BlackBoxTemplate
t
walkTemplate BlackBox
_ = []
getConstant :: Element -> Maybe Int
getConstant (Lit Int
i) = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
i
getConstant (Const Int
i) = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
i
getConstant Element
_ = Maybe Int
forall a. Maybe a
Nothing
fromIntForce :: [Int]
fromIntForce
| Text
nm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Clash.Sized.Internal.BitVector.fromInteger#" = [Int
2]
| Text
nm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Clash.Sized.Internal.BitVector.fromInteger##" = [Int
0,Int
1]
| Text
nm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Clash.Sized.Internal.Index.fromInteger#" = [Int
1]
| Text
nm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Clash.Sized.Internal.Signed.fromInteger#" = [Int
1]
| Text
nm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Clash.Sized.Internal.Unsigned.fromInteger#" = [Int
1]
| Text
nm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Clash.Sized.Vector.replace_int" = [Int
1,Int
2]
| Bool
otherwise = []
constantArgs Text
nm (BlackBoxHaskell{}) = [Int] -> Set Int
forall a. Ord a => [a] -> Set a
Set.fromList [Int]
fromIntForce
where
fromIntForce :: [Int]
fromIntForce
| Text
nm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Clash.Sized.Vector.index_int" = [Int
2]
| Bool
otherwise = []
constantArgs Text
_ CompiledPrimitive
_ = Set Int
forall a. Set a
Set.empty
getFunctionPlurality' :: [(Int, Int)] -> Int -> Int
getFunctionPlurality' :: [(Int, Int)] -> Int -> Int
getFunctionPlurality' [(Int, Int)]
functionPlurality Int
n =
Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
1 ((Int, Int) -> Int
forall a b. (a, b) -> b
snd ((Int, Int) -> Int) -> Maybe (Int, Int) -> Maybe Int
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (((Int, Int) -> Bool) -> [(Int, Int)] -> Maybe (Int, Int)
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Maybe a
find ((Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n) (Int -> Bool) -> ((Int, Int) -> Int) -> (Int, Int) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Int) -> Int
forall a b. (a, b) -> a
fst) [(Int, Int)]
functionPlurality))
getFunctionPlurality
:: HasCallStack
=> CompiledPrimitive
-> [Either Term Type]
-> [Type]
-> Int
-> NetlistMonad Int
getFunctionPlurality :: CompiledPrimitive
-> [Either Term Type] -> [Type] -> Int -> NetlistMonad Int
getFunctionPlurality (Primitive {}) [Either Term Type]
_args [Type]
_resTys Int
_n = Int -> NetlistMonad Int
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Int
1
getFunctionPlurality (BlackBoxHaskell {Text
name :: Text
name :: forall a b c d. Primitive a b c d -> Text
name, (Int, BlackBoxFunction)
function :: (Int, BlackBoxFunction)
function :: forall a b c d. Primitive a b c d -> d
function, BlackBoxFunctionName
functionName :: forall a b c d. Primitive a b c d -> BlackBoxFunctionName
functionName :: BlackBoxFunctionName
functionName}) [Either Term Type]
args [Type]
resTys Int
n = do
Either BBName (BlackBoxMeta, BlackBox)
errOrMeta <- NetlistMonad (Either BBName (BlackBoxMeta, BlackBox))
-> NetlistMonad (Either BBName (BlackBoxMeta, BlackBox))
forall a. NetlistMonad a -> NetlistMonad a
preserveState (((Int, BlackBoxFunction) -> BlackBoxFunction
forall a b. (a, b) -> b
snd (Int, BlackBoxFunction)
function) Bool
False Text
name [Either Term Type]
args [Type]
resTys)
case Either BBName (BlackBoxMeta, BlackBox)
errOrMeta of
Left BBName
err ->
BBName -> NetlistMonad Int
forall a. HasCallStack => BBName -> a
error (BBName -> NetlistMonad Int) -> BBName -> NetlistMonad Int
forall a b. (a -> b) -> a -> b
$ [BBName] -> BBName
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [ BBName
"Tried to determine function plurality for "
, Text -> BBName
TS.unpack Text
name, BBName
" by quering ", BlackBoxFunctionName -> BBName
forall a. Show a => a -> BBName
show BlackBoxFunctionName
functionName
, BBName
". Function returned an error message instead:\n\n"
, BBName
err ]
Right (BlackBoxMeta {[(Int, Int)]
bbFunctionPlurality :: BlackBoxMeta -> [(Int, Int)]
bbFunctionPlurality :: [(Int, Int)]
bbFunctionPlurality}, BlackBox
_bb) ->
Int -> NetlistMonad Int
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([(Int, Int)] -> Int -> Int
getFunctionPlurality' [(Int, Int)]
bbFunctionPlurality Int
n)
getFunctionPlurality (BlackBox {[(Int, Int)]
functionPlurality :: [(Int, Int)]
functionPlurality :: forall a b c d. Primitive a b c d -> [(Int, Int)]
functionPlurality}) [Either Term Type]
_args [Type]
_resTy Int
n =
Int -> NetlistMonad Int
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([(Int, Int)] -> Int -> Int
getFunctionPlurality' [(Int, Int)]
functionPlurality Int
n)