Permalink
Browse files

Add an assembler for the dcpu-16

  • Loading branch information...
jaspervdj committed Apr 6, 2012
1 parent b0f0e4a commit 82b141bf96bb1b9be89d03289f3e382cf6b7604d
Showing with 382 additions and 23 deletions.
  1. +10 −1 README.markdown
  2. +20 −2 dcpu16-hs.cabal
  3. +28 −0 examples/notch.s
  4. +78 −0 src/Assembler.hs
  5. +24 −0 src/Assembler/Main.hs
  6. +154 −0 src/Assembler/Parser.hs
  7. +4 −4 src/Emulator.hs
  8. 0 src/{ → Emulator}/Main.hs
  9. +64 −16 src/Instruction.hs
View
@@ -8,6 +8,11 @@ Implementation of Notch's [dcpu-16] CPU in Haskell.
Status
------
The assembler can assemble Notch's test program.
It generates worse code than the code generated by Notch's assembler because it
never tries to inline literal values into the first word of an instruction.
The emulator seems to run Notch's test program.
The current strategy is to simulate 10000 instructions (*not* cycles). A better
@@ -22,6 +27,10 @@ Building
Running
-------
./dist/build/dcpu16-hs/dcpu16-hs examples/notch.bin
./dist/build/dcpu16-assembler/dcpu16-assembler examples/notch.s
This produces `a.out`
./dist/build/dcpu16-emulator/dcpu16-emulator a.out
You should probably redirect the output to a file.
View
@@ -10,10 +10,10 @@ Category: Development
Build-type: Simple
Cabal-version: >= 1.2
Executable dcpu16-hs
Executable dcpu16-emulator
Ghc-options: -Wall -fwarn-tabs
Hs-source-dirs: src
Main-is: Main.hs
Main-is: Emulator/Main.hs
Other-modules:
Emulator
@@ -26,3 +26,21 @@ Executable dcpu16-hs
bytestring >= 0.9 && < 0.10,
ghc-prim >= 0.2 && < 0.3,
mtl >= 2.0 && < 2.1
Executable dcpu16-assembler
Ghc-options: -Wall -fwarn-tabs
Hs-source-dirs: src
Main-is: Assembler/Main.hs
Other-modules:
Assembler
Assembler.Parser
Instruction
Memory
Build-depends:
base >= 4 && < 5,
blaze-builder >= 0.3 && < 0.4,
bytestring >= 0.9 && < 0.10,
containers >= 0.3 && < 0.5,
parsec >= 3.1 && < 3.2
View
@@ -0,0 +1,28 @@
; Try some basic stuff
SET A, 0x30 ; 7c01 0030
SET [0x1000], 0x20 ; 7de1 1000 0020
SUB A, [0x1000] ; 7803 1000
IFN A, 0x10 ; c00d
SET PC, crash ; 7dc1 001a [*]
; Do a loopy thing
SET I, 10 ; a861
SET A, 0x2000 ; 7c01 2000
:loop SET [0x2000+I], [A] ; 2161 2000
SUB I, 1 ; 8463
IFN I, 0 ; 806d
SET PC, loop ; 7dc1 000d [*]
; Call a subroutine
SET X, 0x4 ; 9031
JSR testsub ; 7c10 0018 [*]
SET PC, crash ; 7dc1 001a [*]
:testsub SHL X, 4 ; 9037
SET PC, POP ; 61c1
; Hang forever. X should now be 0x40 if everything went right.
:crash SET PC, crash ; 7dc1 001a [*]
; [*]: Note that these can be one word shorter and one cycle faster by using the short form (0x00-0x1f) of literals,
; but my assembler doesn't support short form labels yet.
View
@@ -0,0 +1,78 @@
module Assembler
( parse
, calculateLabels
, assemble
) where
import Data.List (foldl')
import Data.Map (Map)
import Data.Word (Word16)
import qualified Data.Map as M
import qualified Text.Parsec as P
import Assembler.Parser
import Instruction
parse :: FilePath -> String -> [(Maybe Label, Instruction AValue)]
parse filePath source = case P.parse statements filePath source of
Left err -> error $ show err
Right xs -> xs
-- | Length of an instruction (in words)
instructionLength :: Instruction AValue -> Int
instructionLength instruction = case instruction of
BasicInstruction _ a b -> 1 + valueLength a + valueLength b
NonBasicInstruction _ a -> 1 + valueLength a
where
-- Extra words needed to encode value
valueLength (ALiteral _) = 1
valueLength (APLiteral _) = 1
valueLength (APLiteralPlusRegister _ _) = 1
valueLength (ALabel _) = 1
valueLength _ = 0
calculateLabels :: [(Maybe Label, Instruction AValue)] -> Map Label Int
calculateLabels = snd . foldl' step (0, M.empty)
where
step (i, labels) (label, instr) = case label of
Nothing -> (i', labels)
Just l
| l `M.member` labels -> error $ "Duplicate label: " ++ l
| otherwise -> (i', M.insert l i labels)
where
i' = i + instructionLength instr
makeOperand :: Map Label Int -> AValue -> (Operand, [Word16])
makeOperand labels val = case val of
(ARegister r) -> (ORegister r, [])
(APRegister r) -> (OPRegister r, [])
(ALiteral w) -> (ONextWord, [w])
(APLiteral w) -> (OPNextWord, [w])
(APLiteralPlusRegister w r) -> (OPNextWordPlusRegister r, [w])
APop -> (OPop, [])
APeek -> (OPeek, [])
APush -> (OPush, [])
ASp -> (OSp, [])
APc -> (OPc, [])
AO -> (OO, [])
(ALabel l) -> (ONextWord, [findLabel l])
where
findLabel l = case M.lookup l labels of
Nothing -> error $ "Unknown label: " ++ l
Just i -> fromIntegral i
assembleInstruction :: Map Label Int
-> Instruction AValue
-> [Word16]
assembleInstruction labels instruction = case instruction of
(BasicInstruction op a b) ->
let (oa, w1) = makeOperand labels a
(ob, w2) = makeOperand labels b
in [encodeInstruction (BasicInstruction op oa ob)] ++ w1 ++ w2
(NonBasicInstruction op a) ->
let (oa, w1) = makeOperand labels a
in [encodeInstruction (NonBasicInstruction op oa)] ++ w1
assemble :: Map Label Int -> [Instruction AValue] -> [Word16]
assemble labels = concatMap (assembleInstruction labels)
View
@@ -0,0 +1,24 @@
module Main where
import System.Environment (getArgs, getProgName)
import System.Exit (exitFailure)
import qualified Blaze.ByteString.Builder as B
import qualified Data.ByteString.Lazy as BL
import Assembler
main :: IO ()
main = do
progName <- getProgName
args <- getArgs
case args of
[x] -> do
source <- readFile x
let instrs = parse x source
labels = calculateLabels instrs
w16s = assemble labels $ map snd instrs
BL.writeFile "a.out" $ B.toLazyByteString $ B.fromWord16sbe w16s
_ -> do
putStr $ "Usage: " ++ progName ++ " <assembler file>"
exitFailure
View
@@ -0,0 +1,154 @@
module Assembler.Parser
( Label
, AValue (..)
, statements
) where
import Control.Applicative ((<$>), (<*>), (<|>), (<*), (*>))
import Control.Monad (void)
import Data.Char (isSpace)
import Data.Word (Word16)
import qualified Text.Parsec as P
import Text.Parsec.String (Parser)
import Instruction
import Memory (Register (..))
type Label = String
data AValue
= ARegister Register
| APRegister Register
| ALiteral Word16
| APLiteral Word16
| APLiteralPlusRegister Word16 Register
| APop
| APeek
| APush
| ASp
| APc
| AO
| ALabel Label
deriving (Show)
statements :: Parser [(Maybe Label, Instruction AValue)]
statements = P.many statement
statement :: Parser (Maybe Label, Instruction AValue)
statement = do
P.skipMany $ P.choice [void (P.space), void comment]
label' <- P.option Nothing $ fmap Just label
P.skipMany $ P.choice [void (P.space), void comment]
instruction' <- instruction
P.skipMany $ P.choice [void (P.space), void comment]
return (label', instruction')
comment :: Parser String
comment = (:)
<$> P.char ';'
<*> P.manyTill P.anyChar (void P.newline <|> P.eof)
label :: Parser Label
label = P.char ':' *> until1 isSpace
instruction :: Parser (Instruction AValue)
instruction = basicInstruction <|> nonBasicInstruction
basicInstruction :: Parser (Instruction AValue)
basicInstruction = do
op <- P.choice $ map tryString instructions
P.skipMany1 P.space
a <- value
P.skipMany P.space
_ <- P.char ','
P.skipMany P.space
b <- value
return $ BasicInstruction op a b
where
instructions =
[ ("SET", Set)
, ("ADD", Add)
, ("SUB", Sub)
, ("MUL", Mul)
, ("DIV", Div)
, ("MOD", Mod)
, ("SHL", Shl)
, ("SHR", Shr)
, ("AND", And)
, ("BOR", Bor)
, ("XOR", Xor)
, ("IFE", Ife)
, ("IFN", Ifn)
, ("IFG", Ifg)
, ("IFB", Ifb)
]
nonBasicInstruction :: Parser (Instruction AValue)
nonBasicInstruction = do
op <- P.choice $ map tryString instructions
P.skipMany1 P.space
a <- value
return $ NonBasicInstruction op a
where
instructions =
[ ("JSR", Jsr)
]
register :: Parser Register
register = P.choice $ map tryString
[ ("A", A)
, ("B", B)
, ("C", C)
, ("X", X)
, ("Y", Y)
, ("Z", Z)
, ("I", I)
, ("J", J)
]
literal :: Parser Word16
literal = P.try hexadecimal <|> P.try decimal
where
hexadecimal = do
_ <- P.string "0x"
xs <- P.many1 P.hexDigit
return $ read $ "0x" ++ xs
decimal = do
xs <- P.many1 P.digit
return $ read xs
value :: Parser AValue
value = P.choice $ map P.try
[ ARegister <$> register
, APRegister <$> brackets register
, ALiteral <$> literal
, APLiteral <$> brackets literal
, brackets $ APLiteralPlusRegister
<$> literal
<* P.skipMany P.space
<* P.char '+'
<* P.skipMany P.space
<*> register
, P.string "POP" *> return APop
, P.string "PEEK" *> return APeek
, P.string "PUSH" *> return APush
, P.string "SP" *> return ASp
, P.string "PC" *> return APc
, P.string "O" *> return AO
, ALabel <$> until1 isSpace
]
where
brackets parser = do
_ <- P.char '['
P.skipMany P.space
x <- parser
P.skipMany P.space
_ <- P.char ']'
return x
until1 :: (Char -> Bool) -> Parser String
until1 = P.many1 . P.satisfy . (not .)
tryString :: (String, a) -> Parser a
tryString (str, x) = P.try (P.string str) *> return x
View
@@ -65,11 +65,11 @@ data Value
loadOperand :: Operand -> EmulatorM s Value
loadOperand (ORegister reg) =
return $ Address $ Memory.register reg
loadOperand (ORamAtRegister reg) = do
loadOperand (OPRegister reg) = do
mem <- ask
regv <- lift $ Memory.load mem (Memory.register reg)
return $ Address $ Memory.ram regv
loadOperand (ORamAtNextWordPlusRegister reg) = do
loadOperand (OPNextWordPlusRegister reg) = do
mem <- ask
nw <- loadNextWord
regv <- lift $ Memory.load mem (Memory.register reg)
@@ -94,7 +94,7 @@ loadOperand OPc =
return $ Address $ Memory.pc
loadOperand OO = do
return $ Address $ Memory.o
loadOperand ORamAtNextWord = do
loadOperand OPNextWord = do
nw <- loadNextWord
return $ Address $ Memory.ram nw
loadOperand ONextWord = do
@@ -122,7 +122,7 @@ step = do
skip <- lift $ Memory.load mem Memory.skip
-- Fetch and decode instruction
instruction <- parseInstruction <$> loadNextWord
instruction <- decodeInstruction <$> loadNextWord
-- Fetch its operands
instruction' <- case instruction of
File renamed without changes.
Oops, something went wrong.

0 comments on commit 82b141b

Please sign in to comment.