neko-lib (empty) → 0.0.1.0
raw patch · 8 files changed
+749/−0 lines, 8 filesdep +basedep +binarydep +bytestringsetup-changed
Dependencies added: base, binary, bytestring, containers, directory, optparse-applicative, process, random, tagged, tasty, tasty-hunit, tasty-smallcheck, temporary
Files
- LICENSE +26/−0
- Setup.hs +2/−0
- neko-lib.cabal +35/−0
- src/lib/Binary/Neko/Globals.hs +86/−0
- src/lib/Binary/Neko/Hashtbl.hs +61/−0
- src/lib/Binary/Neko/Instructions.hs +342/−0
- src/lib/Binary/Neko/Module.hs +111/−0
- src/test/Main.hs +86/−0
+ LICENSE view
@@ -0,0 +1,26 @@+Copyright (c) 2015, Petr Penzin++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ neko-lib.cabal view
@@ -0,0 +1,35 @@+name: neko-lib++version: 0.0.1.0++synopsis: Neko VM code generation and disassembly library+description: Neko Virtual Machine (http://nekovm.org) is a light-weight and portable byte code interpreter; neko-lib is a library for reading and writing NekoVM bytecode implemented entirely in Haskell.+homepage: http://github.com/ppenzin/neko-lib-hs/+license: BSD2+license-file: LICENSE+author: Petr Penzin+maintainer: penzin-dev@gmail.com+category: Build+build-type: Simple+cabal-version: >=1.8+data-files: ++source-repository head+ type: git+ location: https://github.com/ppenzin/neko-lib-hs.git++source-repository this+ type: git+ location: https://github.com/ppenzin/neko-lib-hs.git+ tag: 0.0.1.0++Library+ hs-source-dirs: src/lib+ exposed-modules: Binary.Neko.Module, Binary.Neko.Globals, Binary.Neko.Instructions, Binary.Neko.Hashtbl+ build-depends: base>=4 && <5, bytestring, binary>=0.9.0.0, containers>=0.5.0.0, optparse-applicative, tagged++Test-suite test-lib+ type: exitcode-stdio-1.0+ hs-source-dirs: src/test, src/lib+ main-is: Main.hs+ build-depends: base>=4.7.0.0, bytestring, binary>=0.6.4.0, containers>=0.5.0.0, optparse-applicative, tagged, process, random, directory, tasty==0.10.1.2, tasty-smallcheck==0.8.0.1, tasty-hunit==0.9.2, temporary==1.2.0.3
+ src/lib/Binary/Neko/Globals.hs view
@@ -0,0 +1,86 @@+{-|+Module : Binary.Neko.Globals+Description : Global values for a Binary.Neko module+Copyright : (c) Petr Penzin, 2015+License : BSD2+Maintainer : penzin.dev@gmail.com+Stability : experimental+Portability : cross-platform++Emit and parse global values for a Binary.Neko module.++-}+module Binary.Neko.Globals where++import Data.ByteString.Lazy as BS+import Data.ByteString.Lazy.Char8 as BSChar+import Data.Binary.Get+import Data.Binary.Put+import Data.Either+import Data.Maybe+import Data.Word+import Data.Int++-- | Global value type+data Global =+ GlobalVar String -- ^ Global variable (name)+ | GlobalFunction (Int, Int) -- ^ Function+ | GlobalString String -- ^ String literal+ | GlobalFloat String -- ^ Floating point constant+ | GlobalDebug ([String], [(Int, Int)]) -- ^ Debug information+ | GlobalVersion Int -- ^ Version record+ deriving (Show, Eq)++-- | Read globals from a bytestring+readGlobals :: Word32 -- ^ Number of global values to read+ -> ByteString -- ^ Bytestring to read from+ -> Maybe ([Global], ByteString) -- ^ On success: list of global values read and unconsumed bytestring+readGlobals n bs = if (isRight res) then (Just (gs, rest)) else Nothing + where res = runGetOrFail (getGlobals n) bs+ Right (rest, _, gs) = res++-- | Read a single global value, if succesfull return a single global value and remaining bytestring+readGlobal :: ByteString -- ^ Bytes to read from+ -> Maybe (Global, ByteString) -- ^ Read value and the rest of bytes (if successfull)+readGlobal bs = if (isRight res) then (Just (g, rest)) else Nothing + where res = runGetOrFail getGlobal bs+ Right (rest, _, g) = res++-- | Get a list of globals from a bytestring+getGlobals :: Word32 -- ^ number of globals+ -> Get [Global] -- ^ decode a list+getGlobals 0 = return []+getGlobals n = getGlobal >>= \g -> getGlobals (n - 1) >>= \gs -> return (g:gs)++-- | Read a global from a bytestring+getGlobal :: Get Global+getGlobal = getWord8+ >>= \b -> if (b == 1) then getGlobalVar else+ if (b == 2) then error "TODO getGlobal: implement GlobalFunction" else+ if (b == 3) then getGlobalString else+ if (b == 4) then error "TODO getGlobal: implement GlobalFloat" else+ if (b == 5) then error "TODO getGlobal: implement GlobalDebug" else+ if (b == 6) then error "TODO getGlobal: implement GlobalVersion" else+ fail "getGlobal: urecognized global"++-- | Decode a global variable+getGlobalVar :: Get Global+getGlobalVar = getLazyByteStringNul >>= \b -> return ( GlobalVar $ BSChar.unpack b)++-- | Decode a global string+getGlobalString :: Get Global+getGlobalString = getWord16le+ >>= \length -> getLazyByteString (fromIntegral length)+ >>= \s -> return (GlobalString $ BSChar.unpack s)++-- | Write a global to a bytestring+putGlobal :: Global -> Put+putGlobal (GlobalVar s) = putWord8 1 >> putLazyByteString (BSChar.pack s) >> putWord8 0+putGlobal (GlobalString s) = putWord8 3+ >> putWord16le (fromIntegral $ Prelude.length s) >> putLazyByteString (BSChar.pack s)+putGlobal g = error ("Unimplemented: " ++ (show g)) -- Remove after all implemented++-- | Write a list of globals to a bytestring+putGlobals :: [Global] -> Put+putGlobals [] = return ()+putGlobals (g:gs) = putGlobal g >> putGlobals gs
+ src/lib/Binary/Neko/Hashtbl.hs view
@@ -0,0 +1,61 @@+{-|+Module : Binary.Neko.Hashtbl+Description : Minimal hashtable support+Copyright : (c) Petr Penzin, 2015+License : BSD2+Maintainer : penzin.dev@gmail.com+Stability : experimental+Portability : cross-platform++A minimal support for Binary.Neko hashtable type needed for working with tables of fields++-}+module Binary.Neko.Hashtbl where++import qualified Data.Map.Strict as M+import Data.ByteString.Char8 as BC+import Data.ByteString as B+import Data.Word++-- | A minimal hashtable type. Binary.Neko supports hashing of all types,+-- but we will focus on strings, since those are necessary for assembly and disassembly+type Hashtbl = M.Map Word32 String++-- | Binary.Neko 'hash_field' function+hash :: String -> Word32+hash s = hash' bs+ where bs = B.reverse $ BC.pack s+ hash' b | B.null b = 0+ hash' b | otherwise = (hash' $ B.tail b) * 223 + (fromIntegral $ B.head b)++-- | Create an empty Hashtbl, wrapper for corresponding Map function+empty :: Hashtbl+empty = M.empty++-- | Check whether there is a member for a given key, wrapper for corresponding Map function+member :: Word32 -> Hashtbl -> Bool+member = M.member++-- | Check whether there is a member for a given value+memberString :: String -> Hashtbl -> Bool+memberString s h = M.member (hash s) h++-- | Insert a string to Hashtbl+insertString :: String -> Hashtbl -> Hashtbl+insertString s h = M.insert (hash s) s h++-- | Lookup a value by its key, wrapper for corresponding Map function+lookup :: Word32 -> Hashtbl -> Maybe String+lookup = M.lookup++-- | Convert entire Hashtbl ot a list of key-value pairs, wrapper for corresponding Map function+toList :: Hashtbl -> [(Word32, String)]+toList = M.toList++-- | Convert a list of strings into a Hashtbl, generating hash values for them+fromStringList :: [String] -> Hashtbl+fromStringList ss = M.fromList $ Prelude.map (\s -> (hash s, s)) ss++-- | Get a list of elements (values) in the Hashtbl, wrapper for corresponding Map function+elems :: Hashtbl -> [String]+elems = M.elems
+ src/lib/Binary/Neko/Instructions.hs view
@@ -0,0 +1,342 @@+{-|+Module : Binary.Neko.Instructions+Description : Emit and parse Binary.Neko instructions+Copyright : (c) Petr Penzin, 2015+License : BSD2+Maintainer : penzin.dev@gmail.com+Stability : experimental+Portability : cross-platform++Types and primitives to deal with Binary.Neko instructions++-}+module Binary.Neko.Instructions where++import Data.Int+import Data.Bits+import Data.Word+import Data.Maybe+import Data.Either+import Data.Binary.Get+import Data.Binary.Put+import Data.ByteString.Lazy as BS+import Numeric (showHex)++import Binary.Neko.Hashtbl as H++-- | Various NekoVM instructions+data Instruction = + -- getters+ AccNull+ | AccTrue+ | AccFalse+ | AccThis+ | AccInt Int+ | AccStack Int+ | AccGlobal Int+ | AccEnv Int+ | AccField String+ | AccArray+ | AccIndex Int+ | AccBuiltin String+ -- setters+ | SetStack Int+ | SetGlobal Int+ | SetEnv Int+ | SetField String+ | SetArray+ | SetIndex Int+ | SetThis+ -- stack ops+ | Push+ | Pop Int+ | Call Int+ | ObjCall Int+ | Jump Int+ | JumpIf Int+ | JumpIfNot Int+ | Trap Int+ | EndTrap+ | Ret Int+ | MakeEnv Int+ | MakeArray Int+ -- value ops+ | Bool+ | IsNull+ | IsNotNull+ | Add+ | Sub+ | Mult+ | Div+ | Mod+ | Shl+ | Shr+ | UShr+ | Or+ | And+ | Xor+ | Eq+ | Neq+ | Gt+ | Gte+ | Lt+ | Lte+ | Not+ -- extra ops+ | TypeOf+ | Compare+ | Hash+ | New+ | JumpTable Int+ | Apply Int+ | AccStack0+ | AccStack1+ | AccIndex0+ | AccIndex1+ | PhysCompare+ | TailCall (Int, Int)+ | Loop+ deriving (Show, Eq)++-- | Read instructions+-- Consume bytestring, produce instructions and status message+readInstructions :: Word32 -- ^ code size+ -> Hashtbl -- ^ context (names of fields)+ -> ByteString -- ^ bytes to read from+ -> (ByteString, String, Maybe [Instruction]) -- ^ unconsumed input, status message and list of instructions+readInstructions n ids bs = if (isRight res) then (rest, "Success", Just (is)) else (rest', err, Nothing)+ where res = runGetOrFail (getInstructions n ids) bs+ Right (rest, _, is) = res+ Left (rest', _, err) = res++-- | Read a single bytecode instruction+readInstruction :: Hashtbl -- ^ Names of fieds for the module+ -> ByteString -- ^ Input+ -> (Maybe Instruction, ByteString) -- ^ Result or nothing, unconsumed input+readInstruction ids bs = if (isRight res) then (Just (i), rest) else (Nothing, rest')+ where res = runGetOrFail (getInstruction ids) bs+ Right (rest, _, i) = res+ Left (rest', _, _) = res++-- | Grab instructions from a bytestring+-- Decode bytestring, consuming one byte per instruction with no paramenters+-- and two for instructions with parameters+getInstructions :: Word32 -- ^ code size - number of instructions+arguments left to parse+ -> Hashtbl -- ^ Builtins hashtable to provide context+ -> Get [Instruction] -- ^ decoder+getInstructions 0 _ = return []+getInstructions n ids = if (n < 0) then fail "Stepped over code size" else getInstruction ids+ >>= \i -> getInstructions (n - (if (hasParam i) then 2 else 1)) ids+ >>= \is -> return (i:is)++-- | Grab a single instruction from a bytestring+-- Some instruction acces filds by using hashes of the names, therefore+-- require a hash table with field names.+getInstruction :: Hashtbl -- ^ Builtins hashtable for getting names+ -> Get Instruction -- ^ Instruction parser+getInstruction ids+ = getWord8+ >>= \b -> return (b .&. 3)+ >>= \code -> if (code == 0) then getOp (b `shiftR` 2) Nothing ids+ else if (code == 1) then getOp (b `shiftR` 3) (Just $ fromIntegral $ b `shiftR` 2 .&. 1) ids+ else if (code == 2) then+ getWord8 >>= \w -> if (b == 2) then (getOp (fromIntegral w) Nothing ids)+ else (getOp (b `shiftR` 2) (Just (fromIntegral w)) ids)+ else if (code == 3) then+ getInt32le >>= \i -> getOp (b `shiftR` 2) (Just i) ids+ else fail "Get instruction: unrecognized opcode group"++-- | Second level of instruction read logic+getOp :: Word8 -- ^ Operation number+ -> Maybe Int32 -- ^ Additional argument+ -> Hashtbl -- ^ Some instructions require access to builtins hashtable+ -> Get Instruction -- ^ Instruction parser+getOp opnum arg ids+ = if (opnum == 0) then return (AccNull)+ else if (opnum == 1) then return (AccTrue)+ else if (opnum == 2) then return (AccFalse)+ else if (opnum == 3) then return (AccThis)+ else if (opnum == 4) then return (AccInt $ fromIntegral $ fromJust arg)+ else if (opnum == 5) then return (AccStack $ (fromIntegral $ fromJust arg) + 2)+ else if (opnum == 6) then return (AccGlobal $ fromIntegral $ fromJust arg)+ else if (opnum == 7) then return (AccEnv $ fromIntegral $ fromJust arg)+ else if (opnum == 8) then+ if (member (fromIntegral $ fromJust arg) ids)+ then return (AccField (fromJust $ H.lookup (fromIntegral $ fromJust arg) ids))+ else fail ("Field not found for AccField (" ++ (showHex (fromIntegral $ fromJust arg :: Word32) "") ++ ")")+ else if (opnum == 9) then return (AccArray)+ else if (opnum == 10) then return (AccIndex $ (fromIntegral $ fromJust arg) + 2)+ else if (opnum == 11) then+ if (member (fromIntegral $ fromJust arg) ids)+ then return (AccBuiltin (fromJust $ H.lookup (fromIntegral $ fromJust arg) ids))+ else fail ("Field not found for AccBuiltin (" ++ (showHex (fromIntegral $ fromJust arg :: Word32) "") ++ ")")+ else if (opnum == 12) then return (SetStack $ fromIntegral $ fromJust arg)+ else if (opnum == 13) then return (SetGlobal $ fromIntegral $ fromJust arg)+ else if (opnum == 14) then return (SetEnv $ fromIntegral $ fromJust arg)+ else if (opnum == 15) then+ if (member (fromIntegral $ fromJust arg) ids)+ then return (SetField (fromJust $ H.lookup (fromIntegral $ fromJust arg) ids))+ else fail ("Field not found for SetField (" ++ (showHex (fromIntegral $ fromJust arg :: Word32) "") ++ ")")+ else if (opnum == 16) then return (SetArray)+ else if (opnum == 17) then return (SetIndex $ fromIntegral $ fromJust arg)+ else if (opnum == 18) then return (SetThis)+ else if (opnum == 19) then return (Push)+ else if (opnum == 20) then return (Pop $ fromIntegral $ fromJust arg)+ else if (opnum == 21) then return (Call $ fromIntegral $ fromJust arg)+ else if (opnum == 22) then return (ObjCall $ fromIntegral $ fromJust arg)+ else if (opnum == 23) then return (Jump $ fromIntegral $ fromJust arg)+ else if (opnum == 24) then return (JumpIf $ fromIntegral $ fromJust arg)+ else if (opnum == 25) then return (JumpIfNot $ fromIntegral $ fromJust arg)+ else if (opnum == 26) then return (Trap $ fromIntegral $ fromJust arg)+ else if (opnum == 27) then return (EndTrap)+ else if (opnum == 28) then return (Ret $ fromIntegral $ fromJust arg)+ else if (opnum == 29) then return (MakeEnv $ fromIntegral $ fromJust arg)+ else if (opnum == 30) then return (MakeArray $ fromIntegral $ fromJust arg)+ else if (opnum == 31) then return (Bool)+ else if (opnum == 32) then return (IsNull)+ else if (opnum == 33) then return (IsNotNull)+ else if (opnum == 34) then return (Add)+ else if (opnum == 35) then return (Sub)+ else if (opnum == 36) then return (Mult)+ else if (opnum == 37) then return (Div)+ else if (opnum == 38) then return (Mod)+ else if (opnum == 39) then return (Shl)+ else if (opnum == 40) then return (Shr)+ else if (opnum == 41) then return (UShr)+ else if (opnum == 42) then return (Or)+ else if (opnum == 43) then return (And)+ else if (opnum == 44) then return (Xor)+ else if (opnum == 45) then return (Eq)+ else if (opnum == 46) then return (Neq)+ else if (opnum == 47) then return (Gt)+ else if (opnum == 48) then return (Gte)+ else if (opnum == 49) then return (Lt)+ else if (opnum == 50) then return (Lte)+ else if (opnum == 51) then return (Not)+ else if (opnum == 52) then return (TypeOf)+ else if (opnum == 53) then return (Compare)+ else if (opnum == 54) then return (Hash)+ else if (opnum == 55) then return (New)+ else if (opnum == 56) then return (JumpTable $ fromIntegral $ fromJust arg)+ else if (opnum == 57) then return (Apply $ fromIntegral $ fromJust arg)+ else if (opnum == 58) then return (AccStack0)+ else if (opnum == 59) then return (AccStack1)+ else if (opnum == 60) then return (AccIndex0)+ else if (opnum == 61) then return (AccIndex1)+ else if (opnum == 62) then return (PhysCompare)+ else if (opnum == 63) then return (TailCall ((fromIntegral $ fromJust arg) .&. 7, (fromIntegral $ fromJust arg) `shiftR` 3))+ else if (opnum == 64) then return (Loop)+ else fail "Get instruction: unrecognized opcode"++-- | Get integer opcode+opcode :: Instruction -- ^ Instruction to process+ -> (Word8, Maybe Word32) -- ^ Opcode and additional argument+opcode (AccNull) = (0, Nothing)+opcode (AccTrue) = (1, Nothing)+opcode (AccFalse) = (2, Nothing)+opcode (AccThis) = (3, Nothing)+opcode (AccInt n) = (4, Just $ fromIntegral n)+opcode (AccStack n) = (5, Just $ (fromIntegral n) - 2) -- TODO Do we need to check for n<2 ?+opcode (AccGlobal n) = (6, Just $ fromIntegral n)+opcode (AccEnv n) = (7, Just $ fromIntegral n)+opcode (AccField s) = (8, Just $ hash s)+opcode (AccArray) = (9, Nothing)+opcode (AccIndex n) = (10, Just $ (fromIntegral n) - 2) -- TODO Do we need to check for n<2 ?+opcode (AccBuiltin s) = (11, Just $ hash s)+opcode (SetStack n) = (12, Just $ fromIntegral n)+opcode (SetGlobal n) = (13, Just $ fromIntegral n)+opcode (SetEnv n) = (14, Just $ fromIntegral n)+opcode (SetField s) = (15, Just $ hash s)+opcode (SetArray) = (16, Nothing)+opcode (SetIndex n) = (17, Just $ fromIntegral n)+opcode (SetThis) = (18, Nothing)+opcode (Push) = (19, Nothing)+opcode (Pop n) = (20, Just $ fromIntegral n)+opcode (Call n) = (21, Just $ fromIntegral n)+opcode (ObjCall n) = (22, Just $ fromIntegral n)+opcode (Jump n) = (23, Just $ fromIntegral n)+opcode (JumpIf n) = (24, Just $ fromIntegral n)+opcode (JumpIfNot n) = (25, Just $ fromIntegral n)+opcode (Trap n) = (26, Just $ fromIntegral n)+opcode (EndTrap) = (27, Nothing)+opcode (Ret n) = (28, Just $ fromIntegral n)+opcode (MakeEnv n) = (29, Just $ fromIntegral n)+opcode (MakeArray n) = (30, Just $ fromIntegral n)+opcode (Bool) = (31, Nothing)+opcode (IsNull) = (32, Nothing)+opcode (IsNotNull) = (33, Nothing)+opcode (Add) = (34, Nothing)+opcode (Sub) = (35, Nothing)+opcode (Mult) = (36, Nothing)+opcode (Div) = (37, Nothing)+opcode (Mod) = (38, Nothing)+opcode (Shl) = (39, Nothing)+opcode (Shr) = (40, Nothing)+opcode (UShr) = (41, Nothing)+opcode (Or) = (42, Nothing)+opcode (And) = (43, Nothing)+opcode (Xor) = (44, Nothing)+opcode (Eq) = (45, Nothing)+opcode (Neq) = (46, Nothing)+opcode (Gt) = (47, Nothing)+opcode (Gte) = (48, Nothing)+opcode (Lt) = (49, Nothing)+opcode (Lte) = (50, Nothing)+opcode (Not) = (51, Nothing)+opcode (TypeOf) = (52, Nothing)+opcode (Compare) = (53, Nothing)+opcode (Hash) = (54, Nothing)+opcode (New) = (55, Nothing)+opcode (JumpTable n) = (56, Just $ fromIntegral n)+opcode (Apply n) = (57, Just $ fromIntegral n)+opcode (AccStack0) = (58, Nothing)+opcode (AccStack1) = (59, Nothing)+opcode (AccIndex0) = (60, Nothing)+opcode (AccIndex1) = (61, Nothing)+opcode (PhysCompare) = (62, Nothing)+opcode (TailCall(a,s))= (63, Just $ (fromIntegral a) .|. ((fromIntegral s) `shiftL` 3))+opcode (Loop) = (0, Just 64)++-- | Write instruction out using Put monad+putInstruction :: Instruction -> Put+putInstruction i+ = let (op, arg) = opcode i+ n = fromJust arg+ in if (isNothing arg) then (putWord8 $ op `shiftL` 2)+ else if (op < 32 && (n == 0 || n == 1)) then (putWord8 $ (op `shiftL` 3) .|. ((fromIntegral n) `shiftL` 2) .|. 1)+ else if (n >= 0 && n <= 0xFF) then (putWord8 ((op `shiftL` 2) .|. 2) >> putWord8 (fromIntegral n))+ else (putWord8 ((op `shiftL` 2) .|. 3) >> putWord32le n)++-- | Write a few instructions out using Put monad+putInstructions :: [Instruction] -> Put+putInstructions [] = return ()+putInstructions (i:is) = putInstruction i >> putInstructions is++-- | Determine whether instruction has a parameter+hasParam :: Instruction -> Bool+hasParam (AccInt _) = True+hasParam (AccStack _) = True+hasParam (AccGlobal _) = True+hasParam (AccEnv _) = True+hasParam (AccField _) = True+hasParam (AccIndex _) = True+hasParam (AccBuiltin _) = True+hasParam (SetStack _) = True+hasParam (SetGlobal _) = True+hasParam (SetEnv _) = True+hasParam (SetField _) = True+hasParam (SetIndex _) = True+hasParam (Pop _) = True+hasParam (Call _) = True+hasParam (ObjCall _) = True+hasParam (Jump _) = True+hasParam (JumpIf _) = True+hasParam (JumpIfNot _) = True+hasParam (Trap _) = True+hasParam (Ret _) = True+hasParam (MakeEnv _) = True+hasParam (MakeArray _) = True+hasParam (JumpTable _) = True+hasParam (Apply _) = True+hasParam (TailCall _) = True+hasParam _ = False
+ src/lib/Binary/Neko/Module.hs view
@@ -0,0 +1,111 @@+{-|+Module : Binary.Neko.Module+Description : Emit and parse Binary.Neko bytecode+Copyright : (c) Petr Penzin, 2015+License : BSD2+Maintainer : penzin.dev@gmail.com+Stability : experimental+Portability : cross-platform++Primitives to emit and parse Binary.Neko bytecode, including instruction definitions.++-}+module Binary.Neko.Module where++import Control.Applicative+import Data.ByteString.Lazy as BS+import Data.ByteString.Lazy.Char8 as BSChar+import Data.Binary.Get+import Data.Binary.Put+import Data.Maybe+import Data.Either+import Data.Word+import Data.Int++import Binary.Neko.Hashtbl as H+import Binary.Neko.Globals+import Binary.Neko.Instructions++-- | A Binary.Neko module. Consists of global entities and a list of instructions+data Module = N {globals::[Global], fields::Hashtbl, code::[Instruction]} deriving (Show, Eq)++-- | Parse module from ByteString.+-- Return module or return an error string+readModule :: ByteString -> Either String Module+readModule bs = if (isRight res) then+ if (BS.null rest) then (Right m) else Left "Trailing bytes"+ else Left err+ where res = runGetOrFail getModule bs+ Right (rest, _, m) = res+ Left (_, _, err) = res++-- | Internal type for module header (counts of entities in the module)+data ModuleHeader = ModuleHeader {+ numGlobals :: Word32, -- ^ Number of globals+ numFields :: Word32, -- ^ Number of fields+ codeSize :: Word32 -- ^ Code size (number of instructions+arguments)+}++-- | Pick module header fields from a bytestring. Requires bytestring to start with the first field.+getModuleHeader :: Get ModuleHeader+getModuleHeader = ModuleHeader <$> getWord32le <*> getWord32le <*> getWord32le++-- | Get a full module from a bytestring+getModule :: Get Module+getModule = getMagicCheck+ >>= \good -> if (not good) then fail "Invalid magic value" else getModuleHeader+ >>= \h -> getModuleContents (numGlobals h) (numFields h) (codeSize h)++-- | Parse insides of a module from a bytestring.+-- Bytesting is expected to start with the first section of the module.+getModuleContents :: Word32 -- ^ number of globals+ -> Word32 -- ^ number of fields+ -> Word32 -- ^ code size+ -> Get Module -- ^ decode module+getModuleContents globals fields code+ = if (globals > 0xFFFF) then fail "Number of globals not between 0 and 0xFFFF" else+ if (fields > 0xFFFF) then fail "Number of fields not between 0 and 0xFFFF" else+ if (code > 0xFFFFFF) then fail "Code size not between 0 and 0xFFFFFF" else+ getGlobals globals+ >>= \g -> getFields fields+ >>= \f -> getInstructions code f+ >>= \i -> return (N {globals = g, fields = f, code = i})+ +-- | A check for next four bytes matching neko magic value+getMagicCheck :: Get Bool+getMagicCheck = getLazyByteString 4 >>= \b -> return (b == BSChar.pack "NEKO")++-- | Grab a global field from a bytestring+getField :: Get String+getField = getLazyByteStringNul >>= \b -> return (BSChar.unpack b)++-- | Get a list of fields into a hashtable indexed by their hash values+getFields :: Word32 -> Get Hashtbl+getFields 0 = return H.empty+getFields n = getField+ >>= \s -> getFields (n - 1)+ >>= \h -> if (memberString s h) then fail ("Duplicate field " ++ s)+ else return (H.insertString s h)++-- | Produce a sequence of null-terminated strings+prepStrings :: [String] -> ByteString+prepStrings [] = BS.empty+prepStrings (s:ss) = BS.append (BS.snoc (BSChar.pack s) 0x0) (prepStrings ss)++-- | Generate binary for fields+putFields :: Hashtbl -> Put+putFields = putLazyByteString . prepStrings . H.elems++-- | Generate binary for a module+-- TODO: we are not running any checks on sizes of header fields (like we do +-- while reading), that needs to be implemented, otherwise user will get surprised+-- by Binary.Neko runtime.+putModule :: Module -> Put+putModule m = putLazyByteString (BSChar.pack "NEKO") -- put magic value+ >> putWord32le (fromIntegral $ Prelude.length $ globals m) -- put number of globals+ >> putWord32le (fromIntegral $ Prelude.length $ H.elems $ fields m) -- put number of fields+ >> putWord32le (sum $ Prelude.map (\x -> if (hasParam x) then 2 else 1) $ code m) -- put code size + {- Contents of the module -}+ >> putGlobals (globals m)+ >> putFields (fields m) + >> putInstructions (code m)
+ src/test/Main.hs view
@@ -0,0 +1,86 @@+{-|+Module : Main+Description : Test main+Copyright : (c) Petr Penzin, 2015+License : BSD2+Maintainer : penzin.dev@gmail.com+Stability : stable+Portability : cross-platform++Entry point for the test suite++-}+{-# LANGUAGE DeriveDataTypeable #-}+module Main where ++import Test.Tasty+import Test.Tasty.Options+import Test.Tasty.SmallCheck as SC+import Data.Typeable (Typeable)+import Data.Tagged+import Data.Proxy+import Data.Maybe+import Options.Applicative++-- Import test modules+import Module+import Module.Read+import Module.Run+import Globals+import Globals.Read+import Instructions+import Instructions.Read+import Hashtable++-- Option to enable Neko execution+newtype Neko = Neko Bool+ deriving (Eq, Ord, Typeable)++instance IsOption Neko where+ defaultValue = Neko False+ parseValue = fmap Neko . safeRead+ optionName = return "neko"+ optionHelp = return "Enable Binary.Neko runtime tests"+ optionCLParser = flagCLParser (Just 'n')(Neko True)++-- Option to get Neko executable+newtype NekoExe = NekoExe FilePath+ deriving (Eq, Ord, Typeable)++instance IsOption NekoExe where+ defaultValue = NekoExe ""+ parseValue = parseNekoExe+ optionName = return "neko-exe"+ optionHelp = return "Custom path to Binary.Neko executable, implies --neko"++parseNekoExe :: String -> Maybe NekoExe+parseNekoExe s = return (NekoExe s)++main = defaultMainWithIngredients ings $+ askOption $ \(NekoExe nekoExe) ->+ askOption $ \(Neko runNeko) ->+ testGroup "Tests" $+ defaultTests +++ if ((not runNeko) && nekoExe == "")+ then []+ else [ runBytecodeTests $ if (null nekoExe) then "neko" else nekoExe]+ where+ ings =+ includingOptions [Option (Proxy :: Proxy NekoExe), Option (Proxy :: Proxy Neko)] :+ defaultIngredients++defaultTests :: [TestTree]+defaultTests = [readTests, hashTests, binaryCheckTests]++readTests = testGroup "Binary read tests" + [ dasmTests+ , globalsReadTests+ , instrReadTests+ ]++binaryCheckTests = testGroup "Binary produce/consume tests"+ [ binaryCheckInstructions+ , binaryCheckGlobals+ , binaryCheckModules+ ]+