module DT where

import DTFormat
import Expr_eval

import Prelude hiding (and,or)

import Data.Bits hiding (xor)
import qualified Data.Map as Map
import Data.Word
import Text.Printf
import Text.Parsec
import Text.Parsec.String
import Text.Parsec.Combinator
import Control.Monad
import Control.Applicative hiding ((<|>))


-- parsing --
instruction :: Dict -> Parser Word32
instruction dict = foldl1 (<|>) (fmap (\x -> try (x dict)) instructions) <* char '\n'

testins :: String -> IO ()
testins input =
	case (parse (instruction dict) "" (input++"\n")) of
		Left err -> do { putStr "fail :/\n"; print err}
		Right x -> do { printf "0x%08X\n" x }
	where
	dict = (0x8000,[("lolz", 0x1337), ("rofl", 0xaaaa)])


comma = char ','
mnem m = string m

iLit :: Dict -> Parser Word32
iLit (_,d) = do
	val <- expr d;
	try (do {
		string "@hi";
		return $ shiftR val 16
	}) <|> do {
		string "@lo";
		return $ val .&. 0xffff
	} <|> return val


iLit12 d = do i <- iLit d; return $ i .&. 0x0fff
iLit15 d = do i <- iLit d; return $ i .&. 0xefff
iLit16 d = do i <- iLit d; return $ i .&. 0xffff

imm4 :: Parser String
imm4 = do
	try (do a <- digit; b <- digit; return $ [a,b]) <|> (do a <- digit; return $ [a])

read4imm :: String -> Word32
read4imm s = if erg > 15 then error "invalid register" else erg
	where erg = read s

reg :: Parser Word32
reg = do {parseMySpaces; string "r"; ret <- liftM read4imm (imm4); parseMySpaces; return ret}

condition :: Parser Word32
condition = do
	str <- foldl1 (<|>) (fmap (try . string . fst) conds)
	let (Just ret) = lookup str conds
	return $ ret

carry :: Parser Word32
carry = do { char 'c'; return 1} <|> do {string ""; return 0}

updateDisable :: Parser Word32
updateDisable = do { char 'd'; return 1} <|> do {string ""; return 0}

highlow :: Parser Word32
highlow = do { char 'h'; return 1} <|> do {char 'l'; return 0} <|> do {string ""; return 0}

fill :: Parser Word32
fill = do { char 'f'; return 1} <|> do {string ""; return 0}

sign :: Parser Word32
sign = do { char 's'; return 1} <|> do {string ""; return 0}

branchpred :: Parser Word32
branchpred = do
	x <- do { char '+'; return 1} <|> do {char '-'; return 0} <|> do {string ""; return 0}
	parseMySpaces
	return x

shiftArith :: Parser Word32
shiftArith = do { char 'a'; return 1} <|> do {string ""; return 0}

(<.>) p n = p<*comma<*>n
(<%>) p n = p<*space<*>n
(<@>) p n = p<*char '('<*>n<*char ')'
infixl 1 <.>
infixl 1 <%>
infixl 1 <@>

ins m form e  = do {mnem m; form e}
csv0i_p dict f = f<$>condition<*>branchpred<*>(iLit dict)
csv0i_p' f = f<$>condition<*>branchpred
csv2_scd f = f<$>sign<*>carry<*>updateDisable<*>condition<%>reg<.>reg
csv2m dict f = f<$>condition<%>reg<.>(iLit15 dict)<@>reg
csv2i_scd dict f = f<$>sign<*>carry<*>updateDisable<*>condition<%>reg<.>reg<.>(iLit12 dict)
csv2i_sl dict f = f<$>sign<*>highlow<*>condition<%>reg<.>(iLit16 dict)
csv2i_lfd dict f = f<$>highlow<*>fill<*>updateDisable<*>condition<%>reg<.>(iLit16 dict)
csv3_cd f = f<$>carry<*>updateDisable<*>condition<%>reg<.>reg<.>reg
csv3_d f = f<$>updateDisable<*>condition<%>reg<.>reg<.>reg

instructions = [add, addi, mov, sub, subi,
	and, andx,
	--, or, orx, xor, xorx,not]
	-- pop, push, disc, fetch
	-- movpf, movsf, movpt, movst
	-- ldh, ldb
	ldw, ldi,
	-- stw, sth, stb
	-- ldx, stx
	-- call, reti
	br, ret
	-- brr, callr
	-- cmp, cmpi
	]

-- arithmetic
add _ = ins "add" csv3_cd $ aform 0x00
addi dict = ins "addi" (csv2i_scd dict) $ aformi 0x02
mov _ = ins "mov" csv2_scd $ aformi' 0x02
sub _ = ins "sub" csv3_cd $ aform 0x01
subi dict = ins "subi" (csv2i_scd dict) $ aformi 0x03
-- logic
and _ = ins "and" csv3_d $ aform 0x04 0
andx dict = ins "andx" (csv2i_lfd dict) $ lformi 0x05
-- memory
ldw dict = ins "ldw" (csv2m dict) $ mformi 0x0e
ldi dict = ins "ldi" (csv2i_sl dict) $ lformi' 0x1a
-- misc
-- set signed by default! in very rare cases this can be an issue.
br dict = ins "br" (csv0i_p dict) $ bform 0x16 0x0 1 
ret _ = ins "ret" csv0i_p' $ bform' 0x16 0x2
reti _ = ins "reti" csv0i_p' $ bform' 0x16 0x3

-- instruction formats
aform opcd c d cond rd ra rb = pack [(cond,28),(opcd,23),(rd,19),(ra,15),(rb,11),(free,2),(c,1),(d,0)]
	where free = 0

aformi opcd s c d cond rd ra imm = pack [(cond,28),(opcd,23),(rd,19),(ra,15),(imm,3),(s,2),(c,1),(d,0)]
aformi' opcd s c d cond rd ra = aformi opcd s c d cond rd ra 0

lformi opcd hl f d cond rd imm = pack [(cond,28),(opcd,23),(rd,19),(imm,3),(hl,2),(f,1),(d,0)]
lformi' opcd s hl cond rd imm = lformi opcd s hl 0 cond rd imm

mformi opcd cond rd disp ra = pack [(cond,28),(opcd,23),(rd,19),(ra,15),(disp,0)]

bform opcd typ s cond bp imm = pack [(cond,28),(opcd,23),(imm,7),(free,4),(typ,2),(bp,1),(s,0)]
	where free = 0
bform' opcd typ cond bp = bform opcd typ 0 cond bp 0

-- ppc64 stuff (TODO: remove)
iform opcd aa lk li = pack [(opcd,6),(li,30),(aa,31),(lk,0)]
scform opcd lev = pack [(opcd,6),(lev,27),(1,31)]
dform'b opcd bf l ra si = pack [(opcd,6),(bf,9),(0,10),(l,11),(ra,16),(si,0)]
dsform opcd rt ra ds xo = pack [(opcd,6),(rt,11),(ra,16),(ds,30),(xo,0)]
xform'a opcd rt ra rb xo = pack [(opcd,6),(rt,11),(ra,16),(rb,21),(xo,31)]
xform'b opcd xo bf l ra rb = pack [(opcd,6),(bf,9),(0,10),(l,11),(ra,16),(rb,21),(xo,31),(0,0)]
xform'c opcd xo rs ra rb rc = pack [(opcd,6),(rs,11),(ra,16),(rb,21),(xo,31),(rc,0)]
xform'd opcd xo rc rs ra = pack [(opcd,6),(rs,11),(ra,16),(0,21),(xo,31),(rc,0)]
xlform'a opcd xo bt ba bb = pack [(opcd,6),(bt,11),(ba,16),(bb,21),(xo,31)]
xlform'b opcd xo lk bo bi bh = pack [(opcd,6),(bo,11),(bi,16),(bh,21),(xo,31),(lk,0)]
xlform'c opcd xo bf bfa = pack [(opcd,6),(bf,9),(bfa,14),(xo,31)]
xfxform opcd xo rs spr = pack [(opcd,6),(rs,11),(spr,21),(xo,31)]
xfxform'b opcd h xo fxm rs = pack [(opcd,6),(rs,11),(h,12),(fxm,20),(xo,31)]
--xflform
-- fix xsform
xsform opcd xo rc ra rs sh = pack [(opcd,6),(rs,11),(ra,16),(sh,21),(xo,30),(sh,31),(rc,0)]
xoform' opcd xo oe rc rt ra = pack [(opcd,6),(rt,11),(ra,16),(0,21),(oe,22),(xo,31),(rc,0)]
--aform
mform opcd rc ra rs sh mb me = pack [(opcd,6),(rs,11),(ra,16),(sh,21),(mb,26),(me,31),(rc,0)]
-- mdform needs to be fixed to handle sh correctly
mdform opcd h rc ra rs sh mb = pack [(opcd,6),(rs,11),(ra,16),(sh,21),(mb,27),(h,30),(sh,31),(rc,0)]
mdsform opcd h rc ra rs rb mb = pack [(opcd,6),(rs,11),(ra,16),(rb,21),(mb,27),(h,31),(rc,0)]

-- bit-packing --
pack bf = foldr1 (.|.) $ map (uncurry rotateL) bf

-- condition table
conds :: [(String,Word32)]
conds = [
	("nq", 0x0), ("nz", 0x0),
	("eq", 0x1), ("zs", 0x1),
	("no", 0x2),
	("ov", 0x3),
	("nc", 0x4), ("ae", 0x4),
	("cs", 0x5), ("bl", 0x5),
	("ns", 0x6), ("nn", 0x6),
	("ss", 0x7), ("ns", 0x7),
	("ab", 0x8),
	("be", 0x9),
	("ge", 0xa),
	("lt", 0xb),
	("gt", 0xc),
	("le", 0xd),
	("nv", 0xf),
	("", 0xe) -- always
	]