Unfinished proof of concept LC3 emulator in Haskell. My strategy is to build an EDSL which can be built up programmatically.

lc3.hs

{-# 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 ()

To play with this:

1. Ensure you have the latest version of the Haskell Platform installed
2. Load the file in ghci
3. Run execute asmTest
4. Clean your mind off the wall behind you