├── .gitignore ├── 2048.obj ├── ChangeLog.md ├── LC3.cabal ├── LICENSE ├── README.md ├── Setup.hs ├── default.nix ├── pkg.nix ├── rogue.obj ├── shell.nix └── src └── Main.hs /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | *.o 3 | *.hi 4 | dist/ 5 | result 6 | TAGS 7 | ctags 8 | -------------------------------------------------------------------------------- /2048.obj: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dmjio/LC3/b9c44f1a25bf512b33cda62c905cf48f7fe85415/2048.obj -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Revision history for LC3 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /LC3.cabal: -------------------------------------------------------------------------------- 1 | name: LC3 2 | version: 0.1.0.2 3 | synopsis: LC-3 virtual machine 4 | description: Haskell implementation of the LC-3 VM 5 | license: BSD3 6 | license-file: LICENSE 7 | author: David Johnson 8 | maintainer: code@dmj.io 9 | copyright: David Johnson (c) 2025 10 | category: Language 11 | build-type: Simple 12 | extra-source-files: README.md 13 | cabal-version: >=1.10 14 | 15 | extra-source-files: 16 | README.md 17 | ChangeLog.md 18 | 19 | executable LC3 20 | main-is: 21 | Main.hs 22 | build-depends: 23 | base < 5, 24 | bytestring, 25 | lens, 26 | hspec, 27 | mtl, 28 | vector 29 | hs-source-dirs: 30 | src 31 | default-language: 32 | Haskell2010 33 | 34 | source-repository head 35 | type: git 36 | location: https://github.com/dmjio/LC3.git 37 | 38 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2018, David Johnson 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of David Johnson nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | LC3 2 | =================== 3 | 4 | A Haskell implementation of the [LC3 virtual machine](https://justinmeiners.github.io/lc3-vm/) 5 | 6 | ### Play 2048! 7 | 8 | ```bash 9 | $ nix-build 10 | $ ./result/bin/LC3 ./2048.obj 11 | ``` 12 | 13 | ### Result 14 | 15 | ``` 16 | +--------------------------+ 17 | | | 18 | | 16 4 4 | 19 | | | 20 | | 2 2 | 21 | | | 22 | | 2 | 23 | | | 24 | | | 25 | | | 26 | +--------------------------+ 27 | ``` 28 | 29 | ### Play Rogue! 30 | 31 | ```bash 32 | $ nix-build 33 | $ ./result/bin/LC3 ./rogue.obj 34 | ``` 35 | 36 | ### Result 37 | 38 | ``` 39 | ################## ############ 40 | ################### ######## 41 | ####################### # 42 | ######################## # # 43 | ###############################D 44 | ################################ 45 | ################################ 46 | ############################## 47 | # ############################# 48 | ## @ ########################## 49 | ##### ######################### 50 | ###### ######################## 51 | ####### ###################### 52 | ######### ################### 53 | ############ ## ############## 54 | ############# ############# 55 | ``` 56 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | { pkgs ? import {} }: 2 | pkgs.haskellPackages.callPackage ./pkg.nix {} 3 | -------------------------------------------------------------------------------- /pkg.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, base, bytestring, hspec, lens, mtl, stdenv, vector, lib 2 | }: 3 | mkDerivation { 4 | pname = "LC3"; 5 | version = "0.1.0.2"; 6 | src = ./.; 7 | isLibrary = false; 8 | isExecutable = true; 9 | executableHaskellDepends = [ 10 | base bytestring hspec lens mtl vector 11 | ]; 12 | description = "LC-3 virtual machine"; 13 | license = lib.licenses.bsd3; 14 | } 15 | -------------------------------------------------------------------------------- /rogue.obj: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dmjio/LC3/b9c44f1a25bf512b33cda62c905cf48f7fe85415/rogue.obj -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | (import ./default.nix {}).env 2 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE ViewPatterns #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE PolyKinds #-} 6 | {-# LANGUAGE DataKinds #-} 7 | {-# LANGUAGE KindSignatures #-} 8 | {-# LANGUAGE TemplateHaskell #-} 9 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 10 | {-# LANGUAGE ScopedTypeVariables #-} 11 | {-# LANGUAGE BinaryLiterals #-} 12 | {-# LANGUAGE TypeApplications #-} 13 | {-# LANGUAGE TypeFamilies #-} 14 | module Main where 15 | 16 | import Control.Lens 17 | import Control.Monad.State 18 | import Data.Bits 19 | import Data.Bits.Lens 20 | import Data.Bool 21 | import Data.ByteString (ByteString) 22 | import qualified Data.ByteString as B 23 | import Data.Char 24 | import Data.List 25 | import Data.Proxy 26 | import Data.Vector (Vector) 27 | import qualified Data.Vector as V 28 | import Data.Word 29 | import GHC.TypeLits 30 | import Numeric 31 | import System.Environment 32 | import System.Exit 33 | import System.IO 34 | import Test.Hspec 35 | 36 | newtype Memory (size :: Nat) 37 | = Memory { _mem :: Vector Word16 } 38 | deriving (Show, Eq) 39 | 40 | newtype Registers (size :: Nat) 41 | = Registers { _reg :: Vector Word16 } 42 | deriving (Show, Eq) 43 | 44 | merge :: Word8 -> Word8 -> Word16 45 | merge l r = foldl' go 0x0 (zip [15,14..0] bits) 46 | where 47 | go acc (n,True) = setBit acc n 48 | go acc (n,False) = acc 49 | bits = 50 | map (testBit l) [7,6..0] ++ 51 | map (testBit r) [7,6..0] 52 | 53 | -- | Combine two-byte chunks into Word16 54 | processBits :: [Word8] -> [Word16] 55 | processBits bytes = map go (chunks 2 bytes) 56 | where 57 | go [_] = error "odd number" 58 | go [x,y] = merge x y 59 | 60 | chunks :: Int -> [a] -> [[a]] 61 | chunks _ [] = [] 62 | chunks n xs = do 63 | let (l,r) = splitAt n xs 64 | l : chunks n r 65 | 66 | data R 67 | = R0 68 | | R1 69 | | R2 70 | | R3 71 | | R4 72 | | R5 73 | | R6 74 | | R7 75 | | PC 76 | | Cond 77 | | Count 78 | deriving (Eq, Show, Enum) 79 | 80 | reg' :: R -> Lens' (Registers (nat :: Nat)) Word16 81 | reg' n = lens (\(Registers v) -> v V.! fromEnum n) setter 82 | where 83 | setter (Registers vec) word16 = 84 | Registers $ vec V.// [(fromEnum n, word16)] 85 | 86 | mem' :: Int -> Lens' (Memory (nat :: Nat)) Word16 87 | mem' n = lens (\(Memory v) -> v V.! n) setter 88 | where 89 | setter (Memory vec) word16 = 90 | Memory $ vec V.// [(n, word16)] 91 | 92 | data Machine 93 | = Machine 94 | { _machineReg :: Registers 11 95 | , _machineMem :: Memory 65536 96 | , _machineStatus :: Status 97 | } 98 | 99 | status :: Lens' Machine Status 100 | status = 101 | lens _machineStatus $ \p x -> 102 | p { _machineStatus = x } 103 | 104 | data Status 105 | = Running 106 | | Halted 107 | deriving (Show, Eq) 108 | 109 | reg :: R -> Lens' Machine Word16 110 | reg r = machineReg . reg' r 111 | 112 | mem :: Int -> Lens' Machine Word16 113 | mem n = machineMem . mem' n 114 | 115 | machineReg :: Lens' Machine (Registers 11) 116 | machineReg = 117 | lens _machineReg (\m r -> m { _machineReg = r }) 118 | 119 | machineMem :: Lens' Machine (Memory 65536) 120 | machineMem = 121 | lens _machineMem (\m r -> m { _machineMem = r }) 122 | 123 | registers :: forall n . n ~ 11 => Registers n 124 | registers = Registers (V.replicate n 0x0) 125 | where 126 | n = fromIntegral $ natVal (Proxy @n) 127 | 128 | memory :: forall n . n ~ 65536 => Memory n 129 | memory = Memory (V.replicate n 0x0) 130 | where 131 | n :: Int 132 | n = fromIntegral $ natVal (Proxy @n) 133 | 134 | data OpCode 135 | = BR -- /* branch */ 136 | | ADD -- /* add */ 137 | | LD -- /* load */ 138 | | ST -- /* store */ 139 | | JSR -- /* jump register */ 140 | | AND -- /* bitwise and */ 141 | | LDR -- /* load register */ 142 | | STR -- /* store register */ 143 | | RTI -- /* unused */ 144 | | NOT -- /* bitwise not */ 145 | | LDI -- /* load indirect */ 146 | | STI -- /* store indirect */ 147 | | JMP -- /* jump */ 148 | | RES -- /* reserved (unused) */ 149 | | LEA -- /* load effective address */ 150 | | TRAP -- /* execute trap */ 151 | deriving (Eq, Ord, Show, Enum) 152 | 153 | type Addr = Word16 154 | type Val = Word16 155 | 156 | memWrite :: Addr -> Val -> Routine () 157 | memWrite addr val = mem (fromIntegral addr) .= val 158 | 159 | getKey :: IO Char 160 | getKey = getChar 161 | 162 | checkKey :: IO (Maybe Word16) 163 | checkKey = do 164 | result <- B.hGetNonBlocking stdin 1 165 | case result of 166 | x | B.null x -> pure Nothing 167 | | otherwise -> do 168 | let [l] = B.unpack x 169 | pure $ Just $ fromIntegral l 170 | 171 | memRead :: Addr -> Routine Val 172 | memRead (fromIntegral -> addr) 173 | | addr == mrKBSR = handleKey 174 | | otherwise = use $ mem addr 175 | where 176 | handleKey = do 177 | maybeKey <- liftIO checkKey 178 | case maybeKey of 179 | Just key -> do 180 | mem mrKBSR .= 1 `shiftL` 15 181 | mem mrKBDR .= key 182 | Nothing -> 183 | mem mrKBSR .= 0x0 184 | use (mem addr) 185 | 186 | mrKBSR = 0xFE00 -- /* keyboard status */ 187 | mrKBDR = 0xFE02 -- /* keyboard data */ 188 | 189 | pos, zro, neg :: Word16 190 | pos = 1 191 | zro = 2 192 | neg = 4 193 | 194 | main :: IO () 195 | main = do 196 | hSetBuffering stdin NoBuffering 197 | heap <- readImageFile 198 | let machine = Machine registers heap Running 199 | finished <- runRoutine machine routine 200 | print (finished ^. status) 201 | 202 | readImageFile :: IO (Memory 65536) 203 | readImageFile = do 204 | args <- getArgs 205 | case args of 206 | fileName : _ -> do 207 | (origin:bytes) <- processBits . B.unpack <$> B.readFile fileName 208 | let pad = V.replicate (fromIntegral origin - 1) (0x0 :: Word16) 209 | mid = V.fromList (origin:bytes) 210 | end = V.replicate (65536 - (V.length pad + V.length mid)) (0x0 :: Word16) 211 | pure $ Memory (pad <> mid <> end) 212 | _ -> do 213 | putStrLn "Please enter path to LC3 program" 214 | exitFailure 215 | 216 | test :: IO () 217 | test = hspec tests 218 | 219 | type Routine = StateT Machine IO 220 | 221 | signExtend :: Word16 -> Int -> Word16 222 | signExtend x bitCount 223 | | x `shiftR` (bitCount - 1) .&. 1 == 1 = x .|. (0xFFFF `shiftL` bitCount) 224 | | otherwise = x 225 | 226 | updateFlags :: R -> Routine () 227 | updateFlags r = do 228 | x <- use (reg r) 229 | case x of 230 | z | z == 0 -> reg Cond .= zro 231 | | z ^. bitAt 15 -> reg Cond .= neg 232 | | otherwise -> reg Cond .= pos 233 | 234 | toE :: Enum e => Word16 -> e 235 | toE = toEnum . fromIntegral 236 | 237 | getOp :: Word16 -> OpCode 238 | getOp x = toE (x `shiftR` 12) 239 | 240 | io :: MonadIO m => IO a -> m a 241 | io = liftIO 242 | 243 | routine :: Routine () 244 | routine = do 245 | reg PC .= 0x3000 246 | fix $ \loop -> do 247 | s <- use status 248 | unless (s == Halted) 249 | (go >> loop) 250 | 251 | dumpRegisters :: Routine () 252 | dumpRegisters = do 253 | liftIO (putStrLn mempty) 254 | instr <- memRead =<< use (reg PC) 255 | Registers r <- gets _machineReg 256 | liftIO $ do 257 | putStrLn (showHexAndBinary instr) 258 | V.mapM_ (\(n,x) -> putStrLn $ show (toEnum n :: R) ++ ": 0x" ++ showHex x "") 259 | (V.zip (V.fromList [0..10]) r) 260 | 261 | debug :: Bool 262 | debug = False 263 | 264 | showBinary :: Word16 -> String 265 | showBinary x = "0b" ++ showIntAtBase 2 (head . show) x "" 266 | 267 | showHexAndBinary :: Word16 -> String 268 | showHexAndBinary instr = 269 | show (getOp instr) ++ " -> 0x" ++ showHex instr "" ++ " " ++ showBinary instr 270 | 271 | class ToInstr a where 272 | toInstr :: Word16 -> a 273 | 274 | instance ToInstr Br where toInstr = makeBr 275 | instance ToInstr Add where toInstr = makeAdd 276 | instance ToInstr Ld where toInstr = makeLd 277 | instance ToInstr St where toInstr = makeSt 278 | instance ToInstr Jsr where toInstr = makeJsr 279 | instance ToInstr And where toInstr = makeAnd 280 | instance ToInstr Ldr where toInstr = makeLdr 281 | instance ToInstr Str where toInstr = makeStr 282 | instance ToInstr Not where toInstr = makeNot 283 | instance ToInstr Ldi where toInstr = makeLdi 284 | instance ToInstr Sti where toInstr = makeSti 285 | instance ToInstr Jmp where toInstr = makeJmp 286 | instance ToInstr Lea where toInstr = makeLea 287 | instance ToInstr Trap where toInstr = makeTrap 288 | 289 | data Add 290 | = Add 291 | { dr :: R 292 | , sr1 :: R 293 | , sr2 :: R 294 | } | AddImm 295 | { dr :: R 296 | , sr1 :: R 297 | , imm :: Word16 298 | } deriving (Show, Eq) 299 | 300 | makeAdd :: Word16 -> Add 301 | makeAdd instr = do 302 | let dr = toE $ (instr `shiftR` 9) .&. 0x7 303 | sr1 = toE $ (instr `shiftR` 6) .&. 0x7 304 | sr2 = toE $ instr .&. 0x7 305 | imm = signExtend (instr .&. 0x1F) 5 306 | if instr ^. bitAt 5 307 | then AddImm dr sr1 imm 308 | else Add dr sr1 sr2 309 | 310 | data Ldi 311 | = Ldi 312 | { ldiDR :: R 313 | , ldiPcOffset :: Word16 314 | } deriving (Show, Eq) 315 | 316 | makeLdi :: Word16 -> Ldi 317 | makeLdi instr = do 318 | let r0 = toE $ (instr `shiftR` 9) .&. 0x7 319 | pcOffset = signExtend (instr .&. 0x1ff) 9 320 | Ldi r0 pcOffset 321 | 322 | data And 323 | = And 324 | { addDr :: R 325 | , addSr1 :: R 326 | , addSr2 :: R 327 | } | AndImm 328 | { addDr :: R 329 | , addSr1 :: R 330 | , addImm :: Word16 331 | } deriving (Show, Eq) 332 | 333 | makeAnd :: Word16 -> And 334 | makeAnd instr = do 335 | let dr = toE $ (instr `shiftR` 9) .&. 0x7 336 | sr1 = toE $ (instr `shiftR` 6) .&. 0x7 337 | sr2 = toE (instr .&. 0x7) 338 | imm = signExtend (instr .&. 0x1F) 5 339 | if instr ^. bitAt 5 340 | then AndImm dr sr1 imm 341 | else And dr sr1 sr2 342 | 343 | data Not 344 | = Not 345 | { notDr :: R 346 | , notSr :: R 347 | } deriving (Show, Eq) 348 | 349 | makeNot :: Word16 -> Not 350 | makeNot instr = do 351 | let dr = toE $ (instr `shiftR` 9) .&. 0x7 352 | sr = toE $ (instr `shiftR` 6) .&. 0x7 353 | Not dr sr 354 | 355 | data Br 356 | = Br 357 | { brCondFlag :: Word16 358 | , brPcOffset :: Word16 359 | } deriving (Show, Eq) 360 | 361 | makeBr :: Word16 -> Br 362 | makeBr instr = do 363 | let condFlag = (instr `shiftR` 9) .&. 0x7 364 | pcOffset = signExtend (instr .&. 0x1ff) 9 365 | Br condFlag pcOffset 366 | 367 | data Jmp 368 | = Jmp 369 | { jrDr :: R 370 | } deriving (Show, Eq) 371 | 372 | makeJmp :: Word16 -> Jmp 373 | makeJmp instr = do 374 | let r1 = toE $ (instr `shiftR` 6) .&. 0x7 375 | Jmp r1 376 | 377 | data Jsr 378 | = Jsr 379 | { jsrR1 :: R 380 | , jsrPcOffset :: Word16 381 | , jsrPcFlag :: Word16 382 | } deriving (Show, Eq) 383 | 384 | makeJsr :: Word16 -> Jsr 385 | makeJsr instr = do 386 | let r1 = toE $ (instr `shiftR` 6) .&. 0x7 387 | longPCOffset = signExtend (instr .&. 0x7ff) 11 388 | longFlag = (instr `shiftR` 11) .&. 1 389 | Jsr r1 longPCOffset longFlag 390 | 391 | data Ld 392 | = Ld 393 | { ldR0 :: R 394 | , ldPcOffset :: Word16 395 | } deriving (Show, Eq) 396 | 397 | makeLd :: Word16 -> Ld 398 | makeLd instr = do 399 | let r0 = toE $ (instr `shiftR` 9) .&. 0x7 400 | pcOffset = signExtend (instr .&. 0x1ff) 9 401 | Ld r0 pcOffset 402 | 403 | data Ldr 404 | = Ldr 405 | { ldrR0 :: R 406 | , ldrR1 :: R 407 | , ldrOffset :: Word16 408 | } deriving (Show, Eq) 409 | 410 | makeLdr :: Word16 -> Ldr 411 | makeLdr instr = do 412 | let r0 = toE $ (instr `shiftR` 9) .&. 0x7 413 | r1 = toE $ (instr `shiftR` 6) .&. 0x7 414 | pcOffset = signExtend (instr .&. 0x3F) 6 415 | Ldr r0 r1 pcOffset 416 | 417 | data Lea 418 | = Lea 419 | { leaR0 :: R 420 | , leaPcOffset :: Word16 421 | } deriving (Show, Eq) 422 | 423 | makeLea :: Word16 -> Lea 424 | makeLea instr = do 425 | let r0 = toE $ (instr `shiftR` 9) .&. 0x7 426 | pcOffset = signExtend (instr .&. 0x1ff) 9 427 | Lea r0 pcOffset 428 | 429 | data St 430 | = St 431 | { stR0 :: R 432 | , stPcOffset :: Word16 433 | } deriving (Show, Eq) 434 | 435 | makeSt :: Word16 -> St 436 | makeSt instr = do 437 | let r0 = toE $ (instr `shiftR` 9) .&. 0x7 438 | pcOffset = signExtend (instr .&. 0x1ff) 9 439 | St r0 pcOffset 440 | 441 | data Sti 442 | = Sti 443 | { stiR0 :: R 444 | , stiPcOffset :: Word16 445 | } deriving (Show, Eq) 446 | 447 | makeSti :: Word16 -> Sti 448 | makeSti instr = do 449 | let r0 = toE $ (instr `shiftR` 9) .&. 0x7 450 | pcOffset = signExtend (instr .&. 0x1ff) 9 451 | Sti r0 pcOffset 452 | 453 | data Str 454 | = Str 455 | { strR0 :: R 456 | , strR1 :: R 457 | , strPcOffset :: Word16 458 | } deriving (Show, Eq) 459 | 460 | makeStr :: Word16 -> Str 461 | makeStr instr = do 462 | let r0 = toE $ (instr `shiftR` 9) .&. 0x7 463 | r1 = toE $ (instr `shiftR` 6) .&. 0x7 464 | pcOffset = signExtend (instr .&. 0x3F) 6 465 | Str r0 r1 pcOffset 466 | 467 | data Trap 468 | = Getc 469 | | Out 470 | | Puts 471 | | In 472 | | PutsP 473 | | Halt 474 | deriving (Show, Eq) 475 | 476 | makeTrap :: Word16 -> Trap 477 | makeTrap x 478 | | instr == trapGetc = Getc 479 | | instr == trapOut = Out 480 | | instr == trapPuts = Puts 481 | | instr == trapIn = In 482 | | instr == trapPutsp = PutsP 483 | | instr == trapHalt = Halt 484 | | otherwise = error "Bad TRAP" 485 | where 486 | instr = x .&. 0xFF 487 | 488 | go :: Routine () 489 | go = do 490 | instr <- memRead =<< use (reg PC) 491 | when debug dumpRegisters 492 | reg PC += 1 493 | case getOp instr of 494 | ADD -> do 495 | liftIO $ when debug $ print (toInstr instr :: Add) 496 | case makeAdd instr of 497 | AddImm dr sr1 imm -> do 498 | result <- (imm+) <$> use (reg sr1) 499 | reg dr .= result 500 | updateFlags dr 501 | Add dr sr1 sr2 -> do 502 | r1 <- use (reg sr1) 503 | r2 <- use (reg sr2) 504 | reg dr .= r1 + r2 505 | updateFlags dr 506 | LDI -> do 507 | liftIO $ when debug $ print (toInstr instr :: Ldi) 508 | case makeLdi instr of 509 | Ldi dr pcOffset -> do 510 | pcVal <- use (reg PC) 511 | r <- memRead =<< memRead (pcVal + pcOffset) 512 | reg dr .= r 513 | updateFlags dr 514 | RTI -> 515 | pure () 516 | RES -> 517 | pure () 518 | AND -> do 519 | liftIO $ when debug $ print (toInstr instr :: And) 520 | case makeAnd instr of 521 | AndImm dr sr1 imm -> do 522 | r <- use (reg sr1) 523 | reg dr .= r .&. imm 524 | updateFlags dr 525 | And dr sr1 sr2 -> do 526 | r1 <- use (reg sr1) 527 | r2 <- use (reg sr2) 528 | reg dr .= r1 .&. r2 529 | updateFlags dr 530 | NOT -> do 531 | liftIO $ when debug $ print (toInstr instr :: Not) 532 | case makeNot instr of 533 | Not dr sr -> do 534 | r <- use (reg sr) 535 | reg dr .= complement r 536 | BR -> do 537 | liftIO $ when debug $ print (toInstr instr :: Br) 538 | case makeBr instr of 539 | Br rcCond pcOffset -> do 540 | rCond <- use (reg Cond) 541 | when (rcCond .&. rCond > 0) 542 | (reg PC += pcOffset) 543 | JMP -> do 544 | liftIO $ when debug $ print (toInstr instr :: Jmp) 545 | case makeJmp instr of 546 | Jmp r -> do 547 | r1 <- use (reg r) 548 | reg PC .= r1 549 | JSR -> do 550 | liftIO $ when debug $ print (toInstr instr :: Jsr) 551 | case makeJsr instr of 552 | Jsr r1 longPCOffset longFlag -> do 553 | pc <- use (reg PC) 554 | r <- use (reg r1) 555 | reg R7 .= pc 556 | if longFlag == 1 557 | then reg PC += longPCOffset 558 | else reg PC .= r 559 | LD -> do 560 | liftIO $ when debug $ print (toInstr instr :: Ld) 561 | case makeLd instr of 562 | Ld r0 pcOffset -> do 563 | pc <- use (reg PC) 564 | r <- memRead (pc + pcOffset) 565 | reg r0 .= r 566 | updateFlags r0 567 | LDR -> do 568 | liftIO $ when debug $ print (toInstr instr :: Ldr) 569 | case makeLdr instr of 570 | Ldr r0 r1 pcOffset -> do 571 | r1' <- use (reg r1) 572 | val <- memRead (r1' + pcOffset) 573 | reg r0 .= val 574 | updateFlags r0 575 | LEA -> do 576 | liftIO $ when debug $ print (toInstr instr :: Lea) 577 | case makeLea instr of 578 | Lea r0 offset -> do 579 | pc <- use (reg PC) 580 | reg r0 .= pc + offset 581 | ST -> do 582 | liftIO $ when debug $ print (toInstr instr :: St) 583 | case makeSt instr of 584 | St r0 offset -> do 585 | pc <- (offset+) <$> use (reg PC) 586 | r0' <- use (reg r0) 587 | memWrite pc r0' 588 | STI -> do 589 | liftIO $ when debug $ print (toInstr instr :: Sti) 590 | case makeSti instr of 591 | Sti r0 offset -> do 592 | pc <- use (reg PC) 593 | r0' <- use (reg r0) 594 | val <- memRead (pc + offset) 595 | memWrite val r0' 596 | STR -> do 597 | liftIO $ when debug $ print (toInstr instr :: Str) 598 | case makeStr instr of 599 | Str r0 r1 offset -> do 600 | r0' <- use (reg r0) 601 | r1' <- use (reg r1) 602 | memWrite (r1' + offset) r0' 603 | TRAP -> do 604 | liftIO $ when debug $ print (toInstr instr :: Trap) 605 | case makeTrap instr of 606 | Getc -> do 607 | r <- fromIntegral . ord <$> liftIO getChar 608 | reg R0 .= r 609 | Puts -> do 610 | v <- use (reg R0) 611 | let loop x = do 612 | val <- memRead x 613 | unless (val == 0x0000) $ do 614 | let c = chr (fromIntegral val) 615 | liftIO (putChar c) 616 | loop (x+1) 617 | liftIO (hFlush stdout) 618 | loop v 619 | PutsP -> do 620 | v <- use (reg R0) 621 | let loop x = do 622 | val <- memRead x 623 | unless (val == 0x0000) $ do 624 | let char1 = chr (fromIntegral (val .&. 0xFF)) 625 | char2 = chr (fromIntegral (val `shiftR` 8)) 626 | liftIO $ mapM_ putChar [char1, char2] 627 | loop (x+1) 628 | loop v 629 | Out -> do 630 | liftIO . putChar =<< 631 | chr . fromIntegral <$> use (reg R0) 632 | In -> do 633 | r <- fromIntegral . ord <$> liftIO getChar 634 | reg R0 .= r 635 | Halt -> do 636 | liftIO (putStrLn "HALT") 637 | status .= Halted 638 | 639 | pcStart :: Int 640 | pcStart = fromIntegral 0x3000 641 | 642 | runRoutine :: Machine -> Routine () -> IO Machine 643 | runRoutine = flip execStateT 644 | 645 | -- in the trap 646 | 647 | trapGetc :: Word16 648 | trapGetc = 0x20 -- /* get character from keyboard */ 649 | 650 | trapOut :: Word16 651 | trapOut = 0x21 -- /* output a character */ 652 | 653 | trapPuts :: Word16 654 | trapPuts = 0x22 -- /* output a word string */ 655 | 656 | trapIn :: Word16 657 | trapIn = 0x23 -- /* input a string */ 658 | 659 | trapPutsp :: Word16 660 | trapPutsp = 0x24 -- /* output a byte string */ 661 | 662 | trapHalt :: Word16 663 | trapHalt = 0x25 -- /* halt the program */ 664 | 665 | -- | some tests 666 | 667 | tests :: Spec 668 | tests = do 669 | describe "VM tests" $ do 670 | addTwoNumbers 671 | addTwoNumbersImm 672 | andTwoNumbers 673 | andTwoNumbersImm 674 | complementNumber 675 | 676 | complementNumber :: SpecWith () 677 | complementNumber = 678 | it "Should NOT (complement) a number" $ do 679 | r <- runRoutine ma routine 680 | r ^. reg R5 `shouldBe` (-2) 681 | where 682 | ma = Machine rs me Running 683 | me = memory 684 | & mem' 0x3001 .~ 0b1001101011000100 685 | & mem' 0x3002 .~ haltInstr 686 | rs = registers 687 | & reg' R3 .~ 1 688 | 689 | andTwoNumbers :: SpecWith () 690 | andTwoNumbers = 691 | it "Should AND two numbers" $ do 692 | r <- runRoutine ma routine 693 | r ^. reg R5 `shouldBe` 0 694 | where 695 | ma = Machine rs me Running 696 | me = memory 697 | & mem' 0x3001 .~ 0b0101101011000100 698 | & mem' 0x3002 .~ haltInstr 699 | rs = registers 700 | & reg' R3 .~ 5 701 | & reg' R4 .~ 2 702 | 703 | andTwoNumbersImm :: SpecWith () 704 | andTwoNumbersImm = 705 | it "Should AND two numbers w/ immediate" $ do 706 | r <- runRoutine ma routine 707 | r ^. reg R5 `shouldBe` 1 708 | where 709 | ma = Machine rs me Running 710 | me = memory 711 | & mem' 0x3001 .~ 0b0101101011111111 712 | & mem' 0x3002 .~ haltInstr 713 | rs = registers 714 | & reg' R3 .~ 1 715 | 716 | addTwoNumbers :: SpecWith () 717 | addTwoNumbers = 718 | it "Should ADD two numbers" $ do 719 | r <- runRoutine ma routine 720 | r ^. reg R5 `shouldBe` 2 721 | where 722 | ma = Machine rs me Running 723 | me = memory 724 | & mem' 0x3001 .~ 0b0001101011000100 725 | & mem' 0x3002 .~ haltInstr 726 | rs = registers 727 | & reg' R3 .~ 1 728 | & reg' R4 .~ 1 729 | 730 | addTwoNumbersImm :: SpecWith () 731 | addTwoNumbersImm = 732 | it "Should ADD two numbers w/ immediate" $ do 733 | r <- runRoutine ma routine 734 | r ^. reg R5 `shouldBe` 0 735 | where 736 | ma = Machine rs me Running 737 | me = memory 738 | & mem' 0x3001 .~ 0b0001101011111111 739 | & mem' 0x3002 .~ haltInstr 740 | rs = registers 741 | & reg' R3 .~ 1 742 | 743 | haltInstr = 0b1111000000100101 744 | 745 | -- k' = signExtend (0b0001101011111111 .&. 0x1F) 5 746 | --------------------------------------------------------------------------------