{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE Safe #-}
-- | The VHDL backend on Hyle, mirroring ReWire.Hyle.ToVerilog (the
--   cosimulation check keeps the two aligned). With widths explicit and
--   exact in the IR, the width-reconstruction machinery of the old backend
--   (@wcast@/@expWidth@) disappears: every emitted expression already has
--   exactly the width its context requires, and the rw_helpers package is
--   needed only for the operations themselves (VHDL std_logic_vector has no
--   arithmetic), not for resizing discipline.
--
--   Defn modules never take clock or reset ports (sequential externs are
--   device-level instances). Extern ports connect by name; ports left
--   anonymous in the source-level extern descriptor reach this backend with
--   the @p\<i\>@ names synthesized by the producer, which the hand-written
--   VHDL implementations in the test suite already use.
module ReWire.Hyle.ToVHDL (compileProgram, testbench) where

import ReWire.Annotation (Annote, Annotated (ann))
import ReWire.BitVector (BV, width, bitVec, zeros, ones, lsb1)
import ReWire.Config (Config, ResetFlag (..), vhdlPackages)
import ReWire.Hyle.Interp (Ins, subRange, inputValue, yamlPrefixes)
import ReWire.Hyle.Mangle (mangleFresh, mangleMod, pickFresh, seedNames, stripFreshTag)
import ReWire.Error (failAt, failInternal, AstError, MonadError)
import ReWire.Hyle.Syntax as M
import ReWire.Hyle.ToVerilog (clockReset, defnPortNames, lastComponent, tagReg)
import ReWire.Pretty (showt)

import qualified ReWire.BitVector  as BV
import qualified ReWire.Config     as C
import qualified ReWire.VHDL.Syntax as H

import Control.Arrow ((&&&), first)
import Control.Lens ((^.))
import Control.Monad.State.Strict (MonadState, runStateT, modify', gets)
import Data.HashMap.Strict (HashMap)
import Data.List (nub, sortOn)
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

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

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

-- | Entity port names per defn ('defnPortNames'): call-site component
--   declarations must use the entity's own port names, since VHDL default
--   binding matches component formals to entity ports by name.
type PEnv = HashMap M.GId [Text]

data TS = TS
      { TS -> HashMap Text Int
tsFresh    :: !(HashMap Text Int)
      , TS -> [Signal]
tsSigs     :: ![H.Signal]
      , TS -> [Signal]
tsConsts   :: ![H.Signal]                    -- ^ Emitted constant declarations (st_* state names).
      , TS -> HashMap Text Component
tsComps    :: !(HashMap Text H.Component)
      , TS -> Map Text Text
tsExps     :: !(Map Text H.Name)             -- ^ Emitted let RHS ('expKey') -> its wire (backend CSE).
      , TS -> Map (Text, [Text]) Text
tsCalls    :: !(Map (M.GId, [Text]) H.Name)  -- ^ Emitted defn call ('expKey' args; never an extern XCall) -> its result wire.
      , TS -> Maybe (Text, Size, [(Text, Value)])
tsTags     :: !(Maybe (Text, M.Size, [(Text, Integer)])) -- ^ The tagged state register (device only): name, width, value display names.
      , TS -> Bool
tsTagsDone :: !Bool                          -- ^ The st_* constants have been declared.
      }

-- | Initial state, with the ambient names (ports, registers -- emitted
--   verbatim, never passing through 'fresh') seeded into the used map so
--   generated names can't collide with them. Seeds are case-folded to match
--   the case-folding in 'fresh' (VHDL basic identifiers are
--   case-insensitive).
ts0 :: Maybe (Text, M.Size, [(Text, Integer)]) -> [Text] -> TS
ts0 :: Maybe (Text, Size, [(Text, Value)]) -> [Text] -> TS
ts0 Maybe (Text, Size, [(Text, Value)])
tags [Text]
ambient = HashMap Text Int
-> [Signal]
-> [Signal]
-> HashMap Text Component
-> Map Text Text
-> Map (Text, [Text]) Text
-> Maybe (Text, Size, [(Text, Value)])
-> Bool
-> TS
TS ([Text] -> HashMap Text Int
seedNames ([Text] -> HashMap Text Int) -> [Text] -> HashMap Text Int
forall a b. (a -> b) -> a -> b
$ (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
T.toLower [Text]
ambient) [] [] HashMap Text Component
forall a. Monoid a => a
mempty 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 Bool
False

-- | A fresh signal/instance name: freshening tags stripped, mangled,
--   case-folded (the collision defense for VHDL's case-insensitive
--   namespace), and suffixed out of the way of every name already issued or
--   seeded (reserved words need no dodge here -- the pretty-printer escapes
--   them as extended identifiers). The suffix separator keeps suffixed
--   names basic identifiers (no capitals, which would force extended-
--   identifier escaping).
fresh :: MonadState TS m => Text -> m H.Name
fresh :: forall (m :: * -> *). MonadState TS m => Text -> m Text
fresh Text
s = do
      used <- (TS -> HashMap Text Int) -> m (HashMap Text Int)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets TS -> HashMap Text Int
tsFresh
      let (n, used') = pickFresh "_r" used $ T.toLower $ mangleFresh $ stripFreshTag s
      modify' $ \ TS
ts -> TS
ts { tsFresh = used' }
      pure n

newWire :: MonadState TS m => M.Size -> Text -> m H.Name
newWire :: forall (m :: * -> *). MonadState TS m => Size -> Text -> m Text
newWire Size
sz Text
n = do
      n' <- Text -> m Text
forall (m :: * -> *). MonadState TS m => Text -> m Text
fresh Text
n
      modify' $ \ TS
ts -> TS
ts { tsSigs = tsSigs ts <> [H.Signal n' sz Nothing] }
      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 assign to a
--   fresh wire (seeded with the binder's name), recording it for reuse.
bindLet :: MonadState TS m => M.Size -> Text -> H.Exp -> m (H.Exp, [H.Stmt])
bindLet :: forall (m :: * -> *).
MonadState TS m =>
Size -> Text -> Exp -> m (Exp, [Stmt])
bindLet Size
sz Text
x = \ case
      e :: Exp
e@H.Var {} -> (Exp, [Stmt]) -> m (Exp, [Stmt])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp
e, [])
      e :: Exp
e@H.Lit {} -> (Exp, [Stmt]) -> m (Exp, [Stmt])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp
e, [])
      Exp
e          -> (TS -> 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)
-> (TS -> Map Text Text) -> TS -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TS -> Map Text Text
tsExps) 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 (Text -> Exp
H.Var Text
w, [])
            Maybe Text
Nothing -> do
                  w <- Size -> Text -> m Text
forall (m :: * -> *). MonadState TS m => Size -> Text -> m Text
newWire Size
sz Text
x
                  modify' $ \ TS
ts -> TS
ts { tsExps = OMap.insert (expKey e) w $ tsExps ts }
                  (H.Var w, ) <$> assignStmts (H.LVName w) e

-- | Identity key for compiled expressions (the CSE memos): the full Show
--   rendering. The derived Eq on 'ReWire.VHDL.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. (The selected-assignment matcher needs no key: its
--   scrutinees are restricted to literal-free shapes.)
expKey :: H.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

-- | The statement driving a target: a selected signal assignment when the
--   right-hand side is a same-scrutinee comparison chain (2-state
--   equivalent to the rw_cond chain it replaces; doc/hyle.md, section 8.3),
--   otherwise a plain concurrent assignment. A chain over the tagged state
--   register also declares the st_* constants (the choices themselves stay
--   literal bit-strings).
assignStmts :: MonadState TS m => H.LVal -> H.Exp -> m [H.Stmt]
assignStmts :: forall (m :: * -> *). MonadState TS m => LVal -> Exp -> m [Stmt]
assignStmts LVal
lv Exp
e = case Exp -> Maybe (Exp, [(BV, Exp)], Exp)
matchSelChain Exp
e of
      Just (Exp
scrut, [(BV, Exp)]
arms, Exp
dflt) -> do
            Exp -> m ()
forall (m :: * -> *). MonadState TS m => Exp -> m ()
declareTagConsts Exp
scrut
            [Stmt] -> m [Stmt]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Exp -> LVal -> [(BV, Exp)] -> Exp -> Stmt
H.SelAssign Exp
scrut LVal
lv [(BV, Exp)]
arms Exp
dflt]
      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
H.Assign LVal
lv Exp
e]

-- | Recognize a same-scrutinee comparison chain (see
--   ToVerilog.matchCaseChain): an rw_cond tree testing one scrutinee for
--   rw_eq against literals (either operand order), distinct, same-width,
--   and at least two comparisons deep, ending in an unconditioned else. The
--   scrutinee is restricted to names and static slices, whose subtypes the
--   selected signal assignment can determine.
matchSelChain :: H.Exp -> Maybe (H.Exp, [(BV, H.Exp)], H.Exp)
matchSelChain :: Exp -> Maybe (Exp, [(BV, Exp)], Exp)
matchSelChain = \ case
      H.FunCall Text
"rw_cond" [Exp
c, Exp
t, Exp
f]
            | Just (Exp
s, BV
v) <- Exp -> Maybe (Exp, BV)
eqLit Exp
c
            , Exp -> Bool
selectable Exp
s
            , ([(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 :: H.Exp -> Maybe (H.Exp, BV)
            eqLit :: Exp -> Maybe (Exp, BV)
eqLit = \ case
                  H.FunCall Text
"rw_eq" [Exp
s, H.Lit BV
v] | BV -> Int
width BV
v Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 -> (Exp, BV) -> Maybe (Exp, BV)
forall a. a -> Maybe a
Just (Exp
s, BV
v)
                  H.FunCall Text
"rw_eq" [H.Lit BV
v, Exp
s] | BV -> Int
width BV
v Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 -> (Exp, BV) -> Maybe (Exp, BV)
forall a. a -> Maybe a
Just (Exp
s, BV
v)
                  Exp
_                                            -> Maybe (Exp, BV)
forall a. Maybe a
Nothing

            selectable :: H.Exp -> Bool
            selectable :: Exp -> Bool
selectable = \ case
                  H.Var {}   -> Bool
True
                  H.Slice {} -> Bool
True
                  H.Elem {}  -> Bool
True
                  Exp
_          -> Bool
False

            chain :: H.Exp -> H.Exp -> ([(BV, H.Exp)], H.Exp)
            chain :: Exp -> Exp -> ([(BV, Exp)], Exp)
chain Exp
s = \ case
                  H.FunCall Text
"rw_cond" [Exp
c, Exp
t, Exp
f] | Just (Exp
s', BV
v) <- Exp -> Maybe (Exp, BV)
eqLit Exp
c, Exp
s' Exp -> Exp -> Bool
forall a. Eq a => a -> a -> Bool
== 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)

            distinct :: [BV] -> Bool
            distinct :: [BV] -> Bool
distinct [BV]
vs = [BV] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([BV] -> [BV]
forall a. Eq a => [a] -> [a]
nub [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

-- | Declare the st_* state-name constants (once per unit) when the
--   scrutinee is the tagged state register.
declareTagConsts :: MonadState TS m => H.Exp -> m ()
declareTagConsts :: forall (m :: * -> *). MonadState TS m => Exp -> m ()
declareTagConsts Exp
scrut = (TS -> Maybe (Text, Size, [(Text, Value)]))
-> m (Maybe (Text, Size, [(Text, Value)]))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets TS -> Maybe (Text, Size, [(Text, Value)])
tsTags m (Maybe (Text, Size, [(Text, Value)]))
-> (Maybe (Text, Size, [(Text, Value)]) -> m ()) -> m ()
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
== Text -> Exp
H.Var Text
reg -> (TS -> Bool) -> m Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets TS -> Bool
tsTagsDone m Bool -> (Bool -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ case
            Bool
True  -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            Bool
False -> do
                  (TS -> TS) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' ((TS -> TS) -> m ()) -> (TS -> TS) -> m ()
forall a b. (a -> b) -> a -> b
$ \ TS
ts -> TS
ts { tsTagsDone = True }
                  cs <- ((Text, Value) -> m Signal) -> [(Text, Value)] -> m [Signal]
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) -> (\ Text
n -> Text -> Size -> BV -> Signal
H.Constant Text
n Size
sz (BV -> Signal) -> BV -> Signal
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
v) (Text -> Signal) -> m Text -> m Signal
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> m Text
forall (m :: * -> *). MonadState TS m => Text -> m Text
fresh (Text
"st_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
nm)) [(Text, Value)]
tags
                  modify' $ \ TS
ts -> TS
ts { tsConsts = tsConsts ts <> cs }
      Maybe (Text, Size, [(Text, Value)])
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

addComponent :: MonadState TS m => H.Component -> m ()
addComponent :: forall (m :: * -> *). MonadState TS m => Component -> m ()
addComponent c :: Component
c@(H.Component Text
n [Text]
_ [Port]
_) = (TS -> TS) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' ((TS -> TS) -> m ()) -> (TS -> TS) -> m ()
forall a b. (a -> b) -> a -> b
$ \ TS
ts -> TS
ts { tsComps = Map.insert n c $ tsComps ts }

components :: TS -> [H.Component]
components :: TS -> [Component]
components = (Component -> Text) -> [Component] -> [Component]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (\ (H.Component Text
n [Text]
_ [Port]
_) -> Text
n) ([Component] -> [Component])
-> (TS -> [Component]) -> TS -> [Component]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap Text Component -> [Component]
forall k v. HashMap k v -> [v]
Map.elems (HashMap Text Component -> [Component])
-> (TS -> HashMap Text Component) -> TS -> [Component]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TS -> HashMap Text Component
tsComps

compileProgram :: forall m. MonadError AstError m => Config -> M.Program -> m H.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 -> PEnv -> Device -> m Unit
forall (m :: * -> *).
MonadError AstError m =>
Config -> XEnv -> PEnv -> Device -> m Unit
compileDevice Config
conf XEnv
xenv PEnv
penv Device
dev
      ds' <- mapM (compileDefn conf xenv penv) ds
      pure $ H.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

            penv :: PEnv
            penv :: PEnv
penv = [(Text, [Text])] -> PEnv
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList ([(Text, [Text])] -> PEnv) -> [(Text, [Text])] -> PEnv
forall a b. (a -> b) -> a -> b
$ (Defn -> (Text, [Text])) -> [Defn] -> [(Text, [Text])]
forall a b. (a -> b) -> [a] -> [b]
map (Defn -> Text
defnName (Defn -> Text) -> (Defn -> [Text]) -> Defn -> (Text, [Text])
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')
&&& Defn -> [Text]
defnPortNames) [Defn]
ds

compileDefn :: forall m. MonadError AstError m => Config -> XEnv -> PEnv -> M.Defn -> m H.Unit
compileDefn :: forall (m :: * -> *).
MonadError AstError m =>
Config -> XEnv -> PEnv -> Defn -> m Unit
compileDefn Config
conf XEnv
xenv PEnv
penv d :: Defn
d@(M.Defn Annote
_ Text
g (M.Sig Annote
_ [Size]
argSzs Size
_) [Text]
ps Exp
body Bool
_ (Blind [Text]
docs)) = do
      (stmts, ts) <- (StateT TS m [Stmt] -> TS -> m ([Stmt], TS))
-> TS -> StateT TS m [Stmt] -> m ([Stmt], TS)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT TS m [Stmt] -> TS -> m ([Stmt], TS)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (Maybe (Text, Size, [(Text, Value)]) -> [Text] -> TS
ts0 Maybe (Text, Size, [(Text, Value)])
forall a. Maybe a
Nothing ([Text] -> TS) -> [Text] -> TS
forall a b. (a -> b) -> a -> b
$ [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 ]) (StateT TS m [Stmt] -> m ([Stmt], TS))
-> StateT TS m [Stmt] -> m ([Stmt], TS)
forall a b. (a -> b) -> a -> b
$ do
            (e, estmts) <- XEnv -> PEnv -> LEnv -> Exp -> StateT TS m (Exp, [Stmt])
forall (m :: * -> *).
(MonadState TS m, MonadError AstError m) =>
XEnv -> PEnv -> LEnv -> Exp -> m (Exp, [Stmt])
compileExp XEnv
xenv PEnv
penv LEnv
lenv Exp
body
            resStmts    <- if sizeOf body > 0 then assignStmts (H.LVName "res") e else pure []
            pure $ estmts <> resStmts
      -- Header comments: the unmangled Hyle name, then the defn's doc lines.
      pure $ H.Unit (mangleMod g) (g : docs) (unitPackages conf)
                    (zipWith (\ Text
pn (Text
_, Size
sz) -> Text -> Direction -> Size -> Port
H.Port Text
pn Direction
H.In Size
sz) portNames live <> [ H.Port "res" H.Out (sizeOf body) | sizeOf body > 0 ])
                    (components ts) (tsSigs ts)
                    stmts
      where -- Zero-width parameters and results are erased; references
            -- compile to the empty literal.
            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

            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, BV -> Exp
H.Lit BV
BV.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 Text -> Exp
H.Var [Text]
portNames)

compileDevice :: forall m. MonadError AstError m => Config -> XEnv -> PEnv -> M.Device -> m H.Unit
compileDevice :: forall (m :: * -> *).
MonadError AstError m =>
Config -> XEnv -> PEnv -> Device -> m Unit
compileDevice Config
conf XEnv
xenv PEnv
penv (M.Device Annote
an Text
top [(Text, Size)]
ins [(Text, Size)]
outs [Register]
regs [Instance]
insts [Stmt]
body (Blind [(Text, Value)]
tags)) = do
      (stmts, ts) <- (StateT TS m [Stmt] -> TS -> m ([Stmt], TS))
-> TS -> StateT TS m [Stmt] -> m ([Stmt], TS)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT TS m [Stmt] -> TS -> m ([Stmt], TS)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (Maybe (Text, Size, [(Text, Value)]) -> [Text] -> TS
ts0 Maybe (Text, Size, [(Text, Value)])
tagInfo [Text]
ambient) (StateT TS m [Stmt] -> m ([Stmt], TS))
-> StateT TS m [Stmt] -> m ([Stmt], TS)
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 TS m [[((Text, Text), Text)]]
-> StateT TS m (HashMap (Text, Text) Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Instance -> StateT TS m [((Text, Text), Text)])
-> [Instance] -> StateT TS 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 TS m [((Text, Text), Text)]
forall (m' :: * -> *).
MonadState TS 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 $ H.Unit top [] (unitPackages conf)
                   (map (portIn . (, 1)) (catMaybes [mclk, mrst]) <> map portIn (live ins) <> map portOut (live outs))
                   (components ts)
                   (regLegend <> tsConsts ts <> regSigs <> tsSigs ts)
                   (stmts <> section "state register update" stateProcess)
      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 -> [H.Stmt] -> [H.Stmt]
            section :: Text -> [Stmt] -> [Stmt]
section Text
_ []      = []
            section Text
banner [Stmt]
ss = Text -> Stmt
H.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

            -- | A banner and a legend comment (width, initial value, and --
            --   for the tagged state register -- the state display names)
            --   above the register signal declarations.
            regLegend :: [H.Signal]
            regLegend :: [Signal]
regLegend | [Register] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Register]
liveRegs = []
                      | Bool
otherwise     = Text -> Signal
H.SigComment Text
"state registers" Signal -> [Signal] -> [Signal]
forall a. a -> [a] -> [a]
: (Register -> [Signal]) -> [Register] -> [Signal]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Register -> [Signal]
legend [Register]
liveRegs

            legend :: M.Register -> [H.Signal]
            legend :: Register -> [Signal]
legend (M.Register Annote
_ Text
x Size
sz BV
bv) = Text -> Signal
H.SigComment (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
BV.showHex BV
bv)
                  Signal -> [Signal] -> [Signal]
forall a. a -> [a] -> [a]
: [ Text -> Signal
H.SigComment (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 ]

            portIn, portOut :: (M.Name, M.Size) -> H.Port
            portIn :: (Text, Size) -> Port
portIn  (Text
n, Size
sz) = Text -> Direction -> Size -> Port
H.Port Text
n Direction
H.In Size
sz
            portOut :: (Text, Size) -> Port
portOut (Text
n, Size
sz) = Text -> Direction -> Size -> Port
H.Port Text
n Direction
H.Out Size
sz

            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 ]

            -- | Register signals carry their initial values; the @_next@
            --   wires carry the per-cycle updates.
            regSigs :: [H.Signal]
            regSigs :: [Signal]
regSigs = [[Signal]] -> [Signal]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [Text -> Size -> Maybe BV -> Signal
H.Signal Text
x Size
sz (BV -> Maybe BV
forall a. a -> Maybe a
Just BV
bv), Text -> Size -> Maybe BV -> Signal
H.Signal (Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_next") Size
sz Maybe BV
forall a. Maybe a
Nothing] | M.Register Annote
_ Text
x Size
sz BV
bv <- [Register]
liveRegs ]

            ambientEnv :: HashMap (M.Name, M.Name) H.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 Text -> Exp
H.Var Text
x else BV -> Exp
H.Lit BV
BV.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 Text -> Exp
H.Var Text
x else BV -> Exp
H.Lit BV
BV.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, Text -> Exp
H.Var 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 ]

            instOutWires :: MonadState TS m' => M.Instance -> m' [((M.Name, M.Name), H.Name)]
            instOutWires :: forall (m' :: * -> *).
MonadState TS 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 TS 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) H.Name -> M.Name -> M.Name -> H.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 TS m', MonadError AstError m') => LEnv -> [M.Stmt] -> m' ([H.Stmt], LEnv)
            foldStmts :: forall (m' :: * -> *).
(MonadState TS 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 TS 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 (BV -> Exp
H.Lit BV
BV.nil) LEnv
lenv) [Stmt]
rest
                  M.SLet Annote
_ Text
x Exp
e : [Stmt]
rest -> do
                        (e', stmts)    <- XEnv -> PEnv -> LEnv -> Exp -> m' (Exp, [Stmt])
forall (m :: * -> *).
(MonadState TS m, MonadError AstError m) =>
XEnv -> PEnv -> LEnv -> Exp -> m (Exp, [Stmt])
compileExp XEnv
xenv PEnv
penv 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 TS 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 -> PEnv -> LEnv -> Exp -> m' (Exp, [Stmt])
forall (m :: * -> *).
(MonadState TS m, MonadError AstError m) =>
XEnv -> PEnv -> LEnv -> Exp -> m (Exp, [Stmt])
compileExp XEnv
xenv PEnv
penv LEnv
lenv Exp
e
                        (rest', lenv') <- foldStmts lenv rest
                        pure (stmts <> [H.Assign (H.LVName $ x <> "_next") e'] <> rest', lenv')
                  M.SOutput {} : [Stmt]
rest -> LEnv -> [Stmt] -> m' ([Stmt], LEnv)
forall (m' :: * -> *).
(MonadState TS 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 TS m', MonadError AstError m') =>
LEnv -> [Stmt] -> m' ([Stmt], LEnv)
foldStmts LEnv
lenv [Stmt]
rest -- emitted with the instantiations

            driveOut :: (MonadState TS m', MonadError AstError m') => LEnv -> (M.Name, M.Size) -> m' [H.Stmt]
            driveOut :: forall (m' :: * -> *).
(MonadState TS 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 -> PEnv -> LEnv -> Exp -> m' (Exp, [Stmt])
forall (m :: * -> *).
(MonadState TS m, MonadError AstError m) =>
XEnv -> PEnv -> LEnv -> Exp -> m (Exp, [Stmt])
compileExp XEnv
xenv PEnv
penv LEnv
lenv Exp
e
                        pure $ stmts <> [H.Assign (H.LVName 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 TS m', MonadError AstError m') => HashMap (M.Name, M.Name) H.Name -> LEnv -> M.Instance -> m' [H.Stmt]
            compileInst :: forall (m' :: * -> *).
(MonadState TS 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
                        Component -> m' ()
forall (m :: * -> *). MonadState TS m => Component -> m ()
addComponent (Component -> m' ()) -> Component -> m' ()
forall a b. (a -> b) -> a -> b
$ Extern -> Component
extComponent Extern
e
                        (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 TS 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
                        let outws = [ (Text
q, Text -> Exp
H.Var (Text -> Exp) -> Text -> Exp
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 <> [ H.Instantiate ex inst (zip (extGenerics e) $ map toInteger cs)
                                        $ clkrst <> args <> outws ]

            clockRstPorts :: MonadError AstError m' => Extern -> m' [(H.Name, H.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))
port' Text
"clock" Maybe Text
mc Maybe Text
mclk
                        r <- port' "reset" mr mrst
                        pure $ catMaybes [c, r]
                  where port' :: MonadError AstError m' => Text -> Maybe M.Name -> Maybe Text -> m' (Maybe (H.Name, H.Exp))
                        port' :: forall (m' :: * -> *).
MonadError AstError m' =>
Text -> Maybe Text -> Maybe Text -> m' (Maybe (Text, Exp))
port' 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', Text -> Exp
H.Var 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 TS m', MonadError AstError m') => LEnv -> M.Name -> (M.Name, M.Size) -> m' ((H.Name, H.Exp), [H.Stmt])
            driveIn :: forall (m' :: * -> *).
(MonadState TS m', MonadError AstError m') =>
LEnv -> Text -> (Text, Size) -> m' ((Text, Exp), [Stmt])
driveIn LEnv
lenv Text
x (Text
p, Size
sz) = 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 -> PEnv -> LEnv -> Exp -> m' (Exp, [Stmt])
forall (m :: * -> *).
(MonadState TS m, MonadError AstError m) =>
XEnv -> PEnv -> LEnv -> Exp -> m (Exp, [Stmt])
compileExp XEnv
xenv PEnv
penv LEnv
lenv Exp
e
                        (e'', stmts') <- connect sz e'
                        pure ((p, e''), stmts <> 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 state-update process, with an (a)synchronous reset per
            --   the configured reset flags. No configured clock (--no-clock)
            --   means no process: registers hold their initial values.
            stateProcess :: [H.Stmt]
            stateProcess :: [Stmt]
stateProcess = case ([Register]
liveRegs, Maybe Text
mclk) of
                  ([], Maybe Text
_)       -> []
                  ([Register]
_, Maybe Text
Nothing)  -> []
                  ([Register]
_, Just Text
clk) -> Stmt -> [Stmt]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Stmt -> [Stmt]) -> Stmt -> [Stmt]
forall a b. (a -> b) -> a -> b
$ case (Maybe Text
mrst, Bool
syncRst) of
                        (Just Text
rstn, Bool
False) -> [Text] -> [ProcVar] -> [SeqStmt] -> Stmt
H.Process [Text
clk, Text
rstn] []
                              [[(Cond, [SeqStmt])] -> [SeqStmt] -> SeqStmt
H.SIf [(Text -> Cond
rstCond Text
rstn, [SeqStmt]
rstAssigns), (Text -> Cond
H.CondRising Text
clk, [SeqStmt]
nextAssigns)] []]
                        (Just Text
rstn, Bool
True)  -> [Text] -> [ProcVar] -> [SeqStmt] -> Stmt
H.Process [Text
clk] []
                              [[(Cond, [SeqStmt])] -> [SeqStmt] -> SeqStmt
H.SIf [(Text -> Cond
H.CondRising Text
clk, [[(Cond, [SeqStmt])] -> [SeqStmt] -> SeqStmt
H.SIf [(Text -> Cond
rstCond Text
rstn, [SeqStmt]
rstAssigns)] [SeqStmt]
nextAssigns])] []]
                        (Maybe Text
Nothing, Bool
_)       -> [Text] -> [ProcVar] -> [SeqStmt] -> Stmt
H.Process [Text
clk] []
                              [[(Cond, [SeqStmt])] -> [SeqStmt] -> SeqStmt
H.SIf [(Text -> Cond
H.CondRising Text
clk, [SeqStmt]
nextAssigns)] []]

            rstCond :: Text -> H.Cond
            rstCond :: Text -> Cond
rstCond Text
rstn = Text -> BV -> Cond
H.CondEq Text
rstn (BV -> Cond) -> BV -> Cond
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

            rstAssigns :: [H.SeqStmt]
            rstAssigns :: [SeqStmt]
rstAssigns = [ LVal -> Exp -> SeqStmt
H.SAssign (Text -> LVal
H.LVName Text
x) (Exp -> SeqStmt) -> Exp -> SeqStmt
forall a b. (a -> b) -> a -> b
$ BV -> Exp
H.Lit BV
bv | M.Register Annote
_ Text
x Size
_ BV
bv <- [Register]
liveRegs ]

            nextAssigns :: [H.SeqStmt]
            nextAssigns :: [SeqStmt]
nextAssigns = [ LVal -> Exp -> SeqStmt
H.SAssign (Text -> LVal
H.LVName Text
x) (Exp -> SeqStmt) -> Exp -> SeqStmt
forall a b. (a -> b) -> a -> b
$ Text -> Exp
H.Var (Text -> Exp) -> Text -> Exp
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 ]

            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)

-- | The component declaration for an extern: generics, then clock/reset and
--   inputs, then outputs, with the (possibly synthesized) port names.
extComponent :: Extern -> H.Component
extComponent :: Extern -> Component
extComponent Extern
e = Text -> [Text] -> [Port] -> Component
H.Component (Extern -> Text
extName Extern
e) (Extern -> [Text]
extGenerics Extern
e)
      ([Port] -> Component) -> [Port] -> Component
forall a b. (a -> b) -> a -> b
$  (Text -> Port) -> [Text] -> [Port]
forall a b. (a -> b) -> [a] -> [b]
map (\ Text
n -> Text -> Direction -> Size -> Port
H.Port Text
n Direction
H.In Size
1) (Extern -> [Text]
clkRstNames Extern
e)
      [Port] -> [Port] -> [Port]
forall a. Semigroup a => a -> a -> a
<> ((Text, Size) -> Port) -> [(Text, Size)] -> [Port]
forall a b. (a -> b) -> [a] -> [b]
map (\ (Text
p, Size
sz) -> Text -> Direction -> Size -> Port
H.Port Text
p Direction
H.In Size
sz) (((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)
      [Port] -> [Port] -> [Port]
forall a. Semigroup a => a -> a -> a
<> ((Text, Size) -> Port) -> [(Text, Size)] -> [Port]
forall a b. (a -> b) -> [a] -> [b]
map (\ (Text
q, Size
sz) -> Text -> Direction -> Size -> Port
H.Port Text
q Direction
H.Out Size
sz) (((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)

clkRstNames :: Extern -> [M.Name]
clkRstNames :: Extern -> [Text]
clkRstNames Extern
e = case Extern -> ExternKind
extKind Extern
e of
      ExternKind
Comb      -> []
      Seq Maybe Text
mc Maybe Text
mr -> [Maybe Text] -> [Text]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Text
mc, Maybe Text
mr]

-- | A port-map actual: signal references connect directly; anything else is
--   hoisted into a temporary of exactly the port's width (VHDL port
--   associations are strict about form). Widths always agree by Hyle
--   invariant, so no resizing is involved. Clock signals connect directly by
--   construction (they are plain signal references).
connect :: (MonadState TS m, MonadError AstError m) => M.Size -> H.Exp -> m (H.Exp, [H.Stmt])
connect :: forall (m :: * -> *).
(MonadState TS m, MonadError AstError m) =>
Size -> Exp -> m (Exp, [Stmt])
connect Size
psz Exp
e
      | Exp -> Bool
trivial Exp
e = (Exp, [Stmt]) -> m (Exp, [Stmt])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp
e, [])
      | Bool
otherwise = do
            tmp <- Size -> Text -> m Text
forall (m :: * -> *). MonadState TS m => Size -> Text -> m Text
newWire Size
psz Text
"conn"
            pure (H.Var tmp, [H.Assign (H.LVName tmp) e])
      where trivial :: H.Exp -> Bool
            trivial :: Exp -> Bool
trivial = \ case
                  H.Var {}   -> Bool
True
                  H.Slice {} -> Bool
True
                  H.Elem {}  -> Bool
True
                  H.Lit {}   -> Bool
True
                  Exp
_          -> Bool
False

---

compileExps :: (MonadState TS m, MonadError AstError m) => XEnv -> PEnv -> LEnv -> [M.Exp] -> m ([H.Exp], [H.Stmt])
compileExps :: forall (m :: * -> *).
(MonadState TS m, MonadError AstError m) =>
XEnv -> PEnv -> LEnv -> [Exp] -> m ([Exp], [Stmt])
compileExps XEnv
xenv PEnv
penv 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 -> PEnv -> LEnv -> Exp -> m (Exp, [Stmt])
forall (m :: * -> *).
(MonadState TS m, MonadError AstError m) =>
XEnv -> PEnv -> LEnv -> Exp -> m (Exp, [Stmt])
compileExp XEnv
xenv PEnv
penv LEnv
lenv) [Exp]
es

compileExp :: forall m. (MonadState TS m, MonadError AstError m) => XEnv -> PEnv -> LEnv -> M.Exp -> m (H.Exp, [H.Stmt])
compileExp :: forall (m :: * -> *).
(MonadState TS m, MonadError AstError m) =>
XEnv -> PEnv -> LEnv -> Exp -> m (Exp, [Stmt])
compileExp XEnv
xenv PEnv
penv = LEnv -> Exp -> m (Exp, [Stmt])
go
      where go :: LEnv -> M.Exp -> m (H.Exp, [H.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
litExp 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
litExp (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
hCat (([Exp], [Stmt]) -> (Exp, [Stmt]))
-> m ([Exp], [Stmt]) -> m (Exp, [Stmt])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> XEnv -> PEnv -> LEnv -> [Exp] -> m ([Exp], [Stmt])
forall (m :: * -> *).
(MonadState TS m, MonadError AstError m) =>
XEnv -> PEnv -> LEnv -> [Exp] -> m ([Exp], [Stmt])
compileExps XEnv
xenv PEnv
penv 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 (BV -> Exp
H.Lit BV
BV.nil, []) -- zero-width call: dead logic, erased
                  M.Call Annote
_ Size
sz Text
g [Exp]
es    -> do
                        let esLive :: [Exp]
esLive = (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
                        (es', stmts) <- XEnv -> PEnv -> LEnv -> [Exp] -> m ([Exp], [Stmt])
forall (m :: * -> *).
(MonadState TS m, MonadError AstError m) =>
XEnv -> PEnv -> LEnv -> [Exp] -> m ([Exp], [Stmt])
compileExps XEnv
xenv PEnv
penv LEnv
lenv [Exp]
esLive
                        -- The instantiate memo: an identical call already
                        -- has an instance in this unit; reuse its result
                        -- wire (defn entities are pure, so identical
                        -- arguments mean identical outputs).
                        gets (OMap.lookup (g, map expKey es') . tsCalls) >>= \ case
                              Just Text
mr -> (Exp, [Stmt]) -> m (Exp, [Stmt])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Exp
H.Var Text
mr, [Stmt]
stmts)
                              Maybe Text
Nothing -> do
                                    (conns, hoists) <- (((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
<$> ((Size, Exp) -> m (Exp, [Stmt]))
-> [(Size, 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 ((Size -> Exp -> m (Exp, [Stmt])) -> (Size, Exp) -> m (Exp, [Stmt])
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Size -> Exp -> m (Exp, [Stmt])
forall (m :: * -> *).
(MonadState TS m, MonadError AstError m) =>
Size -> Exp -> m (Exp, [Stmt])
connect) ([Size] -> [Exp] -> [(Size, Exp)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Exp -> Size) -> [Exp] -> [Size]
forall a b. (a -> b) -> [a] -> [b]
map Exp -> Size
forall a. SizeAnnotated a => a -> Size
sizeOf [Exp]
esLive) [Exp]
es')
                                    -- The component's port names must match
                                    -- the entity's: default binding
                                    -- associates them by name.
                                    let pns = [Text] -> Maybe [Text] -> [Text]
forall a. a -> Maybe a -> a
fromMaybe ((Int -> Exp -> Text) -> [Int] -> [Exp] -> [Text]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\ Int
i Exp
_ -> Text
"arg" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. TextShow a => a -> Text
showt (Int
i :: Int)) [Int
0 ..] [Exp]
esLive) (Maybe [Text] -> [Text]) -> Maybe [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> PEnv -> Maybe [Text]
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup Text
g PEnv
penv
                                    addComponent $ H.Component (mangleMod g) []
                                          $  zipWith (\ Text
pn Size
sz' -> Text -> Direction -> Size -> Port
H.Port Text
pn Direction
H.In Size
sz') pns (map sizeOf esLive)
                                          <> [H.Port "res" H.Out sz]
                                    mr   <- newWire sz $ g <> "_out"
                                    inst <- fresh $ lastComponent g <> "_i"
                                    modify' $ \ TS
ts -> TS
ts { tsCalls = OMap.insert (g, map expKey es') mr $ tsCalls ts }
                                    pure (H.Var mr, stmts <> hoists <> [H.Instantiate (mangleMod g) inst [] $ map (mempty, ) $ conns <> [H.Var mr]])
                  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
                              Component -> m ()
forall (m :: * -> *). MonadState TS m => Component -> m ()
addComponent (Component -> m ()) -> Component -> m ()
forall a b. (a -> b) -> a -> b
$ Extern -> Component
extComponent Extern
ex
                              let esLive :: [Exp]
esLive = (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
                                  inPorts :: [(Text, Size)]
inPorts = ((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
ex
                              (es', stmts)    <- XEnv -> PEnv -> LEnv -> [Exp] -> m ([Exp], [Stmt])
forall (m :: * -> *).
(MonadState TS m, MonadError AstError m) =>
XEnv -> PEnv -> LEnv -> [Exp] -> m ([Exp], [Stmt])
compileExps XEnv
xenv PEnv
penv LEnv
lenv [Exp]
esLive
                              (conns, hoists) <- (map fst &&& concatMap snd) <$> mapM (uncurry connect) (zip (map sizeOf esLive) es')
                              mr   <- newWire sz "extres"
                              inst <- fresh $ x <> "_i"
                              pure ( H.Var mr
                                   , stmts <> hoists <> [H.Instantiate x inst (zip (extGenerics ex) $ map toInteger cs)
                                          $ zip (map fst inPorts) conns <> outSlices 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 (H.FunCall "rw_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 (BV -> Exp
H.Lit BV
BV.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')

            -- | The output ports of an extern call, associated with slices
            --   of the result wire (MSB-first in declaration order).
            outSlices :: H.Name -> [(M.Name, M.Size)] -> [(H.Name, H.Exp)]
            outSlices :: Text -> [(Text, Size)] -> [(Text, Exp)]
outSlices Text
mr [(Text, Size)]
qs = [ (Text
q, Text -> Int -> Int -> Exp
H.Slice 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, H.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 :: H.Index, []) [(Text, Size)]
qs

            compilePrim :: LEnv -> Annote -> M.Size -> Op -> [M.Exp] -> m (H.Exp, [H.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 -> PEnv -> LEnv -> [Exp] -> m ([Exp], [Stmt])
forall (m :: * -> *).
(MonadState TS m, MonadError AstError m) =>
XEnv -> PEnv -> LEnv -> [Exp] -> m ([Exp], [Stmt])
compileExps XEnv
xenv PEnv
penv 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)
                      bin Text
f Exp
a Exp
b = Exp -> f (Exp, [Stmt])
forall {f :: * -> *} {a}. Applicative f => a -> f (a, [Stmt])
pure' (Exp -> f (Exp, [Stmt])) -> Exp -> f (Exp, [Stmt])
forall a b. (a -> b) -> a -> b
$ Text -> [Exp] -> Exp
H.FunCall Text
f [Exp
a, Exp
b]
                  case (op, es', es) of
                        (Op
M.Add   , [Exp
a, Exp
b], [Exp]
_) -> Text -> Exp -> Exp -> m (Exp, [Stmt])
forall {f :: * -> *}.
Applicative f =>
Text -> Exp -> Exp -> f (Exp, [Stmt])
bin Text
"rw_add" Exp
a Exp
b
                        (Op
M.Sub   , [Exp
a, Exp
b], [Exp]
_) -> Text -> Exp -> Exp -> m (Exp, [Stmt])
forall {f :: * -> *}.
Applicative f =>
Text -> Exp -> Exp -> f (Exp, [Stmt])
bin Text
"rw_sub" Exp
a Exp
b
                        (Op
M.Mul   , [Exp
a, Exp
b], [Exp]
_) -> Text -> Exp -> Exp -> m (Exp, [Stmt])
forall {f :: * -> *}.
Applicative f =>
Text -> Exp -> Exp -> f (Exp, [Stmt])
bin Text
"rw_mul" Exp
a Exp
b
                        (Op
M.Pow   , [Exp
a, Exp
b], [Exp]
_) -> Text -> Exp -> Exp -> m (Exp, [Stmt])
forall {f :: * -> *}.
Applicative f =>
Text -> Exp -> Exp -> f (Exp, [Stmt])
bin Text
"rw_pow" Exp
a Exp
b
                        (Op
M.UDiv  , [Exp
a, Exp
b], [Exp]
_) -> Text -> Exp -> Exp -> m (Exp, [Stmt])
forall {f :: * -> *}.
Applicative f =>
Text -> Exp -> Exp -> f (Exp, [Stmt])
bin Text
"rw_div" Exp
a Exp
b
                        (Op
M.UMod  , [Exp
a, Exp
b], [Exp]
_) -> Text -> Exp -> Exp -> m (Exp, [Stmt])
forall {f :: * -> *}.
Applicative f =>
Text -> Exp -> Exp -> f (Exp, [Stmt])
bin Text
"rw_mod" Exp
a Exp
b
                        (Op
M.And   , [Exp
a, Exp
b], [Exp]
_) -> Text -> Exp -> Exp -> m (Exp, [Stmt])
forall {f :: * -> *}.
Applicative f =>
Text -> Exp -> Exp -> f (Exp, [Stmt])
bin Text
"rw_and" Exp
a Exp
b
                        (Op
M.Or    , [Exp
a, Exp
b], [Exp]
_) -> Text -> Exp -> Exp -> m (Exp, [Stmt])
forall {f :: * -> *}.
Applicative f =>
Text -> Exp -> Exp -> f (Exp, [Stmt])
bin Text
"rw_or" Exp
a Exp
b
                        (Op
M.XOr   , [Exp
a, Exp
b], [Exp]
_) -> Text -> Exp -> Exp -> m (Exp, [Stmt])
forall {f :: * -> *}.
Applicative f =>
Text -> Exp -> Exp -> f (Exp, [Stmt])
bin Text
"rw_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
$ Text -> [Exp] -> Exp
H.FunCall Text
"rw_not" [Exp
a]
                        (Op
M.Shl   , [Exp
a, Exp
b], [Exp]
_) -> Text -> Exp -> Exp -> m (Exp, [Stmt])
forall {f :: * -> *}.
Applicative f =>
Text -> Exp -> Exp -> f (Exp, [Stmt])
bin Text
"rw_shiftl" Exp
a Exp
b
                        (Op
M.LShr  , [Exp
a, Exp
b], [Exp]
_) -> Text -> Exp -> Exp -> m (Exp, [Stmt])
forall {f :: * -> *}.
Applicative f =>
Text -> Exp -> Exp -> f (Exp, [Stmt])
bin Text
"rw_shiftr" Exp
a Exp
b
                        (Op
M.AShr  , [Exp
a, Exp
b], [Exp]
_) -> Text -> Exp -> Exp -> m (Exp, [Stmt])
forall {f :: * -> *}.
Applicative f =>
Text -> Exp -> Exp -> f (Exp, [Stmt])
bin Text
"rw_ashiftr" Exp
a Exp
b
                        (Op
M.Eq    , [Exp
a, Exp
b], [Exp]
_) -> Text -> Exp -> Exp -> m (Exp, [Stmt])
forall {f :: * -> *}.
Applicative f =>
Text -> Exp -> Exp -> f (Exp, [Stmt])
bin Text
"rw_eq" Exp
a Exp
b
                        (Op
M.Ne    , [Exp
a, Exp
b], [Exp]
_) -> Text -> Exp -> Exp -> m (Exp, [Stmt])
forall {f :: * -> *}.
Applicative f =>
Text -> Exp -> Exp -> f (Exp, [Stmt])
bin Text
"rw_neq" Exp
a Exp
b
                        (Op
M.ULt   , [Exp
a, Exp
b], [Exp]
_) -> Text -> Exp -> Exp -> m (Exp, [Stmt])
forall {f :: * -> *}.
Applicative f =>
Text -> Exp -> Exp -> f (Exp, [Stmt])
bin Text
"rw_lt" Exp
a Exp
b
                        (Op
M.ULe   , [Exp
a, Exp
b], [Exp]
_) -> Text -> Exp -> Exp -> m (Exp, [Stmt])
forall {f :: * -> *}.
Applicative f =>
Text -> Exp -> Exp -> f (Exp, [Stmt])
bin Text
"rw_lteq" Exp
a Exp
b
                        (Op
M.UGt   , [Exp
a, Exp
b], [Exp]
_) -> Text -> Exp -> Exp -> m (Exp, [Stmt])
forall {f :: * -> *}.
Applicative f =>
Text -> Exp -> Exp -> f (Exp, [Stmt])
bin Text
"rw_gt" Exp
a Exp
b
                        (Op
M.UGe   , [Exp
a, Exp
b], [Exp]
_) -> Text -> Exp -> Exp -> m (Exp, [Stmt])
forall {f :: * -> *}.
Applicative f =>
Text -> Exp -> Exp -> f (Exp, [Stmt])
bin Text
"rw_gteq" Exp
a Exp
b
                        (Op
M.SLt   , [Exp
a, Exp
b], [Exp]
_) -> Text -> Exp -> Exp -> m (Exp, [Stmt])
forall {f :: * -> *}.
Applicative f =>
Text -> Exp -> Exp -> f (Exp, [Stmt])
bin Text
"rw_lts" Exp
a Exp
b
                        (Op
M.SLe   , [Exp
a, Exp
b], [Exp]
_) -> Text -> Exp -> Exp -> m (Exp, [Stmt])
forall {f :: * -> *}.
Applicative f =>
Text -> Exp -> Exp -> f (Exp, [Stmt])
bin Text
"rw_lteqs" Exp
a Exp
b
                        (Op
M.SGt   , [Exp
a, Exp
b], [Exp]
_) -> Text -> Exp -> Exp -> m (Exp, [Stmt])
forall {f :: * -> *}.
Applicative f =>
Text -> Exp -> Exp -> f (Exp, [Stmt])
bin Text
"rw_gts" Exp
a Exp
b
                        (Op
M.SGe   , [Exp
a, Exp
b], [Exp]
_) -> Text -> Exp -> Exp -> m (Exp, [Stmt])
forall {f :: * -> *}.
Applicative f =>
Text -> Exp -> Exp -> f (Exp, [Stmt])
bin Text
"rw_gteqs" Exp
a Exp
b
                        (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
$ Text -> [Exp] -> Exp
H.FunCall Text
"rw_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
$ Text -> [Exp] -> Exp
H.FunCall Text
"rw_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
$ Text -> [Exp] -> Exp
H.FunCall Text
"rw_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
$ Text -> [Exp] -> Exp
H.FunCall Text
"rw_resize" [Exp
a, Natural -> Exp
H.Num (Natural -> Exp) -> Natural -> Exp
forall a b. (a -> b) -> a -> b
$ Size -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral Size
m]
                        (M.Trunc 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
$ Text -> [Exp] -> Exp
H.FunCall Text
"rw_resize" [Exp
a, Natural -> Exp
H.Num (Natural -> Exp) -> Natural -> Exp
forall a b. (a -> b) -> a -> b
$ Size -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral Size
m]
                        (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      -> 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
$ Text -> [Exp] -> Exp
H.FunCall Text
"rw_sext" [Exp
a, Natural -> Exp
H.Num (Natural -> Exp) -> Natural -> Exp
forall a b. (a -> b) -> a -> b
$ Size -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral Size
m]
                        (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 -> m (Exp, [Stmt])) -> Exp -> m (Exp, [Stmt])
forall a b. (a -> b) -> a -> b
$ BV -> Exp
H.Lit BV
BV.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
$ Text -> [Exp] -> Exp
H.FunCall Text
"rw_repl" [Natural -> Exp
H.Num 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: slices on names and literals
            --   directly; anything else through a fresh wire.
            sliceExp :: M.Size -> M.Index -> M.Size -> H.Exp -> m (H.Exp, [H.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 (BV -> Exp
H.Lit BV
BV.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
                        H.Var Text
n       -> (Exp, [Stmt]) -> m (Exp, [Stmt])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Int -> Int -> Exp
H.Slice 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), [])
                        H.Slice Text
n Int
a Int
_ -> (Exp, [Stmt]) -> m (Exp, [Stmt])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Int -> Int -> Exp
H.Slice 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), [])
                        H.Lit BV
bv      -> (Exp, [Stmt]) -> m (Exp, [Stmt])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BV -> Exp
H.Lit (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 <- Size -> Text -> m Text
forall (m :: * -> *). MonadState TS m => Size -> Text -> m Text
newWire Size
w Text
"slice_in"
                              pure (H.Slice n i' (i' + k' - 1), [H.Assign (H.LVName n) e])
                  where i', k' :: H.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

-- | Concatenation, filtering zero-width parts.
hCat :: [H.Exp] -> H.Exp
hCat :: [Exp] -> Exp
hCat [Exp]
es = case (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
hIsNil) [Exp]
es of
      [Exp
e] -> Exp
e
      [Exp]
es' -> [Exp] -> Exp
H.Cat [Exp]
es'

hIsNil :: H.Exp -> Bool
hIsNil :: Exp -> Bool
hIsNil = \ case
      H.Lit BV
bv -> BV -> Int
width BV
bv Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0
      Exp
_        -> Bool
False

-- | Break up giant literals (as the Verilog backend does).
litExp :: BV -> H.Exp
litExp :: BV -> Exp
litExp BV
bv | BV -> Int
width BV
bv Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0         = BV -> Exp
H.Lit BV
BV.nil
          | BV -> Int
width BV
bv Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
maxLit     = BV -> Exp
H.Lit BV
bv
          | BV
bv BV -> BV -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> BV
zeros Int
1         = Text -> [Exp] -> Exp
H.FunCall Text
"rw_repl" [Natural -> Exp
H.Num (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, BV -> Exp
H.Lit (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) = Text -> [Exp] -> Exp
H.FunCall Text
"rw_repl" [Natural -> Exp
H.Num (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, BV -> Exp
H.Lit (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
hCat [BV -> Exp
H.Lit (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, Text -> [Exp] -> Exp
H.FunCall Text
"rw_repl" [Natural -> Exp
H.Num Natural
zs, BV -> Exp
H.Lit (BV -> Exp) -> BV -> Exp
forall a b. (a -> b) -> a -> b
$ Int -> BV
zeros Int
1]]
          | Bool
otherwise             = BV -> Exp
H.Lit 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

-- | The context clause for generated units: the configured VHDL packages
--   (--vhdl-packages) plus the defaults and the emitted rw_helpers package.
unitPackages :: Config -> [Text]
unitPackages :: Config -> [Text]
unitPackages Config
conf = (Text -> [Text] -> [Text]) -> [Text] -> [Text] -> [Text]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ Text
pk [Text]
pks -> if Text
pk Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
pks then [Text]
pks else Text
pk Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
pks)
                          [Text
"ieee.std_logic_1164.all", Text
"ieee.numeric_std.all"]
                          (Config
confConfig -> Getting [Text] Config [Text] -> [Text]
forall s a. s -> Getting a s a -> a
^.Getting [Text] Config [Text]
Lens' Config [Text]
vhdlPackages)
                  [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
"work.rw_helpers.all"]

-- | 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 Verilog testbench).
testbench :: Config -> M.Device -> [Ins] -> H.Unit
testbench :: Config -> Device -> [Ins] -> Unit
testbench Config
conf Device
dev [Ins]
inps = Text
-> [Text]
-> [Text]
-> [Port]
-> [Component]
-> [Signal]
-> [Stmt]
-> Unit
H.Unit Text
"tb" []
      [Text
"ieee.std_logic_1164.all", Text
"ieee.numeric_std.all", Text
"std.textio.all"]
      []
      [Text -> [Text] -> [Port] -> Component
H.Component (Device -> Text
devName Device
dev) [] ([Port] -> Component) -> [Port] -> Component
forall a b. (a -> b) -> a -> b
$ ((Text, Size) -> Port) -> [(Text, Size)] -> [Port]
forall a b. (a -> b) -> [a] -> [b]
map (\ (Text
n, Size
sz) -> Text -> Direction -> Size -> Port
H.Port Text
n Direction
H.In Size
sz) ([(Text, Size)]
clkRst [(Text, Size)] -> [(Text, Size)] -> [(Text, Size)]
forall a. Semigroup a => a -> a -> a
<> [(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 (\ (Text
n, Size
sz) -> Text -> Direction -> Size -> Port
H.Port Text
n Direction
H.Out Size
sz) [(Text, Size)]
outs]
      (((Text, Size) -> Signal) -> [(Text, Size)] -> [Signal]
forall a b. (a -> b) -> [a] -> [b]
map (\ (Text
n, Size
sz) -> Text -> Size -> Maybe BV -> Signal
H.Signal Text
n Size
sz Maybe BV
forall a. Maybe a
Nothing) ([(Text, Size)] -> [Signal]) -> [(Text, Size)] -> [Signal]
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)
      [ Text -> Text -> [(Text, Value)] -> [(Text, Exp)] -> Stmt
H.Instantiate (Device -> Text
devName Device
dev) Text
"dut" [] ([(Text, Exp)] -> Stmt) -> [(Text, Exp)] -> Stmt
forall a b. (a -> b) -> a -> b
$ ((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
. Text -> Exp
H.Var (Text -> Exp) -> ((Text, Size) -> Text) -> (Text, Size) -> Exp
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
      , [Text] -> [ProcVar] -> [SeqStmt] -> Stmt
H.Process [] [Text -> ProcVar
H.LineVar Text
"l" | Bool -> Bool
not ([(Text, Size)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Text, Size)]
outs)] ([SeqStmt] -> Stmt) -> [SeqStmt] -> Stmt
forall a b. (a -> b) -> a -> b
$ [SeqStmt]
resetSeq [SeqStmt] -> [SeqStmt] -> [SeqStmt]
forall a. Semigroup a => a -> a -> a
<> (Ins -> [SeqStmt]) -> [Ins] -> [SeqStmt]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Ins -> [SeqStmt]
cyc [Ins]
inps [SeqStmt] -> [SeqStmt] -> [SeqStmt]
forall a. Semigroup a => a -> a -> a
<> [SeqStmt
H.SFinish]
      ]
      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 -> [H.SeqStmt]
            drive :: Ins -> [SeqStmt]
drive Ins
i = ((Text, Size) -> SeqStmt) -> [(Text, Size)] -> [SeqStmt]
forall a b. (a -> b) -> [a] -> [b]
map (\ (Text
n, Size
sz) -> LVal -> Exp -> SeqStmt
H.SAssign (Text -> LVal
H.LVName Text
n) (Exp -> SeqStmt) -> Exp -> SeqStmt
forall a b. (a -> b) -> a -> b
$ BV -> Exp
H.Lit (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
sz Ins
i Text
n) [(Text, Size)]
ins

            bit :: Bool -> H.Exp
            bit :: Bool -> Exp
bit = BV -> Exp
H.Lit (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 -> [H.SeqStmt]
            tick :: Text -> [SeqStmt]
tick Text
clk = [Natural -> SeqStmt
H.SWait Natural
1, LVal -> Exp -> SeqStmt
H.SAssign (Text -> LVal
H.LVName Text
clk) (Exp -> SeqStmt) -> Exp -> SeqStmt
forall a b. (a -> b) -> a -> b
$ Bool -> Exp
bit Bool
True, Natural -> SeqStmt
H.SWait Natural
5, LVal -> Exp -> SeqStmt
H.SAssign (Text -> LVal
H.LVName Text
clk) (Exp -> SeqStmt) -> Exp -> SeqStmt
forall a b. (a -> b) -> a -> b
$ Bool -> Exp
bit Bool
False]

            resetSeq :: [H.SeqStmt]
            resetSeq :: [SeqStmt]
resetSeq = case (Maybe Text
mclk, Maybe Text
mrst) of
                  (Just Text
clk, Just Text
rst) ->
                        [ LVal -> Exp -> SeqStmt
H.SAssign (Text -> LVal
H.LVName Text
clk) (Exp -> SeqStmt) -> Exp -> SeqStmt
forall a b. (a -> b) -> a -> b
$ Bool -> Exp
bit Bool
False, LVal -> Exp -> SeqStmt
H.SAssign (Text -> LVal
H.LVName Text
rst) (Exp -> SeqStmt) -> Exp -> SeqStmt
forall a b. (a -> b) -> a -> b
$ Bool -> Exp
bit Bool
rstActive ]
                        [SeqStmt] -> [SeqStmt] -> [SeqStmt]
forall a. Semigroup a => a -> a -> a
<> Ins -> [SeqStmt]
drive ([Ins] -> Ins
headIns [Ins]
inps)
                        [SeqStmt] -> [SeqStmt] -> [SeqStmt]
forall a. Semigroup a => a -> a -> a
<> [[SeqStmt]] -> [SeqStmt]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Int -> [SeqStmt] -> [[SeqStmt]]
forall a. Int -> a -> [a]
replicate Int
2 [Natural -> SeqStmt
H.SWait Natural
5, LVal -> Exp -> SeqStmt
H.SAssign (Text -> LVal
H.LVName Text
clk) (Exp -> SeqStmt) -> Exp -> SeqStmt
forall a b. (a -> b) -> a -> b
$ Bool -> Exp
bit Bool
True, Natural -> SeqStmt
H.SWait Natural
5, LVal -> Exp -> SeqStmt
H.SAssign (Text -> LVal
H.LVName Text
clk) (Exp -> SeqStmt) -> Exp -> SeqStmt
forall a b. (a -> b) -> a -> b
$ Bool -> Exp
bit Bool
False])
                        [SeqStmt] -> [SeqStmt] -> [SeqStmt]
forall a. Semigroup a => a -> a -> a
<> [ LVal -> Exp -> SeqStmt
H.SAssign (Text -> LVal
H.LVName Text
rst) (Exp -> SeqStmt) -> Exp -> SeqStmt
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 -> SeqStmt
H.SAssign (Text -> LVal
H.LVName Text
clk) (Exp -> SeqStmt) -> Exp -> SeqStmt
forall a b. (a -> b) -> a -> b
$ Bool -> Exp
bit Bool
False ]
                  (Maybe Text, Maybe Text)
_                    -> []

            cyc :: Ins -> [H.SeqStmt]
            cyc :: Ins -> [SeqStmt]
cyc Ins
i = Ins -> [SeqStmt]
drive Ins
i [SeqStmt] -> [SeqStmt] -> [SeqStmt]
forall a. Semigroup a => a -> a -> a
<> case Maybe Text
mclk of
                  Just Text
clk -> [Natural -> SeqStmt
H.SWait Natural
4] [SeqStmt] -> [SeqStmt] -> [SeqStmt]
forall a. Semigroup a => a -> a -> a
<> [SeqStmt]
writes [SeqStmt] -> [SeqStmt] -> [SeqStmt]
forall a. Semigroup a => a -> a -> a
<> Text -> [SeqStmt]
tick Text
clk
                  Maybe Text
Nothing  -> [Natural -> SeqStmt
H.SWait Natural
5] [SeqStmt] -> [SeqStmt] -> [SeqStmt]
forall a. Semigroup a => a -> a -> a
<> [SeqStmt]
writes [SeqStmt] -> [SeqStmt] -> [SeqStmt]
forall a. Semigroup a => a -> a -> a
<> [Natural -> SeqStmt
H.SWait Natural
5]

            writes :: [H.SeqStmt]
            writes :: [SeqStmt]
writes = (Text -> (Text, Size) -> SeqStmt)
-> [Text] -> [(Text, Size)] -> [SeqStmt]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\ Text
pre (Text
n, Size
_) -> [Chunk] -> SeqStmt
H.SWriteLn [Text -> Chunk
H.ChunkLit (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"), Exp -> Chunk
H.ChunkHex (Text -> Exp
H.Var Text
n), Text -> Chunk
H.ChunkLit Text
"'"]) [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