{-|
  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 (\(nms :: (Text, Text)
nms, bb :: BlackBox
bb) -> ((Text, Text)
nms, BlackBox -> Int
hashBlackbox BlackBox
bb)) [((Text, Text), BlackBox)]
includes
      hashBlackbox :: BlackBox -> Int
hashBlackbox (BBTemplate bbTemplate :: BlackBoxTemplate
bbTemplate) = BlackBoxTemplate -> Int
forall a. Hashable a => a -> Int
hash BlackBoxTemplate
bbTemplate
      hashBlackbox (BBFunction bbName :: BBName
bbName bbHash :: Int
bbHash _bbFunc :: 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 cpm :: 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) => HashMap k v -> k -> v
HashMapStrict.!) [Text]
orderedKeys

resolveTemplateSource
  :: HasCallStack
  => FilePath
  -> TemplateSource
  -> IO Text
resolveTemplateSource :: BBName -> TemplateSource -> IO Text
resolveTemplateSource _metaPath :: BBName
_metaPath (TInline text :: Text
text) =
  Text -> IO Text
forall (m :: Type -> Type) a. Monad m => a -> m a
return Text
text
resolveTemplateSource metaPath :: BBName
metaPath (TFile path :: 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' _metaPath :: BBName
_metaPath (Primitive name :: Text
name wf :: WorkInfo
wf primType :: 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' metaPath :: 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, ..} = 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 w :: 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)
    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' metaPath :: BBName
metaPath (BlackBoxHaskell bbName :: Text
bbName wf :: WorkInfo
wf usedArgs :: UsedArguments
usedArgs funcName :: BlackBoxFunctionName
funcName t :: 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 fileName :: 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 nm :: Text
nm primMap :: 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 primMap :: ResolvedPrimMap
primMap (nm :: Text
nm, guard :: 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
        (Nothing, HasBlackBox _) ->
          BBName -> GuardedResolvedPrimitive
forall a. HasCallStack => BBName -> a
error (BBName -> GuardedResolvedPrimitive)
-> BBName -> GuardedResolvedPrimitive
forall a b. (a -> b) -> a -> b
$ "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]
++ "' even"
               BBName -> BBName -> BBName
forall a. [a] -> [a] -> [a]
++ " though this value was annotated with 'HasBlackBox'."
        (Nothing, WarnNonSynthesizable _ _) ->
          BBName -> GuardedResolvedPrimitive
forall a. HasCallStack => BBName -> a
error (BBName -> GuardedResolvedPrimitive)
-> BBName -> GuardedResolvedPrimitive
forall a b. (a -> b) -> a -> b
$ "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]
++ "' even"
               BBName -> BBName -> BBName
forall a. [a] -> [a] -> [a]
++ " though this value was annotated with 'WarnNonSynthesizable'"
               BBName -> BBName -> BBName
forall a. [a] -> [a] -> [a]
++ ", implying it has a BlackBox."
        (Nothing, WarnAlways _ _) ->
          BBName -> GuardedResolvedPrimitive
forall a. HasCallStack => BBName -> a
error (BBName -> GuardedResolvedPrimitive)
-> BBName -> GuardedResolvedPrimitive
forall a b. (a -> b) -> a -> b
$ "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]
++ "' even"
               BBName -> BBName -> BBName
forall a. [a] -> [a] -> [a]
++ " though this value was annotated with 'WarnAlways'"
               BBName -> BBName -> BBName
forall a. [a] -> [a] -> [a]
++ ", implying it has a BlackBox."
        (Just _, DontTranslate) ->
          BBName -> GuardedResolvedPrimitive
forall a. HasCallStack => BBName -> a
error (Text -> BBName
TS.unpack Text
nm BBName -> BBName -> BBName
forall a. [a] -> [a] -> [a]
++ " was annotated with DontTranslate, but a "
                                 BBName -> BBName -> BBName
forall a. [a] -> [a] -> [a]
++ "BlackBox definition was found anyway.")
        (Nothing, DontTranslate) -> GuardedResolvedPrimitive
forall a. PrimitiveGuard a
DontTranslate
        (Just p :: Primitive
  Text
  ((TemplateFormat, BlackBoxFunctionName), Maybe Text)
  ()
  (Maybe Text)
p, g :: 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 unresolvedPrims :: [UnresolvedPrimitive]
unresolvedPrims primGuards :: [(Text, PrimitiveGuard ())]
primGuards filePaths :: [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
     (\filePath :: 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 ".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 nm :: Text
nm BlackBox {template :: forall a b c d. Primitive a b c d -> b
template = templ :: BlackBox
templ@(BBTemplate _), 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 t :: 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 _ = []

  getConstant :: Element -> Maybe Int
getConstant (Lit i :: Int
i)      = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
i
  getConstant (Const i :: Int
i)    = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
i
  getConstant _            = 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
== "Clash.Sized.Internal.BitVector.fromInteger#"  = [2]
    | Text
nm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "Clash.Sized.Internal.BitVector.fromInteger##" = [0,1]
    | Text
nm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "Clash.Sized.Internal.Index.fromInteger#"      = [1]
    | Text
nm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "Clash.Sized.Internal.Signed.fromInteger#"     = [1]
    | Text
nm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "Clash.Sized.Internal.Unsigned.fromInteger#"   = [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
== "Clash.Sized.Vector.index_int"                 = [1,2]
    | Text
nm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "Clash.Sized.Vector.replace_int"               = [1,2]
    | Bool
otherwise = []
constantArgs _ _ = Set Int
forall a. Set a
Set.empty

-- | Helper function of 'getFunctionPlurality'
getFunctionPlurality' :: [(Int, Int)] -> Int -> Int
getFunctionPlurality' :: [(Int, Int)] -> Int -> Int
getFunctionPlurality' functionPlurality :: [(Int, Int)]
functionPlurality n :: Int
n =
  Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe 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 {}) _args :: [Either Term Type]
_args _resTy :: Type
_resTy _n :: Int
_n = Int -> NetlistMonad Int
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure 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}) args :: [Either Term Type]
args resTy :: Type
resTy n :: 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 err :: 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 [ "Tried to determine function plurality for "
                     , Text -> BBName
TS.unpack Text
name, " by quering ", BlackBoxFunctionName -> BBName
forall a. Show a => a -> BBName
show BlackBoxFunctionName
functionName
                     , ". Function returned an error message instead:\n\n"
                     , BBName
err ]
    Right (BlackBoxMeta {[(Int, Int)]
bbFunctionPlurality :: BlackBoxMeta -> [(Int, Int)]
bbFunctionPlurality :: [(Int, Int)]
bbFunctionPlurality}, _bb :: 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}) _args :: [Either Term Type]
_args _resTy :: Type
_resTy n :: 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)