clash-lib-1.10.0: src/Clash/Netlist/BlackBox/Util.hs
{-|
Copyright : (C) 2012-2016, University of Twente,
2016-2017, Myrtle Software Ltd,
2021-2026, QBayLogic B.V.
2022 , LUMI GUIDE FIETSDETECTIE B.V.
2022 , Google Inc.
License : BSD2 (see the file LICENSE)
Maintainer : QBayLogic B.V. <devops@qbaylogic.com>
Utilties to verify blackbox contexts against templates and rendering filled
in templates
-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
module Clash.Netlist.BlackBox.Util
( renderTemplate
, lookupFunctionInstantiation
, walkElement
, verifyBlackBoxContext
, onBlackBox
, setSym
, extractLiterals
, renderBlackBox
, getUsedArguments
, canonicalizeDataFilePath
, addFilePath
, exprToString
, renderElem
, getDomainConf
, prettyBlackBox
) where
import Control.Exception (throw)
import Control.Lens
(use, (%=), _1, _2, element, (^?))
import Control.Monad (forM, (<=<), filterM)
import Control.Monad.Extra (ifM)
import Control.Monad.State (State, StateT (..), lift, gets)
import Data.Bitraversable (bitraverse)
import Data.Bool (bool)
import Data.Coerce (coerce)
import Data.Containers.ListUtils (nubOrd)
import Data.Foldable (foldrM)
import Data.Hashable (Hashable (..))
import qualified Data.HashMap.Strict as HashMap
import qualified Data.IntMap as IntMap
import Data.List (nub)
import Data.List.Extra (indexMaybe)
import qualified Data.Map as Map
import Data.Map (Map)
import Data.Maybe (mapMaybe, maybeToList, fromJust)
import Data.Monoid (Ap(getAp))
import qualified Data.Set as Set
import Data.Set (Set)
import qualified Data.Text
import Data.Text.Lazy (Text)
import qualified Data.Text.Lazy as Text
import System.Directory (doesFileExist, canonicalizePath)
import System.IO.Unsafe (unsafePerformIO)
#if MIN_VERSION_prettyprinter(1,7,0)
import qualified Prettyprinter as PP
#else
import qualified Data.Text.Prettyprint.Doc as PP
#endif
import Data.Text.Prettyprint.Doc.Extra
import GHC.Stack (HasCallStack)
import System.FilePath (replaceBaseName, takeBaseName,
takeFileName, (<.>), isAbsolute, (</>))
import Text.Printf
import Text.Read (readEither)
import Text.Trifecta.Result hiding (Err)
import Clash.Backend
(Backend (..), DomainMap, Usage (..), AggressiveXOptBB(..), RenderEnums(..))
import Clash.Netlist.BlackBox.Parser
import Clash.Netlist.BlackBox.Types
import Clash.Netlist.Types
(BlackBoxContext (..), Expr (..), HWType (..), Literal (..), Modifier (..),
Declaration(BlackBoxD))
import qualified Clash.Netlist.Id as Id
import qualified Clash.Netlist.Types as N
import Clash.Netlist.Util (typeSize, isVoid, stripAttributes, stripVoid)
import Clash.Signal.Internal
(ResetKind(..), ResetPolarity(..), InitBehavior(..), VDomainConfiguration (..))
import Clash.Util
import qualified Clash.Util.Interpolate as I
import Clash.Annotations.Primitive (HDL(VHDL))
inputHole :: Element -> Maybe Int
inputHole = \case
Text _ -> Nothing
Component _ -> Nothing
Result -> Nothing
Arg n -> pure n
ArgGen _ n -> pure n
Const n -> pure n
Lit n -> pure n
Name n -> pure n
ToVar _ n -> pure n
Sym _ _ -> Nothing
Typ nM -> nM
TypM nM -> nM
Err nM -> nM
TypElem _ -> Nothing
CompName -> Nothing
IncludeName _ -> Nothing
IndexType _ -> Nothing
Size _ -> Nothing
Length _ -> Nothing
Depth _ -> Nothing
MaxIndex _ -> Nothing
FilePath _ -> Nothing
Template _ _ -> Nothing
Gen _ -> Nothing
IF _ _ _ -> Nothing
And _ -> Nothing
IW64 -> Nothing
CmpLE _ _ -> Nothing
HdlSyn _ -> Nothing
BV _ _ _ -> Nothing
Sel _ _ -> Nothing
IsLit n -> pure n
IsVar n -> pure n
IsScalar n -> pure n
IsActiveHigh n -> pure n
Tag n -> pure n
Period n -> pure n
LongestPeriod -> Nothing
ActiveEdge _ n -> pure n
IsSync n -> pure n
IsInitDefined n -> pure n
IsActiveEnable n -> pure n
IsUndefined n -> pure n
StrCmp _ n -> pure n
OutputUsage n -> pure n
Vars n -> pure n
GenSym _ _ -> Nothing
Repeat _ _ -> Nothing
DevNull _ -> Nothing
SigD _ nM -> nM
CtxName -> Nothing
EscapedSymbol _ -> Nothing
lookupFunctionInstantiation
:: BlackBoxContext
-> Int
-> Int
-> Either
String
( Either N.BlackBox (Id.Identifier, [Declaration])
, N.Usage
, [BlackBoxTemplate]
, [BlackBoxTemplate]
, [((Data.Text.Text, Data.Text.Text), N.BlackBox)]
, BlackBoxContext
)
lookupFunctionInstantiation bbCtx n subn =
case IntMap.lookup n (bbFunctions bbCtx) of
Nothing ->
Left
( "Blackbox requested instantiation of function at argument "
++ show n
++ ", but BlackBoxContext did not contain one."
)
Just funcs ->
case indexMaybe funcs subn of
Nothing ->
Left
( "Blackbox requested at least "
++ show (subn + 1)
++ " renders of function at argument "
++ show n
++ " but found only "
++ show (length funcs)
)
Just func ->
Right func
-- | Determine if the number of normal\/literal\/function inputs of a blackbox
-- context at least matches the number of argument that is expected by the
-- template.
verifyBlackBoxContext
:: BlackBoxContext
-- ^ Blackbox to verify
-> N.BlackBox
-- ^ Template to check against
-> Maybe String
verifyBlackBoxContext bbCtx (N.BBFunction _ _ (N.TemplateFunction _ f _)) =
if f bbCtx then
Nothing
else
-- TODO: Make TemplateFunction return a string
Just ("Template function for returned False")
verifyBlackBoxContext bbCtx (N.BBTemplate t) =
orElses (concatMap (walkElement verify') t)
where
concatTups = concatMap (\(x, y) -> [x, y])
verify' e =
Just $
case e of
Lit n ->
case indexMaybe (bbInputs bbCtx) n of
Just (inp, isVoid -> False, False) ->
Just ( "Argument " ++ show n ++ " should be literal, as blackbox "
++ "used ~LIT[" ++ show n ++ "], but was:\n\n" ++ show inp)
_ -> Nothing
Const n ->
case indexMaybe (bbInputs bbCtx) n of
Just (inp, isVoid -> False, False) ->
Just ( "Argument " ++ show n ++ " should be literal, as blackbox "
++ "used ~CONST[" ++ show n ++ "], but was:\n\n" ++ show inp)
_ -> Nothing
Component (Decl n subn l') ->
case lookupFunctionInstantiation bbCtx n subn of
Left lookupErr ->
Just lookupErr
Right _ ->
orElses $
map
(verifyBlackBoxContext bbCtx . N.BBTemplate)
(concatTups l')
_ ->
case inputHole e of
Nothing ->
Nothing
Just n ->
case indexMaybe (bbInputs bbCtx) n of
Just _ -> Nothing
Nothing -> do
let str = fromJust (fmap Text.unpack (getAp $ prettyElem e))
Just ( "Blackbox used \"" ++ str ++ "\""
++ ", but only " ++ show (length (bbInputs bbCtx))
++ " arguments were passed." )
extractLiterals :: BlackBoxContext
-> [Expr]
extractLiterals = map (\case (e,_,_) -> e)
. filter (\case (_,_,b) -> b)
. bbInputs
-- | Update all the symbol references in a template, and increment the symbol
-- counter for every newly encountered symbol.
setSym
:: forall m
. Id.IdentifierSetMonad m
=> BlackBoxContext
-> BlackBoxTemplate
-> m (BlackBoxTemplate,[N.Declaration])
setSym bbCtx l = do
(a,(_,decls)) <- runStateT (mapM setSym' l) (IntMap.empty,IntMap.empty)
return (a,concatMap snd (IntMap.elems decls))
where
bbnm = Data.Text.unpack (bbName bbCtx)
setSym'
:: Element
-> StateT ( IntMap.IntMap N.IdentifierText
, IntMap.IntMap (N.IdentifierText, [N.Declaration]))
m
Element
setSym' e = case e of
ToVar nm i | i < length (bbInputs bbCtx) -> case bbInputs bbCtx !! i of
(Identifier nm0 Nothing,_,_) ->
return (ToVar [Text (Id.toLazyText nm0)] i)
(e',hwTy,_) -> do
varM <- IntMap.lookup i <$> use _2
case varM of
Nothing -> do
nm' <- lift (Id.make (Text.toStrict (concatT (Text "c$":nm))))
let decls = case typeSize hwTy of
0 -> []
_ -> [N.NetDecl Nothing nm' hwTy
,N.Assignment nm' N.Cont e' -- TODO De-hardcode Cont
]
_2 %= (IntMap.insert i (Id.toText nm',decls))
return (ToVar [Text (Id.toLazyText nm')] i)
Just (nm',_) ->
return (ToVar [Text (Text.fromStrict nm')] i)
Sym _ i -> do
symM <- IntMap.lookup i <$> use _1
case symM of
Nothing -> do
t <- Id.toText <$> lift (Id.make "c$n")
_1 %= (IntMap.insert i t)
return (Sym (Text.fromStrict t) i)
Just t -> return (Sym (Text.fromStrict t) i)
GenSym t i -> do
symM <- IntMap.lookup i <$> use _1
case symM of
Nothing -> do
t' <- Id.toText <$> lift (Id.makeBasic (Text.toStrict (concatT t)))
_1 %= (IntMap.insert i t')
return (GenSym [Text (Text.fromStrict t')] i)
Just _ ->
error ("Symbol #" ++ show (t,i)
++ " is already defined in BlackBox for: "
++ bbnm)
Component (Decl n subN l') ->
Component <$> (Decl n subN <$> mapM (bitraverse (mapM setSym') (mapM setSym')) l')
IF c t f -> IF <$> pure c <*> mapM setSym' t <*> mapM setSym' f
SigD e' m -> SigD <$> (mapM setSym' e') <*> pure m
BV t e' m -> BV <$> pure t <*> mapM setSym' e' <*> pure m
_ -> pure e
concatT :: [Element] -> Text
concatT = Text.concat . map (
\case
Text t -> t
Name i ->
case elementToText bbCtx (Name i) of
Right t -> t
Left msg ->
error $ $(curLoc) ++ "Could not convert ~NAME[" ++ show i ++ "]"
++ " to string:" ++ msg ++ "\n\nError occured while "
++ "processing blackbox for " ++ bbnm
Lit i ->
case elementToText bbCtx (Lit i) of
Right t -> t
Left msg ->
error $ $(curLoc) ++ "Could not convert ~LIT[" ++ show i ++ "]"
++ " to string:" ++ msg ++ "\n\nError occured while "
++ "processing blackbox for " ++ bbnm
Result | [(Identifier t _, _)] <- bbResults bbCtx -> Id.toLazyText t
CompName -> Id.toLazyText (bbCompName bbCtx)
CtxName ->
case bbCtxName bbCtx of
Just nm -> Text.fromStrict nm
_ | [(Identifier t _, _)] <- bbResults bbCtx -> Id.toLazyText t
_ -> error $ $(curLoc) ++ "Internal error when processing blackbox "
++ "for " ++ bbnm
_ -> error $ $(curLoc) ++ "Unexpected element in GENSYM when processing "
++ "blackbox for " ++ bbnm
)
type FileName = FilePath
-- | Canonicalizes a datafile path, keeping in mind that the path might be
-- relative to one of the import directories passed in with @-i@.
canonicalizeDataFilePath ::
-- | Import directories passed in with @-i@
[FilePath] ->
-- | File to canonicalize
FilePath ->
FilePath
canonicalizeDataFilePath idirs toCanonicalize
| isAbsolute toCanonicalize = unsafePerformIO $
ifM
(doesFileExist toCanonicalize)
(canonicalizePath toCanonicalize)
(error [I.i|Could not find data file #{show toCanonicalize}. Does it exist?|])
| otherwise = unsafePerformIO $ do
let candidates = map (</> toCanonicalize) (nubOrd idirs)
found <- filterM doesFileExist candidates
case found of
[] -> error [I.i|
Could not find data file #{show toCanonicalize}. The following directories were
searched:
#{idirs}
|]
(_:_:_) -> error [I.i|
Multiple data files for #{show toCanonicalize} found. The following candidates
were found:
#{found}
Please disambiguate data files.
|]
[c] ->
canonicalizePath c
{-# NOINLINE canonicalizeDataFilePath #-} -- To contain unsafePerformIO
-- | Select a new file name that doesn't collide with existing names. Might return
-- the same name as given if there are no collisions.
selectNewName ::
-- | Set of existing names
Set FileName ->
-- | Name for file
FileName ->
-- | Updated file name
FileName
selectNewName as a
| a `Set.member` as = selectNewName as (replaceBaseName a (takeBaseName a ++ "_"))
| otherwise = a
-- | Add a data file to a collection of existing files. Typically used in the HDL
-- backend's 'addAndSetData'.
addFilePath ::
-- | Import directories passed in with @-i@
[FilePath] ->
-- | Map of existing file paths to file names. The file names are guaranteed
-- to be unique, as long as this function is used to add new file paths.
Map FilePath FileName ->
-- | New file path to add. The canonicalized version of this file path is stored
-- in the map. See 'canonicalizeFilePath'.
FilePath ->
-- | Updated map and filename. Note that the returned filename might be different
-- from the filename in the given filepath in case of naming collisions.
(Map FilePath FileName, FileName)
addFilePath iDirs existing path =
case Map.lookup canonicalizedPath existing of
Just existingName ->
-- This path was already added, return existing map and name
(existing, existingName)
Nothing ->
-- Select a new name that doesn't collide with existing names
( Map.insert canonicalizedPath newFileName existing
, newFileName
)
where
canonicalizedPath = canonicalizeDataFilePath iDirs path
allNames = Set.fromList (Map.elems existing)
fileName = takeFileName canonicalizedPath
newFileName = selectNewName allNames fileName
-- | Render a blackbox given a certain context. Returns a filled out template
-- and a list of 'hidden' inputs that must be added to the encompassing component.
renderTemplate
:: Backend backend
=> BlackBoxContext -- ^ Context used to fill in the hole
-> BlackBoxTemplate -- ^ Blackbox template
-> State backend (Int -> Text)
renderTemplate bbCtx l = do
l' <- mapM (renderElem bbCtx) l
return (\col -> Text.concat (map ($ col) l'))
renderBlackBox
:: Backend backend
=> [BlackBoxTemplate]
-> [BlackBoxTemplate]
-> [((Data.Text.Text,Data.Text.Text), N.BlackBox)]
-> N.BlackBox
-> BlackBoxContext
-> State backend (Int -> Doc)
renderBlackBox libs imps includes bb bbCtx = do
let nms' = zipWith (\_ i -> "~INCLUDENAME[" <> Text.pack (show i) <> "]")
includes
[(0 :: Int)..]
layout = LayoutOptions (AvailablePerLine 120 0.4)
nms <-
forM includes $ \((nm,_),inc) -> do
case verifyBlackBoxContext bbCtx inc of
Nothing -> return ()
Just err0 -> do
sp <- getSrcSpan
let err1 = concat [ "Couldn't instantiate blackbox for "
, Data.Text.unpack (bbName bbCtx), ". Verification "
, "procedure reported:\n\n" ++ err0 ]
throw (ClashException sp ($(curLoc) ++ err1) Nothing)
let bbCtx' = bbCtx {bbQsysIncName = map Text.toStrict nms'}
incForHash <- onBlackBox (renderTemplate bbCtx')
(\_name _hash (N.TemplateFunction _ _ f) -> do
t <- f bbCtx'
let t' = renderLazy (layoutPretty layout t)
return (const t'))
inc
iw <- iwWidth
topNm <- getTopName
let incHash = hash (incForHash 0)
nm' = Text.concat
[ Text.fromStrict (Id.toText topNm)
, "_"
, Text.fromStrict nm
, "_"
, Text.pack (printf ("%0" ++ show (iw `div` 4) ++ "X") incHash)
]
pure nm'
let bbNamedCtx = bbCtx {bbQsysIncName = map Text.toStrict nms}
incs = snd <$> includes
bb' <- case bb of
N.BBTemplate bt -> do
t <- renderTemplate bbNamedCtx bt
return (\col -> let t1 = t (col + 2)
in if Text.null t1
then PP.emptyDoc
else PP.nest (col-2) (PP.pretty t1))
N.BBFunction _ _ (N.TemplateFunction _ _ bf) -> do
t <- bf bbNamedCtx
return (\_ -> t)
incs' <- mapM (onBlackBox (fmap (PP.pretty . ($ 0)) . renderTemplate bbNamedCtx)
(\_name _hash (N.TemplateFunction _ _ f) -> f bbNamedCtx))
incs
libs' <- mapM (fmap ($ 0) . renderTemplate bbNamedCtx) libs
imps' <- mapM (fmap ($ 0) . renderTemplate bbNamedCtx) imps
addIncludes $ zipWith3 (\nm' ((_, ext), _) inc -> (Text.unpack nm' <.> Data.Text.unpack ext, inc)) nms includes incs'
addLibraries libs'
addImports imps'
return bb'
-- | Render a single template element
renderElem
:: HasCallStack
=> Backend backend
=> BlackBoxContext
-> Element
-> State backend (Int -> Text)
renderElem b (Component (Decl n subN (l:ls))) = do
(o,oTy,_) <- idToExpr <$> bitraverse (lineToIdentifier b) (return . lineToType b) l
is <- mapM (fmap idToExpr . bitraverse (lineToIdentifier b) (return . lineToType b)) ls
sp <- getSrcSpan
case lookupFunctionInstantiation b n subN of
Right (templ0,_,libs,imps,inc,pCtx) -> do
let b' = pCtx { bbResults = [(o,oTy)], bbInputs = bbInputs pCtx ++ is }
layoutOptions = LayoutOptions (AvailablePerLine 120 0.4)
render = N.BBTemplate . parseFail b' . renderLazy . layoutPretty layoutOptions
templ1 <-
case templ0 of
Left t ->
return t
Right (nm0,ds) -> do
nm1 <- Id.next nm0
block <- getAp (blockDecl nm1 ds)
return (render block)
templ4 <-
case templ1 of
N.BBFunction {} ->
return templ1
N.BBTemplate templ2 -> do
(templ3, templDecls) <- setSym b' templ2
case templDecls of
[] ->
return (N.BBTemplate templ3)
_ -> do
nm1 <- Id.toText <$> Id.makeBasic "bb"
nm2 <- Id.makeBasic "bb"
let bbD = BlackBoxD nm1 libs imps inc (N.BBTemplate templ3) b'
block <- getAp (blockDecl nm2 (templDecls ++ [bbD]))
return (render block)
case verifyBlackBoxContext b' templ4 of
Nothing -> do
bb <- renderBlackBox libs imps inc templ4 b'
return (renderLazy . layoutPretty layoutOptions . bb)
Just err0 -> do
let err1 = concat [ "Couldn't instantiate blackbox for "
, Data.Text.unpack (bbName b), ". Verification procedure "
, "reported:\n\n" ++ err0 ]
throw (ClashException sp ($(curLoc) ++ err1) Nothing)
Left err0 ->
throw (ClashException sp ($(curLoc) ++ "renderElem: " ++ err0) Nothing)
renderElem b (SigD e m) = do
e' <- Text.concat <$> mapM (fmap ($ 0) . renderElem b) e
let ty = case m of
Nothing -> snd $ bbResult "~SIGD" b
Just n -> let (_,ty',_) = bbInputs b !! n
in ty'
t <- getAp (hdlSig e' ty)
return (const (renderOneLine t))
renderElem b (Period n) = do
let (_, ty, _) = bbInputs b !! n
case stripVoid ty of
KnownDomain _ period _ _ _ _ ->
return $ const $ Text.pack $ show period
_ ->
error $ $(curLoc) ++ "Period: Expected `KnownDomain` or `KnownConfiguration`, not: " ++ show ty
renderElem _ LongestPeriod = do
doms <- domainConfigurations
-- Longest period with a minimum of 100 ns, see:
-- https://github.com/clash-lang/clash-compiler/issues/2455
let longestPeriod = maximum (100_000 : [vPeriod v | v <- HashMap.elems doms])
return (const (Text.pack (show longestPeriod)))
renderElem b (Tag n) = do
let (_, ty, _) = bbInputs b !! n
case stripVoid ty of
KnownDomain dom _ _ _ _ _ ->
return (const (Text.pack (Data.Text.unpack dom)))
Clock dom ->
return (const (Text.pack (Data.Text.unpack dom)))
ClockN dom ->
return (const (Text.pack (Data.Text.unpack dom)))
Reset dom ->
return (const (Text.pack (Data.Text.unpack dom)))
Enable dom ->
return (const (Text.pack (Data.Text.unpack dom)))
_ ->
error $ $(curLoc) ++ "Tag: Expected `KnownDomain` or `KnownConfiguration`, not: " ++ show ty
renderElem b (IF c t f) = do
iw <- iwWidth
hdl <- gets hdlKind
syn <- hdlSyn
enums <- renderEnums
xOpt <- aggressiveXOptBB
c' <- check (coerce xOpt) iw hdl syn enums c
if c' > 0 then renderTemplate b t else renderTemplate b f
where
check :: Backend backend => Bool -> Int -> HDL -> HdlSyn -> RenderEnums -> Element -> State backend Int
check xOpt iw hdl syn enums c' = case c' of
(Size e) -> pure $ typeSize (lineToType b [e])
(Length e) -> pure $ case lineToType b [e] of
(Vector n _) -> n
Void (Just (Vector n _)) -> n
(MemBlob n _) -> n
Void (Just (MemBlob n _)) -> n
_ -> 0 -- HACK: So we can test in splitAt if one of the
-- vectors in the tuple had a zero length
(Lit n) -> pure $ case bbInputs b !! n of
(l,_,_)
| Literal _ l' <- l ->
case l' of
-- Integer, Int#, KnownNat, Natural, Word#
NumLit i -> fromInteger i
-- Bit
BitLit bl -> case bl of
N.H -> 1
N.L -> 0
_ -> error $ $(curLoc) ++ "IF: LIT bit literal must be high or low"
-- Bool
BoolLit bl -> bool 0 1 bl
_ -> error $ $(curLoc) ++ "IF: LIT must be a numeric lit"
-- Int
| DataCon (Signed _) _ [Literal _ (NumLit i)] <- l
-> fromInteger i
-- Word, SNat
| DataCon (Unsigned _) _ [Literal _ (NumLit i)] <- l
-> fromInteger i
| BlackBoxE pNm _lib _use _incl _templ bbCtx _paren <- l
, pNm `elem` ["GHC.Int.I8#", "GHC.Int.I16#", "GHC.Int.I32#", "GHC.Int.I64#"
,"GHC.Word.W8#","GHC.Word.W16#","GHC.Word.W32#","GHC.Word.W64#"
,"GHC.Types.I#","GHC.Types.W#"
]
, [Literal _ (NumLit j)] <- extractLiterals bbCtx
-> fromInteger j
k -> error $ $(curLoc) ++ ("IF: LIT must be a numeric lit:" ++ show k)
(Depth e) -> pure $ case lineToType b [e] of
(RTree n _) -> n
_ -> error $ $(curLoc) ++ "IF: treedepth of non-tree type"
IW64 -> pure $ if iw == 64 then 1 else 0
(HdlSyn s) -> pure $ if s == syn then 1 else 0
(IsVar n) -> pure $ let (e,_,_) = bbInputs b !! n
in case e of
Identifier _ Nothing -> 1
_ -> 0
(IsLit n) -> pure $ let (e,_,_) = bbInputs b !! n
in case e of
DataCon {} -> 1
Literal {} -> 1
BlackBoxE {} -> 1
_ -> 0
(IsScalar n) -> let (_,ty,_) = bbInputs b !! n
isScalar _ Bit = 1
isScalar _ Bool = 1
isScalar VHDL Integer = 1
isScalar VHDL (Sum _ _) = case enums of
RenderEnums True -> 1
RenderEnums False -> 0
isScalar _ _ = 0
in pure $ isScalar hdl ty
(IsUndefined n) -> pure $
let (e, _, _) = bbInputs b !! n
in if xOpt && checkUndefined e then 1 else 0
(IsActiveEnable n) -> pure $
let (e, ty, _) = bbInputs b !! n in
case ty of
Enable _ ->
case e of
DataCon _ _ [Literal Nothing (BoolLit True)] -> 0
-- TODO: Emit warning? If enable signal is inferred as always
-- TODO: False, the component will never be enabled. This is
-- TODO: probably not the user's intention.
DataCon _ _ [Literal Nothing (BoolLit False)] -> 1
_ -> 1
Bool ->
case e of
Literal Nothing (BoolLit True) -> 0
-- TODO: Emit warning? If enable signal is inferred as always
-- TODO: False, the component will never be enabled. This is
-- TODO: probably not the user's intention.
Literal Nothing (BoolLit False) -> 1
_ -> 1
_ ->
error $ $(curLoc) ++ "IsActiveEnable: Expected Bool or Enable, not: " ++ show ty
(ActiveEdge edgeRequested n) -> do
let (_, ty, _) = bbInputs b !! n
domConf <- getDomainConf ty
case domConf of
VDomainConfiguration _ _ edgeActual _ _ _ -> pure $
if edgeRequested == edgeActual then 1 else 0
(IsSync n) -> do
let (_, ty, _) = bbInputs b !! n
domConf <- getDomainConf ty
case domConf of
VDomainConfiguration _ _ _ Synchronous _ _ -> pure 1
VDomainConfiguration _ _ _ Asynchronous _ _ -> pure 0
(IsInitDefined n) -> do
let (_, ty, _) = bbInputs b !! n
domConf <- getDomainConf ty
case domConf of
VDomainConfiguration _ _ _ _ Defined _ -> pure 1
VDomainConfiguration _ _ _ _ Unknown _ -> pure 0
(IsActiveHigh n) -> do
let (_, ty, _) = bbInputs b !! n
domConf <- getDomainConf ty
case domConf of
VDomainConfiguration _ _ _ _ _ ActiveHigh -> pure 1
VDomainConfiguration _ _ _ _ _ ActiveLow -> pure 0
(StrCmp [Text t1] n) -> pure $
let (e,_,_) = bbInputs b !! n
in case exprToString e of
Just t2
| t1 == Text.pack t2 -> 1
| otherwise -> 0
Nothing -> error $ $(curLoc) ++ "Expected a string literal: " ++ show e
(And es) -> do
es' <- mapM (check xOpt iw hdl syn enums) es
pure $ if all (/=0) es'
then 1
else 0
CmpLE e1 e2 -> do
v1 <- check xOpt iw hdl syn enums e1
v2 <- check xOpt iw hdl syn enums e2
if v1 <= v2
then pure 1
else pure 0
_ -> error $ $(curLoc) ++ "IF: condition must be: SIZE, LENGTH, LIT, DEPTH, IW64, VIVADO, OTHERSYN, ISVAR, ISLIT, ISUNDEFINED, ISACTIVEENABLE, ACTIVEEDGE, ISSYNC, ISINITDEFINED, ISACTIVEHIGH, STRCMP, AND, ISSCALAR or CMPLE."
++ "\nGot: " ++ show c'
renderElem b e = fmap const (renderTag b e)
getDomainConf :: (Backend backend, HasCallStack) => HWType -> State backend VDomainConfiguration
getDomainConf = generalGetDomainConf domainConfigurations
generalGetDomainConf
:: forall m. (Monad m, HasCallStack)
=> (m DomainMap) -- ^ a way to get the `DomainMap`
-> HWType -> m VDomainConfiguration
generalGetDomainConf getDomainMap ty = case (snd . stripAttributes . stripVoid) ty of
KnownDomain dom period activeEdge resetKind initBehavior resetPolarity ->
pure $ VDomainConfiguration (Data.Text.unpack dom) (fromIntegral period) activeEdge resetKind initBehavior resetPolarity
Clock dom -> go dom
ClockN dom -> go dom
Reset dom -> go dom
Enable dom -> go dom
Product _DiffClock _ [Clock dom,_clkN] -> go dom
t -> error $ "Don't know how to get a Domain out of HWType: " <> show t
where
go :: HasCallStack => N.DomainName -> m VDomainConfiguration
go dom = do
doms <- getDomainMap
case HashMap.lookup dom doms of
Nothing -> error $ "Can't find domain " <> show dom <> ". Please report an issue at https://github.com/clash-lang/clash-compiler/issues."
Just conf -> pure conf
parseFail :: BlackBoxContext -> Text -> BlackBoxTemplate
parseFail b t = case runParse t of
Failure errInfo ->
error $ unlines
[ "error while parsing blackbox: " <> Data.Text.unpack (bbName b)
, "in component " <> Data.Text.unpack (Id.toText $ bbCompName b)
, "error:"
, show (_errDoc errInfo)
]
Success templ -> templ
idToExpr
:: (Text, HWType)
-> (Expr, HWType, Bool)
idToExpr (t, ty) =
(Identifier (Id.unsafeMake (Text.toStrict t)) Nothing, ty, False)
bbResult :: HasCallStack => String -> BlackBoxContext -> (Expr, HWType)
bbResult _s (bbResults -> [r]) = r
bbResult s ctx = error [I.i|
Multi result primitives not supported when using template tag #{s}. Tag used
in blackbox implementation of #{bbName ctx} |]
-- | Fill out the template corresponding to an output/input assignment of a
-- component instantiation, and turn it into a single identifier so it can
-- be used for a new blackbox context.
lineToIdentifier :: Backend backend
=> BlackBoxContext
-> BlackBoxTemplate
-> State backend Text
lineToIdentifier b = foldrM (\e a -> do
e' <- renderTag b e
return (e' `Text.append` a)
) Text.empty
lineToType :: BlackBoxContext
-> BlackBoxTemplate
-> HWType
lineToType b [(Typ Nothing)] = snd $ bbResult "~TYPO" b
lineToType b [(Typ (Just n))] = let (_,ty,_) = bbInputs b !! n
in ty
lineToType b [(TypElem t)] = case lineToType b [t] of
Vector _ elTy -> elTy
MemBlob _ m -> BitVector m
_ -> error $ $(curLoc) ++ "Element type selection of a non-vector-like type"
lineToType b [(IndexType (Lit n))] =
case bbInputs b !! n of
(Literal _ (NumLit n'),_,_) -> Index (fromInteger n')
x -> error $ $(curLoc) ++ "Index type not given a literal: " ++ show x
lineToType _ _ = error $ $(curLoc) ++ "Unexpected type manipulation"
-- | Give a context and a tagged hole (of a template), returns part of the
-- context that matches the tag of the hole.
renderTag :: Backend backend
=> BlackBoxContext
-> Element
-> State backend Text
renderTag _ (Text t) = return t
renderTag b (Result) = do
fmap renderOneLine . getAp . expr False . fst $ bbResult "~RESULT" b
renderTag b (Arg n) = do
let (e,_,_) = bbInputs b !! n
renderOneLine <$> getAp (expr True e)
renderTag b (Const n) = do
let (e,_,_) = bbInputs b !! n
renderOneLine <$> getAp (expr False e)
renderTag b t@(ArgGen k n)
| k == bbLevel b
, let (e,_,_) = bbInputs b !! n
= renderOneLine <$> getAp (expr False e)
| otherwise
= getAp (prettyElem t)
renderTag b (Lit n) =
renderOneLine <$> getAp (expr False (mkLit e))
where
(e,_,_) = bbInputs b !! n
mkLit (Literal (Just (Signed _,_)) i) = Literal Nothing i -- Integer, Int#
mkLit (Literal (Just (Unsigned _,_)) i) = Literal Nothing i -- KnownNat, Natural, Word#
mkLit (DataCon _ (DC (Void {}, _)) [Literal (Just (Signed _,_)) i]) = Literal Nothing i -- Int
mkLit (DataCon _ (DC (Void {}, _)) [Literal (Just (Unsigned _,_)) i]) = Literal Nothing i -- SNat, Word
mkLit (BlackBoxE pNm _ _ _ _ bbCtx _) | pNm `elem` ["GHC.Int.I8#", "GHC.Int.I16#", "GHC.Int.I32#", "GHC.Int.I64#"
,"GHC.Word.W8#","GHC.Word.W16#","GHC.Word.W32#","GHC.Word.W64#"
,"GHC.Types.I#","GHC.Types.W#"
]
, [Literal _ i] <- extractLiterals bbCtx
= Literal Nothing i
mkLit (BlackBoxE pNm _ _ _ _ bbCtx _) | pNm `elem` ["Clash.Sized.Internal.Signed.fromInteger#"
,"Clash.Sized.Internal.Unsigned.fromInteger#"
,"Clash.Sized.Internal.Index.fromInteger#"]
, [Literal {}, Literal _ i] <- extractLiterals bbCtx
= Literal Nothing i
mkLit i = i
renderTag b e@(Name _i) =
case elementToText b e of
Right s -> return s
Left msg -> error $ $(curLoc) ++ unwords [ "Error when reducing to string"
, "in ~NAME construct:", msg ]
renderTag _ (ToVar [Text t] _) = return t
renderTag _ (Sym t _) = return t
renderTag b (BV True es e) = do
e' <- Text.concat <$> mapM (fmap ($ 0) . renderElem b) es
let ty = lineToType b [e]
renderOneLine <$> getAp (toBV ty e')
renderTag b (BV False es e) = do
e' <- Text.concat <$> (mapM (fmap ($ 0) . renderElem b) es)
let ty = lineToType b [e]
renderOneLine <$> getAp (fromBV ty e')
renderTag b (Sel e n) =
let ty = lineToType b [e]
in renderOneLine <$> getAp (hdlRecSel ty n)
renderTag b (Typ Nothing) = fmap renderOneLine . getAp . hdlType Internal . snd $ bbResult "~TYPO" b
renderTag b (Typ (Just n)) = let (_,ty,_) = bbInputs b !! n
in renderOneLine <$> getAp (hdlType Internal ty)
renderTag b (TypM Nothing) = fmap renderOneLine . getAp . hdlTypeMark . snd $ bbResult "~TYPMO" b
renderTag b (TypM (Just n)) = let (_,ty,_) = bbInputs b !! n
in renderOneLine <$> getAp (hdlTypeMark ty)
renderTag b (Err Nothing) = fmap renderOneLine . getAp . hdlTypeErrValue . snd $ bbResult "~ERRORO" b
renderTag b (Err (Just n)) = let (_,ty,_) = bbInputs b !! n
in renderOneLine <$> getAp (hdlTypeErrValue ty)
renderTag b (Size e) = return . Text.pack . show . typeSize $ lineToType b [e]
renderTag b (Length e) = return . Text.pack . show . vecLen $ lineToType b [e]
where
vecLen (Vector n _) = n
vecLen (Void (Just (Vector n _))) = n
vecLen (MemBlob n _) = n
vecLen (Void (Just (MemBlob n _))) = n
vecLen thing =
error $ $(curLoc) ++ "vecLen of a non-vector-like type: " ++ show thing
renderTag b (Depth e) = return . Text.pack . show . treeDepth $ lineToType b [e]
where
treeDepth (RTree n _) = n
treeDepth (Void (Just (RTree n _))) = n
treeDepth thing =
error $ $(curLoc) ++ "treeDepth of a non-tree type: " ++ show thing
renderTag b (MaxIndex e) = return . Text.pack . show . vecLen $ lineToType b [e]
where
vecLen (Vector n _) = n-1
vecLen (Void (Just (Vector n _))) = n-1
vecLen (MemBlob n _) = n-1
vecLen (Void (Just (MemBlob n _))) = n-1
vecLen thing =
error $ $(curLoc) ++ "vecLen of a non-vector-like type: " ++ show thing
renderTag b e@(TypElem _) = let ty = lineToType b [e]
in renderOneLine <$> getAp (hdlType Internal ty)
renderTag _ (Gen b) = renderOneLine <$> genStmt b
renderTag _ (GenSym [Text t] _) = return t
-- Determine variables used in argument /n/.
renderTag b (Vars n) = return $ vars'
where
(e, _, _) = bbInputs b !! n
vars = map Text.fromStrict (usedVariables e)
vars' = Text.concat (map (Text.cons ',') vars)
renderTag b (IndexType (Lit n)) =
case bbInputs b !! n of
(Literal _ (NumLit n'),_,_) ->
let hty = Index (fromInteger n')
in fmap renderOneLine (getAp (hdlType Internal hty))
x -> error $ $(curLoc) ++ "Index type not given a literal: " ++ show x
renderTag b (FilePath e) = case e of
Lit n -> do
let (e',_,_) = bbInputs b !! n
case exprToString e' of
Just s -> do
s' <- addAndSetData s
return (Text.pack (show s'))
_ -> do
e2 <- getAp (prettyElem e)
error $ $(curLoc) ++ "argument of ~FILE:" ++ show e2 ++ "does not reduce to a string"
_ -> do e' <- getAp (prettyElem e)
error $ $(curLoc) ++ "~FILE expects a ~LIT[N] argument, but got: " ++ show e'
renderTag b (IncludeName n) = case indexMaybe (bbQsysIncName b) n of
Just nm -> return (Text.fromStrict nm)
_ -> error $ $(curLoc) ++ "~INCLUDENAME[" ++ show n ++ "] does not correspond to any index of the 'includes' field that is specified in the primitive definition"
renderTag b (OutputUsage n) = do
hdl <- gets hdlKind
let u = case IntMap.lookup n (bbFunctions b) of
Just ((_,u',_,_,_,_):_) -> u'
_ -> error $ $(curLoc) ++ "~OUTPUTUSAGE[" ++ show n ++ "] used where argument " ++ show n ++ " is not a function"
pure $ case (hdl, u) of
(VHDL, N.Proc N.Blocking) -> "variable"
(VHDL, _) -> "signal"
(_, N.Cont) -> "wire"
(_, _) -> "reg"
renderTag b (Repeat [es] [i]) = do
i' <- Text.unpack <$> renderTag b i
es' <- renderTag b es
let i'' = case (readEither i' :: Either String Int) of
Left msg -> error $ $(curLoc) ++ "Could not parse " ++ show i' ++ ". read reported: " ++ msg ++ "."
Right n -> n
return $ Text.concat $ take i'' $ repeat es'
renderTag b (DevNull es) = do
_ <- mapM (renderElem b) es
return $ Text.empty
renderTag b (Template filenameL sourceL) = case file of
Left msg ->
error $ $(curLoc) ++ unwords [ "Name or source in ~TEMPLATE construct"
, "did not reduce to a string."
, "'elementToText' reported:"
, msg ]
Right fstup@(filename, _source) -> do
fs <- getMemoryDataFiles
if elem filename (map fst fs)
then if not (elem fstup fs)
then error $ $(curLoc) ++ unwords [ "Multiple ~TEMPLATE constructs"
, "specifiy the same filename"
, "but different contents. Make"
, "sure these names are unique." ]
-- We replace the Template element with an empty constant, so nothing
-- ends up in the generated HDL.
else return (Text.pack "")
else do
addMemoryDataFile fstup
return (Text.pack "")
where
file = do
filename <- elementsToText b filenameL
source <- elementsToText b sourceL
return (Text.unpack filename, Text.unpack source)
renderTag b CompName = pure (Id.toLazyText (bbCompName b))
renderTag b CtxName = case bbCtxName b of
Just nm -> return (Text.fromStrict nm)
_ | Identifier t _ <- fst (bbResult "~CTXNAME" b)
-> return (Id.toLazyText t)
_ -> error "internal error"
renderTag _ (EscapedSymbol sym) = case sym of
SquareBracketOpen -> return "["
SquareBracketClose -> return "]"
renderTag _ e = do e' <- getAp (prettyElem e)
error $ $(curLoc) ++ "Unable to evaluate: " ++ show e'
-- | Compute string from a list of elements. Can interpret ~NAME string literals
-- on template level (constants).
elementsToText
:: BlackBoxContext
-> [Element]
-> Either String Text
elementsToText bbCtx elements =
foldl (\txt el -> case txt of
-- Append new string (if no error) to string so far
Right s -> (Text.append s) <$> elementToText bbCtx el
-- If previous iteration resulted in an error: stop.
msg -> msg) (Right $ Text.pack "") elements
elementToText
:: BlackBoxContext
-> Element
-> Either String Text
elementToText bbCtx (Name n) = elementToText bbCtx (Lit n)
elementToText _bbCtx (Text t) = return $ t
elementToText bbCtx (Lit n) =
case bbInputs bbCtx ^? element n of
Just (e,_,_) ->
case exprToString e of
Just t ->
Right $ Text.pack t
Nothing ->
Left $ $(curLoc) ++ unwords [ "Could not extract string from"
, show e, "referred to by"
, show (Lit n) ]
Nothing ->
Left $ $(curLoc) ++ unwords [ "Invalid literal", show (Lit n)
, "used in blackbox with context:"
, show bbCtx, "." ]
elementToText _bbCtx e = error $ "Unexpected string like: " ++ show e
-- | Extracts string from SSymbol or string literals
exprToString
:: Expr
-> Maybe String
exprToString (Literal _ (NumLit i)) = Just (show i)
exprToString (Literal _ (StringLit l)) = Just l
exprToString (BlackBoxE "Clash.Promoted.Symbol.SSymbol" _ _ _ _ ctx _) =
case bbInputs ctx of
(e0,_,_):_ -> exprToString e0
_ -> error "internal error: insufficient bbInputs"
exprToString (BlackBoxE "GHC.CString.unpackCString#" _ _ _ _ ctx _) =
case bbInputs ctx of
(e0,_,_):_ -> exprToString e0
_ -> error "internal error: insufficient bbInputs"
exprToString _ = Nothing
prettyBlackBox :: Monad m
=> BlackBoxTemplate
-> Ap m Text
prettyBlackBox bbT = Text.concat <$> mapM prettyElem bbT
prettyElem
:: (HasCallStack, Monad m)
=> Element
-> Ap m Text
prettyElem (Text t) = return t
prettyElem (Component (Decl i 0 args)) = do
args' <- mapM (\(a,b) -> (,) <$> prettyBlackBox a <*> prettyBlackBox b) args
case args' of
(arg:rest) ->
renderOneLine <$>
(nest 2 (string "~INST" <+> int i <> line <>
string "~OUTPUT" <+> string "=>" <+> string (fst arg) <+> string (snd arg) <+> string "~" <> line <>
vcat (mapM (\(a,b) -> string "~INPUT" <+> string "=>" <+> string a <+> string b <+> string "~") rest))
<> line <> string "~INST")
_ -> error "internal error: insufficient args"
prettyElem (Component (Decl {})) =
error $ $(curLoc) ++ "prettyElem can't (yet) render ~INST when subfuncion /= 0!"
prettyElem Result = return "~RESULT"
prettyElem (Arg i) = renderOneLine <$> ("~ARG" <> brackets (int i))
prettyElem (Lit i) = renderOneLine <$> (string "~LIT" <> brackets (int i))
prettyElem (Const i) = renderOneLine <$> (string "~CONST" <> brackets (int i))
prettyElem (Name i) = renderOneLine <$> (string "~NAME" <> brackets (int i))
prettyElem (ToVar es i) = do
es' <- prettyBlackBox es
renderOneLine <$> (string "~VAR" <> brackets (string es') <> brackets (int i))
prettyElem (Sym _ i) = renderOneLine <$> (string "~SYM" <> brackets (int i))
prettyElem (Typ Nothing) = return "~TYPO"
prettyElem (Typ (Just i)) = renderOneLine <$> (string "~TYP" <> brackets (int i))
prettyElem (TypM Nothing) = return "~TYPMO"
prettyElem (TypM (Just i)) = renderOneLine <$> (string "~TYPM" <> brackets (int i))
prettyElem (Err Nothing) = return "~ERRORO"
prettyElem (Err (Just i)) = renderOneLine <$> (string "~ERROR" <> brackets (int i))
prettyElem (TypElem e) = do
e' <- prettyElem e
renderOneLine <$> (string "~TYPEL" <> brackets (string e'))
prettyElem CompName = return "~COMPNAME"
prettyElem (IncludeName i) = renderOneLine <$> ("~INCLUDENAME" <> brackets (int i))
prettyElem (IndexType e) = do
e' <- prettyElem e
renderOneLine <$> (string "~INDEXTYPE" <> brackets (string e'))
prettyElem (Size e) = do
e' <- prettyElem e
renderOneLine <$> (string "~SIZE" <> brackets (string e'))
prettyElem (Length e) = do
e' <- prettyElem e
renderOneLine <$> (string "~LENGTH" <> brackets (string e'))
prettyElem (Depth e) = do
e' <- prettyElem e
renderOneLine <$> (string "~DEPTH" <> brackets (string e'))
prettyElem (MaxIndex e) = do
e' <- prettyElem e
renderOneLine <$> (string "~MAXINDEX" <> brackets (string e'))
prettyElem (FilePath e) = do
e' <- prettyElem e
renderOneLine <$> (string "~FILE" <> brackets (string e'))
prettyElem (Gen b) = if b then return "~GENERATE" else return "~ENDGENERATE"
prettyElem (IF b esT esF) = do
b' <- prettyElem b
esT' <- prettyBlackBox esT
esF' <- prettyBlackBox esF
(renderLazy . layoutCompact) <$>
(string "~IF" <+> string b' <+> string "~THEN" <>
string esT' <>
string "~ELSE" <>
string esF' <>
string "~FI")
prettyElem (And es) = renderOneLine <$>
(string "~AND" <>
(brackets (hcat (punctuate comma (mapM (string <=< prettyElem) es)))))
prettyElem (CmpLE e1 e2) = do
e1' <- prettyElem e1
e2' <- prettyElem e2
renderOneLine <$> (string "~CMPLE" <> brackets (string e1')
<> brackets (string e2'))
prettyElem IW64 = return "~IW64"
prettyElem (HdlSyn s) = case s of
Vivado -> return "~VIVADO"
_ -> return "~OTHERSYN"
prettyElem (BV b es e) = do
es' <- prettyBlackBox es
e' <- prettyBlackBox [e]
renderOneLine <$>
if b
then string "~TOBV" <> brackets (string es') <> brackets (string e')
else string "~FROMBV" <> brackets (string es') <> brackets (string e')
prettyElem (Sel e i) = do
e' <- prettyElem e
renderOneLine <$> (string "~SEL" <> brackets (string e') <> brackets (int i))
prettyElem (IsLit i) = renderOneLine <$> (string "~ISLIT" <> brackets (int i))
prettyElem (IsVar i) = renderOneLine <$> (string "~ISVAR" <> brackets (int i))
prettyElem (IsScalar i) = renderOneLine <$> (string "~ISSCALAR" <> brackets (int i))
prettyElem (IsActiveHigh i) = renderOneLine <$> (string "~ISACTIVEHIGH" <> brackets (int i))
prettyElem (IsActiveEnable i) = renderOneLine <$> (string "~ISACTIVEENABLE" <> brackets (int i))
prettyElem (IsUndefined i) = renderOneLine <$> (string "~ISUNDEFINED" <> brackets (int i))
-- Domain attributes:
prettyElem (Tag i) = renderOneLine <$> (string "~TAG" <> brackets (int i))
prettyElem (Period i) = renderOneLine <$> (string "~PERIOD" <> brackets (int i))
prettyElem LongestPeriod = return "~LONGESTPERIOD"
prettyElem (ActiveEdge e i) = renderOneLine <$> (string "~ACTIVEEDGE" <> brackets (string (Text.pack (show e))) <> brackets (int i))
prettyElem (IsSync i) = renderOneLine <$> (string "~ISSYNC" <> brackets (int i))
prettyElem (IsInitDefined i) = renderOneLine <$> (string "~ISINITDEFINED" <> brackets (int i))
prettyElem (StrCmp es i) = do
es' <- prettyBlackBox es
renderOneLine <$> (string "~STRCMP" <> brackets (string es') <> brackets (int i))
prettyElem (GenSym es i) = do
es' <- prettyBlackBox es
renderOneLine <$> (string "~GENSYM" <> brackets (string es') <> brackets (int i))
prettyElem (Repeat [es] [i]) = do
es' <- prettyElem es
i' <- prettyElem i
renderOneLine
<$> string "~REPEAT"
<> brackets (string es')
<> brackets (string i')
prettyElem (Repeat es i) = error $ $(curLoc)
++ "Unexpected number of arguments in either "
++ show es
++ " or "
++ show i
++ ". Both lists are expected to have a single element."
prettyElem (DevNull es) = do
es' <- mapM prettyElem es
renderOneLine <$> (string "~DEVNULL" <> brackets (string $ Text.concat es'))
prettyElem (SigD es mI) = do
es' <- prettyBlackBox es
renderOneLine <$>
(maybe (string "~SIGDO" <> brackets (string es'))
(((string "~SIGD" <> brackets (string es')) <>) . int)
mI)
prettyElem (Vars i) = renderOneLine <$> (string "~VARS" <> brackets (int i))
prettyElem (OutputUsage n) = renderOneLine <$> (string "~OUTPUTUSAGE" <> brackets (int n))
prettyElem (ArgGen n x) =
renderOneLine <$> (string "~ARGN" <> brackets (int n) <> brackets (int x))
prettyElem (Template bbname source) = do
bbname' <- mapM prettyElem bbname
source' <- mapM prettyElem source
renderOneLine <$> (string "~TEMPLATE"
<> brackets (string $ Text.concat bbname')
<> brackets (string $ Text.concat source'))
prettyElem CtxName = return "~CTXNAME"
prettyElem (EscapedSymbol sym) = case sym of
SquareBracketOpen -> return "[\\"
SquareBracketClose -> return "\\]"
-- | Recursively walk @Element@, applying @f@ to each element in the tree.
walkElement
:: (Element -> Maybe a)
-> Element
-> [a]
walkElement f el = maybeToList (f el) ++ walked
where
go = walkElement f
walked =
-- TODO: alternatives are purposely explicitly listed in case @Element@
-- TODO: gets extended. This way, GHC will complain about missing
-- TODO: alternatives. It would probably be better to replace it by Lens
-- TODO: logic?
case el of
Component (Decl _ _ args) ->
concatMap (\(a,b) -> concatMap go a ++ concatMap go b) args
IndexType e -> go e
FilePath e -> go e
Template bbname source ->
concatMap go bbname ++ concatMap go source
IF b esT esF ->
go b ++ concatMap go esT ++ concatMap go esF
SigD es _ -> concatMap go es
BV _ es _ -> concatMap go es
GenSym es _ -> concatMap go es
DevNull es -> concatMap go es
Text _ -> []
Result -> []
Arg _ -> []
ArgGen _ _ -> []
Const _ -> []
Lit _ -> []
Name _ -> []
ToVar es _ -> concatMap go es
Sym _ _ -> []
Typ _ -> []
TypM _ -> []
Err _ -> []
TypElem e -> go e
CompName -> []
IncludeName _ -> []
Size e -> go e
Length e -> go e
Depth e -> go e
MaxIndex e -> go e
Gen _ -> []
And es -> concatMap go es
CmpLE e1 e2 -> go e1 ++ go e2
IW64 -> []
HdlSyn _ -> []
Sel e _ -> go e
IsLit _ -> []
IsVar _ -> []
IsScalar _ -> []
Tag _ -> []
Period _ -> []
LongestPeriod -> []
ActiveEdge _ _ -> []
IsSync _ -> []
IsInitDefined _ -> []
IsActiveHigh _ -> []
IsActiveEnable _ -> []
IsUndefined _ -> []
StrCmp es _ -> concatMap go es
OutputUsage _ -> []
Vars _ -> []
Repeat es1 es2 ->
concatMap go es1 ++ concatMap go es2
CtxName -> []
EscapedSymbol _ -> []
-- | Determine variables used in an expression. Used for VHDL sensitivity list.
-- Also see: https://github.com/clash-lang/clash-compiler/issues/365
usedVariables :: Expr -> [N.IdentifierText]
usedVariables Noop = []
usedVariables (Identifier i _) = [Id.toText i]
usedVariables (DataCon _ _ es) = concatMap usedVariables es
usedVariables (DataTag _ e') = [Id.toText (either id id e')]
usedVariables (Literal {}) = []
usedVariables (ToBv _ _ e') = usedVariables e'
usedVariables (FromBv _ _ e') = usedVariables e'
usedVariables (IfThenElse e1 e2 e3) = concatMap usedVariables [e1,e2,e3]
usedVariables (BlackBoxE _ _ _ _ t bb _) = nub (sList ++ sList')
where
matchArg (Arg i) = Just i
matchArg _ = Nothing
matchVar (ToVar [Text v] _) = Just (Text.toStrict v)
matchVar _ = Nothing
t' = onBlackBox id (\_ _ _ -> []) t
usedIs = mapMaybe (indexMaybe (bbInputs bb)) (concatMap (walkElement matchArg) t')
sList = concatMap (\(e,_,_) -> usedVariables e) usedIs
sList' = concatMap (walkElement matchVar) t'
-- | Collect arguments (e.g., ~ARG, ~LIT) used in this blackbox
getUsedArguments :: N.BlackBox -> [Int]
getUsedArguments (N.BBFunction _nm _hsh (N.TemplateFunction k _ _)) = k
getUsedArguments (N.BBTemplate t) = nub (concatMap (walkElement matchArg) t)
where
matchArg =
\case
Arg i -> Just i
Component (Decl i _ _) -> Just i
Const i -> Just i
IsLit i -> Just i
IsActiveEnable i -> Just i
IsUndefined i -> Just i
Lit i -> Just i
Name i -> Just i
ToVar _ i -> Just i
-- Domain properties (only need type):
IsInitDefined _ -> Nothing
ActiveEdge _ _ -> Nothing
IsSync _ -> Nothing
Period _ -> Nothing
LongestPeriod -> Nothing
Tag _ -> Nothing
-- Others. Template tags only using types of arguments can be considered
-- "not used".
And _ -> Nothing
ArgGen _ _ -> Nothing
BV _ _ _ -> Nothing
CmpLE _ _ -> Nothing
CompName -> Nothing
Depth _ -> Nothing
DevNull _ -> Nothing
Err _ -> Nothing
FilePath _ -> Nothing
Gen _ -> Nothing
GenSym _ _ -> Nothing
HdlSyn _ -> Nothing
IF _ _ _ -> Nothing
IncludeName _ -> Nothing
IndexType _ -> Nothing
IsActiveHigh _ -> Nothing
IsVar _ -> Nothing
IsScalar _ -> Nothing
IW64 -> Nothing
Length _ -> Nothing
MaxIndex _ -> Nothing
OutputUsage _ -> Nothing
Repeat _ _ -> Nothing
Result -> Nothing
Sel _ _ -> Nothing
SigD _ _ -> Nothing
Size _ -> Nothing
StrCmp _ _ -> Nothing
Sym _ _ -> Nothing
Template _ _ -> Nothing
Text _ -> Nothing
Typ _ -> Nothing
TypElem _ -> Nothing
TypM _ -> Nothing
Vars _ -> Nothing
CtxName -> Nothing
EscapedSymbol _ -> Nothing
onBlackBox
:: (BlackBoxTemplate -> r)
-> (N.BBName -> N.BBHash -> N.TemplateFunction -> r)
-> N.BlackBox
-> r
onBlackBox f _ (N.BBTemplate t) = f t
onBlackBox _ g (N.BBFunction n h t) = g n h t
-- | Is the value of the 'Expr' fully undefined?
checkUndefined :: Expr -> Bool
checkUndefined = \case
BlackBoxE _ _ _ _ (N.BBTemplate [Err _]) _ _ -> True
BlackBoxE "Clash.Sized.Internal.BitVector.fromInteger#" [] [] [] _ bbCtx _
| [sz, mask, _val] <- bbInputs bbCtx
, (Literal _ (NumLit sz0), _, True) <- sz
, (Literal _ (NumLit mask0), _, True) <- mask
, mask0 == 2^sz0 - 1
-> True
DataCon (Product _ _ _) _ es -> and (map checkUndefined es)
_ -> False