diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/neko-lib.cabal b/neko-lib.cabal new file mode 100644 --- /dev/null +++ b/neko-lib.cabal @@ -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 diff --git a/src/lib/Binary/Neko/Globals.hs b/src/lib/Binary/Neko/Globals.hs new file mode 100644 --- /dev/null +++ b/src/lib/Binary/Neko/Globals.hs @@ -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 diff --git a/src/lib/Binary/Neko/Hashtbl.hs b/src/lib/Binary/Neko/Hashtbl.hs new file mode 100644 --- /dev/null +++ b/src/lib/Binary/Neko/Hashtbl.hs @@ -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 diff --git a/src/lib/Binary/Neko/Instructions.hs b/src/lib/Binary/Neko/Instructions.hs new file mode 100644 --- /dev/null +++ b/src/lib/Binary/Neko/Instructions.hs @@ -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 diff --git a/src/lib/Binary/Neko/Module.hs b/src/lib/Binary/Neko/Module.hs new file mode 100644 --- /dev/null +++ b/src/lib/Binary/Neko/Module.hs @@ -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) diff --git a/src/test/Main.hs b/src/test/Main.hs new file mode 100644 --- /dev/null +++ b/src/test/Main.hs @@ -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 + ] +