Last active
October 19, 2023 07:45
-
-
Save gatlin/8016855 to your computer and use it in GitHub Desktop.
Unfinished proof of concept LC3 emulator in Haskell. My strategy is to build an EDSL which can be built up programmatically.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# LANGUAGE DeriveFunctor #-} | |
{-# LANGUAGE GeneralizedNewtypeDeriving #-} | |
import Prelude hiding (not,and,log) | |
import Control.Monad | |
import Control.Monad.State | |
import Control.Monad.Free | |
import Control.Monad.Trans | |
import Control.Monad.Writer | |
import qualified Data.Vector.Unboxed as U | |
import qualified Data.Vector.Generic.Mutable as GM | |
import Data.Bits ((.&.), complement) | |
import GHC.Word (Word16 (..)) | |
import Data.List hiding (and) | |
-- | The machine's registers | |
data Register = R0 | R1 | R2 | R3 | R4 | R5 | R6 | R7 | PC | IR | MAR | MDR | |
| CCR | |
deriving (Ord, Show, Eq, Enum, Bounded) | |
-- | A generalization of register and memory addresses | |
data Address = Register Register | |
| Ram Word16 | |
deriving Eq | |
-- | Convert a register into an appropriate machine address | |
fromAddress :: Address -> Int | |
fromAddress (Register r) = 0x10000 + fromEnum r | |
fromAddress (Ram r) = fromIntegral r | |
-- | Condition codes for branching | |
data ConditionCode = CCn | CCz | CCp | |
deriving (Eq, Show, Enum) | |
-- | The state of our machine. Just memory so far, but will eventually include | |
-- a clock and some sources of input | |
data MState = MState { mem :: U.Vector Word16 | |
, cc :: ConditionCode} | |
deriving Show | |
-- | Our machine proper. A composition of StateT, WriterT, and IO monads storing the | |
-- MState. | |
newtype Machine a = M { runM :: WriterT [String] (StateT MState IO) a } | |
deriving (Monad, MonadIO, MonadState MState, MonadWriter [String]) | |
-- | Log a message | |
log :: [String] -> Machine () | |
log msgs = tell [ concat $ intersperse " " msgs ] | |
-- | Self-explanatory | |
initialState :: MState | |
initialState = MState { mem = U.replicate 65548 0x0 | |
, cc = CCz | |
} | |
-- | Run a Machine monad | |
runMachine :: Machine a -> IO ((a, [String]), MState) | |
runMachine k = runStateT (runWriterT (runM k)) initialState | |
-- | Syntax tree for the basic load and store commands memory should support | |
data OpF k = Load Address (Word16 -> k) | |
| Store Address Word16 k | |
| ReadCC (ConditionCode -> k) | |
deriving Functor | |
-- | Op is an operation on memory. | |
type Op = Free OpF | |
-- | Load a Word16 from memory inside the Op. | |
load :: Address -> Op Word16 | |
load x = liftF $ Load x id | |
-- | Store a Word16 in memory. | |
store :: Address -> Word16 -> Op () | |
store x y = liftF $ Store x y () | |
-- | Read the current condition code | |
readCC :: Op ConditionCode | |
readCC = liftF $ ReadCC id | |
-- | Build a Machine computation out of Ops. | |
runOp :: Op a -> Machine a | |
runOp (Pure r) = return r | |
runOp (Free (Store addr val next)) = do | |
state <- get | |
m <- return $ mem state | |
a <- return $ fromAddress addr | |
m' <- return $ U.update m (U.fromList [(a,val)]) | |
put $ state { mem = m' } | |
runOp next | |
runOp (Free (Load addr next)) = do | |
state <- get | |
m <- return $ mem state | |
a <- return $ fromAddress addr | |
val <- return $ m U.! a | |
go addr state val | |
runOp $ next val | |
where go (Register r) s v | v < 0 = put $ s { cc = CCn } | |
| v == 0 = put $ s { cc = CCz } | |
| v > 0 = put $ s { cc = CCp } | |
go (Ram r) s v = put s | |
runOp (Free (ReadCC next)) = do | |
state <- get | |
code <- return $ cc state | |
runOp $ next code | |
opTest :: Machine () | |
opTest = runOp $ do | |
store (Register R0) 1 | |
v <- load $ Register R0 | |
store (Ram 0xFFFF) v | |
store (Register PC) 0x1 | |
pc <- load $ Register PC | |
return () | |
-- | Execution modes for ADD / AND | |
data Mode = Mr | Mi | Ml | |
deriving (Eq, Enum) | |
instance Show Mode where | |
show (Mr) = "r" | |
show (Mi) = "i" | |
show (Ml) = "l" | |
data AssemblyF k = Add Mode Register Register Integer k | |
| And Mode Register Register Integer k | |
| Not Register Register k | |
| Ld Register Integer k | |
| St Register Integer k | |
| Ldr Register Register Integer k | |
| Str Register Register Integer k | |
| Ldi Register Integer k | |
| Sti Register Integer k | |
| Lea Register Integer k | |
| Br ConditionCode Integer k | |
| Jmp Register k | |
| Jsr Integer k | |
| Jsrr Register k | |
| Trap Integer k | |
deriving Functor | |
type Assembly = Free AssemblyF | |
toRegister :: Integer -> Register | |
toRegister n = toEnum $ fromInteger $ n - 65536 | |
fromRegister :: Register -> Integer | |
fromRegister r = toInteger $ fromAddress $ Register r | |
-- | What follows are the Free Monad constructors | |
add :: Mode -> Register -> Register -> Integer -> Assembly () | |
add m d s1 s2 = liftF $ Add m d s1 s2 () | |
and :: Mode -> Register -> Register -> Integer -> Assembly () | |
and m d s1 s2 = liftF $ And m d s1 s2 () | |
not :: Register -> Register -> Assembly () | |
not d s = liftF $ Not d s () | |
ld :: Register -> Integer -> Assembly () | |
ld x y = liftF $ Ld x y () | |
st :: Register -> Integer -> Assembly () | |
st x y = liftF $ St x y () | |
ldr :: Register -> Register -> Integer -> Assembly () | |
ldr d s t = liftF $ Ldr d s t () | |
str :: Register -> Register -> Integer -> Assembly () | |
str d s t = liftF $ Str d s t () | |
ldi :: Register -> Integer -> Assembly () | |
ldi x y = liftF $ Ldi x y () | |
sti :: Register -> Integer -> Assembly () | |
sti x y = liftF $ Sti x y () | |
lea :: Register -> Integer -> Assembly () | |
lea x y = liftF $ Lea x y () | |
br :: ConditionCode -> Integer -> Assembly () | |
br c i = liftF $ Br c i () | |
jmp :: Register -> Assembly () | |
jmp r = liftF $ Jmp r () | |
jsr :: Integer -> Assembly () | |
jsr i = liftF $ Jsr i () | |
jsrr :: Register -> Assembly () | |
jsrr r = liftF $ Jsrr r () | |
trap :: Integer -> Assembly () | |
trap i = liftF $ Trap i () | |
-- | Now for the function which builds a Machine value out of Assembly values | |
-- I'm able to use `log`, `put`,`get` etc freely because Machine is a stack of | |
-- monad transformers. Bam. | |
runAsm :: Assembly a -> Machine a | |
runAsm (Pure r) = return r | |
runAsm (Free (Add mode dst src1 src2 next)) = do | |
val1 <- runOp $ load $ Register src1 | |
val2 <- case mode of | |
Mr -> runOp $ load $ Register $ toRegister src2 | |
_ -> return $ fromInteger src2 | |
runOp $ store (Register dst) (val1 + val2) | |
log $ ["add",show mode,show dst,show src1,show src2] | |
runAsm next | |
runAsm (Free (And mode dst src1 src2 next)) = do | |
val1 <- runOp $ load $ Register src1 | |
val2 <- case mode of | |
Mr -> runOp $ load $ Register $ toRegister src2 | |
_ -> return $ fromInteger src2 | |
runOp $ store (Register dst) $ val1 .&. val2 | |
log $ ["and",show mode,show dst,show src1,show src2] | |
runAsm next | |
runAsm (Free (Not dst src next)) = do | |
val <- runOp $ load $ Register src | |
runOp $ store (Register dst) $ complement val | |
log $ ["not",show dst,show src] | |
runAsm next | |
runAsm (Free (St src offset next)) = do | |
pc <- runOp $ load $ Register PC | |
addr <- return $ pc + (fromInteger offset) | |
val <- runOp $ load $ Register src | |
runOp $ store (Ram addr) val | |
log $ ["st",show src,show offset] | |
runAsm next | |
runAsm (Free (Ld dst offset next)) = do | |
pc <- runOp $ load $ Register PC | |
addr <- return $ pc + (fromInteger offset) | |
val <- runOp $ load $ Ram addr | |
runOp $ store (Register dst) val | |
log $ ["ld",show dst,show offset] | |
runAsm next | |
runAsm (Free (Ldr dst base offset next)) = do | |
b <- runOp $ load $ Register base | |
addr <- return $ b + (fromInteger offset) | |
val <- runOp $ load $ Ram addr | |
runOp $ store (Register dst) val | |
log $ ["ldr",show dst,show base,show offset] | |
runAsm next | |
runAsm (Free (Str src base offset next)) = do | |
b <- runOp $ load $ Register base | |
addr <- return $ b + (fromInteger offset) | |
val <- runOp $ load $ Register src | |
runOp $ store (Ram addr) val | |
log $ ["str",show src,show base,show offset] | |
runAsm next | |
runAsm (Free (Ldi dst offset next)) = do | |
pc <- runOp $ load $ Register PC | |
ptr <- return $ pc + (fromInteger offset) | |
addr <- runOp $ load $ Ram ptr | |
val <- runOp $ load $ Ram addr | |
runOp $ store (Register dst) val | |
log $ ["ldi",show dst,show offset] | |
runAsm next | |
runAsm (Free (Sti src offset next)) = do | |
pc <- runOp $ load $ Register PC | |
ptr <- return $ pc + (fromInteger offset) | |
addr <- runOp $ load $ Ram ptr | |
val <- runOp $ load $ Register src | |
runOp $ store (Ram addr) val | |
log $ ["sti",show src,show offset] | |
runAsm next | |
runAsm (Free (Lea dst offset next)) = do | |
pc <- runOp $ load $ Register PC | |
addr <- return $ pc + (fromInteger offset) | |
runOp $ store (Register dst) addr | |
log $ ["lea",show dst,show offset] | |
runAsm next | |
runAsm (Free (Br cc offset next)) = do | |
pc <- runOp $ load $ Register PC | |
addr <- return $ pc + (fromInteger offset) | |
code <- runOp $ readCC | |
log $ ["br",show cc,show offset] | |
go (cc == code) addr | |
where go True addr = runOp (store (Register PC) addr) >> runAsm next | |
go False addr = runAsm next | |
runAsm (Free (Jmp base next)) = do | |
addr <- runOp $ load $ Register base | |
runOp $ store (Register PC) addr | |
log $ ["jmp",show base] | |
runAsm next | |
runAsm (Free (Trap trapvec next)) = do | |
-- nothing, yet | |
log $ ["trap",show trapvec] | |
runAsm next | |
runAsm (Free (Jsr offset next)) = do | |
pc <- runOp $ load $ Register PC | |
runOp $ store (Register R7) pc | |
runOp $ store (Register PC) (fromInteger offset) | |
log $ ["jsr",show offset] | |
runAsm next | |
runAsm (Free (Jsrr base next)) = do | |
pc <- runOp $ load $ Register PC | |
val <- runOp $ load $ Register base | |
runOp $ store (Register R7) pc | |
runOp $ store (Register PC) val | |
log $ ["jsrr",show base] | |
runAsm next | |
-- | A list of Assembly () values, which could be generated by a very simple | |
-- parser ... :) | |
asmTest :: [Assembly ()] | |
asmTest = [ add Mi R0 R0 15 | |
, add Mr R1 R0 $ fromRegister R0 | |
, and Mi R1 R1 1 | |
, and Mr R1 R1 $ fromRegister R1 | |
, not R2 R1 | |
, not R3 R2 | |
, add Mi R3 R3 1 | |
, st R2 0x10 | |
, ld R4 0x10 | |
, str R1 R4 0x15 | |
, ldr R5 R4 0x10 | |
, add Mi R5 R5 0 | |
] | |
-- | An execution loop. Much work needs to be done here. | |
execute :: [Assembly ()] -> IO () | |
execute as = do | |
result <- runMachine $ do | |
forM_ as $ \a -> do | |
pc <- runOp $ load (Register PC) | |
runOp $ store (Register PC) $ pc + 1 | |
runAsm a | |
log <- return $ snd . fst $ result | |
st <- return $ snd $ result | |
memory <- return $ mem st | |
pc <- return $ memory U.! (fromAddress (Register PC)) | |
mapM putStrLn log | |
putStrLn $ "PC: " ++ show pc | |
return () |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
To play with this:
execute asmTest