{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE Safe #-}
-- | The Verilog backend on Hyle. With widths explicit and exact in the IR
--   (doc/hyle.md, G1), expression emission is a per-construct template: no
--   context-width reconstruction, no pattern compilation, no clock plumbing
--   through the module tree (Hyle defns are always pure -- sequential
--   externs are device-level instances), and the state machine is built
--   from the device's explicit registers rather than reconstructed from the
--   resumption layout.
--
--   Defns are emitted one module each (inlining decisions are made upstream
--   by ReWire.Hyle.Transform.inline); the device becomes the top module:
--   per-register current/next signals updated in a single clocked process,
--   wire assignments for the device lets, and one instantiation per
--   sequential-extern instance.
module ReWire.Hyle.ToVerilog (compileProgram, testbench, clockReset, defnPortNames, lastComponent, tagReg) where

import ReWire.Annotation (Annote, Annotated (ann))
import ReWire.BitVector (BV, width, bitVec, nat, showHex, zeros, ones, lsb1, szBitRep)
import ReWire.Config (Config, ResetFlag (..))
import ReWire.Hyle.Interp (Ins, subRange, inputValue, yamlPrefixes)
import ReWire.Hyle.Mangle (mangleFresh, mangleMod, pickFresh, seedNames, stripFreshTag, svReserved)
import ReWire.Error (failAt, failInternal, AstError, MonadError)
import ReWire.Hyle.Syntax as M
import ReWire.Pretty (showt)
import ReWire.Verilog.Syntax as V

import qualified ReWire.Config as C

import Control.Arrow ((&&&), first)
import Control.Lens ((^.))

import Control.Monad.State.Strict (MonadState, runStateT, modify', gets)
import Data.Char (isDigit)
import Data.HashMap.Strict (HashMap)
import Data.List (nub)
import Data.Map.Strict (Map)
import Data.Maybe (catMaybes, fromMaybe)
import Data.Text (Text)
import Numeric.Natural (Natural)

import qualified Data.HashMap.Strict as Map
import qualified Data.Map.Strict     as OMap
import qualified Data.Text           as T

-- | Per-module emission state: the fresh-name supply, the accumulated
--   signal declarations, the two backend-CSE memos (value numbering for
--   let-bound right-hand sides, and the instantiate memo for defn calls),
--   and the tagged state register (device only): its name, width, and the
--   display names for its values, plus the ST_* localparams once emitted.
data SigInfo = SigInfo
      { SigInfo -> HashMap Text Int
siFresh     :: !(HashMap Text Int)
      , SigInfo -> [Signal]
siSigs      :: ![Signal]
      , SigInfo -> Map Text Text
siExps      :: !(Map Text V.Name)             -- ^ Emitted let RHS ('expKey') -> its wire.
      , SigInfo -> Map (Text, [Text]) Text
siCalls     :: !(Map (M.GId, [Text]) V.Name)  -- ^ Emitted defn call ('expKey' args; never an extern XCall) -> its result wire.
      , SigInfo -> Maybe (Text, Size, [(Text, Value)])
siTags      :: !(Maybe (Text, M.Size, [(Text, Integer)]))
      , SigInfo -> Maybe [(Value, Text)]
siTagConsts :: !(Maybe [(Integer, V.Name)])
      }

sigInfo0 :: Maybe (Text, M.Size, [(Text, Integer)]) -> [Text] -> SigInfo
sigInfo0 :: Maybe (Text, Size, [(Text, Value)]) -> [Text] -> SigInfo
sigInfo0 Maybe (Text, Size, [(Text, Value)])
tags [Text]
ambient = HashMap Text Int
-> [Signal]
-> Map Text Text
-> Map (Text, [Text]) Text
-> Maybe (Text, Size, [(Text, Value)])
-> Maybe [(Value, Text)]
-> SigInfo
SigInfo ([Text] -> HashMap Text Int
seedNames [Text]
ambient) [] Map Text Text
forall a. Monoid a => a
mempty Map (Text, [Text]) Text
forall a. Monoid a => a
mempty Maybe (Text, Size, [(Text, Value)])
tags Maybe [(Value, Text)]
forall a. Maybe a
Nothing

-- | Identity key for compiled expressions (the CSE memos, the case-chain
--   same-scrutinee test): the full Show rendering. The derived Eq on
--   'ReWire.Verilog.Syntax.Exp' (and any derived Ord) inherits the bv
--   package's width-blind BV instances (bitVec 4 0 == bitVec 8 0), which
--   would unify expressions differing only in a literal's width -- a
--   miscompilation, since widths are load-bearing in RTL. BV's Show
--   (@[4]0@) carries the width, so the rendering is width-exact.
expKey :: V.Exp -> Text
expKey :: Exp -> Text
expKey = String -> Text
T.pack (String -> Text) -> (Exp -> String) -> Exp -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> String
forall a. Show a => a -> String
show

-- | Local value environment.
type LEnv = HashMap M.Name V.Exp

-- | Extern declarations, by name.
type XEnv = HashMap M.Name Extern

-- | A fresh signal/instance name: freshening tags stripped (so an inlined
--   @r0$i3@ renders as wire @r0@), mangled (case preserved -- Verilog is
--   case-sensitive), dodging Verilog keywords (all-lowercase and matched
--   exactly, since keywords are case-sensitive too), and suffixed out of
--   the way of every name already issued or seeded as ambient (ports and
--   registers are emitted verbatim and never pass through here -- see the
--   'sigInfo0' calls).
fresh :: MonadState SigInfo m => Text -> m V.Name
fresh :: forall (m :: * -> *). MonadState SigInfo m => Text -> m Text
fresh Text
s = do
      used <- (SigInfo -> HashMap Text Int) -> m (HashMap Text Int)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets SigInfo -> HashMap Text Int
siFresh
      let (n, used') = pickFresh "R" used $ dodge $ mangleFresh $ stripFreshTag s
      modify' $ \ SigInfo
si -> SigInfo
si { siFresh = used' }
      pure n
      where dodge :: Text -> Text
            dodge :: Text -> Text
dodge Text
n | Text -> Bool
svReserved Text
n = Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_"
                    | Bool
otherwise    = Text
n

newWire :: MonadState SigInfo m => M.Size -> Text -> m V.Name
newWire :: forall (m :: * -> *).
MonadState SigInfo m =>
Size -> Text -> m Text
newWire Size
sz Text
n = do
      n' <- Text -> m Text
forall (m :: * -> *). MonadState SigInfo m => Text -> m Text
fresh Text
n
      modify' $ \ SigInfo
si -> SigInfo
si { siSigs = siSigs si <> [mkSignal (n', sz)] }
      pure n'

-- | Bind a let-bound value: copy-propagate bare names and literals (no
--   wire, no assign), reuse the wire of an already-emitted identical
--   right-hand side (backend CSE), and otherwise emit one binding of a
--   fresh wire (seeded with the binder's name), recording it for reuse.
bindLet :: MonadState SigInfo m => M.Size -> Text -> V.Exp -> m (V.Exp, [V.Stmt])
bindLet :: forall (m :: * -> *).
MonadState SigInfo m =>
Size -> Text -> Exp -> m (Exp, [Stmt])
bindLet Size
sz Text
x = \ case
      e :: Exp
e@(LVal (V.Name Text
_)) -> (Exp, [Stmt]) -> m (Exp, [Stmt])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp
e, [])
      e :: Exp
e@LitBits {}        -> (Exp, [Stmt]) -> m (Exp, [Stmt])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp
e, [])
      Exp
e                   -> (SigInfo -> Maybe Text) -> m (Maybe Text)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
OMap.lookup (Exp -> Text
expKey Exp
e) (Map Text Text -> Maybe Text)
-> (SigInfo -> Map Text Text) -> SigInfo -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SigInfo -> Map Text Text
siExps) m (Maybe Text)
-> (Maybe Text -> m (Exp, [Stmt])) -> m (Exp, [Stmt])
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ case
            Just Text
w  -> (Exp, [Stmt]) -> m (Exp, [Stmt])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LVal -> Exp
LVal (LVal -> Exp) -> LVal -> Exp
forall a b. (a -> b) -> a -> b
$ Text -> LVal
V.Name Text
w, [])
            Maybe Text
Nothing -> do
                  (w, stmts) <- Size -> Text -> Exp -> m (Text, [Stmt])
forall (m :: * -> *).
MonadState SigInfo m =>
Size -> Text -> Exp -> m (Text, [Stmt])
bindStmts Size
sz Text
x Exp
e
                  modify' $ \ SigInfo
si -> SigInfo
si { siExps = OMap.insert (expKey e) w $ siExps si }
                  pure (LVal $ V.Name w, stmts)

-- | The statements binding a fresh name (seeded with the binder's name) to
--   a compiled right-hand side: a same-scrutinee comparison chain becomes a
--   case statement targeting a head-declared logic (2-state equivalent to
--   the ternary chain it replaces; doc/hyle.md, section 8.3), anything else
--   a net declaration assignment at the statement position (declare-at-use).
bindStmts :: MonadState SigInfo m => M.Size -> Text -> V.Exp -> m (V.Name, [V.Stmt])
bindStmts :: forall (m :: * -> *).
MonadState SigInfo m =>
Size -> Text -> Exp -> m (Text, [Stmt])
bindStmts Size
sz Text
x Exp
e = case Exp -> Maybe (Exp, [(BV, Exp)], Exp)
matchCaseChain Exp
e of
      Just (Exp, [(BV, Exp)], Exp)
chain -> do
            w <- Size -> Text -> m Text
forall (m :: * -> *).
MonadState SigInfo m =>
Size -> Text -> m Text
newWire Size
sz Text
x
            (w, ) <$> caseAssign (V.Name w) chain
      Maybe (Exp, [(BV, Exp)], Exp)
Nothing    -> do
            w <- Text -> m Text
forall (m :: * -> *). MonadState SigInfo m => Text -> m Text
fresh Text
x
            pure (w, [WireAssign (fromIntegral sz) w e])

-- | Recognize a same-scrutinee comparison chain: a conditional testing one
--   scrutinee for equality against literals (in either operand order),
--   distinct and at least two comparisons deep, ending in an unconditioned
--   else. Yields the scrutinee, the arms, and the default. Recognition is
--   on the compiled expression, so it applies wherever the shape occurs
--   (the state dispatch, constructor-tag decodes); chains that don't match
--   keep the ternary form.
matchCaseChain :: V.Exp -> Maybe (V.Exp, [(BV, V.Exp)], V.Exp)
matchCaseChain :: Exp -> Maybe (Exp, [(BV, Exp)], Exp)
matchCaseChain = \ case
      Cond Exp
c Exp
t Exp
f | Just (Exp
s, BV
v) <- Exp -> Maybe (Exp, BV)
eqLit Exp
c
                 , ([(BV, Exp)]
arms, Exp
dflt) <- Exp -> Exp -> ([(BV, Exp)], Exp)
chain Exp
s Exp
f
                 , Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [(BV, Exp)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(BV, Exp)]
arms -- at least two comparisons
                 , ((BV, Exp) -> Bool) -> [(BV, Exp)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== BV -> Int
width BV
v) (Int -> Bool) -> ((BV, Exp) -> Int) -> (BV, Exp) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BV -> Int
width (BV -> Int) -> ((BV, Exp) -> BV) -> (BV, Exp) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BV, Exp) -> BV
forall a b. (a, b) -> a
fst) [(BV, Exp)]
arms
                 , [BV] -> Bool
distinct ([BV] -> Bool) -> [BV] -> Bool
forall a b. (a -> b) -> a -> b
$ BV
v BV -> [BV] -> [BV]
forall a. a -> [a] -> [a]
: ((BV, Exp) -> BV) -> [(BV, Exp)] -> [BV]
forall a b. (a -> b) -> [a] -> [b]
map (BV, Exp) -> BV
forall a b. (a, b) -> a
fst [(BV, Exp)]
arms
                 -> (Exp, [(BV, Exp)], Exp) -> Maybe (Exp, [(BV, Exp)], Exp)
forall a. a -> Maybe a
Just (Exp
s, (BV
v, Exp
t) (BV, Exp) -> [(BV, Exp)] -> [(BV, Exp)]
forall a. a -> [a] -> [a]
: [(BV, Exp)]
arms, Exp
dflt)
      Exp
_          -> Maybe (Exp, [(BV, Exp)], Exp)
forall a. Maybe a
Nothing
      where eqLit :: V.Exp -> Maybe (V.Exp, BV)
            eqLit :: Exp -> Maybe (Exp, BV)
eqLit = \ case
                  V.Eq Exp
s (LitBits BV
v) | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Exp -> Bool
isLit Exp
s -> (Exp, BV) -> Maybe (Exp, BV)
forall a. a -> Maybe a
Just (Exp
s, BV
v)
                  V.Eq (LitBits BV
v) Exp
s | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Exp -> Bool
isLit Exp
s -> (Exp, BV) -> Maybe (Exp, BV)
forall a. a -> Maybe a
Just (Exp
s, BV
v)
                  Exp
_                                  -> Maybe (Exp, BV)
forall a. Maybe a
Nothing

            isLit :: V.Exp -> Bool
            isLit :: Exp -> Bool
isLit = \ case
                  LitBits {} -> Bool
True
                  Exp
_          -> Bool
False

            -- Scrutinees compare by 'expKey': the derived V.Exp Eq is
            -- width-blind on embedded literals.
            chain :: V.Exp -> V.Exp -> ([(BV, V.Exp)], V.Exp)
            chain :: Exp -> Exp -> ([(BV, Exp)], Exp)
chain Exp
s = \ case
                  Cond Exp
c Exp
t Exp
f | Just (Exp
s', BV
v) <- Exp -> Maybe (Exp, BV)
eqLit Exp
c, Exp -> Text
expKey Exp
s' Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Exp -> Text
expKey Exp
s -> ([(BV, Exp)] -> [(BV, Exp)])
-> ([(BV, Exp)], Exp) -> ([(BV, Exp)], Exp)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((BV
v, Exp
t) (BV, Exp) -> [(BV, Exp)] -> [(BV, Exp)]
forall a. a -> [a] -> [a]
:) (([(BV, Exp)], Exp) -> ([(BV, Exp)], Exp))
-> ([(BV, Exp)], Exp) -> ([(BV, Exp)], Exp)
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> ([(BV, Exp)], Exp)
chain Exp
s Exp
f
                  Exp
e                                                           -> ([], Exp
e)

            -- Width-exact distinctness (BV's Eq compares values only).
            distinct :: [BV] -> Bool
            distinct :: [BV] -> Bool
distinct [BV]
vs = [(Int, Value)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([(Int, Value)] -> [(Int, Value)]
forall a. Eq a => [a] -> [a]
nub ([(Int, Value)] -> [(Int, Value)])
-> [(Int, Value)] -> [(Int, Value)]
forall a b. (a -> b) -> a -> b
$ (BV -> (Int, Value)) -> [BV] -> [(Int, Value)]
forall a b. (a -> b) -> [a] -> [b]
map (\ BV
v -> (BV -> Int
width BV
v, BV -> Value
nat BV
v)) [BV]
vs) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [BV] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BV]
vs

-- | An always_comb case statement assigning the target (which must be
--   declared as a logic, not a net): one item per arm, the unconditioned
--   else as the default item (chains are total by construction, keeping
--   lint clean). The case is over a named wire (iverilog's always_comb
--   doesn't fully support constant selects in the implicit sensitivity
--   list); the scrutinee binds through 'bindLet', so names pass through
--   and repeated scrutinees share the wire.
caseAssign :: MonadState SigInfo m => V.LVal -> (V.Exp, [(BV, V.Exp)], V.Exp) -> m [V.Stmt]
caseAssign :: forall (m :: * -> *).
MonadState SigInfo m =>
LVal -> (Exp, [(BV, Exp)], Exp) -> m [Stmt]
caseAssign LVal
lv (Exp
scrut, [(BV, Exp)]
arms, Exp
dflt) = do
      (scrut', sstmts) <- Size -> Text -> Exp -> m (Exp, [Stmt])
forall (m :: * -> *).
MonadState SigInfo m =>
Size -> Text -> Exp -> m (Exp, [Stmt])
bindLet Size
scrutSz Text
"scrut" Exp
scrut
      (lps, label)     <- tagLabels scrut'
      pure $ sstmts <> lps <> [ AlwaysComb $ Case scrut' [ (label v, SeqAssign lv e) | (v, e) <- arms ]
                                           $ SeqAssign lv dflt ]
      where scrutSz :: M.Size
            scrutSz :: Size
scrutSz = case [(BV, Exp)]
arms of
                  (BV
v, Exp
_) : [(BV, Exp)]
_ -> Int -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Size) -> Int -> Size
forall a b. (a -> b) -> a -> b
$ BV -> Int
width BV
v
                  [(BV, Exp)]
_          -> Size
0

-- | Labels for case items over the given scrutinee: when it is the tagged
--   state register, emit one ST_* localparam per state (once per module;
--   localparams share the module namespace, so the names register with the
--   fresh-name supply) and label matching values with them; otherwise plain
--   literals.
tagLabels :: MonadState SigInfo m => V.Exp -> m ([V.Stmt], BV -> V.Exp)
tagLabels :: forall (m :: * -> *).
MonadState SigInfo m =>
Exp -> m ([Stmt], BV -> Exp)
tagLabels Exp
scrut = (SigInfo -> Maybe (Text, Size, [(Text, Value)]))
-> m (Maybe (Text, Size, [(Text, Value)]))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets SigInfo -> Maybe (Text, Size, [(Text, Value)])
siTags m (Maybe (Text, Size, [(Text, Value)]))
-> (Maybe (Text, Size, [(Text, Value)]) -> m ([Stmt], BV -> Exp))
-> m ([Stmt], BV -> Exp)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ case
      Just (Text
reg, Size
sz, [(Text, Value)]
tags) | Exp
scrut Exp -> Exp -> Bool
forall a. Eq a => a -> a -> Bool
== LVal -> Exp
LVal (Text -> LVal
V.Name Text
reg) -> (SigInfo -> Maybe [(Value, Text)]) -> m (Maybe [(Value, Text)])
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets SigInfo -> Maybe [(Value, Text)]
siTagConsts m (Maybe [(Value, Text)])
-> (Maybe [(Value, Text)] -> m ([Stmt], BV -> Exp))
-> m ([Stmt], BV -> Exp)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ case
            Just [(Value, Text)]
consts -> ([Stmt], BV -> Exp) -> m ([Stmt], BV -> Exp)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], [(Value, Text)] -> BV -> Exp
label [(Value, Text)]
consts)
            Maybe [(Value, Text)]
Nothing     -> do
                  consts <- ((Text, Value) -> m (Value, Text))
-> [(Text, Value)] -> m [(Value, Text)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\ (Text
nm, Value
v) -> (Value
v, ) (Text -> (Value, Text)) -> m Text -> m (Value, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> m Text
forall (m :: * -> *). MonadState SigInfo m => Text -> m Text
fresh (Text
"ST_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
T.toUpper (Text -> Text
mangleFresh Text
nm))) [(Text, Value)]
tags
                  modify' $ \ SigInfo
si -> SigInfo
si { siTagConsts = Just consts }
                  pure ([ LocalParam (fromIntegral sz) c $ bitVec (fromIntegral sz) v | (v, c) <- consts ], label consts)
      Maybe (Text, Size, [(Text, Value)])
_ -> ([Stmt], BV -> Exp) -> m ([Stmt], BV -> Exp)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], BV -> Exp
LitBits)
      where label :: [(Integer, V.Name)] -> BV -> V.Exp
            label :: [(Value, Text)] -> BV -> Exp
label [(Value, Text)]
consts BV
v = Exp -> (Text -> Exp) -> Maybe Text -> Exp
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (BV -> Exp
LitBits BV
v) (LVal -> Exp
LVal (LVal -> Exp) -> (Text -> LVal) -> Text -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> LVal
V.Name) (Maybe Text -> Exp) -> Maybe Text -> Exp
forall a b. (a -> b) -> a -> b
$ Value -> [(Value, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (BV -> Value
nat BV
v) [(Value, Text)]
consts

compileProgram :: forall m. MonadError AstError m => Config -> M.Program -> m V.Device
compileProgram :: forall (m :: * -> *).
MonadError AstError m =>
Config -> Program -> m Device
compileProgram Config
conf (M.Program [Extern]
exts [Defn]
ds Device
dev) = do
      top <- Config -> XEnv -> Device -> m Module
forall (m :: * -> *).
MonadError AstError m =>
Config -> XEnv -> Device -> m Module
compileDevice Config
conf XEnv
xenv Device
dev
      ds' <- mapM (compileDefn xenv) ds
      pure $ V.Device $ top : ds'
      where xenv :: XEnv
            xenv :: XEnv
xenv = [(Text, Extern)] -> XEnv
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList ([(Text, Extern)] -> XEnv) -> [(Text, Extern)] -> XEnv
forall a b. (a -> b) -> a -> b
$ (Extern -> (Text, Extern)) -> [Extern] -> [(Text, Extern)]
forall a b. (a -> b) -> [a] -> [b]
map (\ Extern
e -> (Extern -> Text
extName Extern
e, Extern
e)) [Extern]
exts

compileDefn :: forall m. MonadError AstError m => XEnv -> M.Defn -> m V.Module
compileDefn :: forall (m :: * -> *).
MonadError AstError m =>
XEnv -> Defn -> m Module
compileDefn XEnv
xenv d :: Defn
d@(M.Defn Annote
_ Text
g (M.Sig Annote
_ [Size]
argSzs Size
_) [Text]
ps Exp
body Bool
_ (Blind [Text]
docs)) = do
      (stmts, si) <- (StateT SigInfo m [Stmt] -> SigInfo -> m ([Stmt], SigInfo))
-> SigInfo -> StateT SigInfo m [Stmt] -> m ([Stmt], SigInfo)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT SigInfo m [Stmt] -> SigInfo -> m ([Stmt], SigInfo)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (Maybe (Text, Size, [(Text, Value)]) -> [Text] -> SigInfo
sigInfo0 Maybe (Text, Size, [(Text, Value)])
forall a. Maybe a
Nothing [Text]
ambient) (StateT SigInfo m [Stmt] -> m ([Stmt], SigInfo))
-> StateT SigInfo m [Stmt] -> m ([Stmt], SigInfo)
forall a b. (a -> b) -> a -> b
$ do
            (e, estmts) <- XEnv -> LEnv -> Exp -> StateT SigInfo m (Exp, [Stmt])
forall (m :: * -> *).
(MonadState SigInfo m, MonadError AstError m) =>
XEnv -> LEnv -> Exp -> m (Exp, [Stmt])
compileExp XEnv
xenv LEnv
lenv Exp
body
            resStmts    <- if sizeOf body > 0 then resultStmts e else pure []
            pure $ estmts <> resStmts
      -- Header comments: the unmangled Hyle name, then the defn's doc lines.
      pure $ V.Module (mangleMod g) (g : docs) (inputs <> outputs) (siSigs si) stmts
      where -- | The result port drive: a case statement for a
            --   same-scrutinee chain ("res" is an output logic), otherwise
            --   a continuous assign.
            resultStmts :: MonadState SigInfo m' => V.Exp -> m' [V.Stmt]
            resultStmts :: forall (m' :: * -> *). MonadState SigInfo m' => Exp -> m' [Stmt]
resultStmts Exp
e = case Exp -> Maybe (Exp, [(BV, Exp)], Exp)
matchCaseChain Exp
e of
                  Just (Exp, [(BV, Exp)], Exp)
chain -> LVal -> (Exp, [(BV, Exp)], Exp) -> m' [Stmt]
forall (m :: * -> *).
MonadState SigInfo m =>
LVal -> (Exp, [(BV, Exp)], Exp) -> m [Stmt]
caseAssign (Text -> LVal
V.Name Text
"res") (Exp, [(BV, Exp)], Exp)
chain
                  Maybe (Exp, [(BV, Exp)], Exp)
Nothing    -> [Stmt] -> m' [Stmt]
forall a. a -> m' a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [LVal -> Exp -> Stmt
Assign (Text -> LVal
V.Name Text
"res") Exp
e]

            -- Zero-width parameters and results are erased (doc/hyle.md,
            -- section 8.6): no ports, and references compile to nil.
            live :: [(M.Name, M.Size)]
            live :: [(Text, Size)]
live = [ (Text
x, Size
sz) | (Text
x, Size
sz) <- [Text] -> [Size] -> [(Text, Size)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
ps [Size]
argSzs, Size
sz Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
> Size
0 ]

            portNames :: [Text]
            portNames :: [Text]
portNames = Defn -> [Text]
defnPortNames Defn
d

            ambient :: [Text]
            ambient :: [Text]
ambient = [Text]
portNames [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [ Text
"res" | Exp -> Size
forall a. SizeAnnotated a => a -> Size
sizeOf Exp
body Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
> Size
0 ]

            lenv :: LEnv
            lenv :: LEnv
lenv = [(Text, Exp)] -> LEnv
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList ([(Text, Exp)] -> LEnv) -> [(Text, Exp)] -> LEnv
forall a b. (a -> b) -> a -> b
$ [ (Text
x, Exp
V.nil) | (Text
x, Size
0) <- [Text] -> [Size] -> [(Text, Size)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
ps [Size]
argSzs ]
                              [(Text, Exp)] -> [(Text, Exp)] -> [(Text, Exp)]
forall a. Semigroup a => a -> a -> a
<> [Text] -> [Exp] -> [(Text, Exp)]
forall a b. [a] -> [b] -> [(a, b)]
zip (((Text, Size) -> Text) -> [(Text, Size)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Size) -> Text
forall a b. (a, b) -> a
fst [(Text, Size)]
live) ((Text -> Exp) -> [Text] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map (LVal -> Exp
LVal (LVal -> Exp) -> (Text -> LVal) -> Text -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> LVal
V.Name) [Text]
portNames)

            inputs :: [Port]
            inputs :: [Port]
inputs = (Text -> Size -> Port) -> [Text] -> [Size] -> [Port]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (((Text, Size) -> Port) -> Text -> Size -> Port
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (((Text, Size) -> Port) -> Text -> Size -> Port)
-> ((Text, Size) -> Port) -> Text -> Size -> Port
forall a b. (a -> b) -> a -> b
$ Signal -> Port
Input (Signal -> Port)
-> ((Text, Size) -> Signal) -> (Text, Size) -> Port
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Size) -> Signal
mkSignal) [Text]
portNames ([Size] -> [Port]) -> [Size] -> [Port]
forall a b. (a -> b) -> a -> b
$ ((Text, Size) -> Size) -> [(Text, Size)] -> [Size]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Size) -> Size
forall a b. (a, b) -> b
snd [(Text, Size)]
live

            outputs :: [Port]
            outputs :: [Port]
outputs = [ Signal -> Port
Output (Signal -> Port) -> Signal -> Port
forall a b. (a -> b) -> a -> b
$ (Text, Size) -> Signal
mkSignal (Text
"res", Exp -> Size
forall a. SizeAnnotated a => a -> Size
sizeOf Exp
body) | Exp -> Size
forall a. SizeAnnotated a => a -> Size
sizeOf Exp
body Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
> Size
0 ]

-- | Display names for a defn module's live (nonzero-width) parameters,
--   shared by the Verilog and VHDL backends: VHDL component declarations
--   must agree with the entity's port names (default binding matches
--   formals to entity ports by name), so both the entity and every call
--   site derive the same list from the defn alone. Each parameter name is
--   stripped of freshening tags and mangled; @arg\<i\>@ is the fallback for
--   names that are SystemVerilog keywords, don't start with a letter or
--   underscore, or duplicate an earlier port (positionally, compared
--   case-folded: VHDL basic identifiers are case-insensitive). The result
--   port is always @res@, seeded into the dedupe so no parameter takes it.
defnPortNames :: M.Defn -> [Text]
defnPortNames :: Defn -> [Text]
defnPortNames (M.Defn Annote
_ Text
_ (M.Sig Annote
_ [Size]
argSzs Size
_) [Text]
ps Exp
_ Bool
_ Blind [Text]
_) = [Text] -> [(Int, Text)] -> [Text]
go [Text
"res"] ([(Int, Text)] -> [Text]) -> [(Int, Text)] -> [Text]
forall a b. (a -> b) -> a -> b
$ [Int] -> [Text] -> [(Int, Text)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [ Text
p | (Text
p, Size
sz) <- [Text] -> [Size] -> [(Text, Size)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
ps [Size]
argSzs, Size
sz Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
> Size
0 ]
      where go :: [Text] -> [(Int, Text)] -> [Text]
            go :: [Text] -> [(Int, Text)] -> [Text]
go [Text]
_     []              = []
            go [Text]
taken ((Int
i, Text
p) : [(Int, Text)]
rest) = Text
n Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text] -> [(Int, Text)] -> [Text]
go (Text -> Text
T.toLower Text
n Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
taken) [(Int, Text)]
rest
                  where n :: Text
                        n :: Text
n | Text -> Bool
usable Text
cand = Text
cand
                          | Bool
otherwise   = Int -> Text
fallback Int
0

                        cand :: Text
                        cand :: Text
cand = Text -> Text
mangleFresh (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
stripFreshTag Text
p

                        usable :: Text -> Bool
                        usable :: Text -> Bool
usable Text
c = Bool -> Bool
not (Text -> Bool
T.null Text
c)
                                Bool -> Bool -> Bool
&& Bool -> Bool
not (Char -> Bool
isDigit (Char -> Bool) -> Char -> Bool
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Char
Text -> Char
T.head Text
c)
                                Bool -> Bool -> Bool
&& Bool -> Bool
not (Text -> Bool
svReserved Text
c)
                                Bool -> Bool -> Bool
&& Text -> Text
T.toLower Text
c Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text]
taken

                        -- | @arg\<i\>@, itself suffixed out of the way in the
                        --   (unlikely) case a parameter is literally named
                        --   that.
                        fallback :: Int -> Text
                        fallback :: Int -> Text
fallback Int
k | Text -> Bool
usable Text
f  = Text
f
                                   | Bool
otherwise = Int -> Text
fallback (Int -> Text) -> Int -> Text
forall a b. (a -> b) -> a -> b
$ Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
                              where f :: Text
f | Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0    = Text
"arg" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. TextShow a => a -> Text
showt Int
i
                                      | Bool
otherwise = Text
"arg" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. TextShow a => a -> Text
showt Int
i Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. TextShow a => a -> Text
showt Int
k

-- | The text after the last @.@ of a qualified name (e.g. @main.getIns@ ->
--   @getIns@): the seed for instance labels.
lastComponent :: Text -> Text
lastComponent :: Text -> Text
lastComponent = (Char -> Bool) -> Text -> Text
T.takeWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'.')

-- | The register the device's tag table (devTags) names the values of.
tagReg :: Text
tagReg :: Text
tagReg = Text
"__resumption_tag"

compileDevice :: forall m. MonadError AstError m => Config -> XEnv -> M.Device -> m V.Module
compileDevice :: forall (m :: * -> *).
MonadError AstError m =>
Config -> XEnv -> Device -> m Module
compileDevice Config
conf XEnv
xenv (M.Device Annote
an Text
top [(Text, Size)]
ins [(Text, Size)]
outs [Register]
regs [Instance]
insts [Stmt]
body (Blind [(Text, Value)]
tags)) = do
      -- N.B.: a device with registers but no configured clock (--no-clock)
      -- gets no register process, so the registers hold their initial
      -- values (the flags smoke tests exercise this combination; the user
      -- owns the consequences).
      (stmts, si) <- (StateT SigInfo m [Stmt] -> SigInfo -> m ([Stmt], SigInfo))
-> SigInfo -> StateT SigInfo m [Stmt] -> m ([Stmt], SigInfo)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT SigInfo m [Stmt] -> SigInfo -> m ([Stmt], SigInfo)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (Maybe (Text, Size, [(Text, Value)]) -> [Text] -> SigInfo
sigInfo0 Maybe (Text, Size, [(Text, Value)])
tagInfo [Text]
ambient) (StateT SigInfo m [Stmt] -> m ([Stmt], SigInfo))
-> StateT SigInfo m [Stmt] -> m ([Stmt], SigInfo)
forall a b. (a -> b) -> a -> b
$ do
            instWires <- [((Text, Text), Text)] -> HashMap (Text, Text) Text
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList ([((Text, Text), Text)] -> HashMap (Text, Text) Text)
-> ([[((Text, Text), Text)]] -> [((Text, Text), Text)])
-> [[((Text, Text), Text)]]
-> HashMap (Text, Text) Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[((Text, Text), Text)]] -> [((Text, Text), Text)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[((Text, Text), Text)]] -> HashMap (Text, Text) Text)
-> StateT SigInfo m [[((Text, Text), Text)]]
-> StateT SigInfo m (HashMap (Text, Text) Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Instance -> StateT SigInfo m [((Text, Text), Text)])
-> [Instance] -> StateT SigInfo m [[((Text, Text), Text)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Instance -> StateT SigInfo m [((Text, Text), Text)]
forall (m' :: * -> *).
MonadState SigInfo m' =>
Instance -> m' [((Text, Text), Text)]
instOutWires [Instance]
insts
            (letStmts, lenv) <- foldStmts (ambientEnv instWires) body
            instStmts <- concat <$> mapM (compileInst instWires lenv) insts
            outStmts  <- concat <$> mapM (driveOut lenv) outs
            pure $ section "combinational logic" letStmts
                <> section "instances" instStmts
                <> section "outputs" outStmts
      pure $ V.Module top [] ports (siSigs si)
           $ regDecls <> stmts <> section "state register update" registerProcess
      where (Maybe Text
mclk, Maybe Text
mrst) = Config -> [Register] -> [Instance] -> (Maybe Text, Maybe Text)
clockReset Config
conf [Register]
regs [Instance]
insts

            -- | A section banner, only above a nonempty statement group.
            section :: Text -> [V.Stmt] -> [V.Stmt]
            section :: Text -> [Stmt] -> [Stmt]
section Text
_ []      = []
            section Text
banner [Stmt]
ss = Text -> Stmt
Comment Text
banner Stmt -> [Stmt] -> [Stmt]
forall a. a -> [a] -> [a]
: [Stmt]
ss

            -- | The tagged state register, when live and named by devTags.
            tagInfo :: Maybe (Text, M.Size, [(Text, Integer)])
            tagInfo :: Maybe (Text, Size, [(Text, Value)])
tagInfo = case [ (Text
x, Size
sz) | M.Register Annote
_ Text
x Size
sz BV
_ <- [Register]
liveRegs, Text
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
tagReg ] of
                  [(Text
x, Size
sz)] | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [(Text, Value)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Text, Value)]
tags -> (Text, Size, [(Text, Value)])
-> Maybe (Text, Size, [(Text, Value)])
forall a. a -> Maybe a
Just (Text
x, Size
sz, [(Text, Value)]
tags)
                  [(Text, Size)]
_                           -> Maybe (Text, Size, [(Text, Value)])
forall a. Maybe a
Nothing

            -- | Register declarations in statement position, under a banner
            --   and a legend comment (width, initial value, and -- for the
            --   tagged state register -- the state display names).
            regDecls :: [V.Stmt]
            regDecls :: [Stmt]
regDecls | [Register] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Register]
liveRegs = []
                     | Bool
otherwise     = Text -> Stmt
Comment Text
"state registers" Stmt -> [Stmt] -> [Stmt]
forall a. a -> [a] -> [a]
: (Register -> [Stmt]) -> [Register] -> [Stmt]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Register -> [Stmt]
legend [Register]
liveRegs [Stmt] -> [Stmt] -> [Stmt]
forall a. Semigroup a => a -> a -> a
<> (Signal -> Stmt) -> [Signal] -> [Stmt]
forall a b. (a -> b) -> [a] -> [b]
map Signal -> Stmt
Decl [Signal]
regSigs

            legend :: M.Register -> [V.Stmt]
            legend :: Register -> [Stmt]
legend (M.Register Annote
_ Text
x Size
sz BV
bv) = Text -> Stmt
Comment (Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Size -> Text
forall a. TextShow a => a -> Text
showt Size
sz Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" bits, init " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> BV -> Text
showHex BV
bv)
                  Stmt -> [Stmt] -> [Stmt]
forall a. a -> [a] -> [a]
: [ Text -> Stmt
Comment (Text
"  states: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.unwords [ Value -> Text
forall a. TextShow a => a -> Text
showt Value
v Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
nm | (Text
nm, Value
v) <- [(Text, Value)]
tags ]) | Text
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
tagReg, Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [(Text, Value)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Text, Value)]
tags ]

            ports :: [Port]
            ports :: [Port]
ports = (Text -> Port) -> [Text] -> [Port]
forall a b. (a -> b) -> [a] -> [b]
map (Signal -> Port
Input (Signal -> Port) -> (Text -> Signal) -> Text -> Port
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Size) -> Signal
mkSignal ((Text, Size) -> Signal)
-> (Text -> (Text, Size)) -> Text -> Signal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (, Size
1)) ([Maybe Text] -> [Text]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Text
mclk, Maybe Text
mrst])
                 [Port] -> [Port] -> [Port]
forall a. Semigroup a => a -> a -> a
<> ((Text, Size) -> Port) -> [(Text, Size)] -> [Port]
forall a b. (a -> b) -> [a] -> [b]
map (Signal -> Port
Input (Signal -> Port)
-> ((Text, Size) -> Signal) -> (Text, Size) -> Port
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Size) -> Signal
mkSignal) ([(Text, Size)] -> [(Text, Size)]
live [(Text, Size)]
ins)
                 [Port] -> [Port] -> [Port]
forall a. Semigroup a => a -> a -> a
<> ((Text, Size) -> Port) -> [(Text, Size)] -> [Port]
forall a b. (a -> b) -> [a] -> [b]
map (Signal -> Port
Output (Signal -> Port)
-> ((Text, Size) -> Signal) -> (Text, Size) -> Port
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Size) -> Signal
mkSignal) ([(Text, Size)] -> [(Text, Size)]
live [(Text, Size)]
outs)

            -- Zero-width wires, ports, and registers are erased
            -- (doc/hyle.md, section 8.6).
            live :: [(M.Name, M.Size)] -> [(M.Name, M.Size)]
            live :: [(Text, Size)] -> [(Text, Size)]
live = ((Text, Size) -> Bool) -> [(Text, Size)] -> [(Text, Size)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
> Size
0) (Size -> Bool) -> ((Text, Size) -> Size) -> (Text, Size) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Size) -> Size
forall a b. (a, b) -> b
snd)

            liveRegs :: [M.Register]
            liveRegs :: [Register]
liveRegs = [ Register
r | r :: Register
r@(M.Register Annote
_ Text
_ Size
sz BV
_) <- [Register]
regs, Size
sz Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
> Size
0 ]

            -- | Names emitted verbatim (ports, registers): the fresh-name
            --   supply must avoid them.
            ambient :: [Text]
            ambient :: [Text]
ambient = [Maybe Text] -> [Text]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Text
mclk, Maybe Text
mrst]
                   [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> ((Text, Size) -> Text) -> [(Text, Size)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Size) -> Text
forall a b. (a, b) -> a
fst ([(Text, Size)] -> [(Text, Size)]
live [(Text, Size)]
ins) [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> ((Text, Size) -> Text) -> [(Text, Size)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Size) -> Text
forall a b. (a, b) -> a
fst ([(Text, Size)] -> [(Text, Size)]
live [(Text, Size)]
outs)
                   [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [Text
x, Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_next"] | M.Register Annote
_ Text
x Size
_ BV
_ <- [Register]
liveRegs ]

            regSigs :: [Signal]
            regSigs :: [Signal]
regSigs = [[Signal]] -> [Signal]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [(Text, Size) -> Signal
mkSignal (Text
x, Size
sz), (Text, Size) -> Signal
mkSignal (Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_next", Size
sz)] | M.Register Annote
_ Text
x Size
sz BV
_ <- [Register]
liveRegs ]

            -- | Ambient names: inputs and registers read by their own
            --   (port/signal) names, instance outputs by their wires.
            ambientEnv :: HashMap (M.Name, M.Name) V.Name -> LEnv
            ambientEnv :: HashMap (Text, Text) Text -> LEnv
ambientEnv HashMap (Text, Text) Text
instWires = [(Text, Exp)] -> LEnv
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList ([(Text, Exp)] -> LEnv) -> [(Text, Exp)] -> LEnv
forall a b. (a -> b) -> a -> b
$
                     [ (Text
x, if Size
sz Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
> Size
0 then LVal -> Exp
LVal (LVal -> Exp) -> LVal -> Exp
forall a b. (a -> b) -> a -> b
$ Text -> LVal
V.Name Text
x else Exp
V.nil) | (Text
x, Size
sz) <- [(Text, Size)]
ins ]
                  [(Text, Exp)] -> [(Text, Exp)] -> [(Text, Exp)]
forall a. Semigroup a => a -> a -> a
<> [ (Text
x, if Size
sz Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
> Size
0 then LVal -> Exp
LVal (LVal -> Exp) -> LVal -> Exp
forall a b. (a -> b) -> a -> b
$ Text -> LVal
V.Name Text
x else Exp
V.nil) | M.Register Annote
_ Text
x Size
sz BV
_ <- [Register]
regs ]
                  [(Text, Exp)] -> [(Text, Exp)] -> [(Text, Exp)]
forall a. Semigroup a => a -> a -> a
<> [ (Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
q, LVal -> Exp
LVal (LVal -> Exp) -> LVal -> Exp
forall a b. (a -> b) -> a -> b
$ Text -> LVal
V.Name Text
w) | ((Text
x, Text
q), Text
w) <- HashMap (Text, Text) Text -> [((Text, Text), Text)]
forall k v. HashMap k v -> [(k, v)]
Map.toList HashMap (Text, Text) Text
instWires ]

            -- | One wire per output port of each instance, keyed by
            --   (instance, port).
            instOutWires :: MonadState SigInfo m' => M.Instance -> m' [((M.Name, M.Name), V.Name)]
            instOutWires :: forall (m' :: * -> *).
MonadState SigInfo m' =>
Instance -> m' [((Text, Text), Text)]
instOutWires (M.Instance Annote
_ Text
x Text
ex [Natural]
_) = case Text -> XEnv -> Maybe Extern
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup Text
ex XEnv
xenv of
                  Maybe Extern
Nothing -> [((Text, Text), Text)] -> m' [((Text, Text), Text)]
forall a. a -> m' a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
                  Just Extern
e  -> ((Text, Size) -> m' ((Text, Text), Text))
-> [(Text, Size)] -> m' [((Text, Text), Text)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\ (Text
q, Size
sz) -> ((Text
x, Text
q), ) (Text -> ((Text, Text), Text))
-> m' Text -> m' ((Text, Text), Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Size -> Text -> m' Text
forall (m :: * -> *).
MonadState SigInfo m =>
Size -> Text -> m Text
newWire Size
sz (Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
q)) ([(Text, Size)] -> m' [((Text, Text), Text)])
-> [(Text, Size)] -> m' [((Text, Text), Text)]
forall a b. (a -> b) -> a -> b
$ ((Text, Size) -> Bool) -> [(Text, Size)] -> [(Text, Size)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
> Size
0) (Size -> Bool) -> ((Text, Size) -> Size) -> (Text, Size) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Size) -> Size
forall a b. (a, b) -> b
snd) ([(Text, Size)] -> [(Text, Size)])
-> [(Text, Size)] -> [(Text, Size)]
forall a b. (a -> b) -> a -> b
$ Extern -> [(Text, Size)]
extOutputs Extern
e

            instWire :: HashMap (M.Name, M.Name) V.Name -> M.Name -> M.Name -> V.Name
            instWire :: HashMap (Text, Text) Text -> Text -> Text -> Text
instWire HashMap (Text, Text) Text
m Text
x Text
q = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe (Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
q) (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ (Text, Text) -> HashMap (Text, Text) Text -> Maybe Text
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup (Text
x, Text
q) HashMap (Text, Text) Text
m

            foldStmts :: (MonadState SigInfo m', MonadError AstError m') => LEnv -> [M.Stmt] -> m' ([V.Stmt], LEnv)
            foldStmts :: forall (m' :: * -> *).
(MonadState SigInfo m', MonadError AstError m') =>
LEnv -> [Stmt] -> m' ([Stmt], LEnv)
foldStmts LEnv
lenv = \ case
                  [] -> ([Stmt], LEnv) -> m' ([Stmt], LEnv)
forall a. a -> m' a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], LEnv
lenv)
                  M.SLet Annote
_ Text
x Exp
e : [Stmt]
rest | Exp -> Bool
M.isNil Exp
e -> LEnv -> [Stmt] -> m' ([Stmt], LEnv)
forall (m' :: * -> *).
(MonadState SigInfo m', MonadError AstError m') =>
LEnv -> [Stmt] -> m' ([Stmt], LEnv)
foldStmts (Text -> Exp -> LEnv -> LEnv
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
Map.insert Text
x Exp
V.nil LEnv
lenv) [Stmt]
rest
                  M.SLet Annote
_ Text
x Exp
e : [Stmt]
rest -> do
                        (e', stmts)    <- XEnv -> LEnv -> Exp -> m' (Exp, [Stmt])
forall (m :: * -> *).
(MonadState SigInfo m, MonadError AstError m) =>
XEnv -> LEnv -> Exp -> m (Exp, [Stmt])
compileExp XEnv
xenv LEnv
lenv Exp
e
                        (xv, bstmts)   <- bindLet (sizeOf e) x e'
                        (rest', lenv') <- foldStmts (Map.insert x xv lenv) rest
                        pure (stmts <> bstmts <> rest', lenv')
                  M.SNext Annote
_ Text
_ Exp
e : [Stmt]
rest | Exp -> Bool
M.isNil Exp
e -> LEnv -> [Stmt] -> m' ([Stmt], LEnv)
forall (m' :: * -> *).
(MonadState SigInfo m', MonadError AstError m') =>
LEnv -> [Stmt] -> m' ([Stmt], LEnv)
foldStmts LEnv
lenv [Stmt]
rest
                  M.SNext Annote
_ Text
x Exp
e : [Stmt]
rest -> do
                        (e', stmts) <- XEnv -> LEnv -> Exp -> m' (Exp, [Stmt])
forall (m :: * -> *).
(MonadState SigInfo m, MonadError AstError m) =>
XEnv -> LEnv -> Exp -> m (Exp, [Stmt])
compileExp XEnv
xenv LEnv
lenv Exp
e
                        (rest', lenv') <- foldStmts lenv rest
                        pure (stmts <> [Assign (V.Name $ x <> "_next") e'] <> rest', lenv')
                  M.SOutput {} : [Stmt]
rest -> LEnv -> [Stmt] -> m' ([Stmt], LEnv)
forall (m' :: * -> *).
(MonadState SigInfo m', MonadError AstError m') =>
LEnv -> [Stmt] -> m' ([Stmt], LEnv)
foldStmts LEnv
lenv [Stmt]
rest -- emitted after the lets, in port order
                  M.SInstIn {} : [Stmt]
rest -> LEnv -> [Stmt] -> m' ([Stmt], LEnv)
forall (m' :: * -> *).
(MonadState SigInfo m', MonadError AstError m') =>
LEnv -> [Stmt] -> m' ([Stmt], LEnv)
foldStmts LEnv
lenv [Stmt]
rest -- emitted with the instantiations

            driveOut :: (MonadState SigInfo m', MonadError AstError m') => LEnv -> (M.Name, M.Size) -> m' [V.Stmt]
            driveOut :: forall (m' :: * -> *).
(MonadState SigInfo m', MonadError AstError m') =>
LEnv -> (Text, Size) -> m' [Stmt]
driveOut LEnv
_ (Text
_, Size
0) = [Stmt] -> m' [Stmt]
forall a. a -> m' a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
            driveOut LEnv
lenv (Text
x, Size
_) = case [ Exp
e | M.SOutput Annote
_ Text
x' Exp
e <- [Stmt]
body, Text
x' Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
x ] of
                  [Exp
e] -> do
                        (e', stmts) <- XEnv -> LEnv -> Exp -> m' (Exp, [Stmt])
forall (m :: * -> *).
(MonadState SigInfo m, MonadError AstError m) =>
XEnv -> LEnv -> Exp -> m (Exp, [Stmt])
compileExp XEnv
xenv LEnv
lenv Exp
e
                        pure $ stmts <> [Assign (V.Name x) e']
                  [Exp]
_   -> Annote -> Text -> m' [Stmt]
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> Text -> m a
failInternal Annote
an (Text -> m' [Stmt]) -> Text -> m' [Stmt]
forall a b. (a -> b) -> a -> b
$ Text
"internal error: output " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is not driven exactly once"

            compileInst :: (MonadState SigInfo m', MonadError AstError m') => HashMap (M.Name, M.Name) V.Name -> LEnv -> M.Instance -> m' [V.Stmt]
            compileInst :: forall (m' :: * -> *).
(MonadState SigInfo m', MonadError AstError m') =>
HashMap (Text, Text) Text -> LEnv -> Instance -> m' [Stmt]
compileInst HashMap (Text, Text) Text
instWires LEnv
lenv (M.Instance Annote
an' Text
x Text
ex [Natural]
cs) = case Text -> XEnv -> Maybe Extern
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup Text
ex XEnv
xenv of
                  Maybe Extern
Nothing -> Annote -> Text -> m' [Stmt]
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> Text -> m a
failAt Annote
an' (Text -> m' [Stmt]) -> Text -> m' [Stmt]
forall a b. (a -> b) -> a -> b
$ Text
"instance " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": unknown extern: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ex
                  Just Extern
e  -> do
                        (args, stmts) <- ((((Text, Exp), [Stmt]) -> (Text, Exp))
-> [((Text, Exp), [Stmt])] -> [(Text, Exp)]
forall a b. (a -> b) -> [a] -> [b]
map ((Text, Exp), [Stmt]) -> (Text, Exp)
forall a b. (a, b) -> a
fst ([((Text, Exp), [Stmt])] -> [(Text, Exp)])
-> ([((Text, Exp), [Stmt])] -> [Stmt])
-> [((Text, Exp), [Stmt])]
-> ([(Text, Exp)], [Stmt])
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (((Text, Exp), [Stmt]) -> [Stmt])
-> [((Text, Exp), [Stmt])] -> [Stmt]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Text, Exp), [Stmt]) -> [Stmt]
forall a b. (a, b) -> b
snd) ([((Text, Exp), [Stmt])] -> ([(Text, Exp)], [Stmt]))
-> m' [((Text, Exp), [Stmt])] -> m' ([(Text, Exp)], [Stmt])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Text, Size) -> m' ((Text, Exp), [Stmt]))
-> [(Text, Size)] -> m' [((Text, Exp), [Stmt])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (LEnv -> Text -> (Text, Size) -> m' ((Text, Exp), [Stmt])
forall (m' :: * -> *).
(MonadState SigInfo m', MonadError AstError m') =>
LEnv -> Text -> (Text, Size) -> m' ((Text, Exp), [Stmt])
driveIn LEnv
lenv Text
x) (((Text, Size) -> Bool) -> [(Text, Size)] -> [(Text, Size)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
> Size
0) (Size -> Bool) -> ((Text, Size) -> Size) -> (Text, Size) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Size) -> Size
forall a b. (a, b) -> b
snd) ([(Text, Size)] -> [(Text, Size)])
-> [(Text, Size)] -> [(Text, Size)]
forall a b. (a -> b) -> a -> b
$ Extern -> [(Text, Size)]
extInputs Extern
e)
                        clkrst <- clockRstPorts e
                        inst   <- fresh x
                        -- Positional connections (clock, reset, inputs,
                        -- outputs, in declaration order): the hand-written
                        -- implementations don't know synthesized port names.
                        let outws = [ LVal -> Exp
LVal (LVal -> Exp) -> LVal -> Exp
forall a b. (a -> b) -> a -> b
$ Text -> LVal
V.Name (Text -> LVal) -> Text -> LVal
forall a b. (a -> b) -> a -> b
$ HashMap (Text, Text) Text -> Text -> Text -> Text
instWire HashMap (Text, Text) Text
instWires Text
x Text
q | (Text
q, Size
sz) <- Extern -> [(Text, Size)]
extOutputs Extern
e, Size
sz Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
> Size
0 ]
                        pure $ stmts <> [ Instantiate ex inst (zip (extGenerics e) $ map (LitBits . bitVec 32 . toInteger) cs)
                                        $ map (mempty, ) $ map snd clkrst <> map snd args <> outws ]

            clockRstPorts :: MonadError AstError m' => Extern -> m' [(V.Name, V.Exp)]
            clockRstPorts :: forall (m' :: * -> *).
MonadError AstError m' =>
Extern -> m' [(Text, Exp)]
clockRstPorts Extern
e = case Extern -> ExternKind
extKind Extern
e of
                  ExternKind
Comb      -> [(Text, Exp)] -> m' [(Text, Exp)]
forall a. a -> m' a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
                  Seq Maybe Text
mc Maybe Text
mr -> do
                        c <- Text -> Maybe Text -> Maybe Text -> m' (Maybe (Text, Exp))
forall (m' :: * -> *).
MonadError AstError m' =>
Text -> Maybe Text -> Maybe Text -> m' (Maybe (Text, Exp))
wire Text
"clock" Maybe Text
mc Maybe Text
mclk
                        r <- wire "reset" mr mrst
                        pure $ catMaybes [c, r]
                  where wire :: MonadError AstError m' => Text -> Maybe M.Name -> Maybe Text -> m' (Maybe (V.Name, V.Exp))
                        wire :: forall (m' :: * -> *).
MonadError AstError m' =>
Text -> Maybe Text -> Maybe Text -> m' (Maybe (Text, Exp))
wire Text
what Maybe Text
p Maybe Text
sig = case (Maybe Text
p, Maybe Text
sig) of
                              (Maybe Text
Nothing, Maybe Text
_)      -> Maybe (Text, Exp) -> m' (Maybe (Text, Exp))
forall a. a -> m' a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Text, Exp)
forall a. Maybe a
Nothing
                              (Just Text
p', Just Text
s) -> Maybe (Text, Exp) -> m' (Maybe (Text, Exp))
forall a. a -> m' a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Text, Exp) -> m' (Maybe (Text, Exp)))
-> Maybe (Text, Exp) -> m' (Maybe (Text, Exp))
forall a b. (a -> b) -> a -> b
$ (Text, Exp) -> Maybe (Text, Exp)
forall a. a -> Maybe a
Just (Text
p', LVal -> Exp
LVal (LVal -> Exp) -> LVal -> Exp
forall a b. (a -> b) -> a -> b
$ Text -> LVal
V.Name Text
s)
                              (Just Text
_, Maybe Text
Nothing) -> Annote -> Text -> m' (Maybe (Text, Exp))
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> Text -> m a
failAt (Extern -> Annote
forall a. Annotated a => a -> Annote
ann Extern
e) (Text -> m' (Maybe (Text, Exp))) -> Text -> m' (Maybe (Text, Exp))
forall a b. (a -> b) -> a -> b
$ Text
"external module requires a " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
what Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" signal, but we have no " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
what Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to give it."

            driveIn :: (MonadState SigInfo m', MonadError AstError m') => LEnv -> M.Name -> (M.Name, M.Size) -> m' ((V.Name, V.Exp), [V.Stmt])
            driveIn :: forall (m' :: * -> *).
(MonadState SigInfo m', MonadError AstError m') =>
LEnv -> Text -> (Text, Size) -> m' ((Text, Exp), [Stmt])
driveIn LEnv
lenv Text
x (Text
p, Size
_) = case [ Exp
e | M.SInstIn Annote
_ Text
x' Text
p' Exp
e <- [Stmt]
body, Text
x' Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
x, Text
p' Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
p ] of
                  [Exp
e] -> do
                        (e', stmts) <- XEnv -> LEnv -> Exp -> m' (Exp, [Stmt])
forall (m :: * -> *).
(MonadState SigInfo m, MonadError AstError m) =>
XEnv -> LEnv -> Exp -> m (Exp, [Stmt])
compileExp XEnv
xenv LEnv
lenv Exp
e
                        pure ((p, e'), stmts)
                  [Exp]
_   -> Annote -> Text -> m' ((Text, Exp), [Stmt])
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> Text -> m a
failInternal Annote
an (Text -> m' ((Text, Exp), [Stmt]))
-> Text -> m' ((Text, Exp), [Stmt])
forall a b. (a -> b) -> a -> b
$ Text
"internal error: instance input " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
p Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is not driven exactly once"

            -- | The single clocked process updating the registers (one
            --   nonblocking assign per register; the reset arm reloads the
            --   per-register initials), plus per-register power-on initials.
            registerProcess :: [V.Stmt]
            registerProcess :: [Stmt]
registerProcess = case ([Register]
liveRegs, Maybe Text
mclk) of
                  ([], Maybe Text
_)        -> []
                  ([Register]
_, Maybe Text
Nothing)   -> [] -- rejected above
                  ([Register]
_, Just Text
clk)  ->
                        [ Stmt -> Stmt
Initial (Stmt -> Stmt) -> Stmt -> Stmt
forall a b. (a -> b) -> a -> b
$ LVal -> Exp -> Stmt
SeqAssign (Text -> LVal
V.Name Text
x) (Exp -> Stmt) -> Exp -> Stmt
forall a b. (a -> b) -> a -> b
$ BV -> Exp
bvToExp BV
bv | M.Register Annote
_ Text
x Size
_ BV
bv <- [Register]
liveRegs ]
                        [Stmt] -> [Stmt] -> [Stmt]
forall a. Semigroup a => a -> a -> a
<> [ [Sensitivity] -> Stmt -> Stmt
Always (Text -> Sensitivity
Pos Text
clk Sensitivity -> [Sensitivity] -> [Sensitivity]
forall a. a -> [a] -> [a]
: [Sensitivity]
rstEdge) (Stmt -> Stmt) -> Stmt -> Stmt
forall a b. (a -> b) -> a -> b
$ [Stmt] -> Stmt
Block ([Stmt] -> Stmt) -> [Stmt] -> Stmt
forall a b. (a -> b) -> a -> b
$ case Maybe Text
mrst of
                                    Just Text
rst -> [ Exp -> Stmt -> Stmt -> Stmt
IfElse (Exp -> Exp -> Exp
V.Eq (LVal -> Exp
LVal (LVal -> Exp) -> LVal -> Exp
forall a b. (a -> b) -> a -> b
$ Text -> LVal
V.Name Text
rst) (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ BV -> Exp
LitBits (BV -> Exp) -> BV -> Exp
forall a b. (a -> b) -> a -> b
$ Int -> Int -> BV
forall a. Integral a => Int -> a -> BV
bitVec Int
1 (Int -> BV) -> Int -> BV
forall a b. (a -> b) -> a -> b
$ Bool -> Int
forall a. Enum a => a -> Int
fromEnum (Bool -> Int) -> Bool -> Int
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not Bool
invertRst)
                                                      ([Stmt] -> Stmt
Block [Stmt]
rstAssigns)
                                                      ([Stmt] -> Stmt
Block [Stmt]
nextAssigns) ]
                                    Maybe Text
Nothing  -> [Stmt]
nextAssigns ]

            rstAssigns, nextAssigns :: [V.Stmt]
            rstAssigns :: [Stmt]
rstAssigns  = [ LVal -> Exp -> Stmt
ParAssign (Text -> LVal
V.Name Text
x) (Exp -> Stmt) -> Exp -> Stmt
forall a b. (a -> b) -> a -> b
$ BV -> Exp
bvToExp BV
bv | M.Register Annote
_ Text
x Size
_ BV
bv <- [Register]
liveRegs ]
            nextAssigns :: [Stmt]
nextAssigns = [ LVal -> Exp -> Stmt
ParAssign (Text -> LVal
V.Name Text
x) (Exp -> Stmt) -> Exp -> Stmt
forall a b. (a -> b) -> a -> b
$ LVal -> Exp
LVal (LVal -> Exp) -> LVal -> Exp
forall a b. (a -> b) -> a -> b
$ Text -> LVal
V.Name (Text -> LVal) -> Text -> LVal
forall a b. (a -> b) -> a -> b
$ Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_next" | M.Register Annote
_ Text
x Size
_ BV
_ <- [Register]
liveRegs ]

            rstEdge :: [Sensitivity]
            rstEdge :: [Sensitivity]
rstEdge = case Maybe Text
mrst of
                  Maybe Text
Nothing              -> []
                  Just Text
_ | Bool
syncRst     -> []
                  Just Text
rst | Bool
invertRst -> [Text -> Sensitivity
Neg Text
rst]
                  Just Text
rst             -> [Text -> Sensitivity
Pos Text
rst]

            invertRst, syncRst :: Bool
            invertRst :: Bool
invertRst = ResetFlag
Inverted ResetFlag -> HashSet ResetFlag -> Bool
forall a. Eq a => a -> HashSet a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (Config
confConfig
-> Getting (HashSet ResetFlag) Config (HashSet ResetFlag)
-> HashSet ResetFlag
forall s a. s -> Getting a s a -> a
^.Getting (HashSet ResetFlag) Config (HashSet ResetFlag)
Lens' Config (HashSet ResetFlag)
C.resetFlags)
            syncRst :: Bool
syncRst   = ResetFlag
Synchronous ResetFlag -> HashSet ResetFlag -> Bool
forall a. Eq a => a -> HashSet a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (Config
confConfig
-> Getting (HashSet ResetFlag) Config (HashSet ResetFlag)
-> HashSet ResetFlag
forall s a. s -> Getting a s a -> a
^.Getting (HashSet ResetFlag) Config (HashSet ResetFlag)
Lens' Config (HashSet ResetFlag)
C.resetFlags)

-- | Clock and reset port names, when the device has them: no clock when
--   there are no registers and no instances; no reset without a clock.
clockReset :: Config -> [M.Register] -> [M.Instance] -> (Maybe Text, Maybe Text)
clockReset :: Config -> [Register] -> [Instance] -> (Maybe Text, Maybe Text)
clockReset Config
conf [Register]
regs [Instance]
insts
      | [Register] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Register]
regs Bool -> Bool -> Bool
&& [Instance] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Instance]
insts = (Maybe Text
forall a. Maybe a
Nothing, Maybe Text
forall a. Maybe a
Nothing)
      | Text -> Bool
T.null (Config
confConfig -> Getting Text Config Text -> Text
forall s a. s -> Getting a s a -> a
^.Getting Text Config Text
Lens' Config Text
C.clock)  = (Maybe Text
forall a. Maybe a
Nothing, Maybe Text
forall a. Maybe a
Nothing)
      | Text -> Bool
T.null (Config
confConfig -> Getting Text Config Text -> Text
forall s a. s -> Getting a s a -> a
^.Getting Text Config Text
Lens' Config Text
C.reset)  = (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Config
confConfig -> Getting Text Config Text -> Text
forall s a. s -> Getting a s a -> a
^.Getting Text Config Text
Lens' Config Text
C.clock, Maybe Text
forall a. Maybe a
Nothing)
      | Bool
otherwise               = (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Config
confConfig -> Getting Text Config Text -> Text
forall s a. s -> Getting a s a -> a
^.Getting Text Config Text
Lens' Config Text
C.clock, Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Config
confConfig -> Getting Text Config Text -> Text
forall s a. s -> Getting a s a -> a
^.Getting Text Config Text
Lens' Config Text
C.reset)

---

compileExps :: (MonadState SigInfo m, MonadError AstError m) => XEnv -> LEnv -> [M.Exp] -> m ([V.Exp], [V.Stmt])
compileExps :: forall (m :: * -> *).
(MonadState SigInfo m, MonadError AstError m) =>
XEnv -> LEnv -> [Exp] -> m ([Exp], [Stmt])
compileExps XEnv
xenv LEnv
lenv [Exp]
es = (((Exp, [Stmt]) -> Exp) -> [(Exp, [Stmt])] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map (Exp, [Stmt]) -> Exp
forall a b. (a, b) -> a
fst ([(Exp, [Stmt])] -> [Exp])
-> ([(Exp, [Stmt])] -> [Stmt])
-> [(Exp, [Stmt])]
-> ([Exp], [Stmt])
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& ((Exp, [Stmt]) -> [Stmt]) -> [(Exp, [Stmt])] -> [Stmt]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Exp, [Stmt]) -> [Stmt]
forall a b. (a, b) -> b
snd) ([(Exp, [Stmt])] -> ([Exp], [Stmt]))
-> m [(Exp, [Stmt])] -> m ([Exp], [Stmt])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp -> m (Exp, [Stmt])) -> [Exp] -> m [(Exp, [Stmt])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (XEnv -> LEnv -> Exp -> m (Exp, [Stmt])
forall (m :: * -> *).
(MonadState SigInfo m, MonadError AstError m) =>
XEnv -> LEnv -> Exp -> m (Exp, [Stmt])
compileExp XEnv
xenv LEnv
lenv) [Exp]
es

compileExp :: forall m. (MonadState SigInfo m, MonadError AstError m) => XEnv -> LEnv -> M.Exp -> m (V.Exp, [V.Stmt])
compileExp :: forall (m :: * -> *).
(MonadState SigInfo m, MonadError AstError m) =>
XEnv -> LEnv -> Exp -> m (Exp, [Stmt])
compileExp XEnv
xenv = LEnv -> Exp -> m (Exp, [Stmt])
go
      where go :: LEnv -> M.Exp -> m (V.Exp, [V.Stmt])
            go :: LEnv -> Exp -> m (Exp, [Stmt])
go LEnv
lenv = \ case
                  M.Lit Annote
_ BV
bv          -> (Exp, [Stmt]) -> m (Exp, [Stmt])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BV -> Exp
bvToExp BV
bv, [])
                  M.Undef Annote
_ Size
sz        -> (Exp, [Stmt]) -> m (Exp, [Stmt])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BV -> Exp
bvToExp (BV -> Exp) -> BV -> Exp
forall a b. (a -> b) -> a -> b
$ Int -> BV
zeros (Int -> BV) -> Int -> BV
forall a b. (a -> b) -> a -> b
$ Size -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Size
sz, [])
                  M.Var Annote
an Size
_ Text
x        -> case Text -> LEnv -> Maybe Exp
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup Text
x LEnv
lenv of
                        Just Exp
e  -> (Exp, [Stmt]) -> m (Exp, [Stmt])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp
e, [])
                        Maybe Exp
Nothing -> Annote -> Text -> m (Exp, [Stmt])
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> Text -> m a
failInternal Annote
an (Text -> m (Exp, [Stmt])) -> Text -> m (Exp, [Stmt])
forall a b. (a -> b) -> a -> b
$ Text
"unbound variable: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x
                  e :: Exp
e@M.Cat {}          -> ([Exp] -> Exp) -> ([Exp], [Stmt]) -> (Exp, [Stmt])
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first [Exp] -> Exp
V.cat (([Exp], [Stmt]) -> (Exp, [Stmt]))
-> m ([Exp], [Stmt]) -> m (Exp, [Stmt])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> XEnv -> LEnv -> [Exp] -> m ([Exp], [Stmt])
forall (m :: * -> *).
(MonadState SigInfo m, MonadError AstError m) =>
XEnv -> LEnv -> [Exp] -> m ([Exp], [Stmt])
compileExps XEnv
xenv LEnv
lenv (Exp -> [Exp]
gather Exp
e)
                  M.Slice Annote
_ Size
i Size
k Exp
e     -> do
                        (e', stmts) <- LEnv -> Exp -> m (Exp, [Stmt])
go LEnv
lenv Exp
e
                        (e'', stmts') <- sliceExp (sizeOf e) i k e'
                        pure (e'', stmts <> stmts')
                  M.Prim Annote
an Size
sz Op
op [Exp]
es  -> LEnv -> Annote -> Size -> Op -> [Exp] -> m (Exp, [Stmt])
compilePrim LEnv
lenv Annote
an Size
sz Op
op [Exp]
es
                  M.Call Annote
_ Size
0 Text
_ [Exp]
_      -> (Exp, [Stmt]) -> m (Exp, [Stmt])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp
V.nil, []) -- zero-width call: dead logic, erased
                  M.Call Annote
_ Size
sz Text
g [Exp]
es    -> do
                        (es', stmts) <- XEnv -> LEnv -> [Exp] -> m ([Exp], [Stmt])
forall (m :: * -> *).
(MonadState SigInfo m, MonadError AstError m) =>
XEnv -> LEnv -> [Exp] -> m ([Exp], [Stmt])
compileExps XEnv
xenv LEnv
lenv ([Exp] -> m ([Exp], [Stmt])) -> [Exp] -> m ([Exp], [Stmt])
forall a b. (a -> b) -> a -> b
$ (Exp -> Bool) -> [Exp] -> [Exp]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Exp -> Bool) -> Exp -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> Bool
M.isNil) [Exp]
es
                        -- The instantiate memo: an identical call already
                        -- has an instance in this module; reuse its result
                        -- wire (defn modules are pure, so identical
                        -- arguments mean identical outputs).
                        gets (OMap.lookup (g, map expKey es') . siCalls) >>= \ case
                              Just Text
mr -> (Exp, [Stmt]) -> m (Exp, [Stmt])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LVal -> Exp
LVal (LVal -> Exp) -> LVal -> Exp
forall a b. (a -> b) -> a -> b
$ Text -> LVal
V.Name Text
mr, [Stmt]
stmts)
                              Maybe Text
Nothing -> do
                                    mr   <- Size -> Text -> m Text
forall (m :: * -> *).
MonadState SigInfo m =>
Size -> Text -> m Text
newWire Size
sz (Text -> m Text) -> Text -> m Text
forall a b. (a -> b) -> a -> b
$ Text
g Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_out"
                                    inst <- fresh $ lastComponent g <> "_i"
                                    modify' $ \ SigInfo
si -> SigInfo
si { siCalls = OMap.insert (g, map expKey es') mr $ siCalls si }
                                    pure (LVal $ V.Name mr, stmts <> [Instantiate (mangleMod g) inst [] $ map (mempty, ) $ es' <> [LVal $ V.Name mr]])
                  -- Extern ports connect positionally (declaration order):
                  -- the hand-written Verilog implementations don't know the
                  -- synthesized names of anonymous ports.
                  M.XCall Annote
an Size
sz Text
x [Natural]
cs [Exp]
es -> case Text -> XEnv -> Maybe Extern
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup Text
x XEnv
xenv of
                        Maybe Extern
Nothing -> Annote -> Text -> m (Exp, [Stmt])
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> Text -> m a
failAt Annote
an (Text -> m (Exp, [Stmt])) -> Text -> m (Exp, [Stmt])
forall a b. (a -> b) -> a -> b
$ Text
"unknown extern: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x
                        Just Extern
ex -> do
                              (es', stmts) <- XEnv -> LEnv -> [Exp] -> m ([Exp], [Stmt])
forall (m :: * -> *).
(MonadState SigInfo m, MonadError AstError m) =>
XEnv -> LEnv -> [Exp] -> m ([Exp], [Stmt])
compileExps XEnv
xenv LEnv
lenv ([Exp] -> m ([Exp], [Stmt])) -> [Exp] -> m ([Exp], [Stmt])
forall a b. (a -> b) -> a -> b
$ (Exp -> Bool) -> [Exp] -> [Exp]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Exp -> Bool) -> Exp -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> Bool
M.isNil) [Exp]
es
                              mr           <- newWire sz "extres"
                              inst         <- fresh $ x <> "_i"
                              pure ( LVal $ V.Name mr
                                   , stmts <> [Instantiate x inst (zip (extGenerics ex) $ map (LitBits . bitVec 32 . toInteger) cs)
                                          $ map (mempty, ) $ es' <> map snd (outRanges mr (extOutputs ex))])
                  M.If Annote
_ Size
_ Exp
c Exp
t Exp
e      -> do
                        (c', stmts)   <- LEnv -> Exp -> m (Exp, [Stmt])
go LEnv
lenv Exp
c
                        (t', stmts')  <- go lenv t
                        (e', stmts'') <- go lenv e
                        pure (Cond c' t' e', stmts <> stmts' <> stmts'')
                  M.Let Annote
_ Size
_ Text
x Exp
e1 Exp
e2
                        | Exp -> Bool
M.isNil Exp
e1  -> LEnv -> Exp -> m (Exp, [Stmt])
go (Text -> Exp -> LEnv -> LEnv
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
Map.insert Text
x Exp
V.nil LEnv
lenv) Exp
e2
                        | Bool
otherwise -> do
                              (e1', stmts)  <- LEnv -> Exp -> m (Exp, [Stmt])
go LEnv
lenv Exp
e1
                              (xv, bstmts)  <- bindLet (sizeOf e1) x e1'
                              (e2', stmts') <- go (Map.insert x xv lenv) e2
                              pure (e2', stmts <> bstmts <> stmts')

            compilePrim :: LEnv -> Annote -> M.Size -> Op -> [M.Exp] -> m (V.Exp, [V.Stmt])
            compilePrim :: LEnv -> Annote -> Size -> Op -> [Exp] -> m (Exp, [Stmt])
compilePrim LEnv
lenv Annote
an Size
_sz Op
op [Exp]
es = do
                  (es', stmts) <- XEnv -> LEnv -> [Exp] -> m ([Exp], [Stmt])
forall (m :: * -> *).
(MonadState SigInfo m, MonadError AstError m) =>
XEnv -> LEnv -> [Exp] -> m ([Exp], [Stmt])
compileExps XEnv
xenv LEnv
lenv [Exp]
es
                  let pure' a
e = (a, [Stmt]) -> f (a, [Stmt])
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
e, [Stmt]
stmts)
                  case (op, es', es) of
                        (Op
M.Add   , [Exp
a, Exp
b], [Exp]
_) -> Exp -> m (Exp, [Stmt])
forall {f :: * -> *} {a}. Applicative f => a -> f (a, [Stmt])
pure' (Exp -> m (Exp, [Stmt])) -> Exp -> m (Exp, [Stmt])
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
V.Add Exp
a Exp
b
                        (Op
M.Sub   , [Exp
a, Exp
b], [Exp]
_) -> Exp -> m (Exp, [Stmt])
forall {f :: * -> *} {a}. Applicative f => a -> f (a, [Stmt])
pure' (Exp -> m (Exp, [Stmt])) -> Exp -> m (Exp, [Stmt])
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
V.Sub Exp
a Exp
b
                        (Op
M.Mul   , [Exp
a, Exp
b], [Exp]
_) -> Exp -> m (Exp, [Stmt])
forall {f :: * -> *} {a}. Applicative f => a -> f (a, [Stmt])
pure' (Exp -> m (Exp, [Stmt])) -> Exp -> m (Exp, [Stmt])
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
V.Mul Exp
a Exp
b
                        (Op
M.Pow   , [Exp
a, Exp
b], [Exp]
_) -> Exp -> m (Exp, [Stmt])
forall {f :: * -> *} {a}. Applicative f => a -> f (a, [Stmt])
pure' (Exp -> m (Exp, [Stmt])) -> Exp -> m (Exp, [Stmt])
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
V.Pow Exp
a Exp
b
                        (Op
M.UDiv  , [Exp
a, Exp
b], [Exp
_, Exp
mb]) -> Exp -> m (Exp, [Stmt])
forall {f :: * -> *} {a}. Applicative f => a -> f (a, [Stmt])
pure' (Exp -> m (Exp, [Stmt])) -> Exp -> m (Exp, [Stmt])
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp -> Exp
Cond (Exp -> Exp -> Exp
V.Eq Exp
b (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ BV -> Exp
bvToExp (BV -> Exp) -> BV -> Exp
forall a b. (a -> b) -> a -> b
$ Int -> BV
zeros (Int -> BV) -> Int -> BV
forall a b. (a -> b) -> a -> b
$ Size -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Size -> Int) -> Size -> Int
forall a b. (a -> b) -> a -> b
$ Exp -> Size
forall a. SizeAnnotated a => a -> Size
sizeOf Exp
mb) (BV -> Exp
bvToExp (BV -> Exp) -> BV -> Exp
forall a b. (a -> b) -> a -> b
$ Int -> BV
ones (Int -> BV) -> Int -> BV
forall a b. (a -> b) -> a -> b
$ Size -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Size -> Int) -> Size -> Int
forall a b. (a -> b) -> a -> b
$ Exp -> Size
forall a. SizeAnnotated a => a -> Size
sizeOf Exp
mb) (Exp -> Exp -> Exp
V.Div Exp
a Exp
b)
                        (Op
M.UMod  , [Exp
a, Exp
b], [Exp
_, Exp
mb]) -> Exp -> m (Exp, [Stmt])
forall {f :: * -> *} {a}. Applicative f => a -> f (a, [Stmt])
pure' (Exp -> m (Exp, [Stmt])) -> Exp -> m (Exp, [Stmt])
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp -> Exp
Cond (Exp -> Exp -> Exp
V.Eq Exp
b (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ BV -> Exp
bvToExp (BV -> Exp) -> BV -> Exp
forall a b. (a -> b) -> a -> b
$ Int -> BV
zeros (Int -> BV) -> Int -> BV
forall a b. (a -> b) -> a -> b
$ Size -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Size -> Int) -> Size -> Int
forall a b. (a -> b) -> a -> b
$ Exp -> Size
forall a. SizeAnnotated a => a -> Size
sizeOf Exp
mb) Exp
a (Exp -> Exp -> Exp
V.Mod Exp
a Exp
b)
                        (Op
M.And   , [Exp
a, Exp
b], [Exp]
_) -> Exp -> m (Exp, [Stmt])
forall {f :: * -> *} {a}. Applicative f => a -> f (a, [Stmt])
pure' (Exp -> m (Exp, [Stmt])) -> Exp -> m (Exp, [Stmt])
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
V.And Exp
a Exp
b
                        (Op
M.Or    , [Exp
a, Exp
b], [Exp]
_) -> Exp -> m (Exp, [Stmt])
forall {f :: * -> *} {a}. Applicative f => a -> f (a, [Stmt])
pure' (Exp -> m (Exp, [Stmt])) -> Exp -> m (Exp, [Stmt])
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
V.Or Exp
a Exp
b
                        (Op
M.XOr   , [Exp
a, Exp
b], [Exp]
_) -> Exp -> m (Exp, [Stmt])
forall {f :: * -> *} {a}. Applicative f => a -> f (a, [Stmt])
pure' (Exp -> m (Exp, [Stmt])) -> Exp -> m (Exp, [Stmt])
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
V.XOr Exp
a Exp
b
                        (Op
M.Not   , [Exp
a], [Exp]
_)    -> Exp -> m (Exp, [Stmt])
forall {f :: * -> *} {a}. Applicative f => a -> f (a, [Stmt])
pure' (Exp -> m (Exp, [Stmt])) -> Exp -> m (Exp, [Stmt])
forall a b. (a -> b) -> a -> b
$ Exp -> Exp
V.Not Exp
a
                        (Op
M.Shl   , [Exp
a, Exp
b], [Exp]
_) -> Exp -> m (Exp, [Stmt])
forall {f :: * -> *} {a}. Applicative f => a -> f (a, [Stmt])
pure' (Exp -> m (Exp, [Stmt])) -> Exp -> m (Exp, [Stmt])
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
V.LShift Exp
a Exp
b
                        (Op
M.LShr  , [Exp
a, Exp
b], [Exp]
_) -> Exp -> m (Exp, [Stmt])
forall {f :: * -> *} {a}. Applicative f => a -> f (a, [Stmt])
pure' (Exp -> m (Exp, [Stmt])) -> Exp -> m (Exp, [Stmt])
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
V.RShift Exp
a Exp
b
                        -- $unsigned(.) isolates the signed shift from the
                        -- parent expression's signedness context (function
                        -- arguments are self-determined); without it, an
                        -- enclosing unsigned operation turns >>> logical.
                        (Op
M.AShr  , [Exp
a, Exp
b], [Exp]
_) -> Exp -> m (Exp, [Stmt])
forall {f :: * -> *} {a}. Applicative f => a -> f (a, [Stmt])
pure' (Exp -> m (Exp, [Stmt])) -> Exp -> m (Exp, [Stmt])
forall a b. (a -> b) -> a -> b
$ Exp -> Exp
V.Unsigned (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
V.RShiftArith Exp
a Exp
b
                        (Op
M.Eq    , [Exp
a, Exp
b], [Exp]
_) -> Exp -> m (Exp, [Stmt])
forall {f :: * -> *} {a}. Applicative f => a -> f (a, [Stmt])
pure' (Exp -> m (Exp, [Stmt])) -> Exp -> m (Exp, [Stmt])
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
V.Eq Exp
a Exp
b
                        (Op
M.Ne    , [Exp
a, Exp
b], [Exp]
_) -> Exp -> m (Exp, [Stmt])
forall {f :: * -> *} {a}. Applicative f => a -> f (a, [Stmt])
pure' (Exp -> m (Exp, [Stmt])) -> Exp -> m (Exp, [Stmt])
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
V.NEq Exp
a Exp
b
                        (Op
M.ULt   , [Exp
a, Exp
b], [Exp]
_) -> Exp -> m (Exp, [Stmt])
forall {f :: * -> *} {a}. Applicative f => a -> f (a, [Stmt])
pure' (Exp -> m (Exp, [Stmt])) -> Exp -> m (Exp, [Stmt])
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
V.Lt Exp
a Exp
b
                        (Op
M.ULe   , [Exp
a, Exp
b], [Exp]
_) -> Exp -> m (Exp, [Stmt])
forall {f :: * -> *} {a}. Applicative f => a -> f (a, [Stmt])
pure' (Exp -> m (Exp, [Stmt])) -> Exp -> m (Exp, [Stmt])
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
V.LtEq Exp
a Exp
b
                        (Op
M.UGt   , [Exp
a, Exp
b], [Exp]
_) -> Exp -> m (Exp, [Stmt])
forall {f :: * -> *} {a}. Applicative f => a -> f (a, [Stmt])
pure' (Exp -> m (Exp, [Stmt])) -> Exp -> m (Exp, [Stmt])
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
V.Gt Exp
a Exp
b
                        (Op
M.UGe   , [Exp
a, Exp
b], [Exp]
_) -> Exp -> m (Exp, [Stmt])
forall {f :: * -> *} {a}. Applicative f => a -> f (a, [Stmt])
pure' (Exp -> m (Exp, [Stmt])) -> Exp -> m (Exp, [Stmt])
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
V.GtEq Exp
a Exp
b
                        (Op
M.SLt   , [Exp
a, Exp
b], [Exp]
_) -> Exp -> m (Exp, [Stmt])
forall {f :: * -> *} {a}. Applicative f => a -> f (a, [Stmt])
pure' (Exp -> m (Exp, [Stmt])) -> Exp -> m (Exp, [Stmt])
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
V.Lt (Exp -> Exp
Signed Exp
a) (Exp -> Exp
Signed Exp
b)
                        (Op
M.SLe   , [Exp
a, Exp
b], [Exp]
_) -> Exp -> m (Exp, [Stmt])
forall {f :: * -> *} {a}. Applicative f => a -> f (a, [Stmt])
pure' (Exp -> m (Exp, [Stmt])) -> Exp -> m (Exp, [Stmt])
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
V.LtEq (Exp -> Exp
Signed Exp
a) (Exp -> Exp
Signed Exp
b)
                        (Op
M.SGt   , [Exp
a, Exp
b], [Exp]
_) -> Exp -> m (Exp, [Stmt])
forall {f :: * -> *} {a}. Applicative f => a -> f (a, [Stmt])
pure' (Exp -> m (Exp, [Stmt])) -> Exp -> m (Exp, [Stmt])
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
V.Gt (Exp -> Exp
Signed Exp
a) (Exp -> Exp
Signed Exp
b)
                        (Op
M.SGe   , [Exp
a, Exp
b], [Exp]
_) -> Exp -> m (Exp, [Stmt])
forall {f :: * -> *} {a}. Applicative f => a -> f (a, [Stmt])
pure' (Exp -> m (Exp, [Stmt])) -> Exp -> m (Exp, [Stmt])
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
V.GtEq (Exp -> Exp
Signed Exp
a) (Exp -> Exp
Signed Exp
b)
                        -- A reduction of a zero-width operand emits the
                        -- doc/hyle.md (section 5.2) n = 0 identity
                        -- directly: the operand itself cannot be printed
                        -- (there are no zero-width Verilog expressions).
                        (Op
M.RedAnd, [Exp
_], [Exp
ma]) | Exp -> Size
forall a. SizeAnnotated a => a -> Size
M.sizeOf Exp
ma Size -> Size -> Bool
forall a. Eq a => a -> a -> Bool
== Size
0 -> Exp -> m (Exp, [Stmt])
forall {f :: * -> *} {a}. Applicative f => a -> f (a, [Stmt])
pure' (Exp -> m (Exp, [Stmt])) -> Exp -> m (Exp, [Stmt])
forall a b. (a -> b) -> a -> b
$ BV -> Exp
bvToExp (BV -> Exp) -> BV -> Exp
forall a b. (a -> b) -> a -> b
$ Int -> BV
ones Int
1
                        (Op
M.RedOr , [Exp
_], [Exp
ma]) | Exp -> Size
forall a. SizeAnnotated a => a -> Size
M.sizeOf Exp
ma Size -> Size -> Bool
forall a. Eq a => a -> a -> Bool
== Size
0 -> Exp -> m (Exp, [Stmt])
forall {f :: * -> *} {a}. Applicative f => a -> f (a, [Stmt])
pure' (Exp -> m (Exp, [Stmt])) -> Exp -> m (Exp, [Stmt])
forall a b. (a -> b) -> a -> b
$ BV -> Exp
bvToExp (BV -> Exp) -> BV -> Exp
forall a b. (a -> b) -> a -> b
$ Int -> BV
zeros Int
1
                        (Op
M.RedXOr, [Exp
_], [Exp
ma]) | Exp -> Size
forall a. SizeAnnotated a => a -> Size
M.sizeOf Exp
ma Size -> Size -> Bool
forall a. Eq a => a -> a -> Bool
== Size
0 -> Exp -> m (Exp, [Stmt])
forall {f :: * -> *} {a}. Applicative f => a -> f (a, [Stmt])
pure' (Exp -> m (Exp, [Stmt])) -> Exp -> m (Exp, [Stmt])
forall a b. (a -> b) -> a -> b
$ BV -> Exp
bvToExp (BV -> Exp) -> BV -> Exp
forall a b. (a -> b) -> a -> b
$ Int -> BV
zeros Int
1
                        (Op
M.RedAnd, [Exp
a], [Exp]
_)    -> Exp -> m (Exp, [Stmt])
forall {f :: * -> *} {a}. Applicative f => a -> f (a, [Stmt])
pure' (Exp -> m (Exp, [Stmt])) -> Exp -> m (Exp, [Stmt])
forall a b. (a -> b) -> a -> b
$ Exp -> Exp
V.RAnd Exp
a
                        (Op
M.RedOr , [Exp
a], [Exp]
_)    -> Exp -> m (Exp, [Stmt])
forall {f :: * -> *} {a}. Applicative f => a -> f (a, [Stmt])
pure' (Exp -> m (Exp, [Stmt])) -> Exp -> m (Exp, [Stmt])
forall a b. (a -> b) -> a -> b
$ Exp -> Exp
V.ROr Exp
a
                        (Op
M.RedXOr, [Exp
a], [Exp]
_)    -> Exp -> m (Exp, [Stmt])
forall {f :: * -> *} {a}. Applicative f => a -> f (a, [Stmt])
pure' (Exp -> m (Exp, [Stmt])) -> Exp -> m (Exp, [Stmt])
forall a b. (a -> b) -> a -> b
$ Exp -> Exp
V.RXOr Exp
a
                        (M.ZExt Size
m, [Exp
a], [Exp
ma])
                              | Size
m Size -> Size -> Bool
forall a. Eq a => a -> a -> Bool
== Exp -> Size
forall a. SizeAnnotated a => a -> Size
sizeOf Exp
ma -> Exp -> m (Exp, [Stmt])
forall {f :: * -> *} {a}. Applicative f => a -> f (a, [Stmt])
pure' Exp
a
                              | Bool
otherwise      -> Exp -> m (Exp, [Stmt])
forall {f :: * -> *} {a}. Applicative f => a -> f (a, [Stmt])
pure' (Exp -> m (Exp, [Stmt])) -> Exp -> m (Exp, [Stmt])
forall a b. (a -> b) -> a -> b
$ [Exp] -> Exp
V.cat [BV -> Exp
bvToExp (BV -> Exp) -> BV -> Exp
forall a b. (a -> b) -> a -> b
$ Int -> BV
zeros (Int -> BV) -> Int -> BV
forall a b. (a -> b) -> a -> b
$ Size -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Size
m Size -> Size -> Size
forall a. Num a => a -> a -> a
- Exp -> Size
forall a. SizeAnnotated a => a -> Size
sizeOf Exp
ma), Exp
a]
                        (M.Trunc Size
m, [Exp
a], [Exp
ma]) -> do
                              (a', stmts') <- Size -> Size -> Size -> Exp -> m (Exp, [Stmt])
sliceExp (Exp -> Size
forall a. SizeAnnotated a => a -> Size
sizeOf Exp
ma) Size
0 Size
m Exp
a
                              pure (a', stmts <> stmts')
                        (M.SExt Size
m, [Exp
a], [Exp
ma])
                              | Size
m Size -> Size -> Bool
forall a. Eq a => a -> a -> Bool
== Exp -> Size
forall a. SizeAnnotated a => a -> Size
sizeOf Exp
ma -> Exp -> m (Exp, [Stmt])
forall {f :: * -> *} {a}. Applicative f => a -> f (a, [Stmt])
pure' Exp
a
                              | Bool
otherwise      -> do
                                    (msb, stmts') <- Size -> Size -> Size -> Exp -> m (Exp, [Stmt])
sliceExp (Exp -> Size
forall a. SizeAnnotated a => a -> Size
sizeOf Exp
ma) (Size -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Exp -> Size
forall a. SizeAnnotated a => a -> Size
sizeOf Exp
ma) Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
1) Size
1 Exp
a
                                    pure (V.cat [Repl (toLit $ fromIntegral $ m - sizeOf ma) msb, a], stmts <> stmts')
                        (M.Rep Natural
k, [Exp
a], [Exp]
_)
                              | Natural
k Natural -> Natural -> Bool
forall a. Eq a => a -> a -> Bool
== Natural
0    -> Exp -> m (Exp, [Stmt])
forall {f :: * -> *} {a}. Applicative f => a -> f (a, [Stmt])
pure' Exp
V.nil
                              | Bool
otherwise -> Exp -> m (Exp, [Stmt])
forall {f :: * -> *} {a}. Applicative f => a -> f (a, [Stmt])
pure' (Exp -> m (Exp, [Stmt])) -> Exp -> m (Exp, [Stmt])
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
Repl (Natural -> Exp
toLit Natural
k) Exp
a
                        (Op, [Exp], [Exp])
_ -> Annote -> Text -> m (Exp, [Stmt])
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> Text -> m a
failInternal Annote
an (Text -> m (Exp, [Stmt])) -> Text -> m (Exp, [Stmt])
forall a b. (a -> b) -> a -> b
$ Text
"ill-formed primitive application: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Op -> Text
opName Op
op Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" with " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. TextShow a => a -> Text
showt ([Exp] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Exp]
es) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" arguments"

            -- | Slice a compiled expression: ranges on names and literals
            --   directly; anything else through a fresh wire (declared at
            --   use).
            sliceExp :: M.Size -> M.Index -> M.Size -> V.Exp -> m (V.Exp, [V.Stmt])
            sliceExp :: Size -> Size -> Size -> Exp -> m (Exp, [Stmt])
sliceExp Size
w Size
i Size
k Exp
e
                  | Size
k Size -> Size -> Bool
forall a. Eq a => a -> a -> Bool
== Size
0          = (Exp, [Stmt]) -> m (Exp, [Stmt])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp
V.nil, [])
                  | Size
i Size -> Size -> Bool
forall a. Eq a => a -> a -> Bool
== Size
0, Size
k Size -> Size -> Bool
forall a. Eq a => a -> a -> Bool
== Size
w  = (Exp, [Stmt]) -> m (Exp, [Stmt])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp
e, [])
                  | Bool
otherwise = case Exp
e of
                        LVal (V.Name Text
n)      -> (Exp, [Stmt]) -> m (Exp, [Stmt])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LVal -> Exp
LVal (LVal -> Exp) -> LVal -> Exp
forall a b. (a -> b) -> a -> b
$ Text -> Int -> Int -> LVal
mkRange Text
n Int
i' (Int
i' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
k' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1), [])
                        LVal (V.Range Text
n Int
a Int
_) -> (Exp, [Stmt]) -> m (Exp, [Stmt])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LVal -> Exp
LVal (LVal -> Exp) -> LVal -> Exp
forall a b. (a -> b) -> a -> b
$ Text -> Int -> Int -> LVal
mkRange Text
n (Int
a Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i') (Int
a Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
k' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1), [])
                        LitBits BV
bv           -> (Exp, [Stmt]) -> m (Exp, [Stmt])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BV -> Exp
LitBits (BV -> Exp) -> BV -> Exp
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> BV -> BV
subRange (Size -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Size
i, Size -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Size
i Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral Size
k) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) BV
bv, [])
                        Exp
_                    -> do
                              n <- Text -> m Text
forall (m :: * -> *). MonadState SigInfo m => Text -> m Text
fresh Text
"slice_in"
                              pure (LVal $ mkRange n i' (i' + k' - 1), [WireAssign (fromIntegral w) n e])
                  where i', k' :: V.Index
                        i' :: Int
i' = Size -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Size
i
                        k' :: Int
k' = Size -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Size
k

-- | The output ports of an extern call, as ranges of the result wire
--   (MSB-first in declaration order).
outRanges :: V.Name -> [(M.Name, M.Size)] -> [(V.Name, V.Exp)]
outRanges :: Text -> [(Text, Size)] -> [(Text, Exp)]
outRanges Text
mr [(Text, Size)]
qs = [ (Text
q, LVal -> Exp
LVal (LVal -> Exp) -> LVal -> Exp
forall a b. (a -> b) -> a -> b
$ Text -> Int -> Int -> LVal
mkRange Text
mr Int
off (Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Size -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Size
sz Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)) | (Text
q, Size
sz, Int
off) <- [(Text, Size, Int)]
offsets, Size
sz Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
> Size
0 ]
      where offsets :: [(M.Name, M.Size, V.Index)]
            offsets :: [(Text, Size, Int)]
offsets = (Int, [(Text, Size, Int)]) -> [(Text, Size, Int)]
forall a b. (a, b) -> b
snd ((Int, [(Text, Size, Int)]) -> [(Text, Size, Int)])
-> (Int, [(Text, Size, Int)]) -> [(Text, Size, Int)]
forall a b. (a -> b) -> a -> b
$ ((Text, Size)
 -> (Int, [(Text, Size, Int)]) -> (Int, [(Text, Size, Int)]))
-> (Int, [(Text, Size, Int)])
-> [(Text, Size)]
-> (Int, [(Text, Size, Int)])
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ (Text
q, Size
sz) (Int
o, [(Text, Size, Int)]
acc) -> (Int
o Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Size -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Size
sz, (Text
q, Size
sz, Int
o) (Text, Size, Int) -> [(Text, Size, Int)] -> [(Text, Size, Int)]
forall a. a -> [a] -> [a]
: [(Text, Size, Int)]
acc)) (Int
0 :: V.Index, []) [(Text, Size)]
qs

mkRange :: V.Name -> V.Index -> V.Index -> LVal
mkRange :: Text -> Int -> Int -> LVal
mkRange Text
n Int
i Int
j | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
j    = Text -> Int -> LVal
Element Text
n Int
i
              | Bool
otherwise = Text -> Int -> Int -> LVal
Range Text
n Int
i Int
j

mkSignal :: (Text, M.Size) -> Signal
mkSignal :: (Text, Size) -> Signal
mkSignal (Text
n, Size
sz) = [Size] -> Text -> [Size] -> Signal
Logic [Size -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral Size
sz] Text
n []

toLit :: Natural -> V.Exp
toLit :: Natural -> Exp
toLit Natural
v = BV -> Exp
LitBits (BV -> Exp) -> BV -> Exp
forall a b. (a -> b) -> a -> b
$ Int -> Natural -> BV
forall a. Integral a => Int -> a -> BV
bitVec (Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Natural -> Int) -> Natural -> Int
forall a b. (a -> b) -> a -> b
$ Natural -> Natural
szBitRep Natural
v) Natural
v

-- | Break up giant literals (mirrored by the VHDL backend's @litExp@).
bvToExp :: BV -> V.Exp
bvToExp :: BV -> Exp
bvToExp BV
bv | BV -> Int
width BV
bv Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0         = Exp
V.nil
           | BV -> Int
width BV
bv Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
maxLit     = BV -> Exp
LitBits BV
bv
           | BV
bv BV -> BV -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> BV
zeros Int
1         = Exp -> Exp -> Exp
Repl (Natural -> Exp
toLit (Natural -> Exp) -> Natural -> Exp
forall a b. (a -> b) -> a -> b
$ Int -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Natural) -> Int -> Natural
forall a b. (a -> b) -> a -> b
$ BV -> Int
width BV
bv) (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ BV -> Exp
LitBits (BV -> Exp) -> BV -> Exp
forall a b. (a -> b) -> a -> b
$ Int -> BV
zeros Int
1
           | BV
bv BV -> BV -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> BV
ones (BV -> Int
width BV
bv) = Exp -> Exp -> Exp
Repl (Natural -> Exp
toLit (Natural -> Exp) -> Natural -> Exp
forall a b. (a -> b) -> a -> b
$ Int -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Natural) -> Int -> Natural
forall a b. (a -> b) -> a -> b
$ BV -> Int
width BV
bv) (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ BV -> Exp
LitBits (BV -> Exp) -> BV -> Exp
forall a b. (a -> b) -> a -> b
$ Int -> BV
ones Int
1
           | Natural
zs Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
> Natural
8                = [Exp] -> Exp
V.cat [BV -> Exp
LitBits (BV -> Exp) -> BV -> Exp
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> BV -> BV
subRange (Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
zs, BV -> Int
width BV
bv Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) BV
bv, Exp -> Exp -> Exp
Repl (Natural -> Exp
toLit Natural
zs) (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ BV -> Exp
LitBits (BV -> Exp) -> BV -> Exp
forall a b. (a -> b) -> a -> b
$ Int -> BV
zeros Int
1]
           | Bool
otherwise             = BV -> Exp
LitBits BV
bv
      where zs :: Natural
            zs :: Natural
zs | BV
bv BV -> BV -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> BV
zeros Int
1 = Int -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Natural) -> Int -> Natural
forall a b. (a -> b) -> a -> b
$ BV -> Int
width BV
bv
               | Bool
otherwise     = Int -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Natural) -> Int -> Natural
forall a b. (a -> b) -> a -> b
$ BV -> Int
lsb1 BV
bv

            maxLit :: Int
            maxLit :: Int
maxLit = Int
32

---

-- | A testbench driving the device with interp-style inputs and printing
--   outputs each cycle in the interpreter's YAML format (same protocol and
--   timing as the VHDL testbench).
testbench :: Config -> M.Device -> [Ins] -> V.Module
testbench :: Config -> Device -> [Ins] -> Module
testbench Config
conf Device
dev [Ins]
inps = Text -> [Text] -> [Port] -> [Signal] -> [Stmt] -> Module
V.Module Text
"tb" [] []
      (  ((Text, Size) -> Signal) -> [(Text, Size)] -> [Signal]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Size) -> Signal
mkSignal ([(Text, Size)]
clkRst [(Text, Size)] -> [(Text, Size)] -> [(Text, Size)]
forall a. Semigroup a => a -> a -> a
<> [(Text, Size)]
ins)
      [Signal] -> [Signal] -> [Signal]
forall a. Semigroup a => a -> a -> a
<> ((Text, Size) -> Signal) -> [(Text, Size)] -> [Signal]
forall a b. (a -> b) -> [a] -> [b]
map (\ (Text
n, Size
sz) -> [Size] -> Text -> [Size] -> Signal
Wire [Size -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral Size
sz] Text
n []) [(Text, Size)]
outs )
      (  Text -> Text -> [(Text, Exp)] -> [(Text, Exp)] -> Stmt
Instantiate (Device -> Text
devName Device
dev) Text
"dut" [] (((Text, Size) -> (Text, Exp)) -> [(Text, Size)] -> [(Text, Exp)]
forall a b. (a -> b) -> [a] -> [b]
map ((Text
forall a. Monoid a => a
mempty, ) (Exp -> (Text, Exp))
-> ((Text, Size) -> Exp) -> (Text, Size) -> (Text, Exp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LVal -> Exp
LVal (LVal -> Exp) -> ((Text, Size) -> LVal) -> (Text, Size) -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> LVal
V.Name (Text -> LVal) -> ((Text, Size) -> Text) -> (Text, Size) -> LVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Size) -> Text
forall a b. (a, b) -> a
fst) ([(Text, Size)] -> [(Text, Exp)])
-> [(Text, Size)] -> [(Text, Exp)]
forall a b. (a -> b) -> a -> b
$ [(Text, Size)]
clkRst [(Text, Size)] -> [(Text, Size)] -> [(Text, Size)]
forall a. Semigroup a => a -> a -> a
<> [(Text, Size)]
ins [(Text, Size)] -> [(Text, Size)] -> [(Text, Size)]
forall a. Semigroup a => a -> a -> a
<> [(Text, Size)]
outs)
      Stmt -> [Stmt] -> [Stmt]
forall a. a -> [a] -> [a]
:  [ Stmt -> Stmt
Initial (Stmt -> Stmt) -> Stmt -> Stmt
forall a b. (a -> b) -> a -> b
$ [Stmt] -> Stmt
Block ([Stmt] -> Stmt) -> [Stmt] -> Stmt
forall a b. (a -> b) -> a -> b
$ [Stmt]
resetStmts [Stmt] -> [Stmt] -> [Stmt]
forall a. Semigroup a => a -> a -> a
<> (Ins -> [Stmt]) -> [Ins] -> [Stmt]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Ins -> [Stmt]
cyc [Ins]
inps [Stmt] -> [Stmt] -> [Stmt]
forall a. Semigroup a => a -> a -> a
<> [Stmt
Finish] ] )
      where (Maybe Text
mclk, Maybe Text
mrst) = Config -> [Register] -> [Instance] -> (Maybe Text, Maybe Text)
clockReset Config
conf (Device -> [Register]
devRegisters Device
dev) (Device -> [Instance]
devInstances Device
dev)

            clkRst, ins, outs :: [(Text, M.Size)]
            clkRst :: [(Text, Size)]
clkRst = (Text -> (Text, Size)) -> [Text] -> [(Text, Size)]
forall a b. (a -> b) -> [a] -> [b]
map (, Size
1) ([Text] -> [(Text, Size)]) -> [Text] -> [(Text, Size)]
forall a b. (a -> b) -> a -> b
$ [Maybe Text] -> [Text]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Text
mclk, Maybe Text
mrst]
            ins :: [(Text, Size)]
ins    = ((Text, Size) -> Bool) -> [(Text, Size)] -> [(Text, Size)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
> Size
0) (Size -> Bool) -> ((Text, Size) -> Size) -> (Text, Size) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Size) -> Size
forall a b. (a, b) -> b
snd) ([(Text, Size)] -> [(Text, Size)])
-> [(Text, Size)] -> [(Text, Size)]
forall a b. (a -> b) -> a -> b
$ Device -> [(Text, Size)]
devInputs Device
dev
            outs :: [(Text, Size)]
outs   = ((Text, Size) -> Bool) -> [(Text, Size)] -> [(Text, Size)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
> Size
0) (Size -> Bool) -> ((Text, Size) -> Size) -> (Text, Size) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Size) -> Size
forall a b. (a, b) -> b
snd) ([(Text, Size)] -> [(Text, Size)])
-> [(Text, Size)] -> [(Text, Size)]
forall a b. (a -> b) -> a -> b
$ Device -> [(Text, Size)]
devOutputs Device
dev

            drive :: Ins -> [V.Stmt]
            drive :: Ins -> [Stmt]
drive Ins
i = ((Text, Size) -> Stmt) -> [(Text, Size)] -> [Stmt]
forall a b. (a -> b) -> [a] -> [b]
map (\ (Text
n, Size
sz) -> LVal -> Exp -> Stmt
SeqAssign (Text -> LVal
V.Name Text
n) (Exp -> Stmt) -> Exp -> Stmt
forall a b. (a -> b) -> a -> b
$ BV -> Exp
LitBits (BV -> Exp) -> BV -> Exp
forall a b. (a -> b) -> a -> b
$ Int -> Value -> BV
forall a. Integral a => Int -> a -> BV
bitVec (Size -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Size
sz) (Value -> BV) -> Value -> BV
forall a b. (a -> b) -> a -> b
$ Size -> Ins -> Text -> Value
inputValue (Size -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral Size
sz) Ins
i Text
n) [(Text, Size)]
ins

            bit :: Bool -> V.Exp
            bit :: Bool -> Exp
bit = BV -> Exp
LitBits (BV -> Exp) -> (Bool -> BV) -> Bool -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> BV
forall a. Integral a => Int -> a -> BV
bitVec Int
1 (Int -> BV) -> (Bool -> Int) -> Bool -> BV
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Int
forall a. Enum a => a -> Int
fromEnum

            rstActive :: Bool
            rstActive :: Bool
rstActive = ResetFlag
Inverted ResetFlag -> HashSet ResetFlag -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` (Config
confConfig
-> Getting (HashSet ResetFlag) Config (HashSet ResetFlag)
-> HashSet ResetFlag
forall s a. s -> Getting a s a -> a
^.Getting (HashSet ResetFlag) Config (HashSet ResetFlag)
Lens' Config (HashSet ResetFlag)
C.resetFlags)

            tick :: Text -> [V.Stmt]
            tick :: Text -> [Stmt]
tick Text
clk = [Natural -> Stmt
Delay Natural
1, LVal -> Exp -> Stmt
SeqAssign (Text -> LVal
V.Name Text
clk) (Exp -> Stmt) -> Exp -> Stmt
forall a b. (a -> b) -> a -> b
$ Bool -> Exp
bit Bool
True, Natural -> Stmt
Delay Natural
5, LVal -> Exp -> Stmt
SeqAssign (Text -> LVal
V.Name Text
clk) (Exp -> Stmt) -> Exp -> Stmt
forall a b. (a -> b) -> a -> b
$ Bool -> Exp
bit Bool
False]

            resetStmts :: [V.Stmt]
            resetStmts :: [Stmt]
resetStmts = case (Maybe Text
mclk, Maybe Text
mrst) of
                  (Just Text
clk, Just Text
rst) ->
                        [ LVal -> Exp -> Stmt
SeqAssign (Text -> LVal
V.Name Text
clk) (Exp -> Stmt) -> Exp -> Stmt
forall a b. (a -> b) -> a -> b
$ Bool -> Exp
bit Bool
False, LVal -> Exp -> Stmt
SeqAssign (Text -> LVal
V.Name Text
rst) (Exp -> Stmt) -> Exp -> Stmt
forall a b. (a -> b) -> a -> b
$ Bool -> Exp
bit Bool
rstActive ]
                        [Stmt] -> [Stmt] -> [Stmt]
forall a. Semigroup a => a -> a -> a
<> Ins -> [Stmt]
drive ([Ins] -> Ins
headIns [Ins]
inps)
                        [Stmt] -> [Stmt] -> [Stmt]
forall a. Semigroup a => a -> a -> a
<> [[Stmt]] -> [Stmt]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Int -> [Stmt] -> [[Stmt]]
forall a. Int -> a -> [a]
replicate Int
2 [Natural -> Stmt
Delay Natural
5, LVal -> Exp -> Stmt
SeqAssign (Text -> LVal
V.Name Text
clk) (Exp -> Stmt) -> Exp -> Stmt
forall a b. (a -> b) -> a -> b
$ Bool -> Exp
bit Bool
True, Natural -> Stmt
Delay Natural
5, LVal -> Exp -> Stmt
SeqAssign (Text -> LVal
V.Name Text
clk) (Exp -> Stmt) -> Exp -> Stmt
forall a b. (a -> b) -> a -> b
$ Bool -> Exp
bit Bool
False])
                        [Stmt] -> [Stmt] -> [Stmt]
forall a. Semigroup a => a -> a -> a
<> [ LVal -> Exp -> Stmt
SeqAssign (Text -> LVal
V.Name Text
rst) (Exp -> Stmt) -> Exp -> Stmt
forall a b. (a -> b) -> a -> b
$ Bool -> Exp
bit (Bool -> Exp) -> Bool -> Exp
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not Bool
rstActive ]
                  (Just Text
clk, Maybe Text
Nothing)  -> [ LVal -> Exp -> Stmt
SeqAssign (Text -> LVal
V.Name Text
clk) (Exp -> Stmt) -> Exp -> Stmt
forall a b. (a -> b) -> a -> b
$ Bool -> Exp
bit Bool
False ]
                  (Maybe Text, Maybe Text)
_                    -> []

            cyc :: Ins -> [V.Stmt]
            cyc :: Ins -> [Stmt]
cyc Ins
i = Ins -> [Stmt]
drive Ins
i [Stmt] -> [Stmt] -> [Stmt]
forall a. Semigroup a => a -> a -> a
<> case Maybe Text
mclk of
                  Just Text
clk -> [Natural -> Stmt
Delay Natural
4] [Stmt] -> [Stmt] -> [Stmt]
forall a. Semigroup a => a -> a -> a
<> [Stmt]
disps [Stmt] -> [Stmt] -> [Stmt]
forall a. Semigroup a => a -> a -> a
<> Text -> [Stmt]
tick Text
clk
                  Maybe Text
Nothing  -> [Natural -> Stmt
Delay Natural
5] [Stmt] -> [Stmt] -> [Stmt]
forall a. Semigroup a => a -> a -> a
<> [Stmt]
disps [Stmt] -> [Stmt] -> [Stmt]
forall a. Semigroup a => a -> a -> a
<> [Natural -> Stmt
Delay Natural
5]

            disps :: [V.Stmt]
            disps :: [Stmt]
disps = (Text -> (Text, Size) -> Stmt)
-> [Text] -> [(Text, Size)] -> [Stmt]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\ Text
pre (Text
n, Size
_) -> Text -> [Exp] -> Stmt
Display (Text
pre Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": '0x%0h'") [LVal -> Exp
LVal (LVal -> Exp) -> LVal -> Exp
forall a b. (a -> b) -> a -> b
$ Text -> LVal
V.Name Text
n]) [Text]
yamlPrefixes [(Text, Size)]
outs

            headIns :: [Ins] -> Ins
            headIns :: [Ins] -> Ins
headIns = \ case
                  Ins
i : [Ins]
_ -> Ins
i
                  [Ins]
_     -> Ins
forall a. Monoid a => a
mempty