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

  Utility functions to generate Primitives
-}

{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module Clash.Primitives.Util
  ( generatePrimMap
  , hashCompiledPrimMap
  , constantArgs
  , decodeOrErr
  , getFunctionPlurality
  ) where

import           Control.DeepSeq        (force)
import           Control.Monad          (join)
import           Data.Aeson.Extra       (decodeOrErr)
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, WarnNonSynthesizable, WarnAlways, DontTranslate)
  , extractPrim)
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)

-- | Hash a compiled primitive map. It needs a separate function (as opposed to
-- just 'hash') as it might contain (obviously unhashable) Haskell functions. This
-- function takes the hash value stored with the function instead.
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
    -- TODO: switch to 'normal' map instead of hashmap?
    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')

-- | Replace file pointers with file contents
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, Primitive
  Text
  ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
  ()
  (Maybe Text)
-> GuardedResolvedPrimitive
forall a. 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, resultName :: forall a b c d. Primitive a b c d -> Maybe b
resultName=Maybe
  ((TemplateFormat, BlackBoxFunctionName), Maybe TemplateSource)
r, resultInit :: forall a b c d. Primitive a b c d -> Maybe b
resultInit=Maybe
  ((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
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
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
-> TemplateKind
-> ()
-> Bool
-> [Text]
-> [Text]
-> [(Int, Int)]
-> [((Text, Text),
     ((TemplateFormat, BlackBoxFunctionName), Maybe Text))]
-> Maybe ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
-> Maybe ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
-> ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
-> Primitive
     Text
     ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
     ()
     (Maybe Text)
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
name WorkInfo
workInfo RenderVoid
renderVoid TemplateKind
kind () Bool
outputReg [Text]
libraries [Text]
imports [(Int, Int)]
functionPlurality
          ([((Text, Text),
   ((TemplateFormat, BlackBoxFunctionName), Maybe Text))]
 -> Maybe ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
 -> Maybe ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
 -> ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
 -> Primitive
      Text
      ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
      ()
      (Maybe Text))
-> IO
     [((Text, Text),
       ((TemplateFormat, BlackBoxFunctionName), Maybe Text))]
-> IO
     (Maybe ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
      -> Maybe ((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
  (Maybe ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
   -> Maybe ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
   -> ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
   -> Primitive
        Text
        ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
        ()
        (Maybe Text))
-> IO (Maybe ((TemplateFormat, BlackBoxFunctionName), Maybe Text))
-> IO
     (Maybe ((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))
-> Maybe
     ((TemplateFormat, BlackBoxFunctionName), Maybe TemplateSource)
-> IO (Maybe ((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 Maybe
  ((TemplateFormat, BlackBoxFunctionName), Maybe TemplateSource)
r
          IO
  (Maybe ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
   -> ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
   -> Primitive
        Text
        ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
        ()
        (Maybe Text))
-> IO (Maybe ((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))
-> Maybe
     ((TemplateFormat, BlackBoxFunctionName), Maybe TemplateSource)
-> IO (Maybe ((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 Maybe
  ((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, BBName
-> Primitive
     Text
     ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
     ()
     (Maybe Text)
-> GuardedResolvedPrimitive
forall a. BBName -> a -> PrimitiveGuard a
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, Primitive
  Text
  ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
  ()
  (Maybe Text)
-> GuardedResolvedPrimitive
forall a. a -> PrimitiveGuard a
HasBlackBox Primitive
  Text
  ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
  ()
  (Maybe Text)
bb)
resolvePrimitive' BBName
metaPath (BlackBoxHaskell Text
bbName WorkInfo
wf UsedArguments
usedArgs 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
. Primitive
  Text
  ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
  ()
  (Maybe Text)
-> GuardedResolvedPrimitive
forall a. 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
-> BlackBoxFunctionName
-> Maybe Text
-> Primitive
     Text
     ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
     ()
     (Maybe Text)
forall a b c d.
Text
-> WorkInfo
-> UsedArguments
-> BlackBoxFunctionName
-> d
-> Primitive a b c d
BlackBoxHaskell Text
bbName WorkInfo
wf UsedArguments
usedArgs 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)

-- | Interprets contents of json file as list of @Primitive@s. Throws
-- exception if it fails.
resolvePrimitive
  :: HasCallStack
  => FilePath
  -> IO [(TS.Text, GuardedResolvedPrimitive)]
resolvePrimitive :: BBName -> IO [(Text, GuardedResolvedPrimitive)]
resolvePrimitive BBName
fileName = do
  [UnresolvedPrimitive]
prims <- BBName -> ByteString -> [UnresolvedPrimitive]
forall a. (HasCallStack, FromJSON a) => BBName -> ByteString -> a
decodeOrErr 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

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
forall b.
ResolvedPrimMap -> (Text, PrimitiveGuard b) -> ResolvedPrimMap
go
 where
  lookupPrim :: TS.Text -> ResolvedPrimMap -> Maybe ResolvedPrimitive
  lookupPrim :: Text
-> ResolvedPrimMap
-> Maybe
     (Primitive
        Text
        ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
        ()
        (Maybe Text))
lookupPrim Text
nm ResolvedPrimMap
primMap = Maybe
  (Maybe
     (Primitive
        Text
        ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
        ()
        (Maybe Text)))
-> Maybe
     (Primitive
        Text
        ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
        ()
        (Maybe Text))
forall (m :: Type -> Type) a. Monad m => m (m a) -> m a
join (GuardedResolvedPrimitive
-> Maybe
     (Primitive
        Text
        ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
        ()
        (Maybe Text))
forall a. PrimitiveGuard a -> Maybe a
extractPrim (GuardedResolvedPrimitive
 -> Maybe
      (Primitive
         Text
         ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
         ()
         (Maybe Text)))
-> Maybe GuardedResolvedPrimitive
-> Maybe
     (Maybe
        (Primitive
           Text
           ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
           ()
           (Maybe Text)))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> ResolvedPrimMap -> Maybe GuardedResolvedPrimitive
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMapStrict.lookup Text
nm ResolvedPrimMap
primMap)

  go :: ResolvedPrimMap -> (Text, PrimitiveGuard b) -> ResolvedPrimMap
go ResolvedPrimMap
primMap (Text
nm, PrimitiveGuard b
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
     (Primitive
        Text
        ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
        ()
        (Maybe Text))
lookupPrim Text
nm ResolvedPrimMap
primMap, PrimitiveGuard b
guard) of
        (Maybe
  (Primitive
     Text
     ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
     ()
     (Maybe Text))
Nothing, HasBlackBox b
_) ->
          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'."
        (Maybe
  (Primitive
     Text
     ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
     ()
     (Maybe Text))
Nothing, WarnNonSynthesizable BBName
_ b
_) ->
          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 'WarnNonSynthesizable'"
               BBName -> BBName -> BBName
forall a. [a] -> [a] -> [a]
++ BBName
", implying it has a BlackBox."
        (Maybe
  (Primitive
     Text
     ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
     ()
     (Maybe Text))
Nothing, WarnAlways BBName
_ b
_) ->
          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 'WarnAlways'"
               BBName -> BBName -> BBName
forall a. [a] -> [a] -> [a]
++ BBName
", implying it has a BlackBox."
        (Just Primitive
  Text
  ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
  ()
  (Maybe Text)
_, PrimitiveGuard b
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.")
        (Maybe
  (Primitive
     Text
     ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
     ()
     (Maybe Text))
Nothing, PrimitiveGuard b
DontTranslate) -> GuardedResolvedPrimitive
forall a. PrimitiveGuard a
DontTranslate
        (Just Primitive
  Text
  ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
  ()
  (Maybe Text)
p, PrimitiveGuard b
g) -> (b
 -> Primitive
      Text
      ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
      ()
      (Maybe Text))
-> PrimitiveGuard b -> GuardedResolvedPrimitive
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (Primitive
  Text
  ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
  ()
  (Maybe Text)
-> b
-> Primitive
     Text
     ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
     ()
     (Maybe Text)
forall a b. a -> b -> a
const Primitive
  Text
  ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
  ()
  (Maybe Text)
p) PrimitiveGuard b
g)
      ResolvedPrimMap
primMap

-- | Generate a set of primitives that are found in the primitive definition
-- files in the given directories.
generatePrimMap
  :: HasCallStack
  => [UnresolvedPrimitive]
  -- ^ unresolved primitives found in annotations (in LoadModules and
  -- LoadInterfaceFiles)
  -> [(TS.Text, PrimitiveGuard ())]
  -> [FilePath]
  -- ^ Directories to search for primitive definitions
  -> 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 -> IO [BBName]) -> [BBName] -> IO [[BBName]]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
     (\BBName
filePath -> do
         Bool
fpExists <- BBName -> IO Bool
Directory.doesDirectoryExist BBName
filePath
         if Bool
fpExists
           then
             ([BBName] -> [BBName]) -> IO [BBName] -> IO [BBName]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ( (BBName -> BBName) -> [BBName] -> [BBName]
forall a b. (a -> b) -> [a] -> [b]
map (BBName -> BBName -> BBName
FilePath.combine BBName
filePath)
                  ([BBName] -> [BBName])
-> ([BBName] -> [BBName]) -> [BBName] -> [BBName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BBName -> Bool) -> [BBName] -> [BBName]
forall a. (a -> Bool) -> [a] -> [a]
filter (BBName -> BBName -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isSuffixOf BBName
".json")
                  ) (BBName -> IO [BBName]
Directory.getDirectoryContents BBName
filePath)
           else
             [BBName] -> IO [BBName]
forall (m :: Type -> Type) a. Monad m => a -> m a
return []
     ) [BBName]
filePaths

  [(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 #-}

-- | Determine what argument should be constant / literal
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
_), resultInit :: forall a b c d. Primitive a b c d -> Maybe b
resultInit = Maybe 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
                       , [Int] -> (BlackBox -> [Int]) -> Maybe BlackBox -> [Int]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] BlackBox -> [Int]
walkTemplate Maybe 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

  -- Ensure that if the "Integer" arguments are constants, that they are reduced
  -- to literals, so that the buildin rules can properly fire.
  --
  -- Only in the the case that "Integer" arguments are truly variables should
  -- the blackbox rules fire.
  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]
    -- There is a special code-path for `index_int` in the Verilog backend in
    -- case the index is a variable. But this code path only works when the
    -- vector is (a projection of) a variable. By forcing the arguments of
    -- index_int we can be sure that arguments are either:
    --
    -- Constant Variable
    -- Variable Constant
    -- Variable Variable
    --
    -- As all other cases would be reduced by the evaluator, and even expensive
    -- primitives under index_int are fully unrolled.
    | Text
nm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Clash.Sized.Vector.index_int"                 = [Int
1,Int
2]
    | 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
_ CompiledPrimitive
_ = Set Int
forall a. Set a
Set.empty

-- | Helper function of 'getFunctionPlurality'
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))

-- | Looks up the plurality of a function's function argument. See
-- 'functionPlurality' for more information. If not set, the returned plurality
-- will default to /1/.
getFunctionPlurality
  :: HasCallStack
  => CompiledPrimitive
  -> [Either Term Type]
  -- ^ Arguments passed to blackbox
  -> Type
  -- ^ Result type
  -> Int
  -- ^ Argument number holding the function of interest
  -> NetlistMonad Int
  -- ^ Plurality of function. Defaults to 1. Does not err if argument isn't
  -- a function in the first place. State of monad will not be modified.
getFunctionPlurality :: CompiledPrimitive
-> [Either Term Type] -> Type -> Int -> NetlistMonad Int
getFunctionPlurality (Primitive {}) [Either Term Type]
_args Type
_resTy 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
resTy 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
resTy)
  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)