Haskell, 256 234 lines
I've had this work-in-progress one for some time, I intended to polish it a bit more before publishing, but now the fun's officially started, there's not much point in keeping it hidden anymore. I noticed while extracting it that it's exactly 256 lines long, so I suppose it is at a "remarkable" point of its existence.
What's in: barely enough of the 8086 instruction set to run the example binary flawlessly. Self-modifying code is supported. (prefetch: zero bytes)
Ironically, the first sufficient iterations of the code were longer and supported less of the opcode span. Refactoring ended up beneficial both to code length and to opcode coverage.
What's out: obviously, segments, prefixes and multibyte opcodes, interrupts, I/O ports, string operations, and FP. I initially did follow the original PUSH SP behavior, but had to drop it after a few iterations.
Carry flag results are probably very messed up in a few cases of ADC/SBB.
Anyway, here's the code:
{-# LANGUAGE FlexibleContexts #-}
import Prelude hiding (read)
import Data.Char (chr,isPrint)
import Data.Word (Word8,Word16)
import Data.Int (Int8)
import Data.Bits
import Data.IORef
import Data.Array ((!))
import Data.Array.IO
import Control.Monad.Reader
import Control.Exception (bracket_)
import System
import System.IO (hSetEncoding,stdin,latin1)
ifte t f c = if c then t else f
concatBytes :: Word8 -> Word8 -> Word16
concatBytes l h = (fromIntegral l) .|. (fromIntegral h `shiftL` 8)
byteToWordSE :: Word8 -> Word16
byteToWordSE = (fromIntegral :: Int8 -> Word16) .
(fromIntegral :: Word8 -> Int8)
wordToByteL,wordToByteH :: Word16 -> Word8
wordToByteL = fromIntegral
wordToByteH = fromIntegral . (`shiftR` 8)
byte = undefined :: Word8
word = undefined :: Word16
type Place = (IOArray Word16 Word8,Word16)
[regAl,regAh,regCl,regCh,regDl,regDh,regBl,regBh] = [0..7]
[regAx,regCx,regDx,regBx,regSp,regBp,regSi,regDi] = [0,2..14]
data Proc = Proc {
ram :: IOArray Word16 Word8
, regs :: IOArray Word16 Word8
, ip :: IORef Word16
, cf :: IORef Bool
, zf :: IORef Bool
, sf :: IORef Bool
}
readProc ext = liftIO . readIORef . ext =<< ask
writeProc ext f = liftIO . flip writeIORef f . ext =<< ask
modifyIP f = do
ipRef <- liftM ip ask
old <- liftIO $ readIORef ipRef
liftIO $ modifyIORef ipRef f
return old
readInstr8 = modifyIP (+1) >>= readRam
readInstr16 = liftM2 concatBytes readInstr8 readInstr8
class (Ord a,Bits a) => Width a where
read :: MonadIO m => Place -> m a
write :: MonadIO m => Place -> a -> m ()
instance Width Word8 where
read = liftIO . uncurry readArray
write p = liftIO . uncurry writeArray p
instance Width Word16 where
read (p,a) = liftM2 concatBytes (read (p,a)) (read (p,a+1))
write (p,a) val = do
write (p,a) $ wordToByteL val
write (p,a+1) $ wordToByteH val
readReg reg = ask >>= \p -> read (regs p,reg)
readRam addr = ask >>= \p -> read (ram p,addr)
writeReg reg val = ask >>= \p -> write (regs p,reg) val
writeRam addr val = ask >>= \p -> write (ram p,addr) val
decodeReg8 n = fromIntegral $ (n `shiftL` 1) .|. (n `shiftR` 2)
decodeReg16 n = fromIntegral $ n `shiftL` 1
readDecodedReg8 = readReg . decodeReg8
readDecodedReg16 = readReg . decodeReg16
readModRM = do
modRM <- readInstr8
let mod = modRM `shiftR` 6
opReg = (modRM .&. 0x38) `shiftR` 3
rm = modRM .&. 0x07
proc <- ask
operand <- case mod of
0 -> do
addr <- case rm of
1 -> liftM2 (+) (readReg regBx) (readReg regDi)
2 -> liftM2 (+) (readReg regBp) (readReg regSi)
6 -> readInstr16
7 -> readReg regBx
return (ram proc,addr)
2 -> do
addr <- case rm of
5 -> liftM2 (+) (readReg regDi) readInstr16
7 -> liftM2 (+) (readReg regBx) readInstr16
return (ram proc,addr)
3 -> return (regs proc,2*fromIntegral rm)
return (operand,opReg,opReg)
push16 val = do -- PUSH by value (doesn't reproduce PUSH SP behavior)
sp <- liftM (subtract 2) (readReg regSp)
writeReg regSp sp
writeRam sp (val :: Word16)
pop16 = do
sp <- readReg regSp
val <- readRam sp
writeReg regSp (sp+2)
return val
jump cond = when cond . void . modifyIP . (+) . byteToWordSE =<< readInstr8
alu :: (Width w,MonadIO m,MonadReader Proc m) => w -> m w -> m w -> Place -> (w -> w -> m (Bool,Maybe Bool,w)) -> m ()
alu _ a b r op = do
(rw,c,v) <- join (liftM2 op a b)
when rw $ write r v
maybe (return ()) (writeProc cf) c
writeProc zf (v == 0)
writeProc sf (testBit v (bitSize v - 1))
decodeALU 0 = (\a b -> return (True, Just (a >= negate b), a + b))
decodeALU 1 = (\a b -> return (True, Just False, a .|. b))
decodeALU 2 = (\a b -> liftM (ifte 1 0) (readProc cf) >>= \c ->
return (True, Just (a >= negate (b + c)), a + b + c))
decodeALU 3 = (\a b -> liftM (ifte 1 0) (readProc cf) >>= \c ->
return (True, Just (a < b + c), a - b - c))
decodeALU 4 = (\a b -> return (True, Just False, a .&. b))
decodeALU 5 = (\a b -> return (True, Just (a <= b), a - b))
decodeALU 6 = (\a b -> return (True, Just False, a `xor` b))
decodeALU 7 = (\a b -> return (False,Just (a <= b), a - b))
opIncDec = \a b -> return (True, Nothing, a + b)
processInstr = do
opcode <- readInstr8
regs <- liftM regs ask
let zReg = (regs,decodeReg16 (opcode .&. 0x07))
if opcode < 0x40 then -- no segment or BCD
let aluOp = (opcode .&. 0x38) `shiftR` 3 in case opcode .&. 0x07 of
0 -> do
(operand,reg,_) <- readModRM
alu byte (read operand) (readDecodedReg8 reg) operand (decodeALU aluOp)
1 -> do
(operand,reg,_) <- readModRM
alu word (read operand) (readDecodedReg16 reg) operand (decodeALU aluOp)
4 -> alu byte (readReg regAl) readInstr8 (regs,regAl) (decodeALU aluOp)
else case opcode .&. 0xF8 of -- 16-bit (mostly) reg ops
0x40 -> alu word (read zReg) (return 1 ) zReg opIncDec -- 16b INC
0x48 -> alu word (read zReg) (return (-1)) zReg opIncDec -- 16b DEC
0x50 -> read zReg >>= push16 -- 16b PUSH reg
0x58 -> pop16 >>= write zReg -- 16b POP reg
0x90 -> do -- 16b XCHG (or NOP)
v1 <- read zReg
v2 <- readReg regAx
write zReg (v2 :: Word16)
writeReg regAx (v1 :: Word16)
0xB0 -> readInstr8 >>= write zReg -- (BUG!) -- 8b MOV reg,imm
0xB8 -> readInstr16 >>= write zReg -- 16b MOV reg,imm
_ -> case if opcode == 0x80 then 0x82 else opcode of
0x72 -> jump =<< (readProc cf) -- JB/JNAE/JC
0x74 -> jump =<< (readProc zf) -- JE/JZ
0x75 -> jump . not =<< (readProc zf) -- JNE/JNZ
0x76 -> jump =<< liftM2 (||) (readProc cf) (readProc zf) -- JBE
0x77 -> jump . not =<< liftM2 (||) (readProc cf) (readProc zf) -- JA
0x79 -> jump . not =<< (readProc sf) -- JNS
0x81 -> do -- 16b arith to imm
(operand,_,op) <- readModRM
alu word (read operand) readInstr16 operand (decodeALU op)
0x82 -> do -- 8b arith to imm
(operand,_,op) <- readModRM
alu byte (read operand) readInstr8 operand (decodeALU op)
0x83 -> do -- 16b arith to 8s imm
(operand,_,op) <- readModRM
alu word (read operand) (liftM byteToWordSE readInstr8) operand
(decodeALU op)
0x86 -> do -- 8b XCHG reg,RM
(operand,reg,_) <- readModRM
v1 <- readDecodedReg8 reg
v2 <- read operand
writeReg (decodeReg8 reg) (v2 :: Word8)
write operand v1
0x88 -> do -- 8b MOV RM,reg
(operand,reg,_) <- readModRM
readDecodedReg8 reg >>= write operand
0x89 -> do -- 16b MOV RM,reg
(operand,reg,_) <- readModRM
readDecodedReg16 reg >>= write operand
0x8A -> do -- 8b MOV reg,RM
(operand,reg,_) <- readModRM
val <- read operand
writeReg (decodeReg8 reg) (val :: Word8)
0x8B -> do -- 16b MOV reg,RM
(operand,reg,_) <- readModRM
val <- read operand
writeReg (decodeReg16 reg) (val :: Word16)
0xC3 -> pop16 >>= writeProc ip -- RET
0xC7 -> do -- 16b MOV RM,imm
(operand,_,_) <- readModRM
readInstr16 >>= write operand
0xE8 -> readInstr16 >>= modifyIP . (+) >>= push16 -- CALL relative
0xEB -> jump True -- JMP short
0xF4 -> liftIO (exitWith ExitSuccess) -- HLT
0xF9 -> writeProc cf True -- STC
0xFE -> do -- 8-bit INC/DEC RM
(operand,_,op) <- readModRM
alu byte (read operand) (return $ 1-2*op) operand
(\a b -> return (True,Nothing,a+b)) -- kinda duplicate :(
main = do
ramRef <- newArray (0,0xFFFF) 0 :: IO (IOArray Word16 Word8)
hSetEncoding stdin latin1
mapM_ (uncurry (writeArray ramRef)) .
zip [0..] .
map (fromIntegral . fromEnum) =<<
getContents
regFile <- newArray (0,15) 0 :: IO (IOArray Word16 Word8)
ip <- newIORef 0
cf <- newIORef False
zf <- newIORef False
sf <- newIORef False
let proc = Proc ramRef regFile ip cf zf sf
runReaderT (writeReg regSp (0x100 :: Word16)) proc
bracket_ (return ())
(dumpScreen ramRef)
(forever . flip runReaderT proc $ processInstr)
dumpScreen ramRef = do
mem <- freeze ramRef
forM_ [0..25] $ \i -> do
forM_ [0..79] $ \j -> do
let c = chr . fromIntegral $ mem ! (0x8000 + 80*i + j)
putChar (if isPrint c then c else ' ')
putChar '\n'
The output for the provided sample binary matches the specification perfectly. Try it out using an invocation such as:
runhaskell 8086.hs <8086.bin
Most non-implemented operations will simply result in a pattern matching failure.
I still intend to factor quite a bit more, and implement actual live output with curses.
Update 1: got it down to 234 lines. Better organized the code by functionality, re-aligned what could be, tried to stick to 80 columns. And refactored the ALU multiple times.
I included an interactive debugger as well. 
push spdecrementsspbefore or after pushing it on the 8086 :( – J B Jan 30 '12 at 15:42