Disasm DCPU-16

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
import Data.Array.IO
import Data.Array.MArray
import Data.Word
import Data.Binary
import Data.Binary.Get (isEmpty, runGet)
import Data.Bits
import qualified Data.ByteString.Lazy as BS

type Label = String

data Register = A | B | C | X | Y | Z | I | J deriving (Show, Enum)

data Literal = 
	L00 | L01 | L02 | L03 | L04 | L05 | L06 | L07 | L08 | L09 | L0A | 
	L0B | L0C | L0D | L0E | L0F | L10 | L11 | L12 | L13 | L14 | L15 | 
	L16 | L17 | L18 | L19 | L1A | L1B | L1C | L1D | L1E | L1F
		deriving (Show, Enum)

data Value =
	Register Register | -- A
	DerefRegister Register | -- [A]
	DerefNextWordPlusRegister Register Word16 | -- [PC++ + A]
	Pop | -- [SP++]
	Peek | -- [SP]
	Push | -- [--SP]
	SP | -- SP
	PC | -- PC
	O | -- O
	DerefNextWord Word16 | -- [PC++]
	NextWord Word16 | -- PC++
	Literal Literal
		deriving (Show)

data OPC =
	NBOPC NBOPC |
	Set Value Value | 
	Add Value Value |
	Sub Value Value |
	Mul Value Value | 
	Div Value Value |
	Mod Value Value |
	Shl Value Value |
	Shr Value Value |
	And Value Value |
	Bor Value Value | 
	Xor Value Value |
	Ife Value Value |
	Ifn Value Value |
	Ifg Value Value |
	Ifb Value Value
		deriving (Show)

-- reserved for future expansion
data NBOPC =
	JSR Value 
		deriving (Show)

instance Binary OPC where
	put (NBOPC nbop) = error "non basic"
	put (Set a b) = putBasic 0x1 a b
	put (Add a b) = putBasic 0x2 a b
	put (Sub a b) = putBasic 0x3 a b
	put (Mul a b) = putBasic 0x4 a b
	put (Div a b) = putBasic 0x5 a b
	put (Mod a b) = putBasic 0x6 a b
	put (Shl a b) = putBasic 0x7 a b
	put (Shr a b) = putBasic 0x8 a b
	put (And a b) = putBasic 0x9 a b
	put (Bor a b) = putBasic 0xa a b
	put (Xor a b) = putBasic 0xb a b
	put (Ife a b) = putBasic 0xc a b
	put (Ifn a b) = putBasic 0xd a b
	put (Ifg a b) = putBasic 0xe a b
	put (Ifb a b) = putBasic 0xf a b

	get = do
		op <- get :: Get Word16
		case (op .&. 0x000f) of 
			0x0 -> error "non basic"
			0x1 -> getBasic op Set
			0x2 -> getBasic op Add
			0x3 -> getBasic op Sub
			0x4 -> getBasic op Mul
			0x5 -> getBasic op Div
			0x6 -> getBasic op Mod
			0x7 -> getBasic op Shl
			0x8 -> getBasic op Shr
			0x9 -> getBasic op And
			0xa -> getBasic op Bor
			0xb -> getBasic op Xor
			0xc -> getBasic op Ife
			0xd -> getBasic op Ifn
			0xe -> getBasic op Ifg
			0xf -> getBasic op Ifb

putBasic :: Word16 -> Value -> Value -> Put
putBasic opv a b = do
	-- write these bits: bbbbbbaaaaaaoooo
	put ((bv `shiftL` 10) .|. (av `shiftL` 4) .|. opv)
	mapM_ put (nwa ++ nwb)
	where
		(av, nwa) = encodeValue a
		(bv, nwb) = encodeValue b

		encodeValue :: Value -> (Word16, [Word16])
		encodeValue v = case v of
			Register r -> (fromIntegral $ fromEnum r, [])
			DerefRegister r -> (0x8 + (fromIntegral $ fromEnum r), [])
			DerefNextWordPlusRegister r w -> 
				(0x10 + (fromIntegral $ fromEnum r), [w])
			Pop -> (0x18, [])
			Peek -> (0x19, [])
			Push -> (0x1a, [])
			SP -> (0x1b, [])
			PC -> (0x1c, [])
			O -> (0x1d, [])
			DerefNextWord w -> (0x1e, [w])
			NextWord w -> (0x1f, [w])
			Literal l -> (0x20 + (fromIntegral $ fromEnum l), [])

getBasic :: Word16 -> (Value -> Value -> OPC) -> Get OPC
getBasic op opc = do
	a <- getValue ((op .&. 0x03f0) `shiftR` 4)
	b <- getValue ((op .&. 0xfc00) `shiftR` 10)
	return (opc a b)
	where
		getValue :: Word16 -> Get Value
		getValue v 
			| v < 0x8 = return $ Register $ toEnum $ fromIntegral $ v
			| v < 0x10 = return $ DerefRegister 
				(toEnum $ fromIntegral $ v - 0x8)
			| v < 0x18 = do
				w <- get
				return $ DerefNextWordPlusRegister 
					(toEnum $ fromIntegral $ v - 0x10) w
			| v == 0x18 = return Pop
			| v == 0x19 = return Peek
			| v == 0x1a = return Push
			| v == 0x1b = return SP
			| v == 0x1c = return PC
			| v == 0x1d = return O
			| v == 0x1e = do
				w <- get
				return $ DerefNextWord w
			| v == 0x1f = do
				w <- get
				return $ NextWord w
			| otherwise = return $ Literal $ toEnum $ fromIntegral $ v - 0x20

-- Parse maching code into a list of OPCs
decode0x10c :: BS.ByteString -> [OPC]
decode0x10c = runGet go
	where
		go :: Get [OPC]
		go = do
			e <- isEmpty 
			if e then return [] else get >>= \op -> fmap (op:) go
78:17: Warning: Redundant bracket
Found:
case (op .&. 15) of
0 -> error "non basic"
1 -> getBasic op Set
2 -> getBasic op Add
3 -> getBasic op Sub
4 -> getBasic op Mul
5 -> getBasic op Div
6 -> getBasic op Mod
7 -> getBasic op Shl
8 -> getBasic op Shr
9 -> getBasic op And
10 -> getBasic op Bor
11 -> getBasic op Xor
12 -> getBasic op Ife
13 -> getBasic op Ifn
14 -> getBasic op Ifg
15 -> getBasic op Ifb
Why not:
case op .&. 15 of
0 -> error "non basic"
1 -> getBasic op Set
2 -> getBasic op Add
3 -> getBasic op Sub
4 -> getBasic op Mul
5 -> getBasic op Div
6 -> getBasic op Mod
7 -> getBasic op Shl
8 -> getBasic op Shr
9 -> getBasic op And
10 -> getBasic op Bor
11 -> getBasic op Xor
12 -> getBasic op Ife
13 -> getBasic op Ifn
14 -> getBasic op Ifg
15 -> getBasic op Ifb
108:45: Warning: Redundant $
Found:
8 + (fromIntegral $ fromEnum r)
Why not:
8 + fromIntegral (fromEnum r)
110:34: Warning: Redundant $
Found:
16 + (fromIntegral $ fromEnum r)
Why not:
16 + fromIntegral (fromEnum r)
119:39: Warning: Redundant $
Found:
32 + (fromIntegral $ fromEnum l)
Why not:
32 + fromIntegral (fromEnum l)
129:66: Warning: Redundant $
Found:
fromIntegral $ v
Why not:
fromIntegral v