{-# LANGUAGE DerivingStrategies, GeneralizedNewtypeDeriving #-}
module RetroClash.Memory
    ( RAM, ROM, Port, Port_
    , packRam

    , Handle
    , mapH

    , Addressing
    , memoryMap, memoryMap_

    , conduit, readWrite, readWrite_
    , romFromVec, romFromFile
    , ram0, ramFromFile
    , port, port_

    , connect
    , override

    , from
    , matchJust
    , matchLeft, matchRight
    , tag
    ) where

import Clash.Prelude hiding (Exp, lift)
import RetroClash.Utils
import RetroClash.Port
import Data.Maybe
import Control.Arrow (second)
import Control.Monad
import Control.Monad.Reader
import Control.Monad.Writer
import Data.Kind (Type)

import Data.List as L
import Data.Map.Monoidal as Map

import Language.Haskell.TH hiding (Type)
import Language.Haskell.TH.Instances
import LiftType
import Type.Reflection (Typeable)

type RAM dom addr dat = Signal dom addr -> Signal dom (Maybe (addr, dat)) -> Signal dom dat
type ROM dom addr dat = Signal dom addr ->                                   Signal dom dat
type Port dom addr dat a = Signal dom (Maybe (PortCommand addr dat)) -> (Signal dom dat, a)
type Port_ dom addr dat = Signal dom (Maybe (PortCommand addr dat)) -> Signal dom dat

packRam :: (BitPack dat) => RAM dom addr (BitVector (BitSize dat)) -> RAM dom addr dat
packRam :: RAM dom addr (BitVector (BitSize dat)) -> RAM dom addr dat
packRam RAM dom addr (BitVector (BitSize dat))
ram Signal dom addr
addr = (BitVector (BitSize dat) -> dat)
-> Signal dom (BitVector (BitSize dat)) -> Signal dom dat
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap BitVector (BitSize dat) -> dat
forall a. BitPack a => BitVector (BitSize a) -> a
unpack (Signal dom (BitVector (BitSize dat)) -> Signal dom dat)
-> (Signal dom (Maybe (addr, dat))
    -> Signal dom (BitVector (BitSize dat)))
-> Signal dom (Maybe (addr, dat))
-> Signal dom dat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RAM dom addr (BitVector (BitSize dat))
ram Signal dom addr
addr (Signal dom (Maybe (addr, BitVector (BitSize dat)))
 -> Signal dom (BitVector (BitSize dat)))
-> (Signal dom (Maybe (addr, dat))
    -> Signal dom (Maybe (addr, BitVector (BitSize dat))))
-> Signal dom (Maybe (addr, dat))
-> Signal dom (BitVector (BitSize dat))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe (addr, dat) -> Maybe (addr, BitVector (BitSize dat)))
-> Signal dom (Maybe (addr, dat))
-> Signal dom (Maybe (addr, BitVector (BitSize dat)))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ((dat -> BitVector (BitSize dat))
-> (addr, dat) -> (addr, BitVector (BitSize dat))
forall (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second dat -> BitVector (BitSize dat)
forall a. BitPack a => a -> BitVector (BitSize a)
pack ((addr, dat) -> (addr, BitVector (BitSize dat)))
-> Maybe (addr, dat) -> Maybe (addr, BitVector (BitSize dat))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$>)

data Handle addr = Handle Name Name

-- | type Addr dom addr = TExpQ (Signal dom (Maybe addr))
type Addr = ExpQ

-- | type Dat dom dat = TExpQ (Signal dom (Maybe dat))
type Dat = ExpQ

-- | type Component dom dat a = TExpQ (Signal dom (Maybe dat))
type Component = ExpQ

newtype Addressing addr a = Addressing
    { Addressing addr a
-> ReaderT
     (Addr, Addr) (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q) a
runAddressing :: ReaderT (Addr, Dat) (WriterT (DecsQ, MonoidalMap Name [Addr], [Component]) Q) a }
    deriving newtype (a -> Addressing addr b -> Addressing addr a
(a -> b) -> Addressing addr a -> Addressing addr b
(forall a b. (a -> b) -> Addressing addr a -> Addressing addr b)
-> (forall a b. a -> Addressing addr b -> Addressing addr a)
-> Functor (Addressing addr)
forall k (addr :: k) a b.
a -> Addressing addr b -> Addressing addr a
forall k (addr :: k) a b.
(a -> b) -> Addressing addr a -> Addressing addr b
forall a b. a -> Addressing addr b -> Addressing addr a
forall a b. (a -> b) -> Addressing addr a -> Addressing addr b
forall (f :: Type -> Type).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Addressing addr b -> Addressing addr a
$c<$ :: forall k (addr :: k) a b.
a -> Addressing addr b -> Addressing addr a
fmap :: (a -> b) -> Addressing addr a -> Addressing addr b
$cfmap :: forall k (addr :: k) a b.
(a -> b) -> Addressing addr a -> Addressing addr b
Functor, Functor (Addressing addr)
a -> Addressing addr a
Functor (Addressing addr)
-> (forall a. a -> Addressing addr a)
-> (forall a b.
    Addressing addr (a -> b) -> Addressing addr a -> Addressing addr b)
-> (forall a b c.
    (a -> b -> c)
    -> Addressing addr a -> Addressing addr b -> Addressing addr c)
-> (forall a b.
    Addressing addr a -> Addressing addr b -> Addressing addr b)
-> (forall a b.
    Addressing addr a -> Addressing addr b -> Addressing addr a)
-> Applicative (Addressing addr)
Addressing addr a -> Addressing addr b -> Addressing addr b
Addressing addr a -> Addressing addr b -> Addressing addr a
Addressing addr (a -> b) -> Addressing addr a -> Addressing addr b
(a -> b -> c)
-> Addressing addr a -> Addressing addr b -> Addressing addr c
forall a. a -> Addressing addr a
forall k (addr :: k). Functor (Addressing addr)
forall k (addr :: k) a. a -> Addressing addr a
forall k (addr :: k) a b.
Addressing addr a -> Addressing addr b -> Addressing addr a
forall k (addr :: k) a b.
Addressing addr a -> Addressing addr b -> Addressing addr b
forall k (addr :: k) a b.
Addressing addr (a -> b) -> Addressing addr a -> Addressing addr b
forall k (addr :: k) a b c.
(a -> b -> c)
-> Addressing addr a -> Addressing addr b -> Addressing addr c
forall a b.
Addressing addr a -> Addressing addr b -> Addressing addr a
forall a b.
Addressing addr a -> Addressing addr b -> Addressing addr b
forall a b.
Addressing addr (a -> b) -> Addressing addr a -> Addressing addr b
forall a b c.
(a -> b -> c)
-> Addressing addr a -> Addressing addr b -> Addressing addr c
forall (f :: Type -> Type).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: Addressing addr a -> Addressing addr b -> Addressing addr a
$c<* :: forall k (addr :: k) a b.
Addressing addr a -> Addressing addr b -> Addressing addr a
*> :: Addressing addr a -> Addressing addr b -> Addressing addr b
$c*> :: forall k (addr :: k) a b.
Addressing addr a -> Addressing addr b -> Addressing addr b
liftA2 :: (a -> b -> c)
-> Addressing addr a -> Addressing addr b -> Addressing addr c
$cliftA2 :: forall k (addr :: k) a b c.
(a -> b -> c)
-> Addressing addr a -> Addressing addr b -> Addressing addr c
<*> :: Addressing addr (a -> b) -> Addressing addr a -> Addressing addr b
$c<*> :: forall k (addr :: k) a b.
Addressing addr (a -> b) -> Addressing addr a -> Addressing addr b
pure :: a -> Addressing addr a
$cpure :: forall k (addr :: k) a. a -> Addressing addr a
$cp1Applicative :: forall k (addr :: k). Functor (Addressing addr)
Applicative, Applicative (Addressing addr)
a -> Addressing addr a
Applicative (Addressing addr)
-> (forall a b.
    Addressing addr a -> (a -> Addressing addr b) -> Addressing addr b)
-> (forall a b.
    Addressing addr a -> Addressing addr b -> Addressing addr b)
-> (forall a. a -> Addressing addr a)
-> Monad (Addressing addr)
Addressing addr a -> (a -> Addressing addr b) -> Addressing addr b
Addressing addr a -> Addressing addr b -> Addressing addr b
forall a. a -> Addressing addr a
forall k (addr :: k). Applicative (Addressing addr)
forall k (addr :: k) a. a -> Addressing addr a
forall k (addr :: k) a b.
Addressing addr a -> Addressing addr b -> Addressing addr b
forall k (addr :: k) a b.
Addressing addr a -> (a -> Addressing addr b) -> Addressing addr b
forall a b.
Addressing addr a -> Addressing addr b -> Addressing addr b
forall a b.
Addressing addr a -> (a -> Addressing addr b) -> Addressing addr b
forall (m :: Type -> Type).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> Addressing addr a
$creturn :: forall k (addr :: k) a. a -> Addressing addr a
>> :: Addressing addr a -> Addressing addr b -> Addressing addr b
$c>> :: forall k (addr :: k) a b.
Addressing addr a -> Addressing addr b -> Addressing addr b
>>= :: Addressing addr a -> (a -> Addressing addr b) -> Addressing addr b
$c>>= :: forall k (addr :: k) a b.
Addressing addr a -> (a -> Addressing addr b) -> Addressing addr b
$cp1Monad :: forall k (addr :: k). Applicative (Addressing addr)
Monad)

class Backpane a where
    backpane :: a -> ExpQ

instance Backpane () where
    backpane :: () -> Addr
backpane () = [|()|]

instance (Backpane a1, Backpane a2) => Backpane (a1, a2) where
    backpane :: (a1, a2) -> Addr
backpane (a1
x1, a2
x2) = [| ($(backpane x1), $(backpane x2)) |]

instance (Backpane a1, Backpane a2, Backpane a3) => Backpane (a1, a2, a3) where
    backpane :: (a1, a2, a3) -> Addr
backpane (a1
x1, a2
x2, a3
x3) = [| ($(backpane x1), $(backpane x2), $(backpane x3)) |]

data Result = Result ExpQ

instance Backpane Result where
    backpane :: Result -> Addr
backpane (Result Addr
e) = Addr
e

compile
    :: forall addr a b. (Backpane a)
    => Addressing addr a
    -> Addr
    -> Dat
    -> Component
compile :: Addressing addr a -> Addr -> Addr -> Addr
compile Addressing addr a
addressing Addr
addr Addr
wr = do
    (a
x, (DecsQ
decs, MonoidalMap Name [Addr]
conns, [Addr]
rds)) <-
        WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q a
-> Q (a, (DecsQ, MonoidalMap Name [Addr], [Addr]))
forall w (m :: Type -> Type) a. WriterT w m a -> m (a, w)
runWriterT (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q a
 -> Q (a, (DecsQ, MonoidalMap Name [Addr], [Addr])))
-> WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q a
-> Q (a, (DecsQ, MonoidalMap Name [Addr], [Addr]))
forall a b. (a -> b) -> a -> b
$ ReaderT
  (Addr, Addr) (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q) a
-> (Addr, Addr)
-> WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q a
forall r (m :: Type -> Type) a. ReaderT r m a -> r -> m a
runReaderT (Addressing addr a
-> ReaderT
     (Addr, Addr) (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q) a
forall k (addr :: k) a.
Addressing addr a
-> ReaderT
     (Addr, Addr) (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q) a
runAddressing Addressing addr a
addressing) ([| Just <$> $addr |], Addr
wr)

    let compAddrs :: [DecsQ]
compAddrs = [ [d| $(varP nm) = muxA $(listE addrs) |]
                    | (Name
nm, [Addr]
addrs) <- MonoidalMap Name [Addr] -> [(Name, [Addr])]
forall k a. MonoidalMap k a -> [(k, a)]
Map.toList MonoidalMap Name [Addr]
conns
                    ]
    [Dec]
decs <- [DecsQ] -> DecsQ
forall a. Monoid a => [a] -> a
mconcat (DecsQ
decsDecsQ -> [DecsQ] -> [DecsQ]
forall a. a -> [a] -> [a]
:[DecsQ]
compAddrs)
    [DecQ] -> Addr -> Addr
letE (Dec -> DecQ
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Dec -> DecQ) -> [Dec] -> [DecQ]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [Dec]
decs) [| (muxA $(listE rds), $(backpane x)) |]

memoryMap
    :: forall addr a. (Backpane a)
    => Addr
    -> Dat
    -> Addressing addr a
    -> Component
memoryMap :: Addr -> Addr -> Addressing addr a -> Addr
memoryMap Addr
addr Addr
wr Addressing addr a
addressing =
    [| let addr' = $addr; wr' = $wr
        in $(compile addressing [| addr' |] [| wr' |])
    |]

memoryMap_
    :: forall addr dat. ()
    => Addr
    -> Dat
    -> Addressing addr ()
    -> Dat
memoryMap_ :: Addr -> Addr -> Addressing addr () -> Addr
memoryMap_ Addr
addr Addr
wr Addressing addr ()
addressing = [| fst $(memoryMap addr wr addressing) |]

connect
    :: Handle addr
    -> Addressing addr ()
connect :: Handle addr -> Addressing addr ()
connect (Handle Name
rd Name
compAddr) = ReaderT
  (Addr, Addr)
  (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q)
  ()
-> Addressing addr ()
forall k (addr :: k) a.
ReaderT
  (Addr, Addr) (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q) a
-> Addressing addr a
Addressing (ReaderT
   (Addr, Addr)
   (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q)
   ()
 -> Addressing addr ())
-> ReaderT
     (Addr, Addr)
     (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q)
     ()
-> Addressing addr ()
forall a b. (a -> b) -> a -> b
$ do
    (Addr
addr, Addr
_) <- ReaderT
  (Addr, Addr)
  (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q)
  (Addr, Addr)
forall r (m :: Type -> Type). MonadReader r m => m r
ask
    let masked :: Addr
masked = [| enable (delay False $ isJust <$> $addr) $(varE rd) |]
    (DecsQ, MonoidalMap Name [Addr], [Addr])
-> ReaderT
     (Addr, Addr)
     (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q)
     ()
forall w (m :: Type -> Type). MonadWriter w m => w -> m ()
tell (DecsQ
forall a. Monoid a => a
mempty, Name -> [Addr] -> MonoidalMap Name [Addr]
forall k a. k -> a -> MonoidalMap k a
Map.singleton Name
compAddr [Addr
addr], [Addr
masked])

override
    :: ExpQ
    -> Addressing addr ()
override :: Addr -> Addressing addr ()
override Addr
sig = ReaderT
  (Addr, Addr)
  (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q)
  ()
-> Addressing addr ()
forall k (addr :: k) a.
ReaderT
  (Addr, Addr) (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q) a
-> Addressing addr a
Addressing (ReaderT
   (Addr, Addr)
   (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q)
   ()
 -> Addressing addr ())
-> ReaderT
     (Addr, Addr)
     (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q)
     ()
-> Addressing addr ()
forall a b. (a -> b) -> a -> b
$ do
    Name
rd <- WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q Name
-> ReaderT
     (Addr, Addr)
     (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q)
     Name
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q Name
 -> ReaderT
      (Addr, Addr)
      (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q)
      Name)
-> (Q Name
    -> WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q Name)
-> Q Name
-> ReaderT
     (Addr, Addr)
     (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q)
     Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q Name -> WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q Name
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Name
 -> ReaderT
      (Addr, Addr)
      (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q)
      Name)
-> Q Name
-> ReaderT
     (Addr, Addr)
     (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q)
     Name
forall a b. (a -> b) -> a -> b
$ String -> Q Name
newName String
"rd"
    let decs :: DecsQ
decs = [d| $(varP rd) = $sig |]
    (DecsQ, MonoidalMap Name [Addr], [Addr])
-> ReaderT
     (Addr, Addr)
     (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q)
     ()
forall w (m :: Type -> Type). MonadWriter w m => w -> m ()
tell (DecsQ
decs, MonoidalMap Name [Addr]
forall a. Monoid a => a
mempty, [Name -> Addr
varE Name
rd])

matchAddr
    :: ExpQ {-(addr -> Maybe addr')-}
    -> Addressing addr' a
    -> Addressing addr a
matchAddr :: Addr -> Addressing addr' a -> Addressing addr a
matchAddr Addr
match Addressing addr' a
body = ReaderT
  (Addr, Addr) (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q) a
-> Addressing addr a
forall k (addr :: k) a.
ReaderT
  (Addr, Addr) (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q) a
-> Addressing addr a
Addressing (ReaderT
   (Addr, Addr) (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q) a
 -> Addressing addr a)
-> ReaderT
     (Addr, Addr) (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q) a
-> Addressing addr a
forall a b. (a -> b) -> a -> b
$ do
    Name
nm <- WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q Name
-> ReaderT
     (Addr, Addr)
     (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q)
     Name
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q Name
 -> ReaderT
      (Addr, Addr)
      (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q)
      Name)
-> (Q Name
    -> WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q Name)
-> Q Name
-> ReaderT
     (Addr, Addr)
     (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q)
     Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q Name -> WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q Name
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Name
 -> ReaderT
      (Addr, Addr)
      (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q)
      Name)
-> Q Name
-> ReaderT
     (Addr, Addr)
     (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q)
     Name
forall a b. (a -> b) -> a -> b
$ String -> Q Name
newName String
"addr"
    let addr' :: Addr
addr' = Name -> Addr
varE Name
nm
    ((Addr, Addr)
 -> WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q a)
-> ReaderT
     (Addr, Addr) (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q) a
forall r (m :: Type -> Type) a. (r -> m a) -> ReaderT r m a
ReaderT (((Addr, Addr)
  -> WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q a)
 -> ReaderT
      (Addr, Addr)
      (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q)
      a)
-> ((Addr, Addr)
    -> WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q a)
-> ReaderT
     (Addr, Addr) (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q) a
forall a b. (a -> b) -> a -> b
$ \(Addr
addr, Addr
wr) -> do
        let dec :: DecsQ
dec = [d| $(varP nm) = ($match =<<) <$> $addr |]
        ReaderT
  (Addr, Addr) (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q) a
-> (Addr, Addr)
-> WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q a
forall r (m :: Type -> Type) a. ReaderT r m a -> r -> m a
runReaderT
          ((DecsQ, MonoidalMap Name [Addr], [Addr])
-> ReaderT
     (Addr, Addr)
     (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q)
     ()
forall w (m :: Type -> Type). MonadWriter w m => w -> m ()
tell (DecsQ
dec, MonoidalMap Name [Addr]
forall a. Monoid a => a
mempty, [Addr]
forall a. Monoid a => a
mempty) ReaderT
  (Addr, Addr)
  (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q)
  ()
-> ReaderT
     (Addr, Addr) (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q) a
-> ReaderT
     (Addr, Addr) (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q) a
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> Addressing addr' a
-> ReaderT
     (Addr, Addr) (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q) a
forall k (addr :: k) a.
Addressing addr a
-> ReaderT
     (Addr, Addr) (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q) a
runAddressing Addressing addr' a
body)
          (Addr
addr', Addr
wr)

mapH :: ExpQ -> Handle addr' -> Addressing addr (Handle addr')
mapH :: Addr -> Handle addr' -> Addressing addr (Handle addr')
mapH Addr
f (Handle Name
rd Name
compAddr) = ReaderT
  (Addr, Addr)
  (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q)
  (Handle addr')
-> Addressing addr (Handle addr')
forall k (addr :: k) a.
ReaderT
  (Addr, Addr) (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q) a
-> Addressing addr a
Addressing (ReaderT
   (Addr, Addr)
   (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q)
   (Handle addr')
 -> Addressing addr (Handle addr'))
-> ReaderT
     (Addr, Addr)
     (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q)
     (Handle addr')
-> Addressing addr (Handle addr')
forall a b. (a -> b) -> a -> b
$ do
    Name
rd' <- WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q Name
-> ReaderT
     (Addr, Addr)
     (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q)
     Name
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q Name
 -> ReaderT
      (Addr, Addr)
      (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q)
      Name)
-> (Q Name
    -> WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q Name)
-> Q Name
-> ReaderT
     (Addr, Addr)
     (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q)
     Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q Name -> WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q Name
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Name
 -> ReaderT
      (Addr, Addr)
      (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q)
      Name)
-> Q Name
-> ReaderT
     (Addr, Addr)
     (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q)
     Name
forall a b. (a -> b) -> a -> b
$ String -> Q Name
newName String
"rd"
    (DecsQ, MonoidalMap Name [Addr], [Addr])
-> ReaderT
     (Addr, Addr)
     (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q)
     ()
forall w (m :: Type -> Type). MonadWriter w m => w -> m ()
tell ([d| $(varP rd') = $f <$> $(varE rd)|], MonoidalMap Name [Addr]
forall a. Monoid a => a
mempty, [Addr]
forall a. Monoid a => a
mempty)
    Handle addr'
-> ReaderT
     (Addr, Addr)
     (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q)
     (Handle addr')
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Handle addr'
 -> ReaderT
      (Addr, Addr)
      (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q)
      (Handle addr'))
-> Handle addr'
-> ReaderT
     (Addr, Addr)
     (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q)
     (Handle addr')
forall a b. (a -> b) -> a -> b
$ Name -> Name -> Handle addr'
forall k (addr :: k). Name -> Name -> Handle addr
Handle Name
rd' Name
compAddr

readWrite
    :: forall addr' addr. ()
    => (Addr -> Dat -> Component)
    -> Addressing addr (Handle addr', Result)
readWrite :: (Addr -> Addr -> Addr) -> Addressing addr (Handle addr', Result)
readWrite Addr -> Addr -> Addr
component = ReaderT
  (Addr, Addr)
  (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q)
  (Handle addr', Result)
-> Addressing addr (Handle addr', Result)
forall k (addr :: k) a.
ReaderT
  (Addr, Addr) (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q) a
-> Addressing addr a
Addressing (ReaderT
   (Addr, Addr)
   (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q)
   (Handle addr', Result)
 -> Addressing addr (Handle addr', Result))
-> ReaderT
     (Addr, Addr)
     (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q)
     (Handle addr', Result)
-> Addressing addr (Handle addr', Result)
forall a b. (a -> b) -> a -> b
$ do
    Name
rd <- WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q Name
-> ReaderT
     (Addr, Addr)
     (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q)
     Name
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q Name
 -> ReaderT
      (Addr, Addr)
      (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q)
      Name)
-> (Q Name
    -> WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q Name)
-> Q Name
-> ReaderT
     (Addr, Addr)
     (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q)
     Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q Name -> WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q Name
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Name
 -> ReaderT
      (Addr, Addr)
      (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q)
      Name)
-> Q Name
-> ReaderT
     (Addr, Addr)
     (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q)
     Name
forall a b. (a -> b) -> a -> b
$ String -> Q Name
newName String
"rd"
    Name
addr <- WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q Name
-> ReaderT
     (Addr, Addr)
     (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q)
     Name
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q Name
 -> ReaderT
      (Addr, Addr)
      (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q)
      Name)
-> (Q Name
    -> WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q Name)
-> Q Name
-> ReaderT
     (Addr, Addr)
     (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q)
     Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q Name -> WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q Name
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Name
 -> ReaderT
      (Addr, Addr)
      (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q)
      Name)
-> Q Name
-> ReaderT
     (Addr, Addr)
     (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q)
     Name
forall a b. (a -> b) -> a -> b
$ String -> Q Name
newName String
"compAddr"
    Name
result <- WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q Name
-> ReaderT
     (Addr, Addr)
     (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q)
     Name
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q Name
 -> ReaderT
      (Addr, Addr)
      (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q)
      Name)
-> (Q Name
    -> WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q Name)
-> Q Name
-> ReaderT
     (Addr, Addr)
     (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q)
     Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q Name -> WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q Name
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Name
 -> ReaderT
      (Addr, Addr)
      (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q)
      Name)
-> Q Name
-> ReaderT
     (Addr, Addr)
     (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q)
     Name
forall a b. (a -> b) -> a -> b
$ String -> Q Name
newName String
"result"
    (Addr
_, Addr
wr) <- ReaderT
  (Addr, Addr)
  (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q)
  (Addr, Addr)
forall r (m :: Type -> Type). MonadReader r m => m r
ask
    let decs :: DecsQ
decs = [d| ($(varP rd), $(varP result)) = $(component (varE addr) wr) |]
    (DecsQ, MonoidalMap Name [Addr], [Addr])
-> ReaderT
     (Addr, Addr)
     (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q)
     ()
forall w (m :: Type -> Type). MonadWriter w m => w -> m ()
tell (DecsQ
decs, Name -> [Addr] -> MonoidalMap Name [Addr]
forall k a. k -> a -> MonoidalMap k a
Map.singleton Name
addr [Addr]
forall a. Monoid a => a
mempty, [Addr]
forall a. Monoid a => a
mempty)
    (Handle addr', Result)
-> ReaderT
     (Addr, Addr)
     (WriterT (DecsQ, MonoidalMap Name [Addr], [Addr]) Q)
     (Handle addr', Result)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Name -> Name -> Handle addr'
forall k (addr :: k). Name -> Name -> Handle addr
Handle Name
rd Name
addr, Addr -> Result
Result (Name -> Addr
varE Name
result))

readWrite_
    :: forall addr' addr. ()
    => (Addr -> Dat -> Dat)
    -> Addressing addr (Handle addr')
readWrite_ :: (Addr -> Addr -> Addr) -> Addressing addr (Handle addr')
readWrite_ Addr -> Addr -> Addr
component = ((Handle addr', Result) -> Handle addr')
-> Addressing addr (Handle addr', Result)
-> Addressing addr (Handle addr')
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (Handle addr', Result) -> Handle addr'
forall a b. (a, b) -> a
fst (Addressing addr (Handle addr', Result)
 -> Addressing addr (Handle addr'))
-> Addressing addr (Handle addr', Result)
-> Addressing addr (Handle addr')
forall a b. (a -> b) -> a -> b
$ (Addr -> Addr -> Addr) -> Addressing addr (Handle addr', Result)
forall k k (addr' :: k) (addr :: k).
(Addr -> Addr -> Addr) -> Addressing addr (Handle addr', Result)
readWrite ((Addr -> Addr -> Addr) -> Addressing addr (Handle addr', Result))
-> (Addr -> Addr -> Addr) -> Addressing addr (Handle addr', Result)
forall a b. (a -> b) -> a -> b
$ \Addr
addr Addr
wr -> [| ($(component addr wr), ()) |]

conduit
    :: forall addr' addr. ()
    => ExpQ
    -> Addressing addr (Handle addr', Result, Result)
conduit :: Addr -> Addressing addr (Handle addr', Result, Result)
conduit Addr
rdExt = do
    (Handle addr'
h, Result Addr
x) <- (Addr -> Addr -> Addr) -> Addressing addr (Handle addr', Result)
forall k k (addr' :: k) (addr :: k).
(Addr -> Addr -> Addr) -> Addressing addr (Handle addr', Result)
readWrite ((Addr -> Addr -> Addr) -> Addressing addr (Handle addr', Result))
-> (Addr -> Addr -> Addr) -> Addressing addr (Handle addr', Result)
forall a b. (a -> b) -> a -> b
$ \Addr
addr Addr
wr -> [| ($rdExt, ($addr, $wr)) |]
    (Handle addr', Result, Result)
-> Addressing addr (Handle addr', Result, Result)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Handle addr'
h, Addr -> Result
Result [| fst $x |], Addr -> Result
Result [| snd $x |])

romFromVec
    :: (1 <= n)
    => SNat n
    -> ExpQ {-(Vec n dat)-}
    -> Addressing addr (Handle (Index n))
romFromVec :: SNat n -> Addr -> Addressing addr (Handle (Index n))
romFromVec SNat n
size Addr
xs = (Addr -> Addr -> Addr) -> Addressing addr (Handle (Index n))
forall k k (addr' :: k) (addr :: k).
(Addr -> Addr -> Addr) -> Addressing addr (Handle addr')
readWrite_ ((Addr -> Addr -> Addr) -> Addressing addr (Handle (Index n)))
-> (Addr -> Addr -> Addr) -> Addressing addr (Handle (Index n))
forall a b. (a -> b) -> a -> b
$ \Addr
addr Addr
_wr ->
    [| rom $xs (bitCoerce . fromJustX <$> $addr) |]

romFromFile
    :: (1 <= n)
    => SNat n
    -> ExpQ
    -> Addressing addr (Handle (Index n))
romFromFile :: SNat n -> Addr -> Addressing addr (Handle (Index n))
romFromFile SNat n
size Addr
fileName = (Addr -> Addr -> Addr) -> Addressing addr (Handle (Index n))
forall k k (addr' :: k) (addr :: k).
(Addr -> Addr -> Addr) -> Addressing addr (Handle addr')
readWrite_ ((Addr -> Addr -> Addr) -> Addressing addr (Handle (Index n)))
-> (Addr -> Addr -> Addr) -> Addressing addr (Handle (Index n))
forall a b. (a -> b) -> a -> b
$ \Addr
addr Addr
_wr ->
    [| fmap unpack $ romFilePow2 $fileName (bitCoerce . fromJustX <$> $addr) |]

ram0
    :: (1 <= n)
    => SNat n
    -> Addressing addr (Handle (Index n))
ram0 :: SNat n -> Addressing addr (Handle (Index n))
ram0 SNat n
size = (Addr -> Addr -> Addr) -> Addressing addr (Handle (Index n))
forall k k (addr' :: k) (addr :: k).
(Addr -> Addr -> Addr) -> Addressing addr (Handle addr')
readWrite_ ((Addr -> Addr -> Addr) -> Addressing addr (Handle (Index n)))
-> (Addr -> Addr -> Addr) -> Addressing addr (Handle (Index n))
forall a b. (a -> b) -> a -> b
$ \Addr
addr Addr
wr ->
    [| blockRam1 NoClearOnReset size 0 (fromJustX <$> $addr) (liftA2 (,) <$> $addr <*> $wr) |]

ramFromFile
    :: SNat n
    -> ExpQ {- FilePath -}
    -> Addressing addr (Handle (Index n))
ramFromFile :: SNat n -> Addr -> Addressing addr (Handle (Index n))
ramFromFile SNat n
size Addr
fileName = (Addr -> Addr -> Addr) -> Addressing addr (Handle (Index n))
forall k k (addr' :: k) (addr :: k).
(Addr -> Addr -> Addr) -> Addressing addr (Handle addr')
readWrite_ ((Addr -> Addr -> Addr) -> Addressing addr (Handle (Index n)))
-> (Addr -> Addr -> Addr) -> Addressing addr (Handle (Index n))
forall a b. (a -> b) -> a -> b
$ \Addr
addr Addr
wr ->
    [| packRam (blockRamFile size $fileName)
           (fromJustX <$> $addr)
           (liftA2 (,) <$> $addr <*> $wr)
    |]

port
    :: forall addr' a addr. ()
    => ExpQ
    -> Addressing addr (Handle addr', Result)
port :: Addr -> Addressing addr (Handle addr', Result)
port Addr
mkPort = (Addr -> Addr -> Addr) -> Addressing addr (Handle addr', Result)
forall k k (addr' :: k) (addr :: k).
(Addr -> Addr -> Addr) -> Addressing addr (Handle addr', Result)
readWrite ((Addr -> Addr -> Addr) -> Addressing addr (Handle addr', Result))
-> (Addr -> Addr -> Addr) -> Addressing addr (Handle addr', Result)
forall a b. (a -> b) -> a -> b
$ \Addr
addr Addr
wr ->
  [| let (read, x) = $mkPort $ portFromAddr $addr $wr
     in (delay undefined read, x)
  |]

port_
    :: forall addr' addr. ()
    => ExpQ
    -> Addressing addr (Handle addr')
port_ :: Addr -> Addressing addr (Handle addr')
port_ Addr
mkPort = (Addr -> Addr -> Addr) -> Addressing addr (Handle addr')
forall k k (addr' :: k) (addr :: k).
(Addr -> Addr -> Addr) -> Addressing addr (Handle addr')
readWrite_ ((Addr -> Addr -> Addr) -> Addressing addr (Handle addr'))
-> (Addr -> Addr -> Addr) -> Addressing addr (Handle addr')
forall a b. (a -> b) -> a -> b
$ \Addr
addr Addr
wr ->
  [| let read = $mkPort $ portFromAddr $addr $wr
     in delay undefined read
  |]

from
    :: forall addr' addr a. (Typeable addr', Lift addr)
    => (Integral addr, Ord addr, Integral addr', Bounded addr')
    => addr
    -> Addressing addr' a
    -> Addressing addr a
from :: addr -> Addressing addr' a -> Addressing addr a
from addr
base = Addr -> Addressing addr' a -> Addressing addr a
forall k k (addr' :: k) a (addr :: k).
Addr -> Addressing addr' a -> Addressing addr a
matchAddr [| from' @($(liftTypeQ @addr')) base |]

tag
    :: (Lift addr')
    => addr'
    -> Addressing (addr', addr) a
    -> Addressing addr a
tag :: addr' -> Addressing (addr', addr) a -> Addressing addr a
tag addr'
t = Addr -> Addressing (addr', addr) a -> Addressing addr a
forall k k (addr' :: k) a (addr :: k).
Addr -> Addressing addr' a -> Addressing addr a
matchAddr [| \addr -> Just (t, addr) |]

matchJust
    :: Addressing addr a
    -> Addressing (Maybe addr) a
matchJust :: Addressing addr a -> Addressing (Maybe addr) a
matchJust = Addr -> Addressing addr a -> Addressing (Maybe addr) a
forall k k (addr' :: k) a (addr :: k).
Addr -> Addressing addr' a -> Addressing addr a
matchAddr [| id |]

matchLeft
    :: Addressing addr1 a
    -> Addressing (Either addr1 addr2) a
matchLeft :: Addressing addr1 a -> Addressing (Either addr1 addr2) a
matchLeft = Addr -> Addressing addr1 a -> Addressing (Either addr1 addr2) a
forall k k (addr' :: k) a (addr :: k).
Addr -> Addressing addr' a -> Addressing addr a
matchAddr [| either Just (const Nothing) |]

matchRight
    :: Addressing addr2 a
    -> Addressing (Either addr1 addr2) a
matchRight :: Addressing addr2 a -> Addressing (Either addr1 addr2) a
matchRight = Addr -> Addressing addr2 a -> Addressing (Either addr1 addr2) a
forall k k (addr' :: k) a (addr :: k).
Addr -> Addressing addr' a -> Addressing addr a
matchAddr [| either (const Nothing) Just |]

from'
    :: forall addr' addr. (Integral addr, Ord addr, Integral addr', Bounded addr')
    => addr -> addr -> Maybe addr'
from' :: addr -> addr -> Maybe addr'
from' addr
base addr
addr = do
    Bool -> Maybe ()
forall (f :: Type -> Type). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ addr
addr addr -> addr -> Bool
forall a. Ord a => a -> a -> Bool
>= addr
base
    let offset :: addr
offset = addr
addr addr -> addr -> addr
forall a. Num a => a -> a -> a
- addr
base
    Bool -> Maybe ()
forall (f :: Type -> Type). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ addr
offset addr -> addr -> Bool
forall a. Ord a => a -> a -> Bool
<= addr' -> addr
forall a b. (Integral a, Num b) => a -> b
fromIntegral (addr'
forall a. Bounded a => a
maxBound :: addr')
    addr' -> Maybe addr'
forall (m :: Type -> Type) a. Monad m => a -> m a
return (addr -> addr'
forall a b. (Integral a, Num b) => a -> b
fromIntegral addr
offset)