soyuz (empty) → 0.0.0
raw patch · 14 files changed
+967/−0 lines, 14 filesdep +QuickCheckdep +basedep +bytestringsetup-changed
Dependencies added: QuickCheck, base, bytestring, cereal, cmdargs, containers, pretty, trifecta, uniplate, vector
Files
- DCPU16/Assembler.hs +60/−0
- DCPU16/Assembly/Optimizer.hs +77/−0
- DCPU16/Assembly/Parser.hs +183/−0
- DCPU16/Assembly/Printer.hs +61/−0
- DCPU16/Disassembler.hs +119/−0
- DCPU16/Hex.hs +77/−0
- DCPU16/Instructions.hs +174/−0
- DCPU16/Instructions/Size.hs +24/−0
- DCPU16/Instructions/Time.hs +42/−0
- LICENSE +19/−0
- Main.hs +83/−0
- NOTES +1/−0
- Setup.hs +6/−0
- soyuz.cabal +41/−0
+ DCPU16/Assembler.hs view
@@ -0,0 +1,60 @@+-- | Assembler.+--+-- Works with "DCPU16.Instructions". Does no optimizations, just converts+-- labels to direct addresses and produces machine code.+--+-- Needs to be extended to support relative addressing. Extending labels to do+-- arithmetic: @sub pc,this-loop@ is a necessary step. I see this as more of an+-- optimization problem, since these kinds of rewrites would be neat to perform+-- automatically...+--+-- We'll see which direction it gets approached from.+module DCPU16.Assembler + ( assemble+ -- * Utility+ , labelAddrs+ ) where+import DCPU16.Instructions+import DCPU16.Instructions.Size+import Data.Word (Word16)+import Data.Vector (Vector)+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import qualified Data.Vector as V+import Data.Generics.Uniplate.Data+import qualified Data.Map as M+import Data.Map (Map)+import Data.Serialize++-- | Turn labels into direct addresses, and output machine code.+assemble :: Vector Instruction -> ByteString+assemble = B.concat . V.toList . V.map (runPut . put) . labelsToAddrs+++-- | Build address lookup table for label definitions.+labelAddrs :: Vector Instruction -> Map ByteString Word16+labelAddrs = snd . V.foldl f (0,M.empty) where+ f (addr,map) i = (addr',map') where+ addr' = addr + size i+ map' = case i of+ (Label s) -> M.insert s addr map+ _ -> map++-- | Replace every reference to a label with an address.+--+-- Strips comments and label definitions as well, assuming they won't be needed.+labelsToAddrs :: Vector Instruction -> Vector Instruction+labelsToAddrs is = + let is' = V.filter (not . isComment) is+ lut = labelAddrs is'+ in V.map (remap lut) . V.filter (not . isLabel) $ is'+ where+ isComment (Comment _ _) = True+ isComment _ = False+ isLabel (Label _) = True+ isLabel _ = False+ remap lut = transformBi f where+ f (LabelAddr s) = case M.lookup s lut of+ Just addr -> Const addr+ Nothing -> error $ "Undefined label: "++show s+ f x = x
+ DCPU16/Assembly/Optimizer.hs view
@@ -0,0 +1,77 @@+-- | Simple assembly optimizations.+--+-- Focus on small tweaks, like shortening instructions with small literals, +-- and any NOP\/call\/arithmetic optimizations that come up.+module DCPU16.Assembly.Optimizer + ( Optimization(..)+ , sizeVariant+ ) where+import DCPU16.Instructions+import DCPU16.Instructions.Size+import Data.Maybe (fromMaybe)+import Data.Word (Word16)+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import Data.Vector (Vector)+import qualified Data.Vector as V+import Data.Generics.Uniplate.Data+import qualified Data.Map as M++-- | Optimizations, listed in the order they're performed. (Earliest first.)+data Optimization+ -- | Shortens instructions by 1 word if they use literals smaller than 0x20.+ --+ -- > set a,1 ; 1 word, not 2+ -- > add [0x8000],1 ; 2 words, not 3+ = ShortLiterals+ -- | Performs the short literal optimization on labels.+ --+ -- > :l_0000 set pc,l.0000 ; 1 word, address < 0x20+ -- > :l_8000 set pc,l.8000 ; 2 words, large address+ | ShortLabelLiterals+ deriving (Eq,Read,Show,Ord,Enum,Bounded)++type Step = Vector Instruction -> Vector Instruction++-- | Compose a series of optimizations.+--+-- First in the list = first run. Last = last.+pipeline :: [(Optimization,Step)] -> Step+pipeline = foldl1 (flip (.)) . map snd++-- | Optimizations that change the size of instructions, but not order.+--+-- Should be run before label-to-address translation.+sizeVariant :: Step+sizeVariant = pipeline+ [(ShortLiterals, shortLiterals)+ ,(ShortLabelLiterals, shortLabelLiterals)+ ]+++--+-- Actual optimization implementations follow:+--++shortLiterals :: Vector Instruction -> Vector Instruction+-- ^ Rewrite small constants to make the instructions one word shorter.+--+-- Only works for literals <=32.+shortLiterals = V.map (rewriteBi f) where+ f (DirectLiteral c@(Const w)) | w<=0x1f = Just $ ShortLiteral c+ f _ = Nothing++shortLabelLiterals :: Vector Instruction -> Vector Instruction+-- ^ Rewrite small label addresses to make instructions one word shorter.+--+-- Only works for addresses <=32 (not many) and vulnerable to size changes.+--+-- Should probably be one of the last steps.+shortLabelLiterals is = rewriteBi f `V.map` is where+ f (DirectLiteral l@(LabelAddr s)) | addr s<=0x1f = Just $ ShortLiteral l+ f _ = Nothing+ addr :: ByteString -> Word16+ addr s = fromMaybe (error $ "undefined label "++show s) (M.lookup s lut)+ lut = M.fromList . snd $ V.foldl fun (0,[]) is where+ fun (addr,acc) (Label s) = (addr,(s,addr):acc)+ fun (addr,acc) i = (addr + size i, acc)
+ DCPU16/Assembly/Parser.hs view
@@ -0,0 +1,183 @@+{-# LANGUAGE OverloadedStrings #-}+-- | Parser for what seems to be DCPU16 assembly.+--+-- There is some ambiguity between sources: the specification uses uppercase a+-- lot (which I'd rather put in as an option later, with the strict+-- implementation being default).+--+-- A screenshot also shows indirect mode being done with [] instead of (). Go+-- figure.+module DCPU16.Assembly.Parser+ ( parseFile+ , defaults+ , Options(..)+ ) where+import Text.Trifecta hiding (Pop,Push)+import Control.Applicative hiding (Const)+import DCPU16.Instructions+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as B+import Data.Vector (Vector)+import Data.Word (Word16)+import qualified Data.Vector as V+import Data.Char (toUpper)+import Control.Monad (void,unless)+import Text.Printf++-- | Default parsing options.+defaults :: Options+defaults = Options False++-- | Parsing options, if you want to override the defaults.+data Options = Options+ { roundedBrackets :: Bool+ -- ^ Indirect mode via \(\) instead of \[\]. Default: off.+ --+ -- Weird, but showed up in a screenshot.+ } deriving (Read,Show,Eq)+++-- | Parser state. +--+-- Should factor this into a RWS monad wrapper, but don't understand Trifecta+-- well enough to do so. Monads, how do they work?+data Opt = Opt+ { optSymbols :: Vector ByteString+ , options :: Options+ } deriving (Read,Show,Eq)+++-- | Parse a file.+--+-- Detailed errors with line and column numbers (as well as expected values)+-- will be printed to console if parsing fails.+parseFile opt f = do+ (Just syms) <- parseFromFile symbolDefs f+ parseFromFile (asm (Opt syms opt)) f+++symbolDefs :: Parser String (Vector ByteString)+-- | Label definition only parser.+--+-- Meant to be run as the first pass, to extract a table to check label uses+-- against in a future pass.+symbolDefs = process `fmap` (spaces >> ls <* end) where+ -- labels appear at the start of lines: + -- if something un-label-like seen, skip to next line+ ls = many . lexeme . choice $ [label,nextLine]+ nextLine = Data (Const 0) <$ skipSome (satisfy notMark)+ notMark c = c/='\n'+ process = V.fromList . map (\(Label s)->s) . filter isLabel+ isLabel (Label _) = True+ isLabel _ = False+++-- | Instruction, comment, and label parser.+--+-- Relies on a symbol table parsed in a previous pass to check for label+-- existance.+asm :: Opt -> Parser String (Vector Instruction)+asm o = V.fromList `fmap` (spaces >> instructs <* end) where+ instructs = many . lexeme . choice $ [instruction o, label, comment, dat o]++end = eof <?> "comment, end of file, or valid instruction"++-- | For now, data only handles one word. +--+-- Will figure out good syntax sugar (and refactor "asm" to handle multi-word)+-- later.+dat o = Data <$ symbol "dat" <*> word o++label = Label <$ char ':' <*> labelName <* spaces++labelName = B.pack `fmap` some labelChars++labelChars = alphaNum <|> char '_' <|> char '.'++comment = do+ char ';'+ l <- line+ Comment (B.head l == ';') <$> manyTill anyChar eofOrNewline + where+ eofOrNewline = void (try newline) <|> eof++instruction :: Opt -> Parser String Instruction+instruction o = choice+ [ Basic <$> basicOp o <*> operand o <* comma <*> operand o+ , NonBasic <$> sym o JSR "jsr" <*> operand o+ ]+++operand :: Opt -> Parser String Operand+operand o = choice+ [ sym o Pop "pop"+ , sym o Peek "peek"+ , sym o Push "push"+ , sym o SP "sp"+ , sym o PC "pc"+ , sym o O "o"+ , Direct <$> register o+ , DirectLiteral <$> word o+ , brace o (indirect o)+ ]+ where+ indirect o = choice+ [ try $ Offset <$> word o <* symbol "+" <*> register o+ , try $ flip Offset <$> register o <* symbol "+" <*> word o+ , try $ Indirect <$> register o+ , IndirectLiteral <$> word o+ ]+++-- This code is based on the Haskell parser, and thus strips a lot more+-- whitespace than desired. [\na+2] probably shouldn't be valid assembly.+brace o = if roundedBrackets $ options o + then nesting . between (symbolic '(') (symbolic ')')+ else brackets+ +word :: Opt -> Parser String Word+word o = lexeme $ choice+ [ Const <$> int+ , definedLabel+ ] + where+ definedLabel = do+ s <- labelName+ unless (s `V.elem` optSymbols o) $+ err [] $ "label "++show s++" not defined"+ return $ LabelAddr s+++int :: Parser String Word16+int = fromInteger <$> (num >>= checkSize)+ where+ num = choice+ [ try $ (char '0' <?> "\"0x\"") >> hexadecimal+ , decimal+ ]+ checkSize :: Integer -> Parser String Integer+ checkSize n = if n>0xffff + then do+ err [] (printf fmt n)+ return (mod n 0xffff)+ else return n+ fmt = "literal 0x%x is wider than 16 bits"+++sym o i tok = try $ i <$ token <* notFollowedBy labelChars <* spaces + where+ token = string tok <|> string (map toUpper tok)++register o = try $ choice+ [ sym o A "a", sym o B "b", sym o C "c"+ , sym o X "x", sym o Y "y", sym o Z "z"+ , sym o I "i", sym o J "j"+ ] ++basicOp o = choice+ [ sym o SET "set", sym o ADD "add", sym o SUB "sub"+ , sym o MUL "mul", sym o DIV "div", sym o MOD "mod", sym o SHL "shl"+ , sym o SHR "shr", sym o AND "and", sym o BOR "bor", sym o XOR "xor"+ , sym o IFE "ife", sym o IFN "ifn", sym o IFG "ifg", sym o IFB "ifb"+ ]+
+ DCPU16/Assembly/Printer.hs view
@@ -0,0 +1,61 @@+-- | DCPU-16 pretty-printing.+--+-- Meant for printing disassembly, debugger data, and other machine output.+--+-- Focus is on consistency and predictability, not special snowflake+-- indentation or ASCII art.+--+-- Should be compatible with other people's stuff, with two caveats:+-- +-- * I saw a screenshot that used () for indirect rather than [].+--+-- * Output is lower case.+module DCPU16.Assembly.Printer + ( pprint+ ) where+import DCPU16.Instructions+import Text.PrettyPrint+import Data.Char (toLower)+import Data.ByteString.Char8 (unpack)+import Text.Printf+import Data.Word (Word16)+import Data.Vector (Vector)+import qualified Data.Vector as V++-- | Nicely formatted ASCII output.+pprint :: Vector Instruction -> String+pprint = render . V.foldl pI empty++pI :: Doc -> Instruction -> Doc+pI acc (Comment solo xs) + | not solo = acc $$ nest 40 (semi <> text xs)+ | otherwise = acc $+$ semi <> text xs+pI acc (Label s) = acc $$ colon <> text (unpack s)+pI acc (Data x) = acc $$ nest 16 (text "dat" <+> pW x)+pI acc (Basic op a b) = acc $$ nest 16 (pBO op <+> pO a <> comma <+> pO b)+pI acc (NonBasic op a)= acc $$ nest 16 (pNBO op <+> pO a)++pW (Const x) | x<0xa = text . show $ x+ | otherwise = pHex "0x%x" x+pW (LabelAddr s) = text . unpack $ s++pBO :: BasicOp -> Doc+pBO = text . map toLower . show++pNBO :: NonBasicOp -> Doc+pNBO JSR = text "jsr"+pNBO (Reserved code) = pHex "; RESERVED INSTRUCTION: 0x%x" code++pO :: Operand -> Doc+pO (Direct r) = pReg r+pO (Indirect r) = brackets $ pReg r+pO (Offset off r) = brackets $ pW off <> char '+' <> pReg r+pO (IndirectLiteral w) = brackets $ pW w+pO (DirectLiteral w) = pW w+pO (ShortLiteral w) = pW w+pO o = text . map toLower . show $ o++pHex :: String -> Word16 -> Doc+pHex fmt w = text (printf fmt w)++pReg = text . map toLower . show
+ DCPU16/Disassembler.hs view
@@ -0,0 +1,119 @@+-- | Disassembler.+--+-- I should really convert these to use Vector Word16, rather than ByteString.+--+-- It won't be useful for command line tools, but make more sense for+-- everything else.+module DCPU16.Disassembler+ (+ -- * High level disassembly+ disassemble+ -- * Component functions+ , readInstructions+ , annotate+ ) where+import Data.Word (Word16)+import Data.List (sort)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as B+import Data.Vector (Vector)+import qualified Data.Vector as V+import Text.Printf+import Data.Serialize+import DCPU16.Instructions+import DCPU16.Instructions.Size++-- | Disassembler.+--+-- Annotates result with labels for obvious jumps/calls, but keeps operand+-- addresses as literals.+disassemble :: ByteString -> Vector Instruction+disassemble = annotate . readInstructions+ +++-- | Naive disassembly.+--+-- Disassembly can fail at the very end of a buffer, if a partial multi-word+-- instruction is encountered. I'll eventually treat those as data words+-- instead, but for now it crashes... And is a point of weakness to keep in+-- mind for interpreters. What will the official one do?+--+-- It can also produce gibberish if data words are inserted that look like+-- multi-word instructions. This can be hard to catch, and will throw naive+-- disassemblers.+readInstructions :: ByteString -> Vector Instruction+readInstructions s = case runGet (f []) s of+ Right is -> V.fromList . reverse $ is+ Left s -> error $ "Disassembly should never, ever, ever fail, but: "++s+ where+ f acc = do+ i <- get :: Get Instruction+ n <- remaining+ let next = case n of+ 0 -> return+ _ -> f+ next (i:acc)+++-- | Add easily visible labels to instructions.+--+-- Stuff like JSR foo / SET PC, bar / SUB PC, 5+--+-- Labels are not inserted as operands, only defined. The names have the+-- address in them, to match up with operands.+annotate :: Vector Instruction -> Vector Instruction+annotate is = V.fromList . insertLabels ls . V.toList $ is where+ ls :: [(Word16,LabelType)]+ ls = extractLabels is+++data LabelType = Call | DirectJump | RelativeJump deriving (Eq,Show,Read,Ord)++-- | Get destinations of all JSR 'calls'.+--+-- Assumes there are no labels, only literals. Any label operands will be+-- skipped.+extractLabels :: Vector Instruction -> [(Word16,LabelType)]+extractLabels = snd . foldl f (0,[]) . V.toList where+ -- TODO: factor out size-fold pattern? how to handle instruction size+ -- failure?+ f (addr,acc) i = (addr',acc') where+ addr' = addr + size i+ acc' = accLabels acc addr' i+ -- labels extracted:+ accLabels acc addr (NonBasic JSR l) = (lit l, Call):acc+ accLabels acc addr (Basic SET PC l) | isLit l = + (lit l, DirectJump):acc+ accLabels acc addr (Basic ADD PC l) | isLit l = + (lit l+addr+1, RelativeJump):acc+ accLabels acc addr (Basic SUB PC l) | isLit l = + (lit l+addr+1, RelativeJump):acc+ accLabels acc _ _ = acc+ -- utility+ isLit (DirectLiteral (Const _)) = True+ isLit (ShortLiteral (Const _)) = True+ isLit _ = False+ lit (DirectLiteral (Const w)) = w+ lit (ShortLiteral (Const w)) = w++-- | Insert labels.+--+-- Assumes instructions start at 0x0000, and label addresses are only within+-- the range of instructions.+insertLabels :: [(Word16,LabelType)] -> [Instruction] -> [Instruction]+insertLabels ls is = reverse $ f (sort ls) is 0 [] where+ f labels [] _ acc = acc+ f [] is _ acc = reverse is ++ acc+ f (l@(laddr,_):ls) (i:is) addr acc = f labels is addr' acc' where+ addr' = addr+size i+ (acc',labels) = if laddr>=addr && laddr<addr'+ then (i:Label (showLabel l):acc, ls)+ else (i:acc, l:ls)+ showLabel :: (Word16,LabelType) -> ByteString+ showLabel (w,lt) = B.pack $ printf fmt (toInteger w) where+ fmt = case lt of+ Call -> "func.%04x"+ DirectJump -> "jump.%04x"+ RelativeJump -> "rel.%04x"+
+ DCPU16/Hex.hs view
@@ -0,0 +1,77 @@+-- | A weird utility module, with stuff I don't know where to put.+--+-- I didn't call it Util because that's just a slippery slope.+module DCPU16.Hex ( + -- * Hexdumps+ dump, dumpBytes+ -- * Homeless utility functions+ , warn, getWord16s+ ) where+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import Data.Vector (Vector)+import qualified Data.Vector as V+-- printing warnings to stderr:+import System.IO (hPutStrLn, stderr)+import System.IO.Unsafe (unsafePerformIO)+import Text.Printf+-- bytestring->V word16+import Data.Serialize+import Data.Word (Word16)++-- | Prints a message to stderr.+--+-- Inserts newlines automatically. Pretends it doesn't perform IO.+warn :: String -> a -> a+warn s a = unsafePerformIO (hPutStrLn stderr s >> return a)+++-- | Prints a nice dump of 16-bit words.+--+-- >>> putStrLn . dump . fromList $ [1..32]+-- 0000: 0001 0002 0003 0004 0005 0006 0007 0008+-- 0008: 0009 000a 000b 000c 000d 000e 000f 0010+-- 0010: 0011 0012 0013 0014 0015 0016 0017 0018+-- 0018: 0019 001a 001b 001c 001d 001e 001f 0020+--+-- Complexity is probably terrible, but when people write programs big enough+-- for it to matter, I'll fix it.+dump :: Vector Word16 -> String+dump = concat . V.toList . V.imap pAddr+ where+ pAddr :: Int -> Word16 -> String+ pAddr 0 = ("0000:"++) . pWord+ pAddr n | mod n 8 == 0 = (printf "\n%04x:" n++) . pWord+ | otherwise = pWord+ pWord :: Word16 -> String+ pWord = printf " %04x" . toInteger+++-- | ByteString version of 'dump'.+--+-- If faced with odd number of bytes, truncates the last one and prints a+-- warning to stderr.+dumpBytes :: ByteString -> String+dumpBytes s = dump . getWord16s $ s where+ len = B.length s+ s' = case len `mod` 2 of+ 1 -> warn msg $ B.init s+ 0 -> s+ msg = "Warning: truncating last byte of "++show len++" byte hex string before\n"+ ++ " dumping. Dump works on 16-bit words only."++-- | Utility for parsing bytestrings as word lists.+--+-- >>> getWord16s . pack $ "asdfasdf"+-- fromList [24947,25702,24947,25702]+--+-- If length in bytes is odd, discards last byte silently.+getWord16s :: ByteString -> Vector Word16+getWord16s s = V.fromList . reverse . either err id $ runGet (f len []) s+ where+ len = B.length s `div` 2+ f 0 acc = return acc+ f n acc = do+ w <- getWord16be+ f (n-1) (w:acc)+ err e = error $ "getWord16s impossible error: "++e
+ DCPU16/Instructions.hs view
@@ -0,0 +1,174 @@+{-# LANGUAGE DeriveDataTypeable #-}+-- | Complete abstract description of the DCPU-16 instruction set.+--+-- Based on Version 1.1 of the DCPU-16 Specification by Mojang, retrieved from 0x10c.com.+--+-- Contains a trivial 'Label' extension, which isn't present in machine code+-- but is useful for dealing with assembly.+module DCPU16.Instructions+ ( Instruction(..)+ -- * Operands+ , Operand(..)+ , Register(..)+ , Word(..)+ -- * Operations+ , BasicOp(..)+ , NonBasicOp(..)+ ) where+-- Fundamental types+import Data.Word hiding (Word)+import Data.Data+import Data.ByteString+-- Serialization+import Data.Serialize+import Data.Bits+import Data.Maybe (fromMaybe)+import Control.Applicative hiding (Const)++-- | Abstract DCPU-16 instruction set.+--+-- Can be read and written as machine code via the Serialize instance.+data Instruction + = Basic BasicOp Operand Operand+ | NonBasic NonBasicOp Operand+ | Data Word+ | Label ByteString -- ^ Not present in machine code, for assembler utility only.+ | Comment Bool String -- ^ Boolean true if comment is alone on its own line.+ deriving (Eq,Read,Show,Data,Typeable)++data BasicOp+ = SET+ | ADD | SUB+ | MUL | DIV+ | MOD+ | SHL | SHR+ | AND | BOR | XOR+ | IFE+ | IFN+ | IFG+ | IFB+ deriving (Eq,Read,Show,Data,Typeable)++data NonBasicOp+ = JSR+ | Reserved Word16 -- ^ Opcode not defined yet.+ deriving (Eq,Read,Show,Data,Typeable)++-- | Values instructions operate on.+--+-- Direct operands use the value passed to them.+--+-- Indirect operands treat that value as an address for a specific word in memory.+data Operand+ = Direct Register+ | Indirect Register -- ^ At address [register].+ | Offset Word Register -- ^ At address [next word + register].+ | Pop | Peek | Push+ | SP | PC + | O -- ^ Overflow.+ | IndirectLiteral Word+ | DirectLiteral Word+ | ShortLiteral Word -- ^ Restricted to 0x00-0x1f, 5 bits.+ deriving (Eq,Read,Show,Data,Typeable)++data Register = A|B|C|X|Y|Z|I|J+ deriving (Eq,Read,Show,Data,Typeable,Enum)++-- | Constant data.+--+-- Assembly may use adresses of labels to initialize such data: since the+-- address may not be known immediately, the label extension is added.+data Word + = Const Word16 + | LabelAddr ByteString + deriving (Eq,Read,Show,Data,Typeable)+++++-- Machine language encoding/decoding follows.+--+-- Rather crude for now, needs refactoring to use a bit-aware packer. And+-- general cleanup.++-- | Machine code encoding/decoding.+instance Serialize Instruction where+ put (Basic op a b) = do+ let (a',aw) = packOp a+ (b',bw) = packOp b+ putWord16be $ (((b' `shiftL` 6) .|. a') `shiftL` 4) .|. fromOpCode op+ maybe (return ()) put aw+ maybe (return ()) put bw+ put (NonBasic op a) = putNonBasic opCode a+ where+ opCode = case op of JSR->0x01; Reserved x->0x3f.&.x+ putNonBasic op a = do + let (a',w) = packOp a+ putWord16be $ shiftL (shiftL a' 6 .|. op) 4+ maybe (return ()) put w+ put (Data x) = put x+ put (Label s) = return ()+ get = do+ w <- getWord16be+ let [b,a,op] = fmap (maskShr w) [(0xfc00,10), (0x03f0,4), (0x000f,0)]+ if op==0 then+ NonBasic (getNBCode a) <$> getOp b+ else+ Basic (toOpCode op) <$> getOp a <*> getOp b+ where+ maskShr w (mask,sh) = shiftR (w.&.mask) sh+++instance Serialize Word where+ put (LabelAddr s) = fail $ "can not serialize label address "++show s+ put (Const x) = putWord16be x+ get = Const <$> getWord16be++getNBCode 0x01 = JSR+getNBCode op = Reserved op++-- | Parse 6-bit operand.+getOp :: Word16 -> Get Operand+getOp op | op<=0x17 = getRegMode op+ -- 0x18-0x1d are simple operands+ | op==0x1e = IndirectLiteral <$> get+ | op==0x1f = DirectLiteral <$> get+ | op>=0x20 = return $ (ShortLiteral . Const) (op-0x20)+ | otherwise = return $ toOperand op++-- | Pack 6-bit operand and any additional word it has.+packOp :: Operand -> (Word16, Maybe Word)+packOp (Direct r) = (regId r, Nothing)+packOp (Indirect r) = (0x08+regId r, Nothing)+packOp (Offset off r) = (0x10+regId r, Just off)+packOp (IndirectLiteral w) = (0x1e, Just w)+packOp (DirectLiteral w) = (0x1f, Just w)+packOp (ShortLiteral (Const w)) = (0x20+w, Nothing)+packOp (ShortLiteral (LabelAddr s)) = error $ "can not serialize label address "++show s+packOp o = (fromOperand o, Nothing)++regId = fromIntegral . fromEnum++getRegMode :: Word16 -> Get Operand+getRegMode op | op .&. 0x10 == 0x10 = return (Indirect r)+ | op .&. 0x08 == 0x08 = do offset <- get+ return (Offset offset r)+ | otherwise = return (Direct r)+ where+ r = toEnum . fromIntegral $ op .&. 0x7++toOperand 0x18 = Pop; toOperand 0x19 = Peek; toOperand 0x1a = Push+toOperand 0x1b = SP; toOperand 0x1c = PC; toOperand 0x1d = O++fromOperand Pop = 0x18; fromOperand Peek = 0x19; fromOperand Push = 0x1a+fromOperand SP = 0x1b; fromOperand PC = 0x1c; fromOperand O = 0x1d ++fromOpCode SET=0x1; fromOpCode ADD=0x2; fromOpCode SUB=0x3+fromOpCode MUL=0x4; fromOpCode DIV=0x5; fromOpCode MOD=0x6; fromOpCode SHL=0x7+fromOpCode SHR=0x8; fromOpCode AND=0x9; fromOpCode BOR=0xa; fromOpCode XOR=0xb+fromOpCode IFE=0xc; fromOpCode IFN=0xd; fromOpCode IFG=0xe; fromOpCode IFB=0xf++toOpCode 0x1=SET; toOpCode 0x2=ADD; toOpCode 0x3=SUB+toOpCode 0x4=MUL; toOpCode 0x5=DIV; toOpCode 0x6=MOD; toOpCode 0x7=SHL+toOpCode 0x8=SHR; toOpCode 0x9=AND; toOpCode 0xa=BOR; toOpCode 0xb=XOR+toOpCode 0xc=IFE; toOpCode 0xd=IFN; toOpCode 0xe=IFG; toOpCode 0xf=IFB
+ DCPU16/Instructions/Size.hs view
@@ -0,0 +1,24 @@+-- | DCPU-16 instruction size in memory.+module DCPU16.Instructions.Size + ( size+ ) where+import DCPU16.Instructions+import Data.Word++-- | Instruction size in words.+--+-- Each word is 16 bits. Instructions are always 1, 2, or 3 words in length.+-- +-- Comments and labels don't appear in machine code.+size :: Instruction -> Word16+size (Basic _ a b) = 1 + ops a + ops b+size (NonBasic _ a) = 2 + ops a+size (Comment _ _) = 0+size (Label _) = 0++-- | Operand size.+ops :: Operand -> Word16+ops (Offset _ _) = 1+ops (IndirectLiteral _) = 1+ops (DirectLiteral _) = 1+ops _ = 0
+ DCPU16/Instructions/Time.hs view
@@ -0,0 +1,42 @@+-- | DCPU-16 instruction execution time in cycles.+module DCPU16.Instructions.Time + ( time+ ) where+import DCPU16.Instructions+import Data.List (elem)+import Data.Word++-- | Instruction execution time in cycles.+--+-- Depends on the instruction, and type of operands used.+--+-- There's also a 1-cycle cost for unsuccessful IF? comparisons, but that can't+-- be predicted without running the code. As such, this prediction is+-- optimistic and assumes all comparisons succeed.+--+-- Since the most cycle-efficient way to write loops, is to jump back on a+-- successful comparison, this prediction should be close to accurate.+time :: Instruction -> Int+time (Basic op a b) = baseCost op + opc a + opc b+time (NonBasic JSR a) = 2 + opc a+++-- | Cycle cost regardless of operands.+--+-- Doesn't take 1-cycle failed comparison penalty into account for IF?.+baseCost :: BasicOp -> Int+baseCost op | op `elem` [SET,AND,BOR,XOR, IFE,IFN,IFG,IFB] = 1+ | op `elem` [ADD,SUB,MUL,SHR,SHL] = 2+ | op `elem` [DIV,MOD] = 3++-- | Operand cycle cost.+--+-- Anything that extends instruction length has an extra cycle cost.+--+-- Oddly, there is no cost for accessing indirect addresses. Either a+-- simplification or oversight.+opc :: Operand -> Int+opc (Offset _ _) = 1+opc (IndirectLiteral _) = 1+opc (DirectLiteral _) = 1+opc _ = 0
+ LICENSE view
@@ -0,0 +1,19 @@+Copyright (C) 2012 Alex Kropivny++Permission is hereby granted, free of charge, to any person obtaining a copy of+this software and associated documentation files (the "Software"), to deal in+the Software without restriction, including without limitation the rights to+use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies+of the Software, and to permit persons to whom the Software is furnished to do+so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ Main.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE DeriveDataTypeable #-}+import System.Console.CmdArgs+import System.Exit+import System.IO (hPutStrLn, stderr)+import qualified DCPU16.Assembly.Parser as P+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as B+import Control.Monad (when, void)+import DCPU16.Assembly.Printer+import DCPU16.Assembly.Optimizer+import DCPU16.Assembler+import DCPU16.Disassembler+import DCPU16.Hex++main = do+ opts <- cmdArgs options+ instr <- readInput opts+ let out = processOutput opts . optimize opts $ instr+ case output opts of+ -- absolutely do not do 'putStrLn', to not break binary input:+ "" -> B.putStr out + f -> B.writeFile f out+ where+ packNlEof s = B.snoc (B.pack s) '\n'+ readInput opts = do+ instr <- case runMode opts of+ Disassemble -> do+ s <- B.readFile (inputFile opts)+ return . Just . disassemble $ s+ _ -> do+ let po = P.defaults+ { P.roundedBrackets = parseSmoothBrackets opts+ }+ P.parseFile po (inputFile opts)+ case instr of+ Just is -> return is+ Nothing -> exitFailure -- parser already printed messages+ optimize opts is = if noOptimization opts then is else sizeVariant is+ processOutput opts instr = case runMode opts of+ Assemble -> binEncoding . assemble $ instr+ _ -> packNlEof $ pprint instr+ where+ binEncoding = if hexdump opts then packNlEof . dumpBytes else id++-- | Print a message to stderr and exit.+errorExit :: String -> IO ()+errorExit msg = hPutStrLn stderr msg >> exitFailure++data RunMode = Assemble | Disassemble | PrettyPrint+ deriving (Eq,Show,Read,Data,Typeable)++data Options = Options+ { runMode :: RunMode+ , inputFile :: String+ , noOptimization :: Bool+ , output :: String+ , hexdump :: Bool+ , parseSmoothBrackets :: Bool+ } deriving (Eq,Show,Read,Data,Typeable)++options = Options + { runMode = enum+ [ PrettyPrint&= help "Assembly -> consistently formatted assembly"+ , Assemble &= help "Assembly -> machine code"+ , Disassemble&= help "Machine code -> assembly"+ ] &= groupname "Mode of operation"+ , inputFile = "" &= argPos 0 &= typ "<FILE>"+ , noOptimization = False+ &= explicit &= name "no-optimize"+ &= help "Disable short literal/label optimization"+ &= groupname "Optimization"+ , output = def &= typ "<FILE>"+ &= help "Write to file instead of stdout"+ &= groupname "General"+ , hexdump = False &= help "Encode binary data in a 16-bit hexdump"+ , parseSmoothBrackets = False+ &= explicit &= name "smooth-brackets"+ &= help "Parse (a) instead of [a] for indirect mode"+ } &= program "soyuz"+ &= summary "soyuz 0.0.0, amtal <alex.kropivny@gmail.com>"+ &= details+ [ "Documentation and source at https://github.com/amtal/soyuz or on Hackage."+ ]
+ NOTES view
@@ -0,0 +1,1 @@+None yet.
+ Setup.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import Distribution.Simple++main :: IO ()+main = defaultMain
+ soyuz.cabal view
@@ -0,0 +1,41 @@+name: soyuz+version: 0.0.0+license: MIT+author: Alex Kropivny <alex.kropivny@gmail.com>+maintainer: Alex Kropivny <alex.kropivny@gmail.com>+homepage: https://github.com/amtal/0x10c+stability: Experimental+category: Compilers/Interpreters+synopsis: DCPU-16 architecture utilities for Notch's 0x10c game.+description:+ Utilities for the DCPU-16 architecture, for Notch's upcoming space game, 0x10c.+ .+ Meant to be a library for implementing powerful tools. As demonstrations, contains+ a command-line optimizing assembler\/disassembler\/pretty printer.+ .+ Core of the library is "DCPU16.Instructions". Everything else is built around it.+build-type: Simple+cabal-version: >= 1.4+license-file: LICENSE++extra-source-files:+ NOTES+++flag split-base++executable soyuz+ main-is: Main.hs++library+ exposed-modules:+ DCPU16.Assembly.Parser+ DCPU16.Assembly.Printer+ DCPU16.Assembly.Optimizer+ DCPU16.Instructions+ DCPU16.Instructions.Size+ DCPU16.Instructions.Time+ DCPU16.Assembler+ DCPU16.Disassembler+ DCPU16.Hex+ build-depends: base >= 4 && < 5, vector, QuickCheck, uniplate, cereal, bytestring, trifecta, pretty, containers, cmdargs