Yes, this is very ugly. However, I managed to squeeze so much out of the original code, and make it really fast (though this could be even better). I think I might have gotten to the point where I cannot really make it go faster, but for a basic VM, I think this is bloody good as it is.
Last active
June 2, 2022 15:00
-
-
Save Mesabloo/96aef8da87903201ee76edd6c909c2ff to your computer and use it in GitHub Desktop.
A very simple VM (as a stack script) for a small concatenative programming language which aims to be as performant as possible.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| #!/usr/bin/env stack | |
| -- stack --resolver lts-18.28 script --optimize --ghc-options "-O2" --ghc-options "-flate-dmd-anal" --ghc-options "-fspecialise-aggressively" --ghc-options "-flate-specialise" --ghc-options "-fstatic-argument-transformation" --package text,deepseq | |
| {-# LANGUAGE BangPatterns #-} | |
| {-# LANGUAGE BlockArguments #-} | |
| {-# LANGUAGE CPP #-} | |
| {-# LANGUAGE DataKinds #-} | |
| {-# LANGUAGE DerivingStrategies #-} | |
| {-# LANGUAGE FlexibleInstances #-} | |
| {-# LANGUAGE ImportQualifiedPost #-} | |
| {-# LANGUAGE KindSignatures #-} | |
| {-# LANGUAGE MagicHash #-} | |
| {-# LANGUAGE MonomorphismRestriction #-} | |
| {-# LANGUAGE OverloadedLists #-} | |
| {-# LANGUAGE OverloadedStrings #-} | |
| {-# LANGUAGE PatternSynonyms #-} | |
| {-# LANGUAGE ScopedTypeVariables #-} | |
| {-# LANGUAGE Strict #-} | |
| {-# LANGUAGE TypeApplications #-} | |
| {-# LANGUAGE UnboxedSums #-} | |
| {-# LANGUAGE UnboxedTuples #-} | |
| {-# LANGUAGE UnliftedNewtypes #-} | |
| {-# LANGUAGE Unsafe #-} | |
| {-# LANGUAGE NoImplicitPrelude #-} | |
| {-# OPTIONS -Weverything #-} | |
| {-# OPTIONS -Wno-name-shadowing #-} | |
| {-# OPTIONS -Wno-unused-top-binds #-} | |
| {-# OPTIONS -Wno-missing-import-lists #-} | |
| {-# OPTIONS -Wno-unsafe #-} | |
| #define STACK_SAFE_OPERATIONS 0 | |
| #define NUMBER_OF_BUILTINS 10 | |
| #define DEBUG 0 | |
| import Control.DeepSeq (NFData, force) | |
| import Control.Exception (Exception (..)) | |
| import Data.Bool (Bool (..), not, otherwise, (&&)) | |
| import Data.Functor ((<$>)) | |
| import Data.List qualified as List | |
| #if STACK_SAFE_OPERATIONS == 1 | |
| import GHC.Exts (sizeofMutableArray#, (>=#)) | |
| #endif | |
| import Data.Maybe (Maybe (Just, Nothing)) | |
| import Data.Semigroup ((<>)) | |
| import Data.String (String) | |
| import Data.Text (Text) | |
| import Data.Text qualified as Text | |
| import GHC.Exts (Array#, Char (..), Char#, Double (..), Double#, Int (..), Int#, MutVar#, MutableArray#, RealWorld, State#, Void#, catch#, copyMutableArray#, eqChar#, freezeArray#, indexArray#, newArray#, newMutVar#, raise#, raiseIO#, readArray#, readMutVar#, remInt#, sizeofArray#, sizeofMutableArray#, unsafeFreezeArray#, void#, writeArray#, writeMutVar#, (*#), (+#), (-#), (==#), (==##), (>#), (>=#)) | |
| import GHC.IO (IO (..), unIO, unsafePerformIO) | |
| import GHC.Int (Int32 (I32#)) | |
| import Numeric (showHex) | |
| import System.CPUTime (getCPUTime) | |
| import System.IO (print, putStr, putStrLn) | |
| import Prelude (Integer, Show (..), fromIntegral, read, undefined, ($), ($!), (*), (+), (-), (<), (==), (>=)) | |
| -- | An unlifted, unboxed equivalent to the standard data type 'Bool', where @0#@ is false and @1#@ is true. | |
| newtype Bool# = Bool# Int# | |
| -- | Pattern synonyms for convenience. | |
| pattern True#, False# :: Bool# | |
| pattern True# = Bool# 1# | |
| pattern False# = Bool# 0# | |
| -- | Retrieve the 'String' representation of a 'Bool#'. | |
| -- | |
| -- Note that this is not inside a 'Show' instance as 'Show' takes a lifted type as first parameter. | |
| showBool# :: Bool# -> String | |
| showBool# True# = "true" | |
| showBool# False# = "false" | |
| showBool# _ = undefined | |
| {-# INLINE showBool# #-} | |
| -- | An expression is a list of atoms. | |
| type Expr = [Atom] | |
| instance {-# OVERLAPPING #-} Show Expr where | |
| show ex = List.unwords $ show <$> ex | |
| -- | Atoms are uncuttable parts of a program. | |
| data Atom | |
| = -- | An unevaluated chunk of code, sometimes refered to as a “thunk” or “quote”. | |
| AQuote Expr | |
| | -- | A shortcut to an expression already evaluated. | |
| AIdentifier Text | |
| | -- | A classic integer literal (most likely to be either 32 or 64-bit). | |
| AInteger Int | |
| | -- | A double-precision floating point literal. | |
| AFloat Double | |
| | -- | A unicode character. | |
| ACharacter Char | |
| | -- | A classic boolean (true or false). | |
| ABoolean Bool | |
| | -- | A simple character string. | |
| AString Text | |
| instance Show Atom where | |
| show (AQuote ex) = "[" <> show ex <> "]" | |
| show (AIdentifier id) = Text.unpack id | |
| show (AInteger i) = show i | |
| show (AFloat d) = show d | |
| show (ACharacter c) = show c | |
| show (ABoolean b) = show b | |
| show (AString txt) = show txt | |
| -- | The stack holds intermediate values at runtime. | |
| data Stack# a | |
| = Stack | |
| !(MutableArray# RealWorld a) | |
| !Int# | |
| {- ORMOLU_DISABLE -} | |
| -- | Remove the value on top of the stack, yielding an exception if the stack is empty. | |
| popStack :: MutVar# RealWorld (Stack# a) -> State# RealWorld -> (# State# RealWorld, a #) | |
| popStack ref s0 = | |
| let !(# s1, Stack !array !ptr #) = readMutVar# ref s0 in | |
| #if STACK_SAFE_OPERATIONS == 1 | |
| case ptr of | |
| -1# -> raise# EmptyStackOnPop | |
| _ -> | |
| #endif | |
| readArray# array ptr (writeMutVar# ref (Stack array (ptr -# 1#)) s1) | |
| {-# INLINE popStack #-} | |
| -- | Push the given value on top of the stack. | |
| -- | |
| -- If the stack grows more than its maximum capacity, the behavior of this function is undefined. | |
| pushStack :: MutVar# RealWorld (Stack# a) -> a -> State# RealWorld -> (# State# RealWorld, Void# #) | |
| pushStack ref val s0 = | |
| let !(# s1, Stack !array !ptr #) = readMutVar# ref s0 in | |
| let !ptrPlusOne = ptr +# 1# in | |
| #if STACK_SAFE_OPERATIONS == 1 | |
| case ptrPlusOne >=# sizeofMutableArray# array of | |
| 1# -> raise# StackOverflow | |
| _ -> | |
| #endif | |
| (# writeArray# array ptrPlusOne val (writeMutVar# ref (Stack array ptrPlusOne) s1), void# #) | |
| {-# INLINE pushStack #-} | |
| -- | Get a peak of the value on top of the stack, wihout actually removing it. | |
| peekStack :: MutVar# RealWorld (Stack# a) -> State# RealWorld -> (# State# RealWorld, a #) | |
| peekStack ref s0 = | |
| let !(# s1, Stack !array !ptr #) = readMutVar# ref s0 in | |
| #if STACK_SAFE_OPERATIONS == 1 | |
| case ptr of | |
| -1# -> raise# EmptyStackOnPeek | |
| _ -> | |
| #endif | |
| readArray# array ptr s1 | |
| {-# INLINE peekStack #-} | |
| {- ORMOLU_ENABLE -} | |
| type Closure = MutVar# RealWorld (Stack# Value#) -> State# RealWorld -> (# State# RealWorld, Void# #) | |
| -- | The kind of runtime values as a unboxed sum. | |
| -- | |
| -- (For reasons, this is a @data@ as it cannot be used inside 'Vector's otherwise) | |
| data Value# = Value (# Int32| Double#| Int#| Char#| Bool#| Text| (# Closure, Int# #) #) | |
| pattern VQuote# :: Int32 -> Value# | |
| pattern VQuote# idx = Value (# idx | | | | | | #) | |
| pattern VDouble# :: Double# -> Value# | |
| pattern VDouble# d = Value (# | d | | | | | #) | |
| pattern VInteger# :: Int# -> Value# | |
| pattern VInteger# i = Value (# | | i | | | | #) | |
| pattern VCharacter# :: Char# -> Value# | |
| pattern VCharacter# c = Value (# | | | c | | | #) | |
| pattern VBoolean# :: Bool# -> Value# | |
| pattern VBoolean# b = Value (# | | | | b | | #) | |
| pattern VString# :: Text -> Value# | |
| pattern VString# txt = Value (# | | | | | txt | #) | |
| pattern VPrimitive# :: Closure -> Int# -> Value# | |
| pattern VPrimitive# f id = Value (# | | | | | | (# f, id #) #) | |
| -- | Returns a 'String' representation of a 'Value#'. | |
| showValue# :: Value# -> String | |
| showValue# (VQuote# off) = "#" <> show off | |
| showValue# (VDouble# d) = show (D# d) | |
| showValue# (VInteger# i) = show (I# i) | |
| showValue# (VCharacter# c) = show (C# c) | |
| showValue# (VBoolean# b) = showBool# b | |
| showValue# (VString# txt) = show txt | |
| showValue# (VPrimitive# _ id) = "prim@" <> show (I# id) | |
| showValue# _ = "???" | |
| {-# INLINE showValue# #-} | |
| eqValue# :: Value# -> Value# -> Int# | |
| eqValue# (VDouble# d1) (VDouble# d2) = d1 ==## d2 | |
| eqValue# (VInteger# i1) (VInteger# i2) = i1 ==# i2 | |
| eqValue# (VCharacter# c1) (VCharacter# c2) = eqChar# c1 c2 | |
| eqValue# (VBoolean# (Bool# b1)) (VBoolean# (Bool# b2)) = b1 ==# b2 | |
| eqValue# (VString# t1) (VString# t2) = if t1 == t2 then 1# else 0# | |
| eqValue# (VQuote# (I32# o1)) (VQuote# (I32# o2)) = o1 ==# o2 | |
| eqValue# (VPrimitive# _ id1) (VPrimitive# _ id2) = id1 ==# id2 | |
| eqValue# _ _ = 0# | |
| -- | The evaluation context contains the current stack, environment and expression to evaluate. | |
| data Context | |
| = Context | |
| !(MutVar# RealWorld (Stack# Value#)) | |
| !(MutVar# RealWorld (Stack# Int32)) | |
| !Int32 | |
| !ConstantTable# | |
| !SymbolTable# | |
| !FunctionTable# | |
| !CodeTable# | |
| data EvalError | |
| = EmptyStackOnPop | |
| | EmptyStackOnPeek | |
| | StackOverflow | |
| | UnboundIdentifier !Text | |
| | TypeError !Text | |
| deriving stock (Show) | |
| instance Exception EvalError | |
| ------------------------------------------------------------------ | |
| ----------------------- BYTECODE AND STUFF ----------------------- | |
| ------------------------------------------------------------------ | |
| type ConstantTable# = Array# Value# | |
| type SymbolTable# = Array# Text | |
| type FunctionTable# = Array# Int | |
| type CodeTable# = Array# Int32 | |
| -- | The layout of a bytecode memory file. | |
| data BytecodeFile | |
| = File | |
| !ConstantTable# | |
| -- ^ Constants | |
| !SymbolTable# | |
| -- ^ Symbols | |
| !FunctionTable# | |
| -- ^ Function offsets, mapping byte offsets (as integers) into the code. | |
| !CodeTable# | |
| -- ^ The compiled code itself | |
| !Int# | |
| -- ^ The starting instruction pointer | |
| {- ORMOLU_DISABLE -} | |
| printBytecodeFile :: BytecodeFile -> State# RealWorld -> (# State# RealWorld, Void# #) | |
| printBytecodeFile (File cstTable symTable funTable codeTable ip) s0 = | |
| let !cstTableSize = sizeofArray# cstTable in | |
| let !symTableSize = sizeofArray# symTable in | |
| let !funTableSize = sizeofArray# funTable in | |
| let !codeTableSize = sizeofArray# codeTable in | |
| let !(# s1, _ #) = unIO (putStrLn "-----| CONSTANTS |-----") s0 in | |
| let !(# s2, _ #) = printConstantTable cstTable cstTableSize s1 in | |
| let !(# s3, _ #) = unIO (putStrLn "-----| SYMBOLS |-----") s2 in | |
| let !(# s4, _ #) = printSymbolTable symTable symTableSize s3 in | |
| let !(# s5, _ #) = unIO (putStrLn "-----| FUNCTIONS |-----") s4 in | |
| let !(# s6, _ #) = printFunctionTable funTable funTableSize s5 in | |
| let !(# s7, _ #) = unIO (putStr "-----| CODE |-----") s6 in | |
| let !(# s8, _ #) = printCodeTable codeTable codeTableSize s7 in | |
| let !(# s9, _ #) = unIO (putStrLn $ "IP=" <> show (I# ip)) s8 in | |
| (# s9, void# #) -- TODO | |
| printConstantTable :: ConstantTable# -> Int# -> State# RealWorld -> (# State# RealWorld, Void# #) | |
| printConstantTable table size s0 = go 0# s0 | |
| where | |
| go x s0 = case x >=# size of | |
| 1# -> (# s0, void# #) | |
| 0# -> | |
| let !(# val #) = indexArray# table x in | |
| let !(# s1, !_ #) = unIO (putStrLn $ show (I# x) <> ":\t" <> showValue# val) s0 in | |
| go (x +# 1#) s1 | |
| _ -> undefined | |
| printSymbolTable :: SymbolTable# -> Int# -> State# RealWorld -> (# State# RealWorld, Void# #) | |
| printSymbolTable table size s0 = go 0# s0 | |
| where | |
| go x s0 = case x >=# size of | |
| 1# -> (# s0, void# #) | |
| 0# -> | |
| let !(# sym #) = indexArray# table x in | |
| let !(# s1, !_ #) = unIO (putStrLn $ show (I# x) <> ":\t" <> show (Text.unpack sym)) s0 in | |
| go (x +# 1#) s1 | |
| _ -> undefined | |
| printFunctionTable :: FunctionTable# -> Int# -> State# RealWorld -> (# State# RealWorld, Void# #) | |
| printFunctionTable table size s0 = go 0# s0 | |
| where | |
| go x s0 = case x >=# size of | |
| 1# -> (# s0, void# #) | |
| 0# -> | |
| let !(# off #) = indexArray# table x in | |
| let !(# s1, !_ #) = unIO (putStrLn $ show (I# x) <> ":\t+" <> show off) s0 in | |
| go (x +# 1#) s1 | |
| _ -> undefined | |
| printCodeTable :: CodeTable# -> Int# -> State# RealWorld -> (# State# RealWorld, Void# #) | |
| printCodeTable table size s0 = go 0# s0 | |
| where | |
| go x s0 = case x >=# size of | |
| 1# -> | |
| let !(# s1, _ #) = unIO (putStrLn "") s0 in | |
| (# s1, void# #) | |
| 0# -> | |
| let !(# code #) = indexArray# table x in | |
| let !(# s1, !_ #) = case remInt# x 8# of | |
| 0# -> unIO (putStr $ "\n" <> show (I# x) <> ":\t") s0 | |
| _ -> (# s0, () #) in | |
| let !(# s2, !_ #) = unIO (putStr $ showHex code "\t") s1 in | |
| go (x +# 1#) s2 | |
| _ -> undefined | |
| {- ORMOLU_ENABLE -} | |
| -- Followed by the identifier of the VPrimitive# in the constant table. | |
| #define BYTECODE_PRIM 0x0 | |
| -- Followed by the identifier of the symbol (in both the symbol table and the function table). | |
| #define BYTECODE_REDUCE 0x1 | |
| -- Followed by the identifier of the value in the constant table. | |
| #define BYTECODE_PUSH 0x2 | |
| -- Returns to the calling address. | |
| #define BYTECODE_RET 0x3 | |
| -- Unquote the last quote on the stack. | |
| #define BYTECODE_UNQUOTE 0x4 | |
| {- ORMOLU_DISABLE -} | |
| resizeConstantTableIfNeeded :: Int# -> MutableArray# RealWorld Value# -> State# RealWorld -> (# State# RealWorld, MutableArray# RealWorld Value# #) | |
| resizeConstantTableIfNeeded 0# constants s0 = (# s0, constants #) | |
| resizeConstantTableIfNeeded 1# constants s0 = | |
| let !constantsSize = sizeofMutableArray# constants in | |
| -- let !_ = unsafePerformIO (putStrLn $ ">> Resizing constant table from " <> show (I# constantsSize) <> " to " <> show (I# (constantsSize *# 2#))) in | |
| let !(# s1, arr #) = newArray# (constantsSize *# 2#) (VInteger# 0#) s0 in | |
| let !s2 = copyMutableArray# constants 0# arr 0# constantsSize s1 in | |
| (# s2, arr #) | |
| resizeConstantTableIfNeeded _ _ _ = undefined | |
| resizeSymbolsTableIfNeeded :: Int# -> MutableArray# RealWorld Text -> State# RealWorld -> (# State# RealWorld, MutableArray# RealWorld Text #) | |
| resizeSymbolsTableIfNeeded 0# symbols s0 = (# s0, symbols #) | |
| resizeSymbolsTableIfNeeded 1# symbols s0 = | |
| let !symbolsSize = sizeofMutableArray# symbols in | |
| -- let !_ = unsafePerformIO (putStrLn $ ">> Resizing symbols table from " <> show (I# symbolsSize) <> " to " <> show (I# (symbolsSize *# 2#))) in | |
| let !(# s1, arr #) = newArray# (symbolsSize *# 2#) ("" :: Text) s0 in | |
| let !s2 = copyMutableArray# symbols 0# arr 0# symbolsSize s1 in | |
| (# s2, arr #) | |
| resizeSymbolsTableIfNeeded _ _ _ = undefined | |
| resizeFunctionsTableIfNeeded :: Int# -> MutableArray# RealWorld Int -> State# RealWorld -> (# State# RealWorld, MutableArray# RealWorld Int #) | |
| resizeFunctionsTableIfNeeded 0# functions s0 = (# s0, functions #) | |
| resizeFunctionsTableIfNeeded 1# functions s0 = | |
| let !functionsSize = sizeofMutableArray# functions in | |
| -- let !_ = unsafePerformIO (putStrLn $ ">> Resizing functions table from " <> show (I# functionsSize) <> " to " <> show (I# (functionsSize *# 2#))) in | |
| let !(# s1, arr #) = newArray# (functionsSize *# 2#) (0 :: Int) s0 in | |
| let !s2 = copyMutableArray# functions 0# arr 0# functionsSize s1 in | |
| (# s2, arr #) | |
| resizeFunctionsTableIfNeeded _ _ _ = undefined | |
| resizeCodeTableIfNeeded :: Int# -> MutableArray# RealWorld Int32 -> State# RealWorld -> (# State# RealWorld, MutableArray# RealWorld Int32 #) | |
| resizeCodeTableIfNeeded 0# code s0 = (# s0, code #) | |
| resizeCodeTableIfNeeded 1# code s0 = | |
| let !codeSize = sizeofMutableArray# code in | |
| -- let !_ = unsafePerformIO (putStrLn $ ">> Resizing code table from " <> show (I# codeSize) <> " to " <> show (I# (codeSize *# 2#))) in | |
| let !(# s1, arr #) = newArray# (codeSize *# 2#) (0 :: Int32) s0 in | |
| let !s2 = copyMutableArray# code 0# arr 0# codeSize s1 in | |
| (# s2, arr #) | |
| resizeCodeTableIfNeeded _ _ _ = undefined | |
| -- | Compile a surface language expression into an in-memory bytecode file ready to be evaluated. | |
| compile :: Expr -> [(Text, Expr)] -> State# RealWorld -> (# State# RealWorld, BytecodeFile #) | |
| compile expr bindings s0 = | |
| let !(# s1, (# constants, constantsPtr #) #) = createConstantArray s0 in | |
| let !(# s2, (# symbols, symbolsPtr #) #) = createSymbolsArray s1 in | |
| let !(# s3, (# functions, functionsPtr #) #) = createFunctions s2 in | |
| let !(# s4, (# code, codePtr #) #) = createCode s3 in | |
| let !(# s5, (# ip, constants0, symbols0, functions0, code0 #) #) = | |
| go expr bindings constants constantsPtr symbols symbolsPtr functions functionsPtr code codePtr s4 in | |
| let !(# s6, I# constantsPtr0 #) = readMutVar# constantsPtr s5 in | |
| let !(# s7, constants1 #) = freezeArray# constants0 0# constantsPtr0 s6 in | |
| let !(# s8, I# symbolsPtr0 #) = readMutVar# symbolsPtr s7 in | |
| let !(# s9, symbols1 #) = freezeArray# symbols0 0# symbolsPtr0 s8 in | |
| let !(# s10, I# functionsPtr0 #) = readMutVar# functionsPtr s9 in | |
| let !(# s11, functions1 #) = freezeArray# functions0 0# functionsPtr0 s10 in | |
| let !(# s12, I# codePtr0 #) = readMutVar# codePtr s11 in | |
| let !(# s13, code1 #) = freezeArray# code0 0# codePtr0 s12 in | |
| -- NOTE: symbolsPtr0 ==# functionsPtr0 must be 1# | |
| (# s13, File constants1 symbols1 functions1 code1 ip #) | |
| where | |
| createConstantArray :: State# RealWorld -> (# State# RealWorld, (# MutableArray# RealWorld Value#, MutVar# RealWorld Int #) #) | |
| createConstantArray s0 = | |
| let !(# s1, constants #) = newArray# 10# (VInteger# 0#) s0 in | |
| let !(# s2, ptr #) = newMutVar# (0 :: Int) s1 in | |
| (# s2, (# constants, ptr #) #) | |
| createSymbolsArray :: State# RealWorld -> (# State# RealWorld, (# MutableArray# RealWorld Text, MutVar# RealWorld Int #) #) | |
| createSymbolsArray s0 = | |
| let !(# s1, symbols #) = newArray# 10# ("" :: Text) s0 in | |
| let !(# s2, ptr #) = newMutVar# (0 :: Int) s1 in | |
| (# s2, (# symbols, ptr #) #) | |
| createFunctions :: State# RealWorld -> (# State# RealWorld, (# MutableArray# RealWorld Int, MutVar# RealWorld Int #) #) | |
| createFunctions s0 = | |
| let !(# s1, functions #) = newArray# NUMBER_OF_BUILTINS# (0 :: Int) s0 in | |
| let !(# s2, functionsPtr #) = newMutVar# (0 :: Int) s1 in | |
| (# s2, (# functions, functionsPtr #) #) | |
| createCode :: State# RealWorld -> (# State# RealWorld, (# MutableArray# RealWorld Int32, MutVar# RealWorld Int #) #) | |
| createCode s0 = | |
| let !(# s1, code #) = newArray# 20# (0 :: Int32) s0 in | |
| let !(# s2, codePtr #) = newMutVar# (0 :: Int) s1 in | |
| (# s2, (# code, codePtr #) #) | |
| go expr bindings constants constantsPtr symbols symbolsPtr functions functionsPtr code codePtr s0 = | |
| let !(# s1, (# constants0, symbols0, functions0, code0 #) #) = | |
| compileAdditionalBindings bindings constants constantsPtr symbols symbolsPtr functions functionsPtr code codePtr s0 in | |
| compileExpr expr constants0 constantsPtr symbols0 symbolsPtr functions0 functionsPtr code0 codePtr s1 | |
| compileAdditionalBindings :: [(Text, Expr)] | |
| -> MutableArray# RealWorld Value# -> MutVar# RealWorld Int | |
| -> MutableArray# RealWorld Text -> MutVar# RealWorld Int | |
| -> MutableArray# RealWorld Int -> MutVar# RealWorld Int | |
| -> MutableArray# RealWorld Int32 -> MutVar# RealWorld Int | |
| -> State# RealWorld | |
| -> (# State# RealWorld, (# MutableArray# RealWorld Value#, MutableArray# RealWorld Text, MutableArray# RealWorld Int, MutableArray# RealWorld Int32 #) #) | |
| compileAdditionalBindings [] constants _ symbols _ functions _ code _ s0 = (# s0, (# constants, symbols, functions, code #) #) | |
| compileAdditionalBindings ((name, val) : binds) constants constantsPtr symbols symbolsPtr functions functionsPtr code codePtr s0 = | |
| let !(# s1, !(I# codePtr0) #) = readMutVar# codePtr s0 in | |
| let !(# s2, !(I# symbolsPtr0) #) = readMutVar# symbolsPtr s1 in | |
| let !(# s3, !(I# functionsPtr0) #) = readMutVar# functionsPtr s2 in | |
| let !symbolsSize = sizeofMutableArray# symbols in | |
| let !functionsSize = sizeofMutableArray# functions in | |
| let !(# s4, symbols0 #) = resizeSymbolsTableIfNeeded (symbolsPtr0 >=# symbolsSize) symbols s3 in | |
| let !(# s5, functions0 #) = resizeFunctionsTableIfNeeded (functionsPtr0 >=# functionsSize) functions s4 in | |
| let !s6 = writeArray# symbols0 symbolsPtr0 name s5 in | |
| let !s7 = writeArray# functions0 functionsPtr0 (I# codePtr0) s6 in | |
| let !(# s8, (# ip, constants0, symbols1, functions1, code0 #) #) = | |
| compileExpr val constants constantsPtr symbols0 symbolsPtr functions0 functionsPtr code codePtr s7 in | |
| let !(# s9, I# codePtr1 #) = readMutVar# codePtr s8 in | |
| let !codeSize = sizeofMutableArray# code0 in | |
| let !(# s10, code1 #) = resizeCodeTableIfNeeded (codePtr1 >=# codeSize) code0 s9 in | |
| let !(# s11, code2 #) = pushOpcodes [BYTECODE_RET] codePtr1 code1 codePtr s10 in | |
| let !s12 = writeArray# functions1 functionsPtr0 (I# ip) s11 in | |
| let !s13 = writeMutVar# functionsPtr (I# (functionsPtr0 +# 1#)) s12 in | |
| let !s14 = writeMutVar# symbolsPtr (I# (symbolsPtr0 +# 1#)) s13 in | |
| compileAdditionalBindings binds constants0 constantsPtr symbols1 symbolsPtr functions1 functionsPtr code2 codePtr s14 | |
| compileExpr :: Expr | |
| -> MutableArray# RealWorld Value# -> MutVar# RealWorld Int | |
| -> MutableArray# RealWorld Text -> MutVar# RealWorld Int | |
| -> MutableArray# RealWorld Int -> MutVar# RealWorld Int | |
| -> MutableArray# RealWorld Int32 -> MutVar# RealWorld Int | |
| -> State# RealWorld | |
| -> (# State# RealWorld, (# Int#, MutableArray# RealWorld Value#, MutableArray# RealWorld Text, MutableArray# RealWorld Int, MutableArray# RealWorld Int32 #) #) | |
| compileExpr expr constants constantsPtr symbols symbolsPtr functions functionsPtr code codePtr s0 = | |
| let !(# s1, (# constants0, symbols0, functions0, code0, expr0 #) #) = | |
| precompileQuotes expr constants constantsPtr symbols symbolsPtr functions functionsPtr code codePtr s0 in | |
| let !(# s2, I# ip #) = readMutVar# codePtr s1 in | |
| let !(# s3, (# constants1, symbols1, functions1, code1 #) #) = | |
| compileAtoms expr0 constants0 constantsPtr symbols0 symbolsPtr functions0 functionsPtr code0 codePtr s2 in | |
| (# s3, (# ip, constants1, symbols1, functions1, code1 #) #) | |
| precompileQuotes :: Expr | |
| -> MutableArray# RealWorld Value# -> MutVar# RealWorld Int | |
| -> MutableArray# RealWorld Text -> MutVar# RealWorld Int | |
| -> MutableArray# RealWorld Int -> MutVar# RealWorld Int | |
| -> MutableArray# RealWorld Int32 -> MutVar# RealWorld Int | |
| -> State# RealWorld | |
| -> (# State# RealWorld, (# MutableArray# RealWorld Value#, MutableArray# RealWorld Text, MutableArray# RealWorld Int, MutableArray# RealWorld Int32, Expr #) #) | |
| precompileQuotes = go [] | |
| where | |
| go :: Expr | |
| -> Expr | |
| -> MutableArray# RealWorld Value# -> MutVar# RealWorld Int | |
| -> MutableArray# RealWorld Text -> MutVar# RealWorld Int | |
| -> MutableArray# RealWorld Int -> MutVar# RealWorld Int | |
| -> MutableArray# RealWorld Int32 -> MutVar# RealWorld Int | |
| -> State# RealWorld | |
| -> (# State# RealWorld, (# MutableArray# RealWorld Value#, MutableArray# RealWorld Text, MutableArray# RealWorld Int, MutableArray# RealWorld Int32, Expr #) #) | |
| go acc [] constants _ symbols _ functions _ code _ s0 = (# s0, (# constants, symbols, functions, code, List.reverse acc #) #) | |
| go acc (atom : expr) constants constantsPtr symbols symbolsPtr functions functionsPtr code codePtr s0 = case atom of | |
| AQuote expr0 -> | |
| let !(# s1, (# constants0, symbols0, functions0, code0, expr1 #) #) = | |
| go [] expr0 constants constantsPtr symbols symbolsPtr functions functionsPtr code codePtr s0 in | |
| let !(# s2, I# codePtr0 #) = readMutVar# codePtr s1 in | |
| let !(# s3, (# constants1, symbols1, functions1, code1 #) #) = | |
| compileAtoms expr1 constants0 constantsPtr symbols0 symbolsPtr functions0 functionsPtr code0 codePtr s2 in | |
| let !(# s4, I# codePtr1 #) = readMutVar# codePtr s3 in | |
| let !codeSize = sizeofMutableArray# code1 in | |
| let !(# s5, code2 #) = resizeCodeTableIfNeeded (codePtr1 >=# codeSize) code1 s4 in | |
| let !(# s6, code3 #) = pushOpcodes [BYTECODE_RET] codePtr1 code2 codePtr s5 in | |
| let !quoteId = ("$" <> Text.pack (show (I# codePtr0))) in | |
| go (AIdentifier quoteId : acc) expr constants1 constantsPtr symbols1 symbolsPtr functions1 functionsPtr code3 codePtr s6 | |
| _ -> go (atom : acc) expr constants constantsPtr symbols symbolsPtr functions functionsPtr code codePtr s0 | |
| compileAtoms :: Expr | |
| -> MutableArray# RealWorld Value# -> MutVar# RealWorld Int | |
| -> MutableArray# RealWorld Text -> MutVar# RealWorld Int | |
| -> MutableArray# RealWorld Int -> MutVar# RealWorld Int | |
| -> MutableArray# RealWorld Int32 -> MutVar# RealWorld Int | |
| -> State# RealWorld | |
| -> (# State# RealWorld, (# MutableArray# RealWorld Value#, MutableArray# RealWorld Text, MutableArray# RealWorld Int, MutableArray# RealWorld Int32 #) #) | |
| compileAtoms [] constants _ symbols _ functions _ code _ s0 = (# s0, (# constants, symbols, functions, code #) #) | |
| compileAtoms (atom : expr) constants constantsPtr symbols symbolsPtr functions functionsPtr code codePtr s0 = | |
| let !(# s1, (# constants0, symbols0, functions0, code0 #) #) = compileAtom atom constants symbols functions code s0 in | |
| compileAtoms expr constants0 constantsPtr symbols0 symbolsPtr functions0 functionsPtr code0 codePtr s1 | |
| where | |
| compileAtom :: Atom | |
| -> MutableArray# RealWorld Value# | |
| -> MutableArray# RealWorld Text | |
| -> MutableArray# RealWorld Int | |
| -> MutableArray# RealWorld Int32 | |
| -> State# RealWorld | |
| -> (# State# RealWorld, (# MutableArray# RealWorld Value#, MutableArray# RealWorld Text, MutableArray# RealWorld Int, MutableArray# RealWorld Int32 #) #) | |
| compileAtom (AInteger (I# i)) constants symbols functions code s0 = | |
| let !(# s1, (# constants0, code0 #) #) = insertConstant (VInteger# i) constants constantsPtr code codePtr s0 in | |
| (# s1, (# constants0, symbols, functions, code0 #) #) | |
| compileAtom (ACharacter (C# c)) constants symbols functions code s0 = | |
| let !(# s1, (# constants0, code0 #) #) = insertConstant (VCharacter# c) constants constantsPtr code codePtr s0 in | |
| (# s1, (# constants0, symbols, functions, code0 #) #) | |
| compileAtom (ABoolean !b) constants symbols functions code s0 = | |
| let !(# s1, (# constants0, code0 #) #) = insertConstant (VBoolean# (if b then True# else False#)) constants constantsPtr code codePtr s0 in | |
| (# s1, (# constants0, symbols, functions, code0 #) #) | |
| compileAtom (AFloat (D# d)) constants symbols functions code s0 = | |
| let !(# s1, (# constants0, code0 #) #) = insertConstant (VDouble# d) constants constantsPtr code codePtr s0 in | |
| (# s1, (# constants0, symbols, functions, code0 #) #) | |
| compileAtom (AString !txt) constants symbols functions code s0 = | |
| let !(# s1, (# constants0, code0 #) #) = insertConstant (VString# txt) constants constantsPtr code codePtr s0 in | |
| (# s1, (# constants0, symbols, functions, code0 #) #) | |
| compileAtom (AIdentifier "unquote") constants symbols functions code s0 = | |
| let !(# s1, I# codePtr0 #) = readMutVar# codePtr s0 in | |
| let !codeSize = sizeofMutableArray# code in | |
| let !(# s2, code0 #) = resizeCodeTableIfNeeded (codePtr0 >=# codeSize) code s1 in | |
| let !(# s3, code1 #) = pushOpcodes [BYTECODE_UNQUOTE] codePtr0 code0 codePtr s2 in | |
| (# s3, (# constants, symbols, functions, code1 #) #) | |
| compileAtom (AIdentifier "pop") constants symbols functions code s0 = | |
| let !(# s1, (# constants0, code0 #) #) = insertBuiltin pop 0# constants constantsPtr code codePtr s0 in | |
| (# s1, (# constants0, symbols, functions, code0 #) #) | |
| compileAtom (AIdentifier "dup") constants symbols functions code s0 = | |
| let !(# s1, (# constants0, code0 #) #) = insertBuiltin dup 1# constants constantsPtr code codePtr s0 in | |
| (# s1, (# constants0, symbols, functions, code0 #) #) | |
| compileAtom (AIdentifier "swap") constants symbols functions code s0 = | |
| let !(# s1, (# constants0, code0 #) #) = insertBuiltin swap 2# constants constantsPtr code codePtr s0 in | |
| (# s1, (# constants0, symbols, functions, code0 #) #) | |
| compileAtom (AIdentifier "if") constants symbols functions code s0 = | |
| let !(# s1, (# constants0, code0 #) #) = insertBuiltin ifthenelse 3# constants constantsPtr code codePtr s0 in | |
| (# s1, (# constants0, symbols, functions, code0 #) #) | |
| compileAtom (AIdentifier "rot31") constants symbols functions code s0 = | |
| let !(# s1, (# constants0, code0 #) #) = insertBuiltin rot31 4# constants constantsPtr code codePtr s0 in | |
| (# s1, (# constants0, symbols, functions, code0 #) #) | |
| compileAtom (AIdentifier "+") constants symbols functions code s0 = | |
| let !(# s1, (# constants0, code0 #) #) = insertBuiltin add 5# constants constantsPtr code codePtr s0 in | |
| (# s1, (# constants0, symbols, functions, code0 #) #) | |
| compileAtom (AIdentifier "-") constants symbols functions code s0 = | |
| let !(# s1, (# constants0, code0 #) #) = insertBuiltin sub 6# constants constantsPtr code codePtr s0 in | |
| (# s1, (# constants0, symbols, functions, code0 #) #) | |
| compileAtom (AIdentifier "*") constants symbols functions code s0 = | |
| let !(# s1, (# constants0, code0 #) #) = insertBuiltin times 7# constants constantsPtr code codePtr s0 in | |
| (# s1, (# constants0, symbols, functions, code0 #) #) | |
| compileAtom (AIdentifier "=") constants symbols functions code s0 = | |
| let !(# s1, (# constants0, code0 #) #) = insertBuiltin eq 8# constants constantsPtr code codePtr s0 in | |
| (# s1, (# constants0, symbols, functions, code0 #) #) | |
| compileAtom (AIdentifier !name) constants symbols functions code s0 = | |
| case (# Text.head name, Text.tail name #) of | |
| (# '$', offset #) -> | |
| let !(I# off) = read (Text.unpack offset) in | |
| let !(# s1, (# constants0, code0 #) #) = insertConstant (VQuote# (I32# off)) constants constantsPtr code codePtr s0 in | |
| (# s1, (# constants0, symbols, functions, code0 #) #) | |
| _ -> | |
| let !(# s1, index #) = findIndexFromReducerName symbols name s0 in | |
| let !(# s2, I# codePtr0 #) = readMutVar# codePtr s1 in | |
| let !codeSize = sizeofMutableArray# code in | |
| let !(# s3, code0 #) = resizeCodeTableIfNeeded (codePtr0 >=# codeSize -# 1#) code s2 in | |
| let !(# s4, code1 #) = pushOpcodes [BYTECODE_REDUCE, I32# index] codePtr0 code0 codePtr s3 in | |
| (# s4, (# constants, symbols, functions, code1 #) #) | |
| compileAtom (AQuote _) _ _ _ _ _ = undefined | |
| pushOpcodes :: [Int32] -> Int# -> MutableArray# RealWorld Int32 -> MutVar# RealWorld Int -> State# RealWorld -> (# State# RealWorld, MutableArray# RealWorld Int32 #) | |
| pushOpcodes opcodes offset code codePtr s0 = | |
| let !size = List.length opcodes in | |
| let !s1 = writeMutVar# codePtr (I# offset + size) s0 in | |
| -- let !_ = unsafePerformIO (putStrLn $ "Pushing " <> show size <> " opcodes onto the code section starting at offset " <> show (I# offset)) in | |
| go opcodes offset s1 | |
| where | |
| go [] _ !s0 = (# s0, code #) | |
| go (op : ops) off !s0 = go ops (off +# 1#) (writeArray# code off op s0) | |
| {-# INLINE pushOpcodes #-} | |
| insertConstant :: Value# | |
| -> MutableArray# RealWorld Value# -> MutVar# RealWorld Int | |
| -> MutableArray# RealWorld Int32 -> MutVar# RealWorld Int | |
| -> State# RealWorld | |
| -> (# State# RealWorld, (# MutableArray# RealWorld Value#, MutableArray# RealWorld Int32 #) #) | |
| insertConstant cst table cstPtr code codePtr s0 = | |
| let !(# s1, !(I# cstPtr0) #) = readMutVar# cstPtr s0 in | |
| let !(# s2, !(I# codePtr0) #) = readMutVar# codePtr s1 in | |
| let !(# s3, (# index, table0 #) #) = insertConstantInTableOnlyWhenNotFound cst table cstPtr cstPtr0 s2 in | |
| let !codeSize = sizeofMutableArray# code in | |
| let !(# s4, code0 #) = resizeCodeTableIfNeeded (codePtr0 >=# codeSize -# 1#) code s3 in | |
| let !s5 = writeArray# table0 cstPtr0 cst s4 in | |
| let !(# s6, code1 #) = pushOpcodes [BYTECODE_PUSH, I32# index] codePtr0 code0 codePtr s5 in | |
| (# s6, (# table0, code1 #) #) | |
| insertBuiltin :: Closure -> Int# | |
| -> MutableArray# RealWorld Value# -> MutVar# RealWorld Int | |
| -> MutableArray# RealWorld Int32 -> MutVar# RealWorld Int | |
| -> State# RealWorld | |
| -> (# State# RealWorld, (# MutableArray# RealWorld Value#, MutableArray# RealWorld Int32 #) #) | |
| insertBuiltin f id constants constantsPtr code codePtr s0 = | |
| let !(# s1, !(I# cstPtr0) #) = readMutVar# constantsPtr s0 in | |
| let !(# s2, !(I# codePtr0) #) = readMutVar# codePtr s1 in | |
| let !cst = VPrimitive# f id in | |
| let !(# s3, (# index, constants0 #) #) = insertConstantInTableOnlyWhenNotFound cst constants constantsPtr cstPtr0 s2 in | |
| let !codeSize = sizeofMutableArray# code in | |
| let !(# s4, code0 #) = resizeCodeTableIfNeeded (codePtr0 >=# codeSize -# 1#) code s3 in | |
| let !s5 = writeArray# constants0 cstPtr0 cst s4 in | |
| let !(# s6, code1 #) = pushOpcodes [BYTECODE_PRIM, I32# index] codePtr0 code0 codePtr s5 in | |
| (# s6, (# constants0, code1 #) #) | |
| insertConstantInTableOnlyWhenNotFound :: Value# | |
| -> MutableArray# RealWorld Value# -> MutVar# RealWorld Int -> Int# | |
| -> State# RealWorld | |
| -> (# State# RealWorld, (# Int#, MutableArray# RealWorld Value# #) #) | |
| insertConstantInTableOnlyWhenNotFound cst constants cstPtr cstPtr0 s0 = go constants 0# cstPtr0 s0 | |
| where | |
| go :: MutableArray# RealWorld Value# -> Int# -> Int# -> State# RealWorld -> (# State# RealWorld, (# Int#, MutableArray# RealWorld Value# #) #) | |
| go table x end s0 = case x >=# end of | |
| 1# -> | |
| let !cstSize = sizeofMutableArray# table in | |
| let !(# s1, table0 #) = resizeConstantTableIfNeeded (end >=# cstSize) table s0 in | |
| let !s2 = writeMutVar# cstPtr (I# (end +# 1#)) s1 in | |
| (# s2, (# end, table0 #) #) | |
| 0# -> | |
| let !(# s1, table0 #) = unsafeFreezeArray# table s0 in | |
| let !(# !value #) = indexArray# table0 x in | |
| case eqValue# cst value of | |
| 0# -> go table (x +# 1#) end s1 | |
| 1# -> (# s1, (# x, table #) #) | |
| _ -> undefined | |
| _ -> undefined | |
| findIndexFromReducerName :: MutableArray# RealWorld Text -> Text -> State# RealWorld -> (# State# RealWorld, Int# #) | |
| findIndexFromReducerName functions name s0 = | |
| let !(# s1, functions0 #) = unsafeFreezeArray# functions s0 in | |
| go functions0 0# (sizeofArray# functions0) s1 | |
| where | |
| go :: Array# Text -> Int# -> Int# -> State# RealWorld -> (# State# RealWorld, Int# #) | |
| go funs x end s0 = case x >=# end of | |
| 1# -> raise# $! UnboundIdentifier name | |
| 0# -> | |
| let !(# !fnName #) = indexArray# funs x in | |
| if fnName == name | |
| then (# s0, x #) | |
| else go funs (x +# 1#) end s0 | |
| _ -> undefined | |
| {- ORMOLU_ENABLE -} | |
| ------------------------------------------------------------------ | |
| ------------- SOME EXAMPLES BECAUSE WHY NOT ---------------------- | |
| ------------------------------------------------------------------ | |
| example1 :: Expr | |
| example1 = [AIdentifier "pop"] | |
| example2 :: Expr | |
| example2 = [AInteger 5, AInteger 6, AIdentifier "+"] | |
| example3 :: Expr | |
| example3 = example2 <> example2 <> [AIdentifier "+"] | |
| -- | Computation time: ~6-7us | |
| example4 :: Expr | |
| example4 = example3 <> example3 <> [AIdentifier "pop", AIdentifier "dup", AIdentifier "+"] | |
| -- | Computation time: ~150ms | |
| example5 :: Expr | |
| example5 = [AInteger 3, AInteger 6, AIdentifier "ack"] | |
| -- | Computation time: ~26us | |
| example6 :: Expr | |
| example6 = [AInteger 15, AIdentifier "fact"] | |
| example7 :: Expr | |
| example7 = [AInteger 15, AInteger 6, AInteger 25, AInteger 15] | |
| example8 :: Expr | |
| example8 = [AQuote [AInteger 1], AInteger 2] | |
| example9 :: Expr | |
| example9 = example8 <> [AIdentifier "pop", AIdentifier "unquote"] | |
| example10 :: Expr | |
| example10 = [AQuote [AQuote [AInteger 10], AIdentifier "unquote"], AIdentifier "unquote"] | |
| example11 :: Expr | |
| example11 = [AQuote [AInteger 10, AQuote [AInteger 12], AIdentifier "unquote"], AIdentifier "unquote"] | |
| ------------------------------------------------------------------ | |
| showTime :: Double -> String | |
| showTime = go "s" | |
| where | |
| next :: String -> String | |
| next "s" = "ms" | |
| next "ms" = "us" | |
| next "us" = "ns" | |
| next _ = "ns" | |
| {-# INLINE next #-} | |
| lastUnit :: String -> Bool | |
| lastUnit "ns" = True | |
| lastUnit _ = False | |
| {-# INLINE lastUnit #-} | |
| go :: String -> Double -> String | |
| go unit d | |
| | d < 1 && not (lastUnit unit) = go (next unit) (d * 1000) | |
| | otherwise = show d <> unit | |
| ------------------------------------------------------------- | |
| ----------------------- ENTRY POINT ------------------------- | |
| ------------------------------------------------------------- | |
| main :: IO () | |
| main = IO main' | |
| {- ORMOLU_DISABLE -} | |
| main' :: State# RealWorld -> (# State# RealWorld, () #) | |
| main' s0 = | |
| let !expr = example5 in | |
| let !(# s1, _ #) = unIO (putStr "> ") s0 in | |
| let !(# s2, _ #) = unIO (print expr) s1 in | |
| let !(# s3, bytecodeFile0 #) = compile expr withBindings s2 in | |
| let !(# s4, _ #) = printBytecodeFile bytecodeFile0 s3 in | |
| let !initialSize = 500000# in | |
| let !(# s5, !stack0 #) = newArray# initialSize (VInteger# 0#) s4 in | |
| let !(# s6, !stack1 #) = newMutVar# (Stack stack0 -1#) s5 in | |
| let !(# s7, !cstack0 #) = newArray# 500000# (0 :: Int32) s6 in | |
| let !(# s8, !cstack1 #) = newMutVar# (Stack cstack0 -1#) s7 in | |
| let !(# s9, !(# !time, !_ #) #) = timeItT (eval' stack1 cstack1 bytecodeFile0) s8 in | |
| let !_ = unsafePerformIO (putStr "\nresult: ") in | |
| let !(# s10, !(Stack arr0 ptr) #) = readMutVar# stack1 s9 in | |
| let !(# s11, arr1 #) = unsafeFreezeArray# arr0 s10 in | |
| let !(# s12, !_ #) = printArrayBounds 0# ptr arr1 s11 in | |
| let !_ = unsafePerformIO (putStrLn $ "time taken: " <> showTime time) in | |
| (# s12, () #) | |
| where | |
| withBindings :: [(Text, Expr)] | |
| withBindings = [ | |
| ("fact", fact), | |
| ("ack", ack) | |
| ] | |
| eval' :: MutVar# RealWorld (Stack# Value#) -> MutVar# RealWorld (Stack# Int32) -> BytecodeFile -> State# RealWorld -> (# State# RealWorld, () #) | |
| eval' stack cstack (File constants symbols functions code ip) s0 = | |
| eval (Context stack cstack (I32# ip) constants symbols functions code) s0 | |
| {-# INLINE eval' #-} | |
| timeItT :: NFData a => (State# RealWorld -> (# State# RealWorld, a #)) -> State# RealWorld -> (# State# RealWorld, (# Double, a #) #) | |
| timeItT f s0 = | |
| let !(# s1, start #) = unIO getCPUTime s0 in | |
| let !(# s2, !res #) = f s1 in | |
| let !_ = force res in | |
| let !(# s3, end #) = unIO getCPUTime s2 in | |
| let time :: Double = fromIntegral @Integer @Double (end - start) * 1e-12 in | |
| (# s3, (# time, res #) #) | |
| {-# INLINE timeItT #-} | |
| {-# SPECIALIZE timeItT :: (State# RealWorld -> (# State# RealWorld, () #)) -> State# RealWorld -> (# State# RealWorld, (# Double, () #) #) #-} | |
| {-# INLINE main' #-} | |
| -- | Print all the elements of the given array within the specified bounds. | |
| printArrayBounds :: Int# -> Int# -> Array# Value# -> State# RealWorld -> (# State# RealWorld, () #) | |
| printArrayBounds low high arr s0 = go low s0 | |
| where | |
| go x s0 = | |
| case x ># high of | |
| 1# -> | |
| let !_ = unsafePerformIO (putStrLn "") in | |
| (# s0, () #) | |
| 0# -> | |
| let !(# s1, _ #) = printIthOfArray arr x s0 in | |
| go (x +# 1#) s1 | |
| _ -> undefined | |
| printIthOfArray :: Array# Value# -> Int# -> State# RealWorld -> (# State# RealWorld, () #) | |
| printIthOfArray arr i s0 = | |
| let !(# val #) = indexArray# arr i in | |
| let !_ = unsafePerformIO (putStr $! showValue# val <> " ") in | |
| (# s0, () #) | |
| {-# INLINE printIthOfArray #-} | |
| {-# INLINE printArrayBounds #-} | |
| {- ORMOLU_ENABLE -} | |
| ------------------------------------------------------------- | |
| ------------------ INTERPRETER ENTRY POINT ------------------ | |
| ------------------------------------------------------------- | |
| {- ORMOLU_DISABLE -} | |
| eval :: Context -> State# RealWorld -> (# State# RealWorld, () #) | |
| eval (Context stack callStack ip constants _ functions code) s0 = | |
| let !codeSize = I32# (sizeofArray# code) in | |
| catch# (go codeSize ip) printMachineStateOnError s0 | |
| where | |
| go :: Int32 -> Int32 -> State# RealWorld -> (# State# RealWorld, () #) | |
| go size ip@(I32# ip0) !s0 | |
| | ip >= size = (# s0, () #) | |
| | otherwise = | |
| case indexArray# code ip0 of | |
| (# BYTECODE_RET #) -> | |
| let !(# s1, I32# off #) = popStack callStack s0 in | |
| #if DEBUG == 1 | |
| let !_ = unsafePerformIO (putStrLn $ "> Returning to address " <> show (I32# off)) in | |
| #endif | |
| go size (I32# off) s1 | |
| (# BYTECODE_PRIM #) -> | |
| let !(# I32# idx #) = indexArray# code (ip0 +# 1#) in | |
| let !(# VPrimitive# f _ #) = indexArray# constants idx in | |
| #if DEBUG == 1 | |
| let !_ = unsafePerformIO (putStrLn $ "> Computing primitive at index " <> show (I32# idx)) in | |
| #endif | |
| let !(# s1, _ #) = f stack s0 in | |
| go size (ip + 2) s1 | |
| (# BYTECODE_PUSH #) -> | |
| let !(# I32# idx #) = indexArray# code (ip0 +# 1#) in | |
| let !(# cst #) = indexArray# constants idx in | |
| let !(# s1, _ #) = pushStack stack cst s0 in | |
| #if DEBUG == 1 | |
| let !_ = unsafePerformIO (putStrLn $ "> Pushing constant #" <> show (I32# idx) <> " (" <> showValue# cst <> ")") in | |
| #endif | |
| go size (ip + 2) s1 | |
| (# BYTECODE_REDUCE #) -> | |
| let !(# I32# idx #) = indexArray# code (ip0 +# 1#) in | |
| let !(# I# off #) = indexArray# functions idx in | |
| let !(# s1, _ #) = pushStack callStack (ip + 2) s0 in | |
| #if DEBUG == 1 | |
| let !_ = unsafePerformIO (putStrLn $ "> Jumping to code offset " <> show (I32# off) <> " found at entry #" <> show (I32# idx)) in | |
| #endif | |
| go size (I32# off) s1 | |
| (# BYTECODE_UNQUOTE #) -> | |
| let !(# s1, val #) = popStack stack s0 in | |
| case val of | |
| VQuote# off -> | |
| let !(# s2, _ #) = pushStack callStack (ip + 1) s1 in | |
| #if DEBUG == 1 | |
| let !_ = unsafePerformIO (putStrLn $ "> Unquotting quote found at offset " <> show off) in | |
| #endif | |
| go size off s2 | |
| val -> raise# $! TypeError $ "Not a quote: " <> Text.pack (showValue# val) | |
| (# _ #) -> undefined | |
| printMachineStateOnError e s0 = case fromException @EvalError e of | |
| Just ex -> | |
| let !(# s1, _ #) = unIO (putStrLn $ "/!\\ VM encountered exception: " <> show ex) s0 in | |
| (# s1, () #) | |
| Nothing -> raiseIO# e s0 | |
| {-# INLINE printMachineStateOnError #-} | |
| {-# INLINE eval #-} | |
| {- ORMOLU_ENABLE -} | |
| ------------------------------------------- | |
| ----------- BUILTIN REDUCERS -------------- | |
| ------------------------------------------- | |
| {- ORMOLU_DISABLE -} | |
| pop :: Closure | |
| pop stack s0 = | |
| let !(# s1, _ #) = popStack stack s0 in | |
| (# s1, void# #) | |
| {-# INLINE pop #-} | |
| add :: Closure | |
| add stack s0 = | |
| let !(# s1, v1 #) = popStack stack s0 in | |
| let !(# s2, v2 #) = popStack stack s1 in | |
| case (# v1, v2 #) of | |
| (# VInteger# i1, VInteger# i2 #) -> pushStack stack (VInteger# (i2 +# i1)) s2 | |
| _ -> raise# $! TypeError $ "Expected two ints for reducer '+' (found " <> Text.pack (showValue# v1) <> ", " <> Text.pack (showValue# v2) <> ")" | |
| {-# INLINE add #-} | |
| times :: Closure | |
| times stack s0 = | |
| let !(# s1, v1 #) = popStack stack s0 in | |
| let !(# s2, v2 #) = popStack stack s1 in | |
| case (# v1, v2 #) of | |
| (# VInteger# i1, VInteger# i2 #) -> pushStack stack (VInteger# (i2 *# i1)) s2 | |
| _ -> raise# $! TypeError $ "Expected two ints for reducer '+' (found " <> Text.pack (showValue# v1) <> ", " <> Text.pack (showValue# v2) <> ")" | |
| {-# INLINE times #-} | |
| sub :: Closure | |
| sub stack s0 = | |
| let !(# s1, v1 #) = popStack stack s0 in | |
| let !(# s2, v2 #) = popStack stack s1 in | |
| case (# v1, v2 #) of | |
| (# VInteger# i1, VInteger# i2 #) -> pushStack stack (VInteger# (i2 -# i1)) s2 | |
| _ -> raise# $! TypeError $ "Expected two ints for reducer '-' (found " <> Text.pack (showValue# v1) <> ", " <> Text.pack (showValue# v2) <> ")" | |
| {-# INLINE sub #-} | |
| dup :: Closure | |
| dup stack s0 = | |
| let !(# s1, v #) = peekStack stack s0 in | |
| pushStack stack v s1 | |
| {-# INLINE dup #-} | |
| swap :: Closure | |
| swap stack s0 = | |
| let !(# s1, v1 #) = popStack stack s0 in | |
| let !(# s2, v2 #) = popStack stack s1 in | |
| let !(# s3, _ #) = pushStack stack v1 s2 in | |
| pushStack stack v2 s3 | |
| {-# INLINE swap #-} | |
| rot31 :: Closure | |
| rot31 stack s0 = | |
| let !(# s1, v1 #) = popStack stack s0 in | |
| let !(# s2, v2 #) = popStack stack s1 in | |
| let !(# s3, v3 #) = popStack stack s2 in | |
| let !(# s4, _ #) = pushStack stack v1 s3 in | |
| let !(# s5, _ #) = pushStack stack v3 s4 in | |
| pushStack stack v2 s5 | |
| {-# INLINE rot31 #-} | |
| rot3_1 :: Closure | |
| rot3_1 stack s0 = | |
| let !(# s1, v1 #) = popStack stack s0 in | |
| let !(# s2, v2 #) = popStack stack s1 in | |
| let !(# s3, v3 #) = popStack stack s2 in | |
| let !(# s4, _ #) = pushStack stack v2 s3 in | |
| let !(# s5, _ #) = pushStack stack v3 s4 in | |
| pushStack stack v1 s5 | |
| {-# INLINE rot3_1 #-} | |
| ifthenelse :: Closure | |
| ifthenelse stack s0 = | |
| let !(# s1, vElse #) = popStack stack s0 in | |
| let !(# s2, vThen #) = popStack stack s1 in | |
| let !(# s3, vCond #) = popStack stack s2 in | |
| case vCond of | |
| VBoolean# True# -> pushStack stack vThen s3 | |
| VBoolean# False# -> pushStack stack vElse s3 | |
| _ -> raise# $! TypeError "Expected boolean as condition for condition" | |
| {-# INLINE ifthenelse #-} | |
| eq :: Closure | |
| eq stack s0 = | |
| let !(# s1, v1 #) = popStack stack s0 in | |
| let !(# s2, v2 #) = popStack stack s1 in | |
| case (# v1, v2 #) of | |
| (# VInteger# i1, VInteger# i2 #) -> pushStack stack (VBoolean# (Bool# (i1 ==# i2))) s2 | |
| (# VDouble# d1, VDouble# d2 #) -> pushStack stack (VBoolean# (Bool# (d1 ==## d2))) s2 | |
| _ -> undefined -- TODO | |
| {-# INLINE eq #-} | |
| -- unquote :: Closure | |
| -- unquote stack s0 = | |
| -- let !(# s1, v1 #) = popStack stack s0 in | |
| -- case v1 of | |
| -- VQuote# idx -> | |
| -- _ -> throw# $! TypeError $ "Not a quote: " <> Text.pack (showValue# v1) | |
| --------------------------------------------------------------------------- | |
| -------------------------------- FOR TESTS -------------------------------- | |
| --------------------------------------------------------------------------- | |
| {- ORMOLU_ENABLE -} | |
| fact :: Expr | |
| fact = | |
| [ -- [n] | |
| AIdentifier "dup", -- [n n] | |
| AInteger 0, -- [n n 0] | |
| AIdentifier "=", -- [n (n=0)] | |
| AQuote | |
| [ -- > [n] | |
| AIdentifier "pop", -- > [] | |
| AInteger 1 -- > [1] | |
| ], -- [n (n=0) [1]] | |
| AQuote | |
| [ -- > [n] | |
| AIdentifier "dup", -- > [n n] | |
| AInteger 1, -- > [n n 1] | |
| AIdentifier "-", -- > [n (n-1)] | |
| AIdentifier "fact", -- > [n (n-1) fact] | |
| -- AIdentifier "unquote", -- > [n (fact(n-1))] | |
| AIdentifier "*" -- > [(n*fact(n-1))] | |
| ], -- [n (n=0) [1] [(n*fact(n-1))]] | |
| AIdentifier "if", -- [n [1] | [(n*fact(n-1))]] | |
| AIdentifier "unquote" -- [1 | n*fact(n-1)] | |
| ] | |
| ack :: Expr | |
| ack = | |
| [ -- [m n] | |
| AIdentifier "swap", -- [n m] | |
| AIdentifier "dup", -- [n m m] | |
| AInteger 0, -- [n m m 0] | |
| AIdentifier "=", -- [n m (m=0)] | |
| AQuote | |
| [ -- > [n m] | |
| AIdentifier "pop", -- > [n] | |
| AInteger 1, -- > [n 1] | |
| AIdentifier "+" -- > [(n+1)] | |
| ], -- [n m (m=0) [(n+1)]] | |
| AQuote | |
| [ -- > [n m] | |
| AIdentifier "swap", -- > [m n] | |
| AIdentifier "dup", -- > [m n n] | |
| AInteger 0, -- > [m n n 0] | |
| AIdentifier "=", -- > [m n (n=0)] | |
| AQuote | |
| [ -- >> [m n] | |
| AIdentifier "pop", -- >> [m] | |
| AInteger 1, -- >> [m 1] | |
| AIdentifier "-", -- >> [(m-1)] | |
| AInteger 1, -- >> [(m-1) 1)] | |
| AIdentifier "ack" -- >> [(m-1) 1 ack] | |
| ], -- > [m n (n=0) [(ack(m-1,1))]] | |
| AQuote | |
| [ -- >> [m n] | |
| AIdentifier "swap", -- >> [n m] | |
| AIdentifier "dup", -- >> [n m m] | |
| AIdentifier "rot31", -- >> [m n m] | |
| AInteger 1, -- >> [m n m 1] | |
| AIdentifier "-", -- >> [m n (m-1)] | |
| AIdentifier "rot31", -- >> [(m-1) m n] | |
| AInteger 1, -- >> [(m-1) m n 1] | |
| AIdentifier "-", -- >> [(m-1) m (n-1)] | |
| AIdentifier "ack", -- >> [(m-1) (ack(m,n-1))] | |
| AIdentifier "ack" -- >> [(ack(m-1,ack(m,n-1)))] | |
| ], -- > [m n (n=0) [ack(m-1,1)] [ack(m-1,ack(m,n-1))]] | |
| AIdentifier "if", -- > [m n ([ack(m-1,1)] | [ack(m-1,ack(m,n-1))])] | |
| AIdentifier "unquote" -- > [(ack(m-1,1) | ack(m-1,ack(m,n-1)))] | |
| ], -- [n m (m=0) [(n+1)] [(ack(m-1,1) | ack(m-1,ack(m,n-1)))]] | |
| AIdentifier "if", -- [n m [(n+1) | (ack(m-1,1) | ack(m-1,ack(m,n-1)))]] | |
| AIdentifier "unquote" -- [(n+1 | ack(m-1,1) | ack(m-1,ack(m,n-1)))] | |
| ] |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment