Compare commits
9
Commits
f592a4ecbd
...
2dffdf112c
| Author | SHA1 | Date | |
|---|---|---|---|
 msyds
|
2dffdf112c | ||
|
msyds
|
016ac791ad | ||
|
msyds
|
08b8bc50d6 | ||
|
msyds
|
f593227a70 | ||
|
msyds
|
60482e3567 | ||
|
msyds
|
8a800fdcb2 | ||
|
msyds
|
269d956566 | ||
|
msyds
|
4522e455dd | ||
|
msyds
|
fdf3064665 |
@@ -0,0 +1,17 @@
|
||||
#+title: representation of Scheme types
|
||||
|
||||
the Scheme unitype is encoded as ~(ref eq)~ with immediates in ~(ref i31)~ and heap objects in ~$heap-object~:
|
||||
#+begin_src wat
|
||||
(type $heap-object (sub (struct (field $hash (mut i32)))))
|
||||
#+end_src
|
||||
|
||||
* immediates
|
||||
|
||||
all immediates are stored in ~(ref i31)~ and thus must fit in 31 bits. the most important immediate, the integer, is indicated by a null low bit.
|
||||
#+begin_example
|
||||
XXXX XXXX XXXX XXXX XXXX XXXX XXXX XX00
|
||||
||
|
||||
|\ used by wasm's i31 rep
|
||||
zero indicates a 30-bit fixnum /
|
||||
in the upper bits
|
||||
#+end_example
|
||||
@@ -16,15 +16,23 @@
|
||||
"x86_64-darwin" "x86_64-linux"
|
||||
];
|
||||
|
||||
|
||||
overlays = [
|
||||
haskellNix.overlay
|
||||
(final: prev: {
|
||||
gyehoek-wasmtime-wrapper = final.callPackage ./wasmtime.nix {};
|
||||
})
|
||||
(final: prev: {
|
||||
gyehoek = final.haskell-nix.project' {
|
||||
src = ./.;
|
||||
compiler-nix-name = "ghc912";
|
||||
modules = [({ pkgs, lib, ...}: {
|
||||
packages.gyehoek.components.tests.test.preCheck =
|
||||
let bin = [pkgs.wasmtime pkgs.git];
|
||||
let
|
||||
bin = [
|
||||
pkgs.gyehoek-wasmtime-wrapper
|
||||
pkgs.git
|
||||
];
|
||||
in ''
|
||||
# Wasmtime requires a cache in $HOME. This is less
|
||||
# painful than reconfiguring the cache location.
|
||||
@@ -44,10 +52,10 @@
|
||||
self.packages.${final.stdenv.hostPlatform.system}.shake
|
||||
final.wabt
|
||||
final.nodejs
|
||||
final.wasmtime
|
||||
final.wasm-tools
|
||||
final.wac-cli
|
||||
final.guile
|
||||
final.gyehoek-wasmtime-wrapper
|
||||
];
|
||||
};
|
||||
};
|
||||
|
||||
+30
-2
@@ -1,19 +1,47 @@
|
||||
(module
|
||||
(type $heap-object (sub (struct (field (mut i32)))))
|
||||
(func
|
||||
(param)
|
||||
(result i32)
|
||||
(local i32 i32 i32 i32 i32)
|
||||
(result (ref eq))
|
||||
(local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
|
||||
(i32.const 3)
|
||||
(i32.const 2)
|
||||
i32.shl
|
||||
ref.i31
|
||||
(ref.cast (ref i31))
|
||||
i31.get_s
|
||||
(i32.const 4)
|
||||
(i32.const 2)
|
||||
i32.shl
|
||||
ref.i31
|
||||
(ref.cast (ref i31))
|
||||
i31.get_s
|
||||
i32.mul
|
||||
ref.i31
|
||||
(local.set 0)
|
||||
(i32.const 2)
|
||||
(i32.const 2)
|
||||
i32.shl
|
||||
ref.i31
|
||||
(ref.cast (ref i31))
|
||||
i31.get_s
|
||||
(i32.const 5)
|
||||
(i32.const 2)
|
||||
i32.shl
|
||||
ref.i31
|
||||
(ref.cast (ref i31))
|
||||
i31.get_s
|
||||
i32.mul
|
||||
ref.i31
|
||||
(local.set 1)
|
||||
(local.get 0)
|
||||
(ref.cast (ref i31))
|
||||
i31.get_s
|
||||
(local.get 1)
|
||||
(ref.cast (ref i31))
|
||||
i31.get_s
|
||||
i32.add
|
||||
ref.i31
|
||||
(local.set 2)
|
||||
(local.get 2))
|
||||
(export "main" (func 0)))
|
||||
@@ -1,11 +1,13 @@
|
||||
(module
|
||||
(type (sub (struct (field (mut i32)))))
|
||||
(func
|
||||
(param)
|
||||
(result i32)
|
||||
(local i32 i32 i32 i32 i32)
|
||||
(result (ref eq))
|
||||
(local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
|
||||
(i32.const 0)
|
||||
ref.i31
|
||||
(if
|
||||
(result i32)
|
||||
(then (i32.const 777))
|
||||
(else (i32.const 555))))
|
||||
(then (i32.const 777) ref.i31)
|
||||
(else (i32.const 555) ref.i31)))
|
||||
(export "main" (func 0)))
|
||||
@@ -1,11 +1,13 @@
|
||||
(module
|
||||
(type (sub (struct (field (mut i32)))))
|
||||
(func
|
||||
(param)
|
||||
(result i32)
|
||||
(local i32 i32 i32 i32 i32)
|
||||
(result (ref eq))
|
||||
(local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
|
||||
(i32.const 1)
|
||||
ref.i31
|
||||
(if
|
||||
(result i32)
|
||||
(then (i32.const 777))
|
||||
(else (i32.const 555))))
|
||||
(then (i32.const 777) ref.i31)
|
||||
(else (i32.const 555) ref.i31)))
|
||||
(export "main" (func 0)))
|
||||
@@ -0,0 +1 @@
|
||||
(λ (x) x)
|
||||
+20
@@ -0,0 +1,20 @@
|
||||
<html>
|
||||
<head>
|
||||
<script>
|
||||
const imports = {
|
||||
guppy: {
|
||||
print: (arg) => console.log (arg)
|
||||
}
|
||||
}
|
||||
|
||||
fetch("u.wasm")
|
||||
.then((response) => response.arrayBuffer())
|
||||
.then((bytes) => WebAssembly.instantiate(bytes, imports))
|
||||
.then((results) => {
|
||||
results.instance.exports.main ();
|
||||
});
|
||||
</script>
|
||||
</head>
|
||||
<body>
|
||||
</body>
|
||||
</html>
|
||||
+241
-57
@@ -4,16 +4,18 @@
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE MultilineStrings #-}
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
{-# LANGUAGE ApplicativeDo #-}
|
||||
{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
|
||||
{- HLINT ignore "Use camelCase" -}
|
||||
module Gyehoek.CPS.Lower
|
||||
(
|
||||
lower, lowerProgram) where
|
||||
(lower, lowerProgram) where
|
||||
|
||||
import Gyehoek.CPS.Syntax
|
||||
import Data.Generics.Labels
|
||||
import Gyehoek.Scheme.Syntax qualified as Scm
|
||||
import Gyehoek.GenSym
|
||||
import Data.List.NonEmpty (NonEmpty((:|)))
|
||||
import Data.List (List)
|
||||
import Effectful
|
||||
import Control.Monad.Cont qualified as Cont
|
||||
import Effectful.Writer.Static.Local
|
||||
@@ -31,77 +33,259 @@ import qualified Data.Vector.Strict as V
|
||||
import Data.IntMap.Strict (IntMap)
|
||||
import Data.String.Interpolate
|
||||
import Gyehoek.Wasm qualified as Wasm
|
||||
import Gyehoek.Wasm (i32, ins, sxp)
|
||||
import Gyehoek.Wasm hiding (Expr)
|
||||
import Language.Sexp.Located qualified as SL
|
||||
import Debug.Pretty.Simple
|
||||
import Control.Monad.Fix
|
||||
import Language.Sexp.Located (Sexp)
|
||||
import Data.Functor.Foldable (cata)
|
||||
|
||||
|
||||
data Env = MkEnv { vars :: Vector Name }
|
||||
data Env = MkEnv
|
||||
{ runtime :: Runtime
|
||||
, vars :: Vector Name
|
||||
, kvars :: Vector Name
|
||||
}
|
||||
deriving (Show, Generic)
|
||||
|
||||
emptyEnv :: Env
|
||||
emptyEnv = MkEnv mempty
|
||||
|
||||
type instance Index Env = Natural
|
||||
type instance IxValue Env = Name
|
||||
|
||||
instance Ixed Env where
|
||||
ix i = #vars . ix (fromIntegral i)
|
||||
|
||||
|
||||
|
||||
tshow :: Show a => a -> Text
|
||||
tshow = T.pack . show
|
||||
data Runtime = MkRuntime
|
||||
{ argArrayType :: Idx
|
||||
, argArray :: Idx
|
||||
, contType :: Idx
|
||||
, contStackType :: Idx
|
||||
, contStackTop :: Idx
|
||||
, contStack :: Idx
|
||||
, result :: Idx
|
||||
, halt :: Idx
|
||||
}
|
||||
deriving (Show, Generic)
|
||||
|
||||
|
||||
|
||||
lowerVal :: Env -> Val -> Wasm.Expr
|
||||
-- | @makeSmallFixnum@ emits an expression injecting the i32 on top
|
||||
-- of the stack into the SCM unitype.
|
||||
-- makeSmallFixnum :: Wasm.Expr
|
||||
-- makeSmallFixnum = mconcat
|
||||
-- [ ins "i32.const" [sxp @Int 1]
|
||||
-- , ins "i32.shl" []
|
||||
-- , ins "ref.i31" []
|
||||
-- ]
|
||||
|
||||
lowerVal g (ValLit l) =
|
||||
case l of
|
||||
LitInt n -> ins "i32.const" [sxp n]
|
||||
LitBool b -> ins "i32.const" [sxp @Int $ if b then 1 else 0]
|
||||
_ -> _
|
||||
-- | Given an expression @e@ leaving a @ref eq@ atop the stack,
|
||||
-- @pushArg rt n e@ sets the nth slot of the arg-passing array to the
|
||||
-- result of @e@.
|
||||
-- pushArg :: Runtime -> Int -> Wasm.Expr -> Wasm.Expr
|
||||
-- pushArg (MkRuntime {argArrayType,argArray}) n e = mconcat
|
||||
-- [ ins "global.get" [sxp argArray]
|
||||
-- , ins "i32.const" [sxp n]
|
||||
-- , e
|
||||
-- , ins "array.set" [sxp argArrayType]
|
||||
-- ]
|
||||
|
||||
lowerVal g (ValVar x) = ins "local.get" [sxp l]
|
||||
where
|
||||
l = V.elemIndex x g.vars ^?! _Just
|
||||
|
||||
lower' :: Env -> Exp -> Wasm.Expr
|
||||
|
||||
lower' g (Halt [e]) = lowerVal g e
|
||||
|
||||
lower' g (ExpPrim p rs e) =
|
||||
case p of
|
||||
PrimAdd x y -> lowerBinOp "i32.add" g x y r e
|
||||
PrimMul x y -> lowerBinOp "i32.mul" g x y r e
|
||||
where
|
||||
r = head rs
|
||||
|
||||
lower' g (ExpIf c t f) =
|
||||
lowerVal g c
|
||||
<> Wasm.if' (Wasm.result [i32])
|
||||
(lower' g t)
|
||||
(lower' g f)
|
||||
|
||||
lowerBinOp
|
||||
:: _
|
||||
-> _ -> _ -> _ -> _ -> _ -> Wasm.Expr
|
||||
lowerBinOp op g x y r e =
|
||||
lowerVal g x
|
||||
<> lowerVal g y
|
||||
<> ins op []
|
||||
<> ins "local.set" [sxp n]
|
||||
<> lower' g' e
|
||||
where
|
||||
g' = g & #vars <>~ [r]
|
||||
n = length (g ^. #vars)
|
||||
-- | Pop the nth arg from the arg-passing array onto the stack.
|
||||
-- popArg :: Runtime -> Int -> Wasm.Expr
|
||||
-- popArg (MkRuntime {argArrayType,argArray}) n = mconcat
|
||||
-- [ ins "global.get" [sxp argArray]
|
||||
-- , ins "i32.const" [sxp n]
|
||||
-- , ins "array.get" [sxp argArrayType]
|
||||
-- , ins "ref.as_non_null" []
|
||||
-- ]
|
||||
|
||||
|
||||
|
||||
lower :: Exp -> Eff es Text
|
||||
lower e = fmap Wasm.renderModule . Wasm.execGenMod $ do
|
||||
main <- Wasm.defun [] [i32] [i32, i32, i32, i32, i32] \_ ->
|
||||
lower' emptyEnv e
|
||||
Wasm.export "main" "func" main
|
||||
-- lowerVal :: Env -> Val -> Wasm.Expr
|
||||
|
||||
lowerProgram :: Program -> Eff es Text
|
||||
lowerProgram (MkProgram e) = lower e
|
||||
-- lowerVal g (ValLit l) =
|
||||
-- case l of
|
||||
-- LitInt n ->
|
||||
-- ins "i32.const" [sxp n]
|
||||
-- <> makeSmallFixnum
|
||||
-- LitBool b ->
|
||||
-- ins "i32.const" [sxp @Int $ if b then 1 else 0]
|
||||
-- <> ins "ref.i31" []
|
||||
-- _ -> _
|
||||
|
||||
-- lowerVal g (ValVar x) = ins "local.get" [sxp (1+l)]
|
||||
-- where
|
||||
-- l = V.elemIndex x g.vars ^?! _Just
|
||||
|
||||
-- lower' :: (GenMod :> es) => Env -> Exp -> Eff es Wasm.Expr
|
||||
|
||||
-- lower' g (Halt [v]) = pure . mconcat $
|
||||
-- [ pushArg g.runtime 0 (lowerVal g v)
|
||||
-- , ins "return_call" [sxp @Int 1]
|
||||
-- ]
|
||||
|
||||
-- lower' g (ExpPrim p rs e) =
|
||||
-- case p of
|
||||
-- PrimAdd x y -> lowerBinOp "i32.add" g x y r e
|
||||
-- PrimMul x y -> lowerBinOp "i32.mul" g x y r e
|
||||
-- where
|
||||
-- r = head rs
|
||||
|
||||
-- lower' g (ExpIf c t f) = do
|
||||
-- t' <- lower' g t
|
||||
-- f' <- lower' g f
|
||||
-- pure $ lowerVal g c
|
||||
-- <> Wasm.if' (Wasm.result [i32]) t' f'
|
||||
|
||||
-- lower' g (ExpContinue k [x]) = pure . mconcat $
|
||||
-- [ pushArg rt 0 (lowerVal g x)
|
||||
-- , ins "i32.const" [sxp @Int 1] -- nargs
|
||||
-- -- get the return continuation.
|
||||
-- , ins "global.get" [sxp rt.contStack]
|
||||
-- , ins "global.get" [sxp rt.contStackTop]
|
||||
-- , ins "array.get" [sxp rt.contStackType]
|
||||
-- , ins "ref.as_non_null" []
|
||||
-- -- decrement contStackTop, completing the "pop."
|
||||
-- , ins "global.get" [sxp rt.contStackTop]
|
||||
-- , ins "i32.const" [sxp @Int (1 + l)]
|
||||
-- , ins "i32.sub" []
|
||||
-- , ins "global.set" [sxp rt.contStackTop]
|
||||
-- , ins "return_call_ref" [sxp rt.contType]
|
||||
-- ]
|
||||
-- where
|
||||
-- rt = g.runtime
|
||||
-- l = V.elemIndex k g.kvars ^?! _Just
|
||||
|
||||
-- lower' g (ExpLet [(r,MkLambda xs ktail m)] e) = do
|
||||
-- idx <- defun [i32] [] (replicate 5 scm) \_ -> do
|
||||
-- let g' = g & #vars <>~ V.fromList xs
|
||||
-- & #kvars <>~ [ktail]
|
||||
-- m' <- lower' g' m
|
||||
-- pure . mconcat $
|
||||
-- [ xs & ifoldMap \n _ ->
|
||||
-- popArg g.runtime n <> ins "local.set" [sxp (1+n)]
|
||||
-- , m'
|
||||
-- ]
|
||||
-- declareFuncref idx
|
||||
-- let g' = g & #vars <>~ [r]
|
||||
-- let n = length g.vars
|
||||
-- e' <- lower' g' e
|
||||
-- pure . mconcat $
|
||||
-- [ ins "ref.func" [sxp idx]
|
||||
-- , ins "local.set" [sxp (n+1)]
|
||||
-- , e'
|
||||
-- ]
|
||||
|
||||
-- lower' g e = error . show $ e
|
||||
|
||||
-- lowerBinOp
|
||||
-- :: (GenMod :> es)
|
||||
-- => Text -> Env -> Val -> Val -> Name -> Exp -> Eff es Wasm.Expr
|
||||
-- lowerBinOp op g x y r e = do
|
||||
-- e' <- lower' g' e
|
||||
-- pure . mconcat $
|
||||
-- [ lowerVal g x
|
||||
-- , ins "ref.cast" [sxp $ ref i31]
|
||||
-- , ins "i31.get_s" []
|
||||
-- , lowerVal g y
|
||||
-- , ins "ref.cast" [sxp $ ref i31]
|
||||
-- , ins "i31.get_s" []
|
||||
-- , ins op []
|
||||
-- , ins "ref.i31" []
|
||||
-- , ins "local.set" [sxp (1+n)]
|
||||
-- , e'
|
||||
-- ]
|
||||
-- where
|
||||
-- g' = g & #vars <>~ [r]
|
||||
-- n = length (g ^. #vars)
|
||||
|
||||
|
||||
|
||||
-- scm = ref eq
|
||||
|
||||
|
||||
|
||||
-- emitRuntime :: GenMod :> es => Eff es Runtime
|
||||
-- emitRuntime = mfix \runtime -> do
|
||||
-- heapObjectIdx <- Wasm.deftypeNamed "$heap-object" $ Wasm.sub [] $ Wasm.struct
|
||||
-- [ Wasm.mut i32 ]
|
||||
-- -- cont stack
|
||||
-- contType <- Wasm.deftype $ Wasm.func [i32] []
|
||||
-- contStackType <- Wasm.deftype $ array $ mut $ refnull (fromIdx contType)
|
||||
-- contStackTop <- Wasm.defglobal (mut i32) $ ins "i32.const" [sxp @Int 0]
|
||||
-- contStack <- Wasm.defglobal (ref (Wasm.fromIdx contStackType)) $
|
||||
-- ins "i32.const" [sxp @Int 128]
|
||||
-- <> ins "array.new_default" [sxp contStackType]
|
||||
-- -- arg array
|
||||
-- argArrayType <- Wasm.deftype $ Wasm.array $ mut $ refnull eq
|
||||
-- argArray <- Wasm.defglobal (ref (Wasm.fromIdx argArrayType)) $
|
||||
-- ins "i32.const" [sxp @Int 32]
|
||||
-- <> ins "array.new_default" [sxp argArrayType]
|
||||
-- -- consIdx <- Wasm.defun _ _ _ _
|
||||
-- result <- Wasm.defglobal (mut (refnull eq)) $ ins "ref.null" [sxp eq]
|
||||
-- halt <- Wasm.defun [i32] [] (replicate 5 scm) \_ ->
|
||||
-- pure . mconcat $
|
||||
-- [ popArg runtime 0
|
||||
-- , ins "global.set" [sxp result]
|
||||
-- ]
|
||||
-- pure $ MkRuntime
|
||||
-- {argArray,argArrayType
|
||||
-- ,contStack,contStackTop,contStackType,contType
|
||||
-- ,result,halt}
|
||||
-- -- pure $ error "todo"
|
||||
|
||||
-- lower :: Exp -> Eff es Text
|
||||
-- lower e = fmap Wasm.renderModule . Wasm.execGenMod $ do
|
||||
-- runtime <- emitRuntime
|
||||
-- let g = MkEnv runtime mempty mempty
|
||||
-- scm_entry <- Wasm.defun [i32] [] (replicate 5 scm) \_ ->
|
||||
-- lower' g e
|
||||
-- main <- Wasm.defun [] [scm] [scm, scm, scm, scm, scm] \_ ->
|
||||
-- pure . mconcat $
|
||||
-- -- push return cont
|
||||
-- [-- ins "ref.func" [sxp halt]
|
||||
-- -- make call
|
||||
-- ins "i32.const" [sxp @Int 0]
|
||||
-- , ins "call" [sxp scm_entry]
|
||||
-- , ins "global.get" [sxp runtime.result]
|
||||
-- , ins "ref.as_non_null" []
|
||||
-- ]
|
||||
-- Wasm.export "main" "func" main
|
||||
|
||||
-- lowerProgram :: Program -> Eff es Text
|
||||
-- lowerProgram (MkProgram e) = lower e
|
||||
|
||||
lower = _
|
||||
lowerProgram = _
|
||||
|
||||
antiquote_example =
|
||||
let
|
||||
metavar :: Integer
|
||||
metavar = 123
|
||||
|
||||
e1 :: Wasm.Expr
|
||||
e1 = [expr|
|
||||
(func $blah (result i32)
|
||||
(i32.const #{metavar}))
|
||||
|]
|
||||
|
||||
e2 :: Wasm.Expr
|
||||
e2 = [expr|
|
||||
(func $blah (result i32)
|
||||
(i32.const 123))
|
||||
|]
|
||||
in (metavar,e1,e2,e1==e2)
|
||||
|
||||
antiquote_splicing_example =
|
||||
let
|
||||
metavars :: List Sexp
|
||||
metavars = [sxs'|i32 i64 f64|]
|
||||
|
||||
e1 :: Wasm.Expr
|
||||
e1 = [expr|
|
||||
(func $blah (param ##{metavars}))
|
||||
|]
|
||||
|
||||
e2 :: Wasm.Expr
|
||||
e2 = [expr|
|
||||
(func $blah (param i32 i64 f64))
|
||||
|]
|
||||
in (metavars, e1, e2, e1 == e2)
|
||||
|
||||
@@ -1,5 +1,6 @@
|
||||
{-# LANGUAGE OverloadedLabels #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
module Gyehoek.CPS.Syntax
|
||||
( Val(..)
|
||||
, Kappa(..)
|
||||
|
||||
@@ -1,7 +1,9 @@
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE OverloadedLabels #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE PartialTypeSignatures #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE OrPatterns #-}
|
||||
@@ -17,6 +19,10 @@ module Gyehoek.Scheme.Syntax
|
||||
, CommandOrDef(..)
|
||||
, primSexpIso
|
||||
, pattern Void
|
||||
, free
|
||||
, qexp
|
||||
, qprog
|
||||
, subst
|
||||
)
|
||||
where
|
||||
|
||||
@@ -37,11 +43,17 @@ import Control.Lens
|
||||
import Data.String (IsString)
|
||||
import Data.Hashable (Hashable)
|
||||
import Control.Lens.Unsound (prismSum)
|
||||
import Data.Data (Data)
|
||||
import Data.Functor.Foldable.TH (makeBaseFunctor)
|
||||
import Data.Functor.Foldable hiding (fold)
|
||||
import Data.HashSet (HashSet)
|
||||
import qualified Data.HashSet as HS
|
||||
import Data.Foldable (fold)
|
||||
|
||||
|
||||
newtype Name = MkName { getName :: Text }
|
||||
deriving newtype (Show, Eq, IsString, Gen, Hashable)
|
||||
deriving stock (Generic)
|
||||
deriving stock (Generic, Data)
|
||||
|
||||
data Prim e
|
||||
= PrimAdd e e
|
||||
@@ -57,7 +69,7 @@ data Prim e
|
||||
| PrimWrite e
|
||||
| PrimZeroP e
|
||||
| PrimNewline
|
||||
deriving (Show, Generic, Functor, Foldable, Traversable)
|
||||
deriving (Show, Generic, Functor, Foldable, Traversable, Data)
|
||||
|
||||
instance Each (Prim e) (Prim e') e e'
|
||||
|
||||
@@ -67,7 +79,7 @@ data Lit
|
||||
| LitBool Bool
|
||||
| LitString Text
|
||||
| LitQuote Sexp
|
||||
deriving (Show, Generic)
|
||||
deriving (Show, Generic, Data)
|
||||
|
||||
pattern Void :: Lit
|
||||
pattern Void = LitNil
|
||||
@@ -75,7 +87,7 @@ pattern Void = LitNil
|
||||
data Def
|
||||
= DefConstant Name Exp
|
||||
| DefProcedure Name (List Name) (List Exp)
|
||||
deriving (Show, Generic)
|
||||
deriving (Show, Generic, Data)
|
||||
|
||||
data Exp
|
||||
= ExpLet (NonEmpty (Name, Exp)) Exp
|
||||
@@ -86,24 +98,24 @@ data Exp
|
||||
| ExpLambda (List Name) Exp
|
||||
| ExpVar Name
|
||||
| ExpApply Exp (List Exp)
|
||||
deriving (Show, Generic)
|
||||
deriving (Show, Generic, Data)
|
||||
|
||||
data Sexp
|
||||
= SexpCons Sexp Sexp
|
||||
| SexpSymbol Text
|
||||
| SexpLit Lit
|
||||
deriving (Show, Generic)
|
||||
deriving (Show, Generic, Data)
|
||||
|
||||
data CommandOrDef
|
||||
= Command Exp
|
||||
| Definition Def
|
||||
| Begin (List CommandOrDef)
|
||||
deriving (Show, Generic)
|
||||
deriving (Show, Generic, Data)
|
||||
|
||||
data Program = MkProgram
|
||||
{ commandsAndDefs :: List CommandOrDef
|
||||
}
|
||||
deriving (Show, Generic)
|
||||
deriving (Show, Generic, Data)
|
||||
|
||||
instance Each Program Program (Either Exp Def) (Either Exp Def) where
|
||||
each = #commandsAndDefs . each . go
|
||||
@@ -116,6 +128,8 @@ instance Each Program Program (Either Exp Def) (Either Exp Def) where
|
||||
go k (Definition d) = inj <$> k (Right d)
|
||||
go k (Begin xs) = Begin <$> traverse (go k) xs
|
||||
|
||||
makeBaseFunctor ''Exp
|
||||
|
||||
|
||||
|
||||
instance SexpIso Name where
|
||||
@@ -211,3 +225,31 @@ instance SexpIso CommandOrDef where
|
||||
$ End
|
||||
where
|
||||
bgn = list $ el (sym "begin") >>> rest sexpIso
|
||||
|
||||
|
||||
-- utilities
|
||||
|
||||
qexp = Gyehoek.Sexp.makeSx $ sexpIso @Exp
|
||||
qprog = Gyehoek.Sexp.makeSxs (sexpIso @CommandOrDef) MkProgram
|
||||
|
||||
free :: Exp -> HashSet Name
|
||||
free = cata \case
|
||||
ExpVarF x -> HS.singleton x
|
||||
ExpLetF bs e -> error "todo lol"
|
||||
ExpLambdaF binders vs -> deleteFrom binders vs
|
||||
e -> fold e
|
||||
|
||||
deleteFrom :: (Foldable f, Hashable a) => f a -> HashSet a -> HashSet a
|
||||
deleteFrom = flip $ foldr HS.delete
|
||||
|
||||
insertFrom :: (Foldable f, Hashable a) => f a -> HashSet a -> HashSet a
|
||||
insertFrom = flip $ foldr HS.insert
|
||||
|
||||
subst :: (Name -> Maybe Exp) -> Exp -> Exp
|
||||
subst f = \e -> cata go e mempty where
|
||||
go (ExpVarF x) bound
|
||||
| not (x `HS.member` bound), Just e' <- f x = e'
|
||||
| otherwise = ExpVar x
|
||||
go (ExpLetF _ _) _ = error "todo lol"
|
||||
go (ExpLambdaF bs e) bound = e $ insertFrom bs bound
|
||||
go e bound = embed $ fmap ($ bound) e
|
||||
|
||||
+178
-6
@@ -4,6 +4,8 @@
|
||||
{-# LANGUAGE OverloadedLabels #-}
|
||||
{-# LANGUAGE DerivingVia #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TemplateHaskellQuotes #-}
|
||||
{-# LANGUAGE OrPatterns #-}
|
||||
module Gyehoek.Sexp
|
||||
( let_
|
||||
, sexp
|
||||
@@ -25,11 +27,23 @@ module Gyehoek.Sexp
|
||||
, encodePretty
|
||||
, UglySexpIso(..)
|
||||
, AsSexpIso(..)
|
||||
, parseSexpsWithPos
|
||||
, parseSexpWithPos
|
||||
, parseSexp
|
||||
, sx
|
||||
, sxs
|
||||
, makeSx
|
||||
, makeSxs
|
||||
, toSexp
|
||||
, fromSexp
|
||||
, stripLocation
|
||||
, sx'
|
||||
, sxs'
|
||||
)
|
||||
where
|
||||
|
||||
import Data.Text (Text)
|
||||
import Language.SexpGrammar as Sexp hiding (List, encode, decode, encodeWith, decodeWith, iso, encodePrettyWith, encodePretty)
|
||||
import Language.SexpGrammar as Sexp hiding (toSexp, List, encode, decode, encodeWith, decodeWith, iso, encodePrettyWith, encodePretty, fromSexp)
|
||||
import Language.SexpGrammar qualified as Sexp
|
||||
import Language.Sexp qualified as S
|
||||
import Language.SexpGrammar.Generic
|
||||
@@ -37,7 +51,8 @@ import Data.InvertibleGrammar.Base qualified as IGB
|
||||
import Data.InvertibleGrammar qualified as IG
|
||||
import Data.InvertibleGrammar.Base ((:-)((:-)))
|
||||
import Data.List.NonEmpty (NonEmpty ((:|)))
|
||||
import Data.List (List)
|
||||
import Data.List.NonEmpty qualified as NE
|
||||
import Data.List (List, groupBy)
|
||||
import Data.Text.Encoding
|
||||
import Data.Either (either)
|
||||
import GHC.Generics (Generic)
|
||||
@@ -47,10 +62,19 @@ import System.Process
|
||||
import GHC.IO.Unsafe (unsafePerformIO)
|
||||
import qualified Data.Text.IO as TIO
|
||||
import Control.Monad (join)
|
||||
import qualified Language.Sexp.Located as SexpLoc
|
||||
import Data.Void (absurd)
|
||||
import qualified Language.Sexp.Located as SL
|
||||
import Data.Void (absurd, Void)
|
||||
import Data.Coerce (coerce)
|
||||
import qualified Data.Map
|
||||
import Language.Haskell.TH.Quote
|
||||
import Language.Haskell.TH (Quote, location, Loc (..), ExpQ, varE, mkName, listE, Exp, appE, conE)
|
||||
import qualified Data.Text as T
|
||||
import qualified Control.Category
|
||||
import Data.Data (Data, Typeable, cast)
|
||||
import Language.Haskell.TH.Syntax (lift, Lift)
|
||||
import GHC.IsList (fromList)
|
||||
import Data.Functor.Foldable (cata)
|
||||
import Data.Functor.Classes (Show1(..))
|
||||
|
||||
|
||||
sexp :: SexpIso a => Iso' a Text
|
||||
@@ -78,8 +102,22 @@ encodePrettyWith g =
|
||||
(_Right %~ decodeUtf8 . view strict) . Sexp.encodePrettyWith g
|
||||
|
||||
parseSexps :: SexpIso a => FilePath -> Text -> Either String (List a)
|
||||
parseSexps f = marshal . SexpLoc.parseSexps f . view lazy . encodeUtf8
|
||||
where marshal = join . traverseOf (_Right . each) (fromSexp sexpIso)
|
||||
parseSexps f = marshal . SL.parseSexps f . view lazy . encodeUtf8
|
||||
where marshal = join . traverseOf (_Right . each) (Sexp.fromSexp sexpIso)
|
||||
|
||||
parseSexp :: SexpIso a => FilePath -> Text -> Either String a
|
||||
parseSexp f = marshal . SL.parseSexp f . view lazy . encodeUtf8
|
||||
where marshal = join . traverseOf _Right (Sexp.fromSexp sexpIso)
|
||||
|
||||
parseSexpsWithPos :: SexpGrammar a -> Position -> Text -> Either String (List a)
|
||||
parseSexpsWithPos g pos =
|
||||
marshal . SL.parseSexpsWithPos pos . view lazy . encodeUtf8
|
||||
where marshal = join . traverseOf (_Right . each) (Sexp.fromSexp g)
|
||||
|
||||
parseSexpWithPos :: SexpGrammar a -> Position -> Text -> Either String a
|
||||
parseSexpWithPos g pos =
|
||||
marshal . SL.parseSexpWithPos pos . view lazy . encodeUtf8
|
||||
where marshal = join . traverseOf _Right (Sexp.fromSexp g)
|
||||
|
||||
nonEmptyGrammar :: Grammar p (NonEmpty x :- t) (List x :- x :- t)
|
||||
nonEmptyGrammar = IGB.Iso
|
||||
@@ -183,3 +221,137 @@ instance UglySexpIso Int where uglySexpIso = sexpIso
|
||||
instance UglySexpIso Bool where uglySexpIso = sexpIso
|
||||
instance UglySexpIso Double where uglySexpIso = sexpIso
|
||||
instance UglySexpIso () where uglySexpIso = sexpIso
|
||||
|
||||
instance SexpIso Sexp where
|
||||
sexpIso = Control.Category.id
|
||||
|
||||
-- evil ass orphan instances
|
||||
deriving instance (Data a, Data e) => Data (SL.LocatedBy a e)
|
||||
deriving instance Data SL.Atom
|
||||
deriving instance Data SL.Prefix
|
||||
deriving instance Data SL.Position
|
||||
deriving instance (Data e) => Data (SL.SexpF e)
|
||||
|
||||
|
||||
-- Quasiquoter
|
||||
|
||||
getPos = do
|
||||
Loc {loc_filename,loc_start} <- location
|
||||
pure $ SL.Position loc_filename (fst loc_start) (snd loc_start)
|
||||
|
||||
fromSexp :: SexpIso a => Sexp -> a
|
||||
fromSexp = either error id . Sexp.fromSexp sexpIso
|
||||
|
||||
toSexp :: SexpIso a => a -> Sexp
|
||||
toSexp = either error id . Sexp.toSexp sexpIso
|
||||
|
||||
toSexps :: (Foldable f, SexpIso a) => f a -> List Sexp
|
||||
toSexps = foldMap \x -> [toSexp x]
|
||||
|
||||
pattern Unquote x =
|
||||
SL.Modified Hash (SL.BraceList [SL.Symbol x])
|
||||
pattern UnquoteSplicing x =
|
||||
SL.Modified Hash (SL.Modified Hash (SL.BraceList [SL.Symbol x]))
|
||||
|
||||
_UnquoteSplicing :: Prism' Sexp.Sexp Text
|
||||
_UnquoteSplicing = prism'
|
||||
UnquoteSplicing
|
||||
(\case { UnquoteSplicing x -> Just x ; _ -> Nothing })
|
||||
|
||||
instance Each Sexp Sexp Sexp Sexp where
|
||||
each k (SL.ParenList xs) = SL.ParenList <$> traverse k xs
|
||||
each k (SL.BracketList xs) = SL.BracketList <$> traverse k xs
|
||||
each k (SL.BraceList xs) = SL.BraceList <$> traverse k xs
|
||||
each _ e@(SL.Atom _; SL.Modified _ _) = pure e
|
||||
|
||||
stripLocation :: Sexp -> Sexp
|
||||
stripLocation = cata \case
|
||||
SL.Compose (a SL.:< e) ->
|
||||
SL.Fix . SL.Compose $ SL.dummyPos SL.:< e
|
||||
|
||||
metaSexp :: Sexp.Sexp -> Maybe ExpQ
|
||||
metaSexp (Unquote x) =
|
||||
Just [| stripLocation . toSexp $ $(varE (mkName (T.unpack x))) |]
|
||||
metaSexp (SL.ParenList xs)
|
||||
| (_:_) <- xs ^.. each . _UnquoteSplicing
|
||||
= Just [| stripLocation . toSexp $ SL.ParenList (mconcat $(listE spans)) |]
|
||||
where
|
||||
spans = xs
|
||||
& groupBy \cases
|
||||
(UnquoteSplicing _) _ -> False
|
||||
_ (UnquoteSplicing _) -> False
|
||||
_ _ -> True
|
||||
& fmap \case
|
||||
[UnquoteSplicing x] ->
|
||||
[| stripLocation <$> toSexps $(varE (mkName (T.unpack x))) |]
|
||||
x -> [| stripLocation <$> x |]
|
||||
metaSexp _ = Nothing
|
||||
|
||||
-- 뻘짓뻘짓뻘짓뻘짓뻘짓
|
||||
class Lift1 f where
|
||||
liftLift :: Quote m => (a -> m Exp) -> f a -> m Exp
|
||||
|
||||
lift1 :: (Lift1 f, Lift a, Quote m) => f a -> m Exp
|
||||
lift1 = liftLift lift
|
||||
|
||||
instance Lift1 f => Lift (SL.Fix f) where
|
||||
lift (SL.Fix inner) = appE [|SL.Fix|] (lift1 inner)
|
||||
|
||||
instance (Lift1 f, Lift1 g) => Lift1 (SL.Compose f g) where
|
||||
liftLift l (SL.Compose fga) = [|SL.Compose $(liftLift (liftLift l) fga)|]
|
||||
|
||||
instance Lift a => Lift1 (SL.LocatedBy a) where
|
||||
liftLift l (a SL.:< e) = [|(SL.:<) $(lift a) $(l e)|]
|
||||
|
||||
instance Lift1 List where
|
||||
liftLift l xs = listE $ l <$> xs
|
||||
|
||||
instance Lift1 SL.SexpF where
|
||||
liftLift l = \case
|
||||
SL.AtomF a -> [|SL.AtomF $(lift a)|]
|
||||
SL.ParenListF es -> [|SL.ParenListF $(liftLift l es)|]
|
||||
SL.BracketListF es -> [|SL.BracketListF $(liftLift l es)|]
|
||||
SL.BraceListF es -> [|SL.BraceListF $(liftLift l es)|]
|
||||
SL.ModifiedF p e -> [|SL.Modified $(lift p) $(l e)|]
|
||||
|
||||
-- deriving instance Lift a => Lift (SL.SexpF a)
|
||||
deriving instance Lift SL.Atom
|
||||
deriving instance Lift SL.Position
|
||||
deriving instance Lift SL.Prefix
|
||||
|
||||
extQ :: (Typeable a, Typeable b) => (a -> r) -> (b -> r) -> a -> r
|
||||
extQ f g a = maybe (f a) g (cast a)
|
||||
|
||||
makeSxs
|
||||
:: Data b
|
||||
=> (List a -> b) -> SexpGrammar a -> QuasiQuoter
|
||||
makeSxs f g = QuasiQuoter
|
||||
{ quoteExp = \str -> do
|
||||
pos <- getPos
|
||||
case parseSexpsWithPos g pos (T.pack str) of
|
||||
Left e -> fail e
|
||||
Right xs -> dataToExpQ (const Nothing `extQ` metaSexp) (f xs)
|
||||
, quotePat = undefined
|
||||
, quoteType = undefined
|
||||
, quoteDec = undefined
|
||||
}
|
||||
|
||||
makeSx
|
||||
:: (Data a, Data r)
|
||||
=> (a -> r) -> SexpGrammar a -> QuasiQuoter
|
||||
makeSx f g = QuasiQuoter
|
||||
{ quoteExp = \str -> do
|
||||
pos <- getPos
|
||||
case parseSexpWithPos g pos (T.pack str) of
|
||||
Left e -> fail e
|
||||
Right x -> dataToExpQ (const Nothing `extQ` metaSexp) (f x)
|
||||
, quotePat = undefined
|
||||
, quoteType = undefined
|
||||
, quoteDec = undefined
|
||||
}
|
||||
|
||||
sxs = makeSxs id (sexpIso @Sexp)
|
||||
sx = makeSx id (sexpIso @Sexp)
|
||||
|
||||
sxs' = makeSxs (fmap stripLocation) (sexpIso @Sexp)
|
||||
sx' = makeSx stripLocation (sexpIso @Sexp)
|
||||
|
||||
+125
-197
@@ -3,6 +3,7 @@
|
||||
{-# LANGUAGE DeepSubsumption #-}
|
||||
{-# LANGUAGE NoFieldSelectors #-}
|
||||
{-# LANGUAGE OverloadedRecordDot #-}
|
||||
{-# LANGUAGE RecordPuns #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE OverloadedLabels #-}
|
||||
@@ -10,29 +11,30 @@
|
||||
{-# LANGUAGE ImpredicativeTypes #-}
|
||||
{-# LANGUAGE DerivingVia #-}
|
||||
module Gyehoek.Wasm
|
||||
( defun
|
||||
, deftype
|
||||
, start
|
||||
(
|
||||
-- * syntax
|
||||
Module
|
||||
, Idx
|
||||
, Expr
|
||||
-- ** quasiquoters
|
||||
, expr
|
||||
, Gyehoek.Sexp.sx
|
||||
, Gyehoek.Sexp.sxs
|
||||
, Gyehoek.Sexp.sx'
|
||||
, Gyehoek.Sexp.sxs'
|
||||
-- * GenMod effect
|
||||
, GenMod
|
||||
, runGenMod
|
||||
, execGenMod
|
||||
, renderModule
|
||||
, Module
|
||||
, Function
|
||||
, Expr
|
||||
, Instr
|
||||
, GenMod
|
||||
, i32
|
||||
, export
|
||||
, ins
|
||||
, sxp
|
||||
, result
|
||||
, param
|
||||
, if'
|
||||
, defineFunction
|
||||
, defineType
|
||||
, defineGlobal
|
||||
, declare
|
||||
)
|
||||
where
|
||||
|
||||
import Language.SexpGrammar
|
||||
( SexpIso(..), list, el, (>>>), rest, sym, symbol )
|
||||
( SexpIso(..), list, el, (>>>), rest, sym, symbol, (:-) )
|
||||
import Language.SexpGrammar qualified as Sexp
|
||||
import Language.SexpGrammar.Generic
|
||||
import Data.List (List)
|
||||
@@ -59,199 +61,125 @@ import Language.Sexp.Located
|
||||
import qualified Gyehoek.Sexp
|
||||
import GHC.IsList (IsList(..))
|
||||
import Data.Coerce (coerce)
|
||||
import qualified Control.Category
|
||||
import Data.Functor (void)
|
||||
import Language.Haskell.TH.Quote (QuasiQuoter)
|
||||
import Data.Data (Data)
|
||||
import Data.Functor.Foldable (cata)
|
||||
|
||||
|
||||
data Module = MkModule
|
||||
{ types :: Vector Type
|
||||
, functions :: Vector Function
|
||||
, start :: Maybe Idx
|
||||
, exports :: Vector Export
|
||||
}
|
||||
deriving (Show, Generic)
|
||||
|
||||
instance Semigroup Module where
|
||||
m1 <> m2 = MkModule
|
||||
{ types = m1.types <> m2.types
|
||||
, functions = m1.functions <> m2.functions
|
||||
, start = m2.start <|> m1.start
|
||||
, exports = m1.exports <> m2.exports
|
||||
}
|
||||
|
||||
instance Monoid Module where
|
||||
mempty = MkModule mempty mempty Nothing mempty
|
||||
|
||||
data Function = MkFunction
|
||||
{ params :: List Type
|
||||
, result :: List Type
|
||||
, locals :: List Type
|
||||
, body :: Expr
|
||||
}
|
||||
deriving (Show, Generic)
|
||||
|
||||
newtype Export = MkExport { inner :: Sexp }
|
||||
deriving (Show, Generic)
|
||||
|
||||
newtype Expr = MkExpr { inner :: Vector Instr }
|
||||
newtype Module = MkModule { inner :: Vector Sexp }
|
||||
deriving (Show, Generic)
|
||||
deriving newtype (Semigroup, Monoid)
|
||||
|
||||
newtype Instr = MkInstr { inner :: Sexp }
|
||||
deriving (Show, Generic)
|
||||
|
||||
newtype Type = MkType { inner :: Sexp }
|
||||
deriving (Show, Generic)
|
||||
|
||||
newtype Idx = MkIdx { getIdx :: Natural }
|
||||
deriving newtype (Show)
|
||||
|
||||
data GenMod :: Effect where
|
||||
DefType :: Type -> GenMod m Idx
|
||||
Defun :: List Type -> List Type -> List Type -> (Idx -> Expr) -> GenMod m Idx
|
||||
Start :: Idx -> GenMod m ()
|
||||
Export :: Text -> Text -> Idx -> GenMod m ()
|
||||
|
||||
type instance DispatchOf GenMod = Dynamic
|
||||
|
||||
export :: (GenMod :> es) => Text -> Text -> Idx -> Eff es ()
|
||||
export name ty idx = send $ Export name ty idx
|
||||
|
||||
start :: (GenMod :> es) => Idx -> Eff es ()
|
||||
start = send . Start
|
||||
|
||||
deftype :: (GenMod :> es) => Type -> Eff es Idx
|
||||
deftype = send . DefType
|
||||
|
||||
defun
|
||||
:: (GenMod :> es)
|
||||
=> List Type -> List Type -> List Type
|
||||
-> (Idx -> Expr)
|
||||
-> Eff es Idx
|
||||
defun params result locals code = send $ Defun params result locals code
|
||||
|
||||
-- defun
|
||||
-- :: (GenMod :> es)
|
||||
-- => List Type -> List Type -> List Type
|
||||
-- -> (Idx -> Eff '[GenExp] a)
|
||||
-- -> Eff es Idx
|
||||
-- defun params result locals code =
|
||||
-- send $ Defun params result locals (runPureEff . execWriterLocal . code)
|
||||
|
||||
runGenMod :: Eff (GenMod : es) a -> Eff es (a, Module)
|
||||
runGenMod =
|
||||
reinterpret (runStateLocal (mempty :: Module)) \cases
|
||||
_ (DefType t) -> state \m ->
|
||||
( MkIdx . fromIntegral . length $ m.types
|
||||
, m & #types <>~ V.singleton t
|
||||
)
|
||||
_ (Start idx) -> assign #start (Just idx)
|
||||
_ (Export name ty idx) ->
|
||||
#exports <>= V.singleton e
|
||||
where e = MkExport $ ParenList
|
||||
[ "export", sxp name, ParenList [ "func", sxp idx ] ]
|
||||
_ (Defun params result locals code) -> state \m ->
|
||||
let idx = MkIdx . fromIntegral . length $ m.functions
|
||||
in ( idx
|
||||
, m & #functions <>~ V.singleton
|
||||
(MkFunction params result locals (code idx))
|
||||
)
|
||||
|
||||
execGenMod = fmap snd . runGenMod
|
||||
|
||||
renderModule :: Module -> Text
|
||||
renderModule = (^?! _Right) . Gyehoek.Sexp.encodePretty
|
||||
|
||||
i32 :: Type
|
||||
i32 = MkType $ Symbol "i32"
|
||||
|
||||
|
||||
|
||||
instance SexpIso Idx where
|
||||
sexpIso = Sexp.integer >>> Sexp.partialOsi f g
|
||||
where
|
||||
f n | n < 0 = Left $ Sexp.unexpected "negative" <> Sexp.expected "natural"
|
||||
| otherwise = Right . MkIdx $ fromIntegral n
|
||||
g (MkIdx n) = fromIntegral n
|
||||
|
||||
instance SexpIso Instr where
|
||||
sexpIso = Sexp.iso coerce coerce
|
||||
|
||||
instance SexpIso Type where
|
||||
sexpIso = Sexp.iso coerce coerce
|
||||
|
||||
instance SexpIso Export where
|
||||
sexpIso = Sexp.iso coerce coerce
|
||||
|
||||
instance SexpIso Function where
|
||||
sexpIso = with \func ->
|
||||
list ( el (sym "func")
|
||||
>>> el (list $ el (sym "param") >>> rest (sexpIso @Type))
|
||||
>>> el (list $ el (sym "result") >>> rest (sexpIso @Type))
|
||||
>>> el (list $ el (sym "local") >>> rest (sexpIso @Type))
|
||||
>>> rest (sexpIso @Instr)
|
||||
>>> Sexp.onTail
|
||||
(Sexp.iso
|
||||
(view instrsExpr)
|
||||
(review instrsExpr))
|
||||
)
|
||||
>>> func
|
||||
where
|
||||
instrsExpr :: Iso' (List Instr) Expr
|
||||
instrsExpr = vector . coerced
|
||||
|
||||
instance SexpIso Module where
|
||||
sexpIso = Sexp.partialOsi (const $ Left mempty) \m ->
|
||||
ParenList $
|
||||
[ Symbol "module" ]
|
||||
<> (m ^.. #types . each . #inner)
|
||||
<> (m ^.. #functions . each . to sxp)
|
||||
<> (m ^.. #exports . each . to sxp)
|
||||
|
||||
instance Each Expr Expr Instr Instr where
|
||||
each = #MkExpr . each
|
||||
|
||||
sxp :: SexpIso a => a -> Sexp
|
||||
sxp e = Sexp.toSexp sexpIso e ^?! _Right
|
||||
|
||||
ins :: Text -> List Sexp -> Expr
|
||||
ins op [] = [ MkInstr $ Symbol op ]
|
||||
ins op xs = [ MkInstr . ParenList $ Symbol op : xs ]
|
||||
|
||||
instance IsString Sexp where
|
||||
fromString = Symbol . T.pack
|
||||
newtype Expr = MkExpr { inner :: Vector Instr }
|
||||
deriving (Show, Generic, Data, Eq)
|
||||
deriving newtype (Semigroup, Monoid)
|
||||
|
||||
instance IsList Expr where
|
||||
type Item Expr = Instr
|
||||
fromList = MkExpr . V.fromList
|
||||
toList e = V.toList e.inner
|
||||
toList = V.toList . view #inner
|
||||
|
||||
data ResultType = MkResultType
|
||||
{ params :: List Type
|
||||
, result :: List Type
|
||||
newtype Instr = MkInstr { inner :: Sexp }
|
||||
deriving (Show, Generic, Data, Eq)
|
||||
|
||||
newtype Idx = MkIdx { inner :: Natural }
|
||||
deriving (Generic, Data)
|
||||
deriving newtype (Show)
|
||||
|
||||
|
||||
-- GenMod
|
||||
|
||||
-- | 'GenModState' is a 'Module' paired with the numbers of functions,
|
||||
-- types, globals, etc. defined in the module.
|
||||
data GenModState = MkGenModState
|
||||
{ mod :: Module
|
||||
, funcs :: Natural
|
||||
, types :: Natural
|
||||
, globals :: Natural
|
||||
}
|
||||
deriving stock (Generic)
|
||||
deriving (Semigroup, Monoid)
|
||||
via Generically ResultType
|
||||
deriving (Show, Generic)
|
||||
|
||||
param :: List Type -> ResultType
|
||||
param ts = MkResultType ts mempty
|
||||
instance Semigroup GenModState where
|
||||
m1 <> m2 = MkGenModState
|
||||
{ mod = m1.mod <> m2.mod
|
||||
, funcs = m1.funcs + m2.funcs
|
||||
, types = m1.types + m2.types
|
||||
, globals = m1.globals + m2.globals
|
||||
}
|
||||
|
||||
result :: List Type -> ResultType
|
||||
result ts = MkResultType mempty ts
|
||||
instance Monoid GenModState where
|
||||
mempty = MkGenModState
|
||||
{ mod = mempty
|
||||
, funcs = 0
|
||||
, types = 0
|
||||
, globals = 0
|
||||
}
|
||||
|
||||
resultTypeSexp :: ResultType -> List Sexp
|
||||
resultTypeSexp rt =
|
||||
f "param" (coerce <$> rt.params) <> f "result" (coerce <$> rt.result)
|
||||
where
|
||||
f :: Text -> List Sexp -> List Sexp
|
||||
f _ [] = []
|
||||
f kw s = [ ParenList $ Symbol kw : s ]
|
||||
data GenMod :: Effect where
|
||||
DefineFunction :: Sexp -> GenMod m Idx
|
||||
DefineType :: Sexp -> GenMod m Idx
|
||||
DefineGlobal :: Sexp -> GenMod m Idx
|
||||
Declare :: Sexp -> GenMod m ()
|
||||
|
||||
-- resultSexp :: ResultType -> Sexp
|
||||
-- resultSexp rt = ParenList $ Symbol "param" : (coerce <$> rt.result)
|
||||
type instance DispatchOf GenMod = Dynamic
|
||||
|
||||
if' :: ResultType -> Expr -> Expr -> Expr
|
||||
if' rt t f = MkExpr . V.singleton . MkInstr . ParenList $
|
||||
[ Symbol "if" ]
|
||||
<> resultTypeSexp rt
|
||||
<> [ ParenList $ Symbol "then" : (t ^.. each . to sxp) ]
|
||||
<> [ ParenList $ Symbol "else" : (f ^.. each . to sxp) ]
|
||||
defineFunction :: GenMod :> es => Sexp -> Eff es Idx
|
||||
defineFunction = send . DefineFunction
|
||||
|
||||
defineType :: GenMod :> es => Sexp -> Eff es Idx
|
||||
defineType = send . DefineType
|
||||
|
||||
defineGlobal :: GenMod :> es => Sexp -> Eff es Idx
|
||||
defineGlobal = send . DefineGlobal
|
||||
|
||||
declare :: GenMod :> es => Sexp -> Eff es ()
|
||||
declare = send . Declare
|
||||
|
||||
appendAndIncrement
|
||||
:: State GenModState :> es
|
||||
=> LensLike' ((,) _) GenModState Natural
|
||||
-> Sexp
|
||||
-> Eff es Idx
|
||||
appendAndIncrement l s =
|
||||
state \st -> st
|
||||
& #mod . #inner <>~ V.singleton s
|
||||
& l <<%~ succ
|
||||
& _1 %~ MkIdx
|
||||
|
||||
runGenMod :: Eff (GenMod : es) a -> Eff es (a, Module)
|
||||
runGenMod =
|
||||
let run = (mapped . _2 %~ view #mod) . runStateLocal (mempty @GenModState)
|
||||
in reinterpret run \cases
|
||||
_ (DefineFunction s) -> appendAndIncrement #funcs s
|
||||
_ (DefineType s) -> appendAndIncrement #types s
|
||||
_ (DefineGlobal s) -> appendAndIncrement #globals s
|
||||
_ (Declare s) -> #mod . #inner <>= V.singleton s
|
||||
|
||||
execGenMod :: Eff (GenMod : es) a -> Eff es Module
|
||||
execGenMod = fmap snd . runGenMod
|
||||
|
||||
|
||||
-- SexpIso instances
|
||||
|
||||
instance SexpIso Idx where
|
||||
sexpIso = with \idx ->
|
||||
Sexp.integer >>> Sexp.partialOsi f g
|
||||
>>> idx
|
||||
where
|
||||
f n | n < 0 = Left $ Sexp.unexpected "negative"
|
||||
<> Sexp.expected "natural"
|
||||
| otherwise = Right $ fromIntegral n
|
||||
g = fromIntegral
|
||||
|
||||
instance SexpIso Instr where
|
||||
sexpIso = with id
|
||||
|
||||
|
||||
-- quasiquoters
|
||||
|
||||
expr :: QuasiQuoter
|
||||
expr = Gyehoek.Sexp.makeSxs
|
||||
(MkExpr . V.fromList . (each . #inner %~ Gyehoek.Sexp.stripLocation))
|
||||
(sexpIso @Instr)
|
||||
|
||||
@@ -0,0 +1,18 @@
|
||||
const imports = {
|
||||
guppy: {
|
||||
print: (arg) => console.log (arg)
|
||||
}
|
||||
}
|
||||
|
||||
// Assume add.wasm file exists that contains a single function adding 2 provided arguments
|
||||
const fs = require('node:fs');
|
||||
|
||||
// Use the readFileSync function to read the contents of the "add.wasm" file
|
||||
const wasmBuffer = fs.readFileSync('u.wasm');
|
||||
|
||||
// Use the WebAssembly.instantiate method to instantiate the WebAssembly module
|
||||
WebAssembly.instantiate(wasmBuffer, imports).then(wasmModule => {
|
||||
// Exported function lives under instance.exports object
|
||||
const { main } = wasmModule.instance.exports;
|
||||
main ()
|
||||
});
|
||||
@@ -0,0 +1,69 @@
|
||||
(module
|
||||
(type $heap-object (sub (struct (field (mut i32)))))
|
||||
(type $open-procedure (func (param i32)))
|
||||
(type $closure (sub $heap-object
|
||||
(struct (field (mut i32))
|
||||
(field (ref $open-procedure)))))
|
||||
(type $cont-stack-type (array (mut (ref null $open-procedure))))
|
||||
(type $arg-array-type (array (mut (ref null eq))))
|
||||
(global $cont-stack-top (mut i32) (i32.const 0))
|
||||
(global $cont-stack (ref $cont-stack-type)
|
||||
(i32.const 128)
|
||||
(array.new_default $cont-stack-type))
|
||||
(global $arg-array (ref $arg-array-type)
|
||||
(i32.const 32)
|
||||
(array.new_default $arg-array-type))
|
||||
(global (mut (ref null eq)) (ref.null eq))
|
||||
(elem declare funcref (ref.func 1))
|
||||
(func
|
||||
(param i32)
|
||||
(result)
|
||||
(local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
|
||||
(global.get 2)
|
||||
(i32.const 0)
|
||||
(array.get 3)
|
||||
ref.as_non_null
|
||||
(global.set 3))
|
||||
(func
|
||||
(param i32)
|
||||
(result)
|
||||
(local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
|
||||
(global.get 2)
|
||||
(i32.const 0)
|
||||
(array.get 3)
|
||||
ref.as_non_null
|
||||
(local.set 1)
|
||||
(global.get 2)
|
||||
(i32.const 0)
|
||||
(local.get 1)
|
||||
(array.set 3)
|
||||
(i32.const 1)
|
||||
(global.get 1)
|
||||
(global.get 0)
|
||||
(array.get 2)
|
||||
ref.as_non_null
|
||||
(global.get 0)
|
||||
(i32.const 1)
|
||||
i32.sub
|
||||
(global.set 0)
|
||||
(return_call_ref 1))
|
||||
(func
|
||||
(param i32)
|
||||
(result)
|
||||
(local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
|
||||
(ref.func 1)
|
||||
(local.set 1)
|
||||
(global.get 2)
|
||||
(i32.const 0)
|
||||
(local.get 1)
|
||||
(array.set 3)
|
||||
(return_call 1))
|
||||
(func
|
||||
(param)
|
||||
(result (ref eq))
|
||||
(local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
|
||||
(i32.const 0)
|
||||
(call 1)
|
||||
(global.get 3)
|
||||
ref.as_non_null)
|
||||
(export "main" (func 3)))
|
||||
@@ -0,0 +1,65 @@
|
||||
(module
|
||||
(type $heap-object (sub (struct (field (mut i32)))))
|
||||
(type $open-procedure (func (param i32)))
|
||||
(type $closure (sub $heap-object
|
||||
(struct (field (mut i32))
|
||||
(field (ref $open-procedure)))))
|
||||
(type $cont-stack-type (array (mut (ref null $open-procedure))))
|
||||
(type $arg-array-type (array (mut eqref)))
|
||||
(type (func (result (ref eq))))
|
||||
(global $cont-stack-top (mut i32) (i32.const 0))
|
||||
(global $cont-stack (ref $cont-stack-type)
|
||||
(array.new_default $cont-stack-type (i32.const 128)))
|
||||
(global $arg-array (ref $arg-array-type)
|
||||
(array.new_default $arg-array-type (i32.const 32)))
|
||||
(global (mut eqref) (ref.null eq))
|
||||
(elem declare funcref (ref.func 1))
|
||||
(func $halt (param i32)
|
||||
(local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
|
||||
(global.set 3
|
||||
(ref.as_non_null
|
||||
(array.get $arg-array-type
|
||||
(global.get $arg-array)
|
||||
(i32.const 0)))))
|
||||
(func $f1 (param i32)
|
||||
(local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
|
||||
;; pop arg 0
|
||||
(local.set
|
||||
1
|
||||
(ref.as_non_null
|
||||
(array.get $arg-array-type
|
||||
(global.get $arg-array)
|
||||
(i32.const 0))))
|
||||
;; push arg 0
|
||||
(array.set $arg-array-type
|
||||
(global.get $arg-array)
|
||||
(i32.const 0)
|
||||
(local.get 1))
|
||||
;; pop continuation
|
||||
(return_call_ref
|
||||
$open-procedure
|
||||
(i32.const 1)
|
||||
(ref.as_non_null (array.get $cont-stack-type
|
||||
(global.get $cont-stack)
|
||||
(global.get $cont-stack-top)))
|
||||
(global.set $cont-stack-top
|
||||
(i32.sub
|
||||
(global.get $cont-stack-top)
|
||||
(i32.const 1)))))
|
||||
(func $f2 (type $open-procedure) (param i32)
|
||||
(local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
|
||||
(local.set 1
|
||||
(struct.new $closure
|
||||
(i32.const 0)
|
||||
(ref.func $f1)))
|
||||
(array.set $arg-array-type
|
||||
(global.get $arg-array)
|
||||
(i32.const 0)
|
||||
(local.get 1))
|
||||
(i32.const 1)
|
||||
(return_call $f1))
|
||||
(func $main (export "main") (result (ref eq))
|
||||
(local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
|
||||
(call $f2 (i32.const 0))
|
||||
(ref.as_non_null
|
||||
(global.get 3))))
|
||||
@@ -0,0 +1,78 @@
|
||||
(module
|
||||
(func $print (import "guppy" "print") (param i32))
|
||||
(table 2 funcref)
|
||||
(elem (i32.const 0) $halt)
|
||||
|
||||
(type $cont (func (param i32)))
|
||||
(type $cont-stack-type (array (mut (ref null $cont))))
|
||||
(global $cont-stack (ref $cont-stack-type)
|
||||
(array.new_default $cont-stack-type (i32.const 128)))
|
||||
(global $cont-stack-top (mut i32) (i32.const 0))
|
||||
|
||||
(type $arg-array-type (array (mut (ref null eq))))
|
||||
(global $arg-array (ref $arg-array-type)
|
||||
(array.new_default $arg-array-type (i32.const 32)))
|
||||
|
||||
;; (memory $memory i32 1)
|
||||
;; (global $arg-stack-base i32 (i32.const 0))
|
||||
;; (global $arg-stack-ptr i32 (global.get $arg-stack-base))
|
||||
;; (global $cont-stack-base i32 (i32.const 32))
|
||||
;; (global $cont-stack-ptr i32 (global.get $cont-stack-base))
|
||||
|
||||
(func $add (param $nargs i32)
|
||||
(local $x (ref eq))
|
||||
(local $y (ref eq))
|
||||
(local $return (ref $cont))
|
||||
(local.set $x (ref.as_non_null
|
||||
(array.get $arg-array-type
|
||||
(global.get $arg-array)
|
||||
(i32.const 0))))
|
||||
(local.set $y (ref.as_non_null
|
||||
(array.get $arg-array-type
|
||||
(global.get $arg-array)
|
||||
(i32.const 1))))
|
||||
(array.set $arg-array-type
|
||||
(global.get $arg-array)
|
||||
(i32.const 0)
|
||||
(ref.i31
|
||||
(i32.add (i31.get_s (ref.cast (ref i31) (local.get $x)))
|
||||
(i31.get_s (ref.cast (ref i31) (local.get $y))))))
|
||||
(return_call_ref
|
||||
$cont
|
||||
(i32.const 1)
|
||||
(block (result (ref $cont))
|
||||
(ref.as_non_null
|
||||
(array.get $cont-stack-type
|
||||
(global.get $cont-stack)
|
||||
(global.get $cont-stack-top)))
|
||||
(global.set $cont-stack-top
|
||||
(i32.sub (global.get $cont-stack-top)
|
||||
(i32.const 1))))))
|
||||
(func $halt (param $nargs i32)
|
||||
(call $print
|
||||
(i31.get_s
|
||||
(ref.cast
|
||||
(ref i31)
|
||||
(ref.as_non_null
|
||||
(array.get $arg-array-type
|
||||
(global.get $arg-array)
|
||||
(i32.const 0)))))))
|
||||
(func (export "main")
|
||||
;; push args
|
||||
(array.set $arg-array-type
|
||||
(global.get $arg-array)
|
||||
(i32.const 0)
|
||||
(ref.i31 (i32.const 4)))
|
||||
(array.set $arg-array-type
|
||||
(global.get $arg-array)
|
||||
(i32.const 1)
|
||||
(ref.i31 (i32.const 5)))
|
||||
;; push return continuation
|
||||
(array.set $cont-stack-type
|
||||
(global.get $cont-stack)
|
||||
(i32.const 0)
|
||||
(ref.func $halt))
|
||||
;; make call }:)
|
||||
(return_call $add
|
||||
;; inform $add how many arguments we called it with
|
||||
(i32.const 2))))
|
||||
@@ -0,0 +1,26 @@
|
||||
# A Wasmtime wrapper that provides our desired configuration.
|
||||
{ wasmtime
|
||||
, makeWrapper
|
||||
, symlinkJoin
|
||||
, formats
|
||||
, extraSettings ? {}
|
||||
}:
|
||||
|
||||
let
|
||||
config = {
|
||||
wasm.gc = true;
|
||||
};
|
||||
config-file =
|
||||
(formats.toml {}).generate
|
||||
"gyehoek-wasmtime.toml"
|
||||
(config // extraSettings);
|
||||
in symlinkJoin {
|
||||
name = "gyehoek-wasmtime";
|
||||
inherit (wasmtime) version;
|
||||
paths = [ wasmtime ];
|
||||
nativeBuildInputs = [ makeWrapper ];
|
||||
postBuild = ''
|
||||
wrapProgram $out/bin/wasmtime \
|
||||
--add-flags "--config ${config-file}"
|
||||
'';
|
||||
}
|
||||
@@ -0,0 +1,6 @@
|
||||
# Comment out certain settings to use default values.
|
||||
# For more settings, please refer to the documentation:
|
||||
# https://bytecodealliance.github.io/wasmtime/cli-cache.html
|
||||
|
||||
[wasm]
|
||||
gc=true
|
||||
Reference in New Issue
Block a user