-- SPDX-FileCopyrightText: 2023-2024 University of Bremen
-- SPDX-FileCopyrightText: 2025 Sören Tempel <soeren+git@soeren-tempel.net>
--
-- SPDX-License-Identifier: MIT AND GPL-3.0-only

-- | This module provides an implementation of a simple byte-addressable memory
-- based on "Data.Array".
module Language.QBE.Simulator.Memory
  ( -- * Type Aliases
    Address,
    Size,
    showAddr,

    -- * Value Representation
    Storable (toBytes, fromBytes),

    -- * Memory Representation
    Memory,
    mkMemory,
    memSize,
    loadBytes,
    storeBytes,

    -- * Memory Address
    toMemAddr,
    addrOverlap,
    alignAddr,
  )
where

import Data.Array.IO
  ( MArray,
    getBounds,
    newArray_,
    readArray,
    writeArray,
  )
import Data.Bits (complement, (.&.))
import Data.Word (Word64)
import Language.QBE.Types qualified as QBE
import Numeric (showHex)

-- | Type used to represent an address in memory.
type Address = Word64

-- | Type used to represent the memory's size.
type Size = Word64

-- | Represent an address as a hexadecimal string.
showAddr :: Address -> String
showAddr :: Address -> String
showAddr Address
addr = String
"0x" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Address -> String -> String
forall a. Integral a => a -> String -> String
showHex Address
addr String
""

------------------------------------------------------------------------

-- | Type class for types that can be stored in memory. That is, types whose
-- values can be converted to the given byte representation and vice versa.
class Storable valTy byteTy where
  -- | Convert a value type to a list of byte types.
  toBytes :: valTy -> [byteTy]

  -- | Convert a list of bytes to a value type of 'QBE.LoadType'. Returns
  -- 'Nothing' if the length of the list is incompatible with the given
  -- 'QBE.LoadType'.
  fromBytes :: QBE.LoadType -> [byteTy] -> Maybe valTy

-- | Memory parameterized over the Array type (e.g. 'Data.Array.IO.IOUArray')
-- and a byte polymorphic representation (e.g. 'Data.Word.Word8').
data Memory a v = Memory
  { forall {k} (a :: * -> k -> *) (v :: k). Memory a v -> Address
memStart :: Address,
    forall {k} (a :: * -> k -> *) (v :: k). Memory a v -> a Address v
memBytes :: a Address v
  }

-- | Create a new t'Memory' which starts at the given base address and
-- has a maximum capacity (i.e., can store up to the given amount of bytes).
-- The memory is not initialized, reading an uninitialized values results
-- in an error.
mkMemory :: (MArray t a IO) => Address -> Size -> IO (Memory t a)
mkMemory :: forall (t :: * -> * -> *) a.
MArray t a IO =>
Address -> Address -> IO (Memory t a)
mkMemory Address
startAddr Address
size = do
  t Address a
ary <- (Address, Address) -> IO (t Address a)
forall i. Ix i => (i, i) -> IO (t i a)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
newArray_ (Address
0, Address
size Address -> Address -> Address
forall a. Num a => a -> a -> a
- Address
1)
  Memory t a -> IO (Memory t a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Memory t a -> IO (Memory t a)) -> Memory t a -> IO (Memory t a)
forall a b. (a -> b) -> a -> b
$ Address -> t Address a -> Memory t a
forall {k} (a :: * -> k -> *) (v :: k).
Address -> a Address v -> Memory a v
Memory Address
startAddr t Address a
ary

-- | Translate global address to a memory-local address. That is, performs
-- address translation relative to the base address of the t'Memory'.
toMemAddr :: Memory t a -> Address -> Address
toMemAddr :: forall {k} (t :: * -> k -> *) (a :: k).
Memory t a -> Address -> Address
toMemAddr Memory t a
mem Address
addr = Address
addr Address -> Address -> Address
forall a. Num a => a -> a -> a
- Memory t a -> Address
forall {k} (a :: * -> k -> *) (v :: k). Memory a v -> Address
memStart Memory t a
mem

-- | Returns true if the given addresses, passed in the first and second
-- argument, overlap in the given range (i.e., the given amount of bytes).
addrOverlap :: Address -> Address -> Size -> Bool
addrOverlap :: Address -> Address -> Address -> Bool
addrOverlap Address
addr1 Address
addr2 Address
range =
  Address
addr1 Address -> Address -> Bool
forall a. Ord a => a -> a -> Bool
< Address -> Address
endAddr Address
addr2 Bool -> Bool -> Bool
&& Address -> Address
endAddr Address
addr1 Address -> Address -> Bool
forall a. Ord a => a -> a -> Bool
> Address
addr2
  where
    endAddr :: Address -> Address
    endAddr :: Address -> Address
endAddr Address
a = Address
a Address -> Address -> Address
forall a. Num a => a -> a -> a
+ Address
range

-- | Align an address upwards for the given alignment.
alignAddr :: Address -> Size -> Address
alignAddr :: Address -> Address -> Address
alignAddr Address
addr Address
align = (Address
addr Address -> Address -> Address
forall a. Num a => a -> a -> a
+ (Address
align Address -> Address -> Address
forall a. Num a => a -> a -> a
- Address
1)) Address -> Address -> Address
forall a. Bits a => a -> a -> a
.&. Address -> Address
forall a. Bits a => a -> a
complement (Address
align Address -> Address -> Address
forall a. Num a => a -> a -> a
- Address
1)

-- | Returns the size of the memory in bytes.
memSize :: (MArray t a IO) => Memory t a -> IO Size
memSize :: forall (t :: * -> * -> *) a.
MArray t a IO =>
Memory t a -> IO Address
memSize = ((Address, Address) -> Address)
-> IO (Address, Address) -> IO Address
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Address -> Address -> Address
forall a. Num a => a -> a -> a
+ Address
1) (Address -> Address)
-> ((Address, Address) -> Address) -> (Address, Address) -> Address
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Address, Address) -> Address
forall a b. (a, b) -> b
snd) (IO (Address, Address) -> IO Address)
-> (Memory t a -> IO (Address, Address))
-> Memory t a
-> IO Address
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t Address a -> IO (Address, Address)
forall i. Ix i => t i a -> IO (i, i)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> m (i, i)
getBounds (t Address a -> IO (Address, Address))
-> (Memory t a -> t Address a)
-> Memory t a
-> IO (Address, Address)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Memory t a -> t Address a
forall {k} (a :: * -> k -> *) (v :: k). Memory a v -> a Address v
memBytes

-- | Write the list of bytes to memory at the given address.
storeBytes :: (MArray t a IO) => Memory t a -> Address -> [a] -> IO ()
storeBytes :: forall (t :: * -> * -> *) a.
MArray t a IO =>
Memory t a -> Address -> [a] -> IO ()
storeBytes Memory t a
mem Address
addr [a]
bytes =
  ((Address, a) -> IO ()) -> [(Address, a)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(Address
off, a
val) -> Memory t a -> Address -> a -> IO ()
forall (t :: * -> * -> *) a.
MArray t a IO =>
Memory t a -> Address -> a -> IO ()
storeByte Memory t a
mem (Address
addr Address -> Address -> Address
forall a. Num a => a -> a -> a
+ Address
off) a
val) ([(Address, a)] -> IO ()) -> [(Address, a)] -> IO ()
forall a b. (a -> b) -> a -> b
$
    [Address] -> [a] -> [(Address, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Address
0 ..] [a]
bytes
  where
    storeByte :: (MArray t a IO) => Memory t a -> Address -> a -> IO ()
    storeByte :: forall (t :: * -> * -> *) a.
MArray t a IO =>
Memory t a -> Address -> a -> IO ()
storeByte Memory t a
m Address
a = t Address a -> Address -> a -> IO ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray (Memory t a -> t Address a
forall {k} (a :: * -> k -> *) (v :: k). Memory a v -> a Address v
memBytes Memory t a
m) (Address -> a -> IO ()) -> Address -> a -> IO ()
forall a b. (a -> b) -> a -> b
$ Memory t a -> Address -> Address
forall {k} (t :: * -> k -> *) (a :: k).
Memory t a -> Address -> Address
toMemAddr Memory t a
mem Address
a
{-# INLINEABLE storeBytes #-}

-- | Load the given amount of bytes at the given address.
loadBytes :: (MArray t a IO) => Memory t a -> Address -> Size -> IO [a]
loadBytes :: forall (t :: * -> * -> *) a.
MArray t a IO =>
Memory t a -> Address -> Address -> IO [a]
loadBytes Memory t a
mem Address
addr Address
byteSize =
  (Address -> IO a) -> [Address] -> IO [a]
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 (\Address
off -> Memory t a -> Address -> IO a
forall (t :: * -> * -> *) a.
MArray t a IO =>
Memory t a -> Address -> IO a
loadByte Memory t a
mem (Address
addr Address -> Address -> Address
forall a. Num a => a -> a -> a
+ Address
off)) [Address
0 .. Address
byteSize Address -> Address -> Address
forall a. Num a => a -> a -> a
- Address
1]
  where
    loadByte :: (MArray t a IO) => Memory t a -> Address -> IO a
    loadByte :: forall (t :: * -> * -> *) a.
MArray t a IO =>
Memory t a -> Address -> IO a
loadByte Memory t a
m = t Address a -> Address -> IO a
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray (Memory t a -> t Address a
forall {k} (a :: * -> k -> *) (v :: k). Memory a v -> a Address v
memBytes Memory t a
m) (Address -> IO a) -> (Address -> Address) -> Address -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Memory t a -> Address -> Address
forall {k} (t :: * -> k -> *) (a :: k).
Memory t a -> Address -> Address
toMemAddr Memory t a
m
{-# INLINEABLE loadBytes #-}