module Language.Lua.Bytecode.Parser
(
parseLuaBytecode
, parseLuaBytecodeFile
, dumpLuaBytecode
, dumpLuaBytecodeFile
, BytecodeMode(..)
, Sizet(..)
, LuacVersion(..)
, luaBytecodeMode53
) where
import Control.Applicative
import Control.Monad (when, guard)
import Control.Exception
import Data.Binary.Get
import Data.Binary.Put
import Data.Binary.IEEE754 (putFloat64le, getFloat64le)
import Data.Bits
import Data.ByteString (ByteString)
import Data.Foldable (traverse_)
import Data.Maybe (fromMaybe)
import qualified Data.Text as Text
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import Data.Vector (Vector)
import qualified Data.Vector as Vector
import Data.Word (Word8, Word32)
import Numeric (showHex)
import System.Environment (lookupEnv)
import System.Exit
import System.IO
import System.IO.Error
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString as B
import Language.Lua.Bytecode
type Puts a = a -> Put
data LuacVersion = Luac52 | Luac53
deriving (Eq, Ord, Show, Read)
data Sizet = Sizet32 | Sizet64
sizetSize :: Sizet -> Int
sizetSize Sizet32 = 4
sizetSize Sizet64 = 8
data BytecodeMode = BytecodeMode
{ bytecodeVersion :: !LuacVersion
, bytecodeSizet :: !Sizet
}
parseLuaBytecode :: Maybe String ->
L.ByteString ->
Either String Chunk
parseLuaBytecode mbName bc =
case runGetOrFail loadChunk bc of
Left (_,_,e) -> Left e
Right (_,_,chunk) -> Right (maybe chunk (setName chunk) mbName)
where
setName (Chunk n f) nm = Chunk n (setSourceName nm f)
dumpLuaBytecode :: BytecodeMode -> Chunk -> L.ByteString
dumpLuaBytecode mode = runPut . saveChunk mode
parseLuaBytecodeFile :: FilePath -> IO (Either String Chunk)
parseLuaBytecodeFile fp = parseLuaBytecode (Just fp) <$> L.readFile fp
dumpLuaBytecodeFile :: FilePath -> Chunk -> IO ()
dumpLuaBytecodeFile fp luafile =
L.writeFile fp (dumpLuaBytecode luaBytecodeMode53 luafile)
luaBytecodeMode53 :: BytecodeMode
luaBytecodeMode53 = BytecodeMode Luac53 Sizet64
setSourceName :: String -> Function -> Function
setSourceName name func = func { funcSource = Just (packUtf8 name) }
unpackUtf8 :: ByteString -> String
unpackUtf8 = Text.unpack . decodeUtf8
packUtf8 :: String -> ByteString
packUtf8 = encodeUtf8 . Text.pack
luaSignature :: ByteString
luaSignature = "\x1bLua"
mkLuaVersion :: Word8 -> Word8 -> Word8
mkLuaVersion major minor
| major < 16, minor < 16 = major * 16 + minor
| otherwise = error "mkLuaVersion: Bad arguments"
luacFormat :: Word8
luacFormat = 0
luacData :: ByteString
luacData = "\x19\x93\r\n\x1a\n"
luacInt :: Int
luacInt = 0x5678
luacNum :: Double
luacNum = 370.5
intSize :: Word8
intSize = 4
instructionSize :: Word8
instructionSize = intSize
luaIntegerSize :: Word8
luaIntegerSize = 8
luaNumberSize :: Word8
luaNumberSize = 8
loadChunk :: Get Chunk
loadChunk =
do mode <- loadHeader
case bytecodeVersion mode of
Luac52 -> do f <- loadFunction mode
return (Chunk (Vector.length (funcUpvalues f)) f)
Luac53 -> do n <- fromIntegral <$> loadByte
f <- loadFunction mode
return (Chunk n f)
saveChunk :: BytecodeMode -> Puts Chunk
saveChunk mode (Chunk n f) =
do saveHeader mode
saveByte (fromIntegral n)
saveFunction mode f
loadSizeT :: BytecodeMode -> Get Int
loadSizeT mode =
case bytecodeSizet mode of
Sizet64 -> fromIntegral <$> getWord64host
Sizet32 -> fromIntegral <$> getWord32host
saveSizeT :: BytecodeMode -> Puts Int
saveSizeT mode =
case bytecodeSizet mode of
Sizet64 -> putWord64host . fromIntegral
Sizet32 -> putWord32host . fromIntegral
loadString :: BytecodeMode -> Get (Maybe ByteString)
loadString mode =
case bytecodeVersion mode of
Luac52 ->
do n <- loadSizeT mode
if n == 0
then pure Nothing
else Just . B.init <$> getByteString n
Luac53 ->
do n <- loadByte
mb <- case n of
0 -> return Nothing
0xff -> Just <$> loadSizeT mode
_ -> return (Just (fromIntegral n))
traverse (\n' -> getByteString (n'1)) mb
loadString' :: String -> BytecodeMode -> Get ByteString
loadString' name mode =
do mb <- loadString mode
case mb of
Nothing -> fail name
Just x -> return x
saveString :: BytecodeMode -> Puts (Maybe ByteString)
saveString _ Nothing = saveByte 0
saveString mode (Just x) =
do let n = B.length x
if n < 0xfe
then saveByte (fromIntegral n+1)
else saveByte 0xff >> saveSizeT mode (n+1)
putByteString x
saveString' :: BytecodeMode -> Puts ByteString
saveString' mode = saveString mode . Just
loadByte :: Get Word8
loadByte = getWord8
saveByte :: Puts Word8
saveByte = putWord8
loadInteger :: Get Int
loadInteger = fromIntegral <$> getWord64host
saveInteger :: Puts Int
saveInteger = putWord64host . fromIntegral
loadInt :: Get Int
loadInt = fromIntegral <$> getWord32host
saveInt :: Puts Int
saveInt = putWord32host . fromIntegral
loadNumber :: Get Double
loadNumber = getFloat64le
saveNumber :: Puts Double
saveNumber = putFloat64le
loadBool :: Get Bool
loadBool = fmap (/= 0) loadByte
saveBool :: Puts Bool
saveBool x = saveByte (if x then 1 else 0)
loadVectorOf :: Get a -> Get (Vector a)
loadVectorOf p =
do n <- loadInt
Vector.replicateM n p
saveVectorOf :: Puts a -> Puts (Vector a)
saveVectorOf put xs =
do saveInt (Vector.length xs)
traverse_ put xs
(<?>) :: Get a -> String -> Get a
m <?> str = m <|> fail str
string :: ByteString -> Get ()
string xs =
do ys <- getByteString (B.length xs)
guard (xs == ys)
word8 :: Word8 -> Get ()
word8 x =
do y <- getWord8
guard (x == y)
loadHeader :: Get BytecodeMode
loadHeader =
do string luaSignature <?> "signature"
version <- getWord8
if version == mkLuaVersion 5 3 then loadHeader53
else if version == mkLuaVersion 5 2 then loadHeader52
else fail "Unknown version"
loadHeader52 :: Get BytecodeMode
loadHeader52 =
do word8 luacFormat <?> "luac format"
word8 1 <?> "endianess"
word8 intSize <?> "int size"
sizet <- getSizetSize
word8 instructionSize <?> "Instruction size"
word8 luaNumberSize <?> "Number size"
word8 0 <?> "Integral Number"
string luacData <?> "corruption check"
return BytecodeMode
{ bytecodeVersion = Luac52
, bytecodeSizet = sizet
}
loadHeader53 :: Get BytecodeMode
loadHeader53 =
do word8 luacFormat <?> "luac format"
string luacData <?> "corruption check"
word8 intSize <?> "int size"
sizet <- getSizetSize
word8 instructionSize <?> "Instruction size"
word8 luaIntegerSize <?> "Integer size"
word8 luaNumberSize <?> "Number size"
luaInteger luacInt <?> "Integer encoding"
luaNumber luacNum <?> "Number encoding"
return BytecodeMode
{ bytecodeVersion = Luac53
, bytecodeSizet = sizet
}
where
luaInteger x =
do y <- loadInteger
guard (x == y)
luaNumber x =
do y <- loadNumber
guard (x == y)
getSizetSize :: Get Sizet
getSizetSize =
do n <- getWord8
case n of
8 -> return Sizet64
4 -> return Sizet32
_ -> fail ("Bad size_t size: " ++ show n)
saveHeader :: BytecodeMode -> Put
saveHeader mode =
case bytecodeVersion mode of
Luac52 -> error "saveHeader not implemented for version 5.2"
Luac53 ->
do putByteString luaSignature
saveByte (mkLuaVersion 5 3)
saveByte luacFormat
putByteString luacData
saveByte intSize
saveByte (fromIntegral (sizetSize (bytecodeSizet mode)))
saveByte instructionSize
saveByte luaIntegerSize
saveByte luaNumberSize
saveInteger luacInt
saveNumber luacNum
loadFunction :: BytecodeMode -> Get Function
loadFunction mode =
case bytecodeVersion mode of
Luac52 ->
do funcLineDefined <- loadInt
funcLastLineDefined <- loadInt
funcNumParams <- fromIntegral <$> loadByte
funcIsVararg <- loadBool
funcMaxStackSize <- fromIntegral <$> loadByte
funcCode <- loadVectorOf (loadInstruction mode)
funcConstants <- loadVectorOf (loadConstant mode)
funcProtos <- loadVectorOf (loadFunction mode)
funcUpvalues <- loadVectorOf loadUpvalue
funcSource <- loadString mode
funcDebug <- loadDebugInfo mode
return Function{..}
Luac53 -> Function
<$> loadString mode
<*> loadInt
<*> loadInt
<*> (fromIntegral <$> loadByte)
<*> loadBool
<*> (fromIntegral <$> loadByte)
<*> loadVectorOf (loadInstruction mode)
<*> loadVectorOf (loadConstant mode)
<*> loadVectorOf loadUpvalue
<*> loadVectorOf (loadFunction mode)
<*> loadDebugInfo mode
saveFunction :: BytecodeMode -> Puts Function
saveFunction mode Function{..} =
do saveString mode funcSource
saveInt funcLineDefined
saveInt funcLastLineDefined
saveByte (fromIntegral funcNumParams)
saveBool funcIsVararg
saveByte (fromIntegral funcMaxStackSize)
saveVectorOf saveInstruction funcCode
saveVectorOf (saveConstant mode) funcConstants
saveVectorOf saveUpvalue funcUpvalues
saveVectorOf (saveFunction mode) funcProtos
saveDebugInfo mode funcDebug
loadDebugInfo :: BytecodeMode -> Get DebugInfo
loadDebugInfo mode = DebugInfo
<$> loadVectorOf loadInt
<*> loadVectorOf (loadVarInfo mode)
<*> loadVectorOf (fromMaybe "UNKNOWN" <$> loadString mode)
saveDebugInfo :: BytecodeMode -> Puts DebugInfo
saveDebugInfo mode DebugInfo{..} =
do saveVectorOf saveInt debugInfoLines
saveVectorOf (saveVarInfo mode) debugInfoVars
saveVectorOf (saveString' mode) debugInfoUpvalues
loadConstant :: BytecodeMode -> Get Constant
loadConstant mode =
do tag <- loadByte
case tag of
0 -> return KNil
1 -> KBool <$> loadBool
3 -> KNum <$> loadNumber
4 -> KString <$> loadString' "short constant" mode
19 -> KInt <$> loadInteger
20 -> KLongString <$> loadString' "long constant" mode
_ -> fail ("unknown constant type: " ++ show tag)
saveConstant :: BytecodeMode -> Puts Constant
saveConstant mode x =
case x of
KNil -> saveByte 0
KBool b -> saveByte 1 >> saveBool b
KNum n -> saveByte 3 >> saveNumber n
KString s -> saveByte 4 >> saveString' mode s
KInt i -> saveByte 19 >> saveInteger i
KLongString s -> saveByte 20 >> saveString' mode s
loadUpvalue :: Get Upvalue
loadUpvalue =
do instack <- loadBool
idx <- fromIntegral <$> loadByte
return (if instack then UpReg (Reg idx) else UpUp (UpIx idx))
saveUpvalue :: Puts Upvalue
saveUpvalue x =
case x of
UpReg (Reg idx) -> saveBool True >> saveByte (fromIntegral idx)
UpUp (UpIx idx) -> saveBool False >> saveByte (fromIntegral idx)
loadVarInfo :: BytecodeMode -> Get VarInfo
loadVarInfo mode = VarInfo
<$> loadString' "local variable" mode
<*> loadInt
<*> loadInt
saveVarInfo :: BytecodeMode -> Puts VarInfo
saveVarInfo mode VarInfo{..} =
do saveString' mode varInfoName
saveInt varInfoStart
saveInt varInfoEnd
loadInstruction :: BytecodeMode -> Get OpCode
loadInstruction mode =
case bytecodeVersion mode of
Luac52 -> loadInstruction52
Luac53 -> loadInstruction53
loadInstruction52 :: Get OpCode
loadInstruction52 =
do raw <- getWord32host
let op = extractPart size_OP pos_OP raw
a = extractPart size_A pos_A raw
ax = extractPart size_Ax pos_Ax raw
b = extractPart size_B pos_B raw
bx = extractPart size_Bx pos_Bx raw
c = extractPart size_B pos_C raw
rk x | testBit x (size_B1) = RK_Kst (Kst (clearBit x (size_B1)))
| otherwise = RK_Reg (Reg x)
sBx = bx ((1 `shiftL` (size_Bx1)) 1)
case op of
0 -> return $! OP_MOVE (Reg a) (Reg b)
1 -> return $! OP_LOADK (Reg a) (Kst bx)
2 -> return $! OP_LOADKX (Reg a)
3 -> return $! OP_LOADBOOL (Reg a) (b /= 0) (c /= 0)
4 -> return $! OP_LOADNIL (Reg a) b
5 -> return $! OP_GETUPVAL (Reg a) (UpIx b)
6 -> return $! OP_GETTABUP (Reg a) (UpIx b) (rk c)
7 -> return $! OP_GETTABLE (Reg a) (Reg b) (rk c)
8 -> return $! OP_SETTABUP (UpIx a) (rk b) (rk c)
9 -> return $! OP_SETUPVAL (Reg a) (UpIx b)
10 -> return $! OP_SETTABLE (Reg a) (rk b) (rk c)
11 -> return $! OP_NEWTABLE (Reg a) (fb2int b) (fb2int c)
12 -> return $! OP_SELF (Reg a) (Reg b) (rk c)
13 -> return $! OP_ADD (Reg a) (rk b) (rk c)
14 -> return $! OP_SUB (Reg a) (rk b) (rk c)
15 -> return $! OP_MUL (Reg a) (rk b) (rk c)
16 -> return $! OP_DIV (Reg a) (rk b) (rk c)
17 -> return $! OP_MOD (Reg a) (rk b) (rk c)
18 -> return $! OP_POW (Reg a) (rk b) (rk c)
19 -> return $! OP_UNM (Reg a) (Reg b)
20 -> return $! OP_NOT (Reg a) (Reg b)
21 -> return $! OP_LEN (Reg a) (Reg b)
22 -> return $! OP_CONCAT (Reg a) (Reg b) (Reg c)
23 -> let r | a == 0 = Nothing
| otherwise = Just (Reg (a1))
in return $! OP_JMP r sBx
24 -> return $! OP_EQ (a /= 0) (rk b) (rk c)
25 -> return $! OP_LT (a /= 0) (rk b) (rk c)
26 -> return $! OP_LE (a /= 0) (rk b) (rk c)
27 -> return $! OP_TEST (Reg a) (c /= 0)
28 -> return $! OP_TESTSET (Reg a) (Reg b) (c /= 0)
29 -> return $! OP_CALL (Reg a) (mkCount b) (mkCount c)
30 -> return $! OP_TAILCALL (Reg a) (mkCount b) (mkCount c)
31 -> return $! OP_RETURN (Reg a) (mkCount b)
32 -> return $! OP_FORLOOP (Reg a) sBx
33 -> return $! OP_FORPREP (Reg a) sBx
34 -> return $! OP_TFORCALL (Reg a) c
35 -> return $! OP_TFORLOOP (Reg a) sBx
36 -> return $! OP_SETLIST (Reg a) b c
37 -> return $! OP_CLOSURE (Reg a) (ProtoIx bx)
38 -> return $! OP_VARARG (Reg a) (mkCount b)
39 -> return $! OP_EXTRAARG ax
_ -> fail $ "Bad instruction: 0x" ++ showHex raw ""
loadInstruction53 :: Get OpCode
loadInstruction53 =
do raw <- getWord32host
let op = extractPart size_OP pos_OP raw
a = extractPart size_A pos_A raw
ax = extractPart size_Ax pos_Ax raw
b = extractPart size_B pos_B raw
bx = extractPart size_Bx pos_Bx raw
c = extractPart size_B pos_C raw
rk x | testBit x (size_B1) = RK_Kst (Kst (clearBit x (size_B1)))
| otherwise = RK_Reg (Reg x)
sBx = bx ((1 `shiftL` (size_Bx1)) 1)
case op of
0 -> return $! OP_MOVE (Reg a) (Reg b)
1 -> return $! OP_LOADK (Reg a) (Kst bx)
2 -> return $! OP_LOADKX (Reg a)
3 -> return $! OP_LOADBOOL (Reg a) (b /= 0) (c /= 0)
4 -> return $! OP_LOADNIL (Reg a) b
5 -> return $! OP_GETUPVAL (Reg a) (UpIx b)
6 -> return $! OP_GETTABUP (Reg a) (UpIx b) (rk c)
7 -> return $! OP_GETTABLE (Reg a) (Reg b) (rk c)
8 -> return $! OP_SETTABUP (UpIx a) (rk b) (rk c)
9 -> return $! OP_SETUPVAL (Reg a) (UpIx b)
10 -> return $! OP_SETTABLE (Reg a) (rk b) (rk c)
11 -> return $! OP_NEWTABLE (Reg a) (fb2int b) (fb2int c)
12 -> return $! OP_SELF (Reg a) (Reg b) (rk c)
13 -> return $! OP_ADD (Reg a) (rk b) (rk c)
14 -> return $! OP_SUB (Reg a) (rk b) (rk c)
15 -> return $! OP_MUL (Reg a) (rk b) (rk c)
16 -> return $! OP_MOD (Reg a) (rk b) (rk c)
17 -> return $! OP_POW (Reg a) (rk b) (rk c)
18 -> return $! OP_DIV (Reg a) (rk b) (rk c)
19 -> return $! OP_IDIV (Reg a) (rk b) (rk c)
20 -> return $! OP_BAND (Reg a) (rk b) (rk c)
21 -> return $! OP_BOR (Reg a) (rk b) (rk c)
22 -> return $! OP_BXOR (Reg a) (rk b) (rk c)
23 -> return $! OP_SHL (Reg a) (rk b) (rk c)
24 -> return $! OP_SHR (Reg a) (rk b) (rk c)
25 -> return $! OP_UNM (Reg a) (Reg b)
26 -> return $! OP_BNOT (Reg a) (Reg b)
27 -> return $! OP_NOT (Reg a) (Reg b)
28 -> return $! OP_LEN (Reg a) (Reg b)
29 -> return $! OP_CONCAT (Reg a) (Reg b) (Reg c)
30 -> let r | a == 0 = Nothing
| otherwise = Just (Reg (a1))
in return $! OP_JMP r sBx
31 -> return $! OP_EQ (a /= 0) (rk b) (rk c)
32 -> return $! OP_LT (a /= 0) (rk b) (rk c)
33 -> return $! OP_LE (a /= 0) (rk b) (rk c)
34 -> return $! OP_TEST (Reg a) (c /= 0)
35 -> return $! OP_TESTSET (Reg a) (Reg b) (c /= 0)
36 -> return $! OP_CALL (Reg a) (mkCount b) (mkCount c)
37 -> return $! OP_TAILCALL (Reg a) (mkCount b) (mkCount c)
38 -> return $! OP_RETURN (Reg a) (mkCount b)
39 -> return $! OP_FORLOOP (Reg a) sBx
40 -> return $! OP_FORPREP (Reg a) sBx
41 -> return $! OP_TFORCALL (Reg a) c
42 -> return $! OP_TFORLOOP (Reg a) sBx
43 -> return $! OP_SETLIST (Reg a) b c
44 -> return $! OP_CLOSURE (Reg a) (ProtoIx bx)
45 -> return $! OP_VARARG (Reg a) (mkCount b)
46 -> return $! OP_EXTRAARG ax
_ -> fail $ "Bad instruction: 0x" ++ showHex raw ""
mkCount :: Int -> Count
mkCount 0 = CountTop
mkCount x = CountInt (x1)
saveInstruction :: Puts OpCode
saveInstruction x = putWord32host $ sum $
case x of
OP_MOVE a b -> [asOp 0, asA a, asB b]
OP_LOADK a bx -> [asOp 1, asA a, asBX bx]
OP_LOADKX a -> [asOp 2, asA a]
OP_LOADBOOL a b c -> [asOp 3, asA a, asB b, asC c]
OP_LOADNIL a b -> [asOp 4, asA a, asB b]
OP_GETUPVAL a b -> [asOp 5, asA a, asB b]
OP_GETTABUP a b c -> [asOp 6, asA a, asB b, asC c]
OP_GETTABLE a b c -> [asOp 7, asA a, asB b, asC c]
OP_SETTABUP a b c -> [asOp 8, asA a, asB b, asC c]
OP_SETUPVAL a b -> [asOp 9, asA a, asB b]
OP_SETTABLE a b c -> [asOp 10, asA a, asB b, asC c]
OP_NEWTABLE a b c -> [asOp 11, asA a, asB (int2fb b), asC (int2fb c)]
OP_SELF a b c -> [asOp 12, asA a, asB b, asC c]
OP_ADD a b c -> [asOp 13, asA a, asB b, asC c]
OP_SUB a b c -> [asOp 14, asA a, asB b, asC c]
OP_MUL a b c -> [asOp 15, asA a, asB b, asC c]
OP_MOD a b c -> [asOp 16, asA a, asB b, asC c]
OP_POW a b c -> [asOp 17, asA a, asB b, asC c]
OP_DIV a b c -> [asOp 18, asA a, asB b, asC c]
OP_IDIV a b c -> [asOp 19, asA a, asB b, asC c]
OP_BAND a b c -> [asOp 20, asA a, asB b, asC c]
OP_BOR a b c -> [asOp 21, asA a, asB b, asC c]
OP_BXOR a b c -> [asOp 22, asA a, asB b, asC c]
OP_SHL a b c -> [asOp 23, asA a, asB b, asC c]
OP_SHR a b c -> [asOp 24, asA a, asB b, asC c]
OP_UNM a b -> [asOp 25, asA a, asB b]
OP_BNOT a b -> [asOp 26, asA a, asB b]
OP_NOT a b -> [asOp 27, asA a, asB b]
OP_LEN a b -> [asOp 28, asA a, asB b]
OP_CONCAT a b c -> [asOp 29, asA a, asB b, asC c]
OP_JMP Nothing sbx -> [asOp 30, asSBX sbx]
OP_JMP (Just (Reg a)) sbx -> [asOp 30, asA (a+1), asSBX sbx]
OP_EQ a b c -> [asOp 31, asA a, asB b, asC c]
OP_LT a b c -> [asOp 32, asA a, asB b, asC c]
OP_LE a b c -> [asOp 33, asA a, asB b, asC c]
OP_TEST a c -> [asOp 34, asA a, asC c]
OP_TESTSET a b c -> [asOp 35, asA a, asB b, asC c]
OP_CALL a b c -> [asOp 36, asA a, asB b, asC c]
OP_TAILCALL a b c -> [asOp 37, asA a, asB b, asC c]
OP_RETURN a b -> [asOp 38, asA a, asB b]
OP_FORLOOP a sbx -> [asOp 39, asA a, asSBX sbx]
OP_FORPREP a sbx -> [asOp 40, asA a, asSBX sbx]
OP_TFORCALL a c -> [asOp 41, asA a, asC c]
OP_TFORLOOP a sbx -> [asOp 42, asA a, asSBX sbx]
OP_SETLIST a b c -> [asOp 43, asA a, asB b, asC c]
OP_CLOSURE a bx -> [asOp 44, asA a, asBX bx]
OP_VARARG a b -> [asOp 45, asA a, asB b]
OP_EXTRAARG ax -> [asOp 46, asAX ax]
class OpArg a where opArg :: a -> Word32
instance OpArg Reg where opArg (Reg x) = fromIntegral x
instance OpArg UpIx where opArg (UpIx x) = fromIntegral x
instance OpArg Kst where opArg (Kst x) = fromIntegral x
instance OpArg ProtoIx where opArg (ProtoIx x) = fromIntegral x
instance OpArg Int where opArg = fromIntegral
instance OpArg Word32 where opArg = id
instance OpArg Bool where opArg True = 1
opArg False = 0
instance OpArg RK where opArg (RK_Reg r) = opArg r
opArg (RK_Kst k) = setBit (opArg k) (size_B1)
instance OpArg Count where opArg CountTop = 0
opArg (CountInt x) = fromIntegral x + 1
asOp :: Word32 -> Word32
asOp = createPart size_OP pos_OP
asA :: OpArg a => a -> Word32
asA = createPart size_A pos_A . opArg
asB :: OpArg a => a -> Word32
asB = createPart size_B pos_B . opArg
asC :: OpArg a => a -> Word32
asC = createPart size_C pos_C . opArg
asSBX :: Int -> Word32
asSBX = createPart size_Bx pos_Bx . fromIntegral . correct
where
correct x = x + ((1 `shiftL` (size_Bx1)) 1)
asBX :: OpArg a => a -> Word32
asBX = createPart size_Bx pos_Bx . opArg
asAX :: OpArg a => a -> Word32
asAX = createPart size_Ax pos_Ax . opArg
extractPart :: Int -> Int -> Word32 -> Int
extractPart size pos x = fromIntegral ((x `shiftL` (32sizepos)) `shiftR` (32size))
createPart :: Int -> Int -> Word32 -> Word32
createPart size pos x = (mask .&. x) `shiftL` pos
where
mask = 1 `shiftL` size 1
fb2int :: Int -> Int
fb2int x
| x < 8 = x
| otherwise = (8 + (x .&. 7)) * 2^(shiftR x 3 1)
int2fb :: Int -> Word32
int2fb x0
| x0 < 0 = error "int2fb: negative argument"
| x0 < 8 = fromIntegral x0
| otherwise = coarse 0 (fromIntegral x0)
where
coarse e x
| x >= 8 `shiftL` 4 = coarse (e+4) ((x + 0xf) `shiftR` 4)
| otherwise = fine e x
fine e x
| x >= 8 `shiftL` 1 = fine (e+1) ((x + 1) `shiftR` 1)
| otherwise = finish e x
finish e x = (e+1) `shiftL` 3 .|. (x 8)
size_A, size_Ax, size_B, size_Bx, size_C, size_OP :: Int
pos_A, pos_Ax, pos_B, pos_Bx, pos_C, pos_OP :: Int
pos_A = (pos_OP + size_OP)
pos_Ax = pos_A
pos_B = (pos_C + size_C)
pos_Bx = pos_C
pos_C = (pos_A + size_A)
pos_OP = 0
size_A = 8
size_Ax = (size_C + size_B + size_A)
size_B = 9
size_C = 9
size_Bx = (size_C + size_B)
size_OP = 6