diff options
author | defanor <defanor@thunix.net> | 2024-02-17 23:47:20 +0300 |
---|---|---|
committer | defanor <defanor@thunix.net> | 2024-02-17 23:53:27 +0300 |
commit | c8aa72570046cdce0b1deeb2e22a026acb1ba59c (patch) | |
tree | c0a1273868d94b1f6f2d94052cc15138199d6228 |
The initial language description, its basic interpreter, and an
example program are added.
-rw-r--r-- | README | 42 | ||||
-rw-r--r-- | Stamp.hs | 227 | ||||
-rw-r--r-- | hello.stm | 50 | ||||
-rw-r--r-- | stamp.cabal | 36 |
4 files changed, 355 insertions, 0 deletions
@@ -0,0 +1,42 @@ +A state transition language, for state and stack machines. + +Made to play with, without practical applications in mind. Intended to +be simple. + +The basic idea is to define transitions on sequences of bits. For +instance, a 2-bit increment (with overflow) machine: + +0 0 . 0 1 +0 1 . 1 0 +1 0 . 1 1 +1 1 . 0 0 + +For compactness, wildcards and references are supported: + +_ 0 . ^0 1 +0 _ . 1 0 +_ _ . 0 0 + +Only the matched part of a state changes, so it is suitable for +defining reusable subroutines. Left-hand side and right-hand side may +be of the same length, making it a state machine, or they may vary in +length, so that it behaves rather like a stack. + +Basic syntactic sugar allows to employ hexadecimal numbers, strings, +wildcards of a given length, and range references. + +Memory reading, writing, and syscalls are implemented with built-in +(or "external", "magic") "subroutines": + +# request to write the x2a byte into memory at a 64-bit address given +# after "test" +'test _x40 . 'mwr? ^x20+x3f x2a 'step2 + +# call exit(42) afterwards +'mwr. _x40 _x8 'step2 . 'req1 x000000000000003c x000000000000002a + + +An interpreter is implemented here in Haskell, along with an example +program. To run it: + +cabal run < hello.stm ; echo $? diff --git a/Stamp.hs b/Stamp.hs new file mode 100644 index 0000000..b19929d --- /dev/null +++ b/Stamp.hs @@ -0,0 +1,227 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +import qualified Data.ByteString as BS +import Data.List +import Foreign.C.String +import Foreign.Ptr +import Foreign.Storable +import Numeric +import Data.Word +import Data.Bits +import Data.Char +import Data.Proxy +import Data.Maybe +import Text.Parsec hiding (State) +import Data.List.Split (chunksOf) +-- import Text.Parsec.ByteString + + +foreign import ccall "syscall" syscall0 :: Int -> IO Int +foreign import ccall "syscall" syscall1 :: Int -> Int -> IO Int +foreign import ccall "syscall" syscall2 :: Int -> Int -> Int -> IO Int +foreign import ccall "syscall" syscall3 :: Int -> Int -> Int -> Int -> IO Int +foreign import ccall "syscall" syscall4 + :: Int -> Int -> Int -> Int -> Int -> IO Int +foreign import ccall "syscall" syscall5 + :: Int -> Int -> Int -> Int -> Int -> Int -> IO Int +foreign import ccall "syscall" syscall6 + :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> IO Int + +data LHSToken = LWildcard | LBit Bool + deriving (Show) +data RHSToken = RRef Int | RBit Bool + deriving (Show) +data Transition = Transition [LHSToken] [RHSToken] + deriving (Show) +type Program = [Transition] +type State = [Bool] + +matchesState :: State -> [LHSToken] -> Bool +matchesState s l = bitsMatch s l + where + bitsMatch [] [] = True + bitsMatch _ [] = True + bitsMatch [] _ = False + bitsMatch (_:st) (LWildcard:lhs) = bitsMatch st lhs + bitsMatch (b1:st) (LBit b2:lhs) = b1 == b2 && bitsMatch st lhs + +iter :: Program -> State -> Either String State +iter p s = case find (matchesState s . (\(Transition l _) -> l)) p of + Nothing -> Left "No matching pattern found" + Just (Transition l r) -> do + transitioned <- mapM transition r + pure $ transitioned ++ drop (length l) s + where + transition (RBit b) = Right b + transition (RRef n) + | length s > n = Right $ s !! n + | otherwise = + Left $ "The referenced index " ++ show n + ++ " is out of state bounds for state of length " ++ show (length s) + +iterIO :: Program -> State -> IO (Either String State) +iterIO p s + | take 24 s == strBits "req" = + case bitsToChar (take 8 $ drop 24 s) of + 'r' -> do + w8 <- peek (ptrAt 32) :: IO Word8 + pure $ Right $ strBits "repr" ++ fbToBits w8 ++ drop (32 + 8) s + 'w' -> do + poke (ptrAt 32) (fbAt (Proxy :: Proxy Word8) (32 + intSz)) + pure $ Right $ strBits "repw" ++ drop 32 s + c -> if c >= '0' && c <= '6' + then do + r <- case c of + '0' -> syscall0 (intAt 32) + '1' -> syscall1 (intAt 32) (intAt (32 + intSz)) + '2' -> syscall2 (intAt 32) (intAt (32 + intSz)) (intAt (32 + intSz * 2)) + '3' -> syscall3 (intAt 32) (intAt (32 + intSz)) (intAt (32 + intSz * 2)) + (intAt (32 + intSz * 3)) + '4' -> syscall4 (intAt 32) (intAt (32 + intSz)) (intAt (32 + intSz * 2)) + (intAt (32 + intSz * 3)) (intAt (32 + intSz * 4)) + '5' -> syscall5 (intAt 32) (intAt (32 + intSz)) (intAt (32 + intSz * 2)) + (intAt (32 + intSz * 3)) (intAt (32 + intSz * 4)) + (intAt (32 + intSz * 5)) + '6' -> syscall6 (intAt 32) (intAt (32 + intSz)) (intAt (32 + intSz * 2)) + (intAt (32 + intSz * 3)) (intAt (32 + intSz * 4)) + (intAt (32 + intSz * 5)) (intAt (32 + intSz * 6)) + pure $ Right $ strBits ("rep" ++ [c]) ++ fbToBits r ++ drop (32 + intSz) s + else pure $ Left $ "An unknown sys command: " ++ [c] + | otherwise = pure $ iter p s + where + intSz = finiteBitSize (0 :: Int) + fbAt :: FiniteBits a => Proxy a -> Int -> a + fbAt (Proxy :: Proxy a) offset = + bitsToFB (take (finiteBitSize (zeroBits :: a)) (drop offset s)) + intAt :: Int -> Int + intAt = fbAt (Proxy :: Proxy Int) + ptrAt offset = wordPtrToPtr (WordPtr (fbAt (Proxy :: Proxy Word) offset)) + +run :: Program -> State -> IO (Either String State) +run p s = do + let asBinary True = '1' + asBinary False = '0' + -- putStrLn $ map asBinary s + -- putStrLn $ map bitsToChar $ chunksOf 8 s + r <- iterIO p s + case r of + Left err -> pure $ Left err + Right s' -> run p s' + +main :: IO () +main = do + c <- BS.getContents + case runParser pProgram () "input" c of + Right p -> do + -- print p + print =<< run p (strBits "start") + Left err -> print err + +fbToBits :: FiniteBits a => a -> [Bool] +fbToBits bits = let sz = finiteBitSize bits in + [ testBit bits (sz - n) | n <- [1..sz] ] + +bitsToFB :: FiniteBits a => [Bool] -> a +bitsToFB [] = zeroBits +bitsToFB (True:xs) = setBit (bitsToFB xs) (length xs) +bitsToFB (False:xs) = bitsToFB xs + +charToBits :: Char -> [Bool] +charToBits c + | ord c < 128 = fbToBits (fromIntegral (ord c) :: Word8) + +bitsToChar :: [Bool] -> Char +bitsToChar b = chr $ fromIntegral (bitsToFB b :: Word8) + +bsBits :: BS.ByteString -> [Bool] +bsBits = concatMap fbToBits . BS.unpack + +strBits :: String -> [Bool] +strBits = concatMap charToBits + +-- data ParserState = PS { lhsBits :: Int +-- , rhsBits :: Int +-- } deriving (Show, Eq) + +type Parser = Parsec BS.ByteString () + +pHex :: Parser (Integer, Int) +pHex = do + char 'x' + digits <- many1 hexDigit + let bitNum = length digits * 4 + [(n, "")] = readHex digits + pure (n, bitNum) + +pBin :: Parser (Integer, Int) +pBin = do + digits <- many1 (oneOf ['0', '1']) + let bitNum = length digits + [(n, "")] = + readInt 2 (`elem` ("01" :: String)) (\x -> ord x - 0x30) digits + pure (n, bitNum) + +pChars :: Parser [Bool] +pChars = do + char '\'' + c <- anyChar + cs <- many (noneOf " \n") + pure $ concatMap charToBits (c:cs) + +pNum :: Parser (Integer, Int) +pNum = choice [pHex, pBin] + +pNum' :: Parser Integer +pNum' = fst <$> pNum + +pNumBits :: Parser [Bool] +pNumBits = do + (n, nBits) <- pNum + pure $ map (\pos -> testBit n (nBits - pos)) [1..nBits] + +pWildcard :: Parser [LHSToken] +pWildcard = char '_' *> + (((\n -> replicate (fromIntegral n) LWildcard) <$> pNum') + <|> pure [LWildcard]) + +pLHS :: Parser [LHSToken] +pLHS = choice + [ map LBit <$> pNumBits + , map LBit <$> pChars + , pWildcard + ] + +pRef :: Parser [RHSToken] +pRef = do + char '^' + from <- pNum' + len <- option 0 (char '+' *> pNum') + pure $ map (RRef . fromInteger) [from..from + len] + +pRHS :: Parser [RHSToken] +pRHS = choice + [ map RBit <$> pNumBits + , map RBit <$> pChars + , pRef + ] + +pTransition :: Parser Transition +pTransition = do + lhs <- concat <$> (pLHS `sepEndBy` char ' ') <?> "LHS" + string ". " + rhs <- concat <$> (pRHS `sepBy` char ' ') <?> "RHS" + pure $ Transition lhs rhs + +pComment :: Parser String +pComment = char '#' *> many (noneOf "\n") + +pProgramLine :: Parser (Maybe Transition) +pProgramLine = (pComment *> pure Nothing) + <|> (pure <$> pTransition) + +pProgram :: Parser Program +pProgram = + catMaybes <$> (pProgramLine <?> "transition") `sepEndBy1` (many1 newline) + <* eof diff --git a/hello.stm b/hello.stm new file mode 100644 index 0000000..ff1a5d0 --- /dev/null +++ b/hello.stm @@ -0,0 +1,50 @@ +# inc: increment a 64-bit number (incomplete) + +'inc? _x3f 0 . 'inc. ^x20+x3e 1 +'inc? _x3e 0 1 . 'inc. ^x20+x3d 10 +'inc? _x3d 0 11 . 'inc. ^x20+x3c 100 +'inc? _x3c 0 111 . 'inc. ^x20+x3b 1000 +'inc? _x3b 0 xf . 'inc. ^x20+x3a 1 x0 +'inc? _x3a 0 1 xf . 'inc. ^x20+x39 10 x0 +'inc? _x39 0 11 xf . 'inc. ^x20+x38 100 x0 +'inc? _x38 0 111 xf . 'inc. ^x20+x37 1000 x0 +'inc? _x37 0 xff . 'inc. ^x20+x36 1 x00 +'inc? _x36 0 1 xff . 'inc. ^x20+x35 10 x00 +'inc? _x35 0 11 xff . 'inc. ^x20+x34 100 x00 +'inc? _x34 0 111 xff . 'inc. ^x20+x33 1000 x00 +'inc? _x33 0 xfff . 'inc. ^x20+x32 1 x000 +'inc? _x32 0 1 xfff . 'inc. ^x20+x31 10 x000 +'inc? _x31 0 11 xfff . 'inc. ^x20+x30 100 x000 +'inc? _x30 0 111 xfff . 'inc. ^x20+x2f 1000 x000 +'inc? _x2f 0 xffff . 'inc. ^x20+x2e 1 x0000 +'inc? _x2e 0 1 xffff . 'inc. ^x20+x2d 10 x0000 +'inc? _x2d 0 11 xffff . 'inc. ^x20+x2c 100 x0000 + +# mwr: write a byte into memory, increment the pointer + +'mwr? _x40 _x8 . 'reqw ^x20+x3f ^x60+x7 'mwr. +'repw _x40 _x8 'mwr. . 'inc? ^x20+x3f ^x60+x7 'mwr. +'inc. _x40 _x8 'mwr. . 'mwr. ^x20+x3f ^x60+x7 + + +# start: allocate memory with +# mmap(NULL, 4096, PROT_READ | PROT_WRITE, MAP_PRIVATE | MAP_ANONYMOUS, NULL, 0) +# mmap = 9 +# PROT_READ = 0x1, PROT_WRITE = 0x2 +# MAP_SHARED = 0x01, MAP_PRIVATE = 0x02, MAP_SHARED_VALIDATE = 0x03, +# MAP_ANONYMOUS = 0x20 +'start . 'req6 x0000000000000009 x0000000000000000 x0000000000001000 x0000000000000003 x0000000000000022 x0000000000000000 x0000000000000000 'allocated + +# Prepare the "hello\n" message in the allocated memory +'rep6 _x1c0 'allocated . 'mwr? ^x20+x3f 'h ^x20+x3f 'hello-1 +'mwr. _x40 _x8 _x40 'hello-1 . 'mwr? ^x20+x3f 'e ^x68+x3f 'hello-2 +'mwr. _x40 _x8 _x40 'hello-2 . 'mwr? ^x20+x3f 'l ^x68+x3f 'hello-3 +'mwr. _x40 _x8 _x40 'hello-3 . 'mwr? ^x20+x3f 'l ^x68+x3f 'hello-4 +'mwr. _x40 _x8 _x40 'hello-4 . 'mwr? ^x20+x3f 'o ^x68+x3f 'hello-5 +'mwr. _x40 _x8 _x40 'hello-5 . 'mwr? ^x20+x3f x0a ^x68+x3f 'hello-6 + +# Call write(1, ptr, 6) +'mwr. _x40 _x8 _x40 'hello-6 . 'req3 x0000000000000001 x0000000000000001 ^x68+x3f x0000000000000006 'wrote + +# Call exit(42) +'rep3 _x40 _x40 _x40 _x40 'wrote . 'req1 x000000000000003c x000000000000002a diff --git a/stamp.cabal b/stamp.cabal new file mode 100644 index 0000000..ba1150b --- /dev/null +++ b/stamp.cabal @@ -0,0 +1,36 @@ +cabal-version: 2.4 +name: stamp +version: 0.1.0.0 + +-- A short (one-line) description of the package. +-- synopsis: + +-- A longer description of the package. +-- description: + +-- A URL where users can report bugs. +-- bug-reports: + +-- The license under which the package is released. +license: MIT +author: defanor +maintainer: defanor@thunix.net + +-- A copyright notice. +-- copyright: +-- category: +-- extra-source-files: CHANGELOG.md + +executable stamp + main-is: Stamp.hs + + -- Modules included in this executable, other than Main. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + build-depends: base >= 4.7 && < 5 + , bytestring >= 0.10 + , parsec >= 3 && < 4 + , split >= 0.2 && < 1 + default-language: Haskell2010 |