Compare commits
8
Commits
f592a4ecbd
...
lam
| Author | SHA1 | Date | |
|---|---|---|---|
 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"
|
"x86_64-darwin" "x86_64-linux"
|
||||||
];
|
];
|
||||||
|
|
||||||
|
|
||||||
overlays = [
|
overlays = [
|
||||||
haskellNix.overlay
|
haskellNix.overlay
|
||||||
|
(final: prev: {
|
||||||
|
gyehoek-wasmtime-wrapper = final.callPackage ./wasmtime.nix {};
|
||||||
|
})
|
||||||
(final: prev: {
|
(final: prev: {
|
||||||
gyehoek = final.haskell-nix.project' {
|
gyehoek = final.haskell-nix.project' {
|
||||||
src = ./.;
|
src = ./.;
|
||||||
compiler-nix-name = "ghc912";
|
compiler-nix-name = "ghc912";
|
||||||
modules = [({ pkgs, lib, ...}: {
|
modules = [({ pkgs, lib, ...}: {
|
||||||
packages.gyehoek.components.tests.test.preCheck =
|
packages.gyehoek.components.tests.test.preCheck =
|
||||||
let bin = [pkgs.wasmtime pkgs.git];
|
let
|
||||||
|
bin = [
|
||||||
|
pkgs.gyehoek-wasmtime-wrapper
|
||||||
|
pkgs.git
|
||||||
|
];
|
||||||
in ''
|
in ''
|
||||||
# Wasmtime requires a cache in $HOME. This is less
|
# Wasmtime requires a cache in $HOME. This is less
|
||||||
# painful than reconfiguring the cache location.
|
# painful than reconfiguring the cache location.
|
||||||
@@ -44,10 +52,10 @@
|
|||||||
self.packages.${final.stdenv.hostPlatform.system}.shake
|
self.packages.${final.stdenv.hostPlatform.system}.shake
|
||||||
final.wabt
|
final.wabt
|
||||||
final.nodejs
|
final.nodejs
|
||||||
final.wasmtime
|
|
||||||
final.wasm-tools
|
final.wasm-tools
|
||||||
final.wac-cli
|
final.wac-cli
|
||||||
final.guile
|
final.guile
|
||||||
|
final.gyehoek-wasmtime-wrapper
|
||||||
];
|
];
|
||||||
};
|
};
|
||||||
};
|
};
|
||||||
|
|||||||
+30
-2
@@ -1,19 +1,47 @@
|
|||||||
(module
|
(module
|
||||||
|
(type $heap-object (sub (struct (field (mut i32)))))
|
||||||
(func
|
(func
|
||||||
(param)
|
(param)
|
||||||
(result i32)
|
(result (ref eq))
|
||||||
(local i32 i32 i32 i32 i32)
|
(local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
|
||||||
(i32.const 3)
|
(i32.const 3)
|
||||||
|
(i32.const 2)
|
||||||
|
i32.shl
|
||||||
|
ref.i31
|
||||||
|
(ref.cast (ref i31))
|
||||||
|
i31.get_s
|
||||||
(i32.const 4)
|
(i32.const 4)
|
||||||
|
(i32.const 2)
|
||||||
|
i32.shl
|
||||||
|
ref.i31
|
||||||
|
(ref.cast (ref i31))
|
||||||
|
i31.get_s
|
||||||
i32.mul
|
i32.mul
|
||||||
|
ref.i31
|
||||||
(local.set 0)
|
(local.set 0)
|
||||||
(i32.const 2)
|
(i32.const 2)
|
||||||
|
(i32.const 2)
|
||||||
|
i32.shl
|
||||||
|
ref.i31
|
||||||
|
(ref.cast (ref i31))
|
||||||
|
i31.get_s
|
||||||
(i32.const 5)
|
(i32.const 5)
|
||||||
|
(i32.const 2)
|
||||||
|
i32.shl
|
||||||
|
ref.i31
|
||||||
|
(ref.cast (ref i31))
|
||||||
|
i31.get_s
|
||||||
i32.mul
|
i32.mul
|
||||||
|
ref.i31
|
||||||
(local.set 1)
|
(local.set 1)
|
||||||
(local.get 0)
|
(local.get 0)
|
||||||
|
(ref.cast (ref i31))
|
||||||
|
i31.get_s
|
||||||
(local.get 1)
|
(local.get 1)
|
||||||
|
(ref.cast (ref i31))
|
||||||
|
i31.get_s
|
||||||
i32.add
|
i32.add
|
||||||
|
ref.i31
|
||||||
(local.set 2)
|
(local.set 2)
|
||||||
(local.get 2))
|
(local.get 2))
|
||||||
(export "main" (func 0)))
|
(export "main" (func 0)))
|
||||||
@@ -1,11 +1,13 @@
|
|||||||
(module
|
(module
|
||||||
|
(type (sub (struct (field (mut i32)))))
|
||||||
(func
|
(func
|
||||||
(param)
|
(param)
|
||||||
(result i32)
|
(result (ref eq))
|
||||||
(local i32 i32 i32 i32 i32)
|
(local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
|
||||||
(i32.const 0)
|
(i32.const 0)
|
||||||
|
ref.i31
|
||||||
(if
|
(if
|
||||||
(result i32)
|
(result i32)
|
||||||
(then (i32.const 777))
|
(then (i32.const 777) ref.i31)
|
||||||
(else (i32.const 555))))
|
(else (i32.const 555) ref.i31)))
|
||||||
(export "main" (func 0)))
|
(export "main" (func 0)))
|
||||||
@@ -1,11 +1,13 @@
|
|||||||
(module
|
(module
|
||||||
|
(type (sub (struct (field (mut i32)))))
|
||||||
(func
|
(func
|
||||||
(param)
|
(param)
|
||||||
(result i32)
|
(result (ref eq))
|
||||||
(local i32 i32 i32 i32 i32)
|
(local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
|
||||||
(i32.const 1)
|
(i32.const 1)
|
||||||
|
ref.i31
|
||||||
(if
|
(if
|
||||||
(result i32)
|
(result i32)
|
||||||
(then (i32.const 777))
|
(then (i32.const 777) ref.i31)
|
||||||
(else (i32.const 555))))
|
(else (i32.const 555) ref.i31)))
|
||||||
(export "main" (func 0)))
|
(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>
|
||||||
+172
-29
@@ -4,10 +4,10 @@
|
|||||||
{-# LANGUAGE TypeFamilies #-}
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
{-# LANGUAGE MultilineStrings #-}
|
{-# LANGUAGE MultilineStrings #-}
|
||||||
{-# LANGUAGE OverloadedLists #-}
|
{-# LANGUAGE OverloadedLists #-}
|
||||||
|
{-# LANGUAGE ApplicativeDo #-}
|
||||||
{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
|
{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
|
||||||
module Gyehoek.CPS.Lower
|
module Gyehoek.CPS.Lower
|
||||||
(
|
(lower, lowerProgram) where
|
||||||
lower, lowerProgram) where
|
|
||||||
|
|
||||||
import Gyehoek.CPS.Syntax
|
import Gyehoek.CPS.Syntax
|
||||||
import Data.Generics.Labels
|
import Data.Generics.Labels
|
||||||
@@ -31,25 +31,67 @@ import qualified Data.Vector.Strict as V
|
|||||||
import Data.IntMap.Strict (IntMap)
|
import Data.IntMap.Strict (IntMap)
|
||||||
import Data.String.Interpolate
|
import Data.String.Interpolate
|
||||||
import Gyehoek.Wasm qualified as Wasm
|
import Gyehoek.Wasm qualified as Wasm
|
||||||
import Gyehoek.Wasm (i32, ins, sxp)
|
import Gyehoek.Wasm hiding (Expr)
|
||||||
|
import Language.Sexp.Located (pattern ParenList)
|
||||||
|
import Debug.Pretty.Simple
|
||||||
|
import Control.Monad.Fix
|
||||||
|
|
||||||
|
|
||||||
data Env = MkEnv { vars :: Vector Name }
|
data Env = MkEnv
|
||||||
|
{ runtime :: Runtime
|
||||||
|
, vars :: Vector Name
|
||||||
|
, kvars :: Vector Name
|
||||||
|
}
|
||||||
deriving (Show, Generic)
|
deriving (Show, Generic)
|
||||||
|
|
||||||
emptyEnv :: Env
|
|
||||||
emptyEnv = MkEnv mempty
|
|
||||||
|
|
||||||
type instance Index Env = Natural
|
type instance Index Env = Natural
|
||||||
type instance IxValue Env = Name
|
type instance IxValue Env = Name
|
||||||
|
|
||||||
instance Ixed Env where
|
instance Ixed Env where
|
||||||
ix i = #vars . ix (fromIntegral i)
|
ix i = #vars . ix (fromIntegral i)
|
||||||
|
|
||||||
|
data Runtime = MkRuntime
|
||||||
|
{ argArrayType :: Idx
|
||||||
|
, argArray :: Idx
|
||||||
|
, contType :: Idx
|
||||||
|
, contStackType :: Idx
|
||||||
|
, contStackTop :: Idx
|
||||||
|
, contStack :: Idx
|
||||||
|
, result :: Idx
|
||||||
|
, halt :: Idx
|
||||||
|
}
|
||||||
|
deriving (Show, Generic)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
tshow :: Show a => a -> Text
|
-- | @makeSmallFixnum@ emits an expression injecting the i32 on top
|
||||||
tshow = T.pack . show
|
-- of the stack into the SCM unitype.
|
||||||
|
makeSmallFixnum :: Wasm.Expr
|
||||||
|
makeSmallFixnum = mconcat
|
||||||
|
[ ins "i32.const" [sxp @Int 1]
|
||||||
|
, ins "i32.shl" []
|
||||||
|
, ins "ref.i31" []
|
||||||
|
]
|
||||||
|
|
||||||
|
-- | 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]
|
||||||
|
]
|
||||||
|
|
||||||
|
-- | 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" []
|
||||||
|
]
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
@@ -57,17 +99,24 @@ lowerVal :: Env -> Val -> Wasm.Expr
|
|||||||
|
|
||||||
lowerVal g (ValLit l) =
|
lowerVal g (ValLit l) =
|
||||||
case l of
|
case l of
|
||||||
LitInt n -> ins "i32.const" [sxp n]
|
LitInt n ->
|
||||||
LitBool b -> ins "i32.const" [sxp @Int $ if b then 1 else 0]
|
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 l]
|
lowerVal g (ValVar x) = ins "local.get" [sxp (1+l)]
|
||||||
where
|
where
|
||||||
l = V.elemIndex x g.vars ^?! _Just
|
l = V.elemIndex x g.vars ^?! _Just
|
||||||
|
|
||||||
lower' :: Env -> Exp -> Wasm.Expr
|
lower' :: (GenMod :> es) => Env -> Exp -> Eff es Wasm.Expr
|
||||||
|
|
||||||
lower' g (Halt [e]) = lowerVal g e
|
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) =
|
lower' g (ExpPrim p rs e) =
|
||||||
case p of
|
case p of
|
||||||
@@ -76,31 +125,125 @@ lower' g (ExpPrim p rs e) =
|
|||||||
where
|
where
|
||||||
r = head rs
|
r = head rs
|
||||||
|
|
||||||
lower' g (ExpIf c t f) =
|
lower' g (ExpIf c t f) = do
|
||||||
lowerVal g c
|
t' <- lower' g t
|
||||||
<> Wasm.if' (Wasm.result [i32])
|
f' <- lower' g f
|
||||||
(lower' g t)
|
pure $ lowerVal g c
|
||||||
(lower' g f)
|
<> 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
|
lowerBinOp
|
||||||
:: _
|
:: (GenMod :> es)
|
||||||
-> _ -> _ -> _ -> _ -> _ -> Wasm.Expr
|
=> Text -> Env -> Val -> Val -> Name -> Exp -> Eff es Wasm.Expr
|
||||||
lowerBinOp op g x y r e =
|
lowerBinOp op g x y r e = do
|
||||||
lowerVal g x
|
e' <- lower' g' e
|
||||||
<> lowerVal g y
|
pure . mconcat $
|
||||||
<> ins op []
|
[ lowerVal g x
|
||||||
<> ins "local.set" [sxp n]
|
, ins "ref.cast" [sxp $ ref i31]
|
||||||
<> lower' g' e
|
, 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
|
where
|
||||||
g' = g & #vars <>~ [r]
|
g' = g & #vars <>~ [r]
|
||||||
n = length (g ^. #vars)
|
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 :: Exp -> Eff es Text
|
||||||
lower e = fmap Wasm.renderModule . Wasm.execGenMod $ do
|
lower e = fmap Wasm.renderModule . Wasm.execGenMod $ do
|
||||||
main <- Wasm.defun [] [i32] [i32, i32, i32, i32, i32] \_ ->
|
runtime <- emitRuntime
|
||||||
lower' emptyEnv e
|
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
|
Wasm.export "main" "func" main
|
||||||
|
|
||||||
lowerProgram :: Program -> Eff es Text
|
lowerProgram :: Program -> Eff es Text
|
||||||
|
|||||||
@@ -1,7 +1,9 @@
|
|||||||
{-# LANGUAGE DeriveGeneric #-}
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE OverloadedLabels #-}
|
{-# LANGUAGE OverloadedLabels #-}
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
{-# LANGUAGE TypeOperators #-}
|
{-# LANGUAGE TypeOperators #-}
|
||||||
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
{-# LANGUAGE PartialTypeSignatures #-}
|
{-# LANGUAGE PartialTypeSignatures #-}
|
||||||
{-# LANGUAGE DerivingStrategies #-}
|
{-# LANGUAGE DerivingStrategies #-}
|
||||||
{-# LANGUAGE OrPatterns #-}
|
{-# LANGUAGE OrPatterns #-}
|
||||||
@@ -17,6 +19,11 @@ module Gyehoek.Scheme.Syntax
|
|||||||
, CommandOrDef(..)
|
, CommandOrDef(..)
|
||||||
, primSexpIso
|
, primSexpIso
|
||||||
, pattern Void
|
, pattern Void
|
||||||
|
, free
|
||||||
|
, qexp
|
||||||
|
, qprog
|
||||||
|
, subst
|
||||||
|
, freeVariables
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
@@ -37,11 +44,17 @@ import Control.Lens
|
|||||||
import Data.String (IsString)
|
import Data.String (IsString)
|
||||||
import Data.Hashable (Hashable)
|
import Data.Hashable (Hashable)
|
||||||
import Control.Lens.Unsound (prismSum)
|
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 }
|
newtype Name = MkName { getName :: Text }
|
||||||
deriving newtype (Show, Eq, IsString, Gen, Hashable)
|
deriving newtype (Show, Eq, IsString, Gen, Hashable)
|
||||||
deriving stock (Generic)
|
deriving stock (Generic, Data)
|
||||||
|
|
||||||
data Prim e
|
data Prim e
|
||||||
= PrimAdd e e
|
= PrimAdd e e
|
||||||
@@ -57,7 +70,7 @@ data Prim e
|
|||||||
| PrimWrite e
|
| PrimWrite e
|
||||||
| PrimZeroP e
|
| PrimZeroP e
|
||||||
| PrimNewline
|
| PrimNewline
|
||||||
deriving (Show, Generic, Functor, Foldable, Traversable)
|
deriving (Show, Generic, Functor, Foldable, Traversable, Data)
|
||||||
|
|
||||||
instance Each (Prim e) (Prim e') e e'
|
instance Each (Prim e) (Prim e') e e'
|
||||||
|
|
||||||
@@ -67,7 +80,7 @@ data Lit
|
|||||||
| LitBool Bool
|
| LitBool Bool
|
||||||
| LitString Text
|
| LitString Text
|
||||||
| LitQuote Sexp
|
| LitQuote Sexp
|
||||||
deriving (Show, Generic)
|
deriving (Show, Generic, Data)
|
||||||
|
|
||||||
pattern Void :: Lit
|
pattern Void :: Lit
|
||||||
pattern Void = LitNil
|
pattern Void = LitNil
|
||||||
@@ -75,7 +88,7 @@ pattern Void = LitNil
|
|||||||
data Def
|
data Def
|
||||||
= DefConstant Name Exp
|
= DefConstant Name Exp
|
||||||
| DefProcedure Name (List Name) (List Exp)
|
| DefProcedure Name (List Name) (List Exp)
|
||||||
deriving (Show, Generic)
|
deriving (Show, Generic, Data)
|
||||||
|
|
||||||
data Exp
|
data Exp
|
||||||
= ExpLet (NonEmpty (Name, Exp)) Exp
|
= ExpLet (NonEmpty (Name, Exp)) Exp
|
||||||
@@ -86,24 +99,24 @@ data Exp
|
|||||||
| ExpLambda (List Name) Exp
|
| ExpLambda (List Name) Exp
|
||||||
| ExpVar Name
|
| ExpVar Name
|
||||||
| ExpApply Exp (List Exp)
|
| ExpApply Exp (List Exp)
|
||||||
deriving (Show, Generic)
|
deriving (Show, Generic, Data)
|
||||||
|
|
||||||
data Sexp
|
data Sexp
|
||||||
= SexpCons Sexp Sexp
|
= SexpCons Sexp Sexp
|
||||||
| SexpSymbol Text
|
| SexpSymbol Text
|
||||||
| SexpLit Lit
|
| SexpLit Lit
|
||||||
deriving (Show, Generic)
|
deriving (Show, Generic, Data)
|
||||||
|
|
||||||
data CommandOrDef
|
data CommandOrDef
|
||||||
= Command Exp
|
= Command Exp
|
||||||
| Definition Def
|
| Definition Def
|
||||||
| Begin (List CommandOrDef)
|
| Begin (List CommandOrDef)
|
||||||
deriving (Show, Generic)
|
deriving (Show, Generic, Data)
|
||||||
|
|
||||||
data Program = MkProgram
|
data Program = MkProgram
|
||||||
{ commandsAndDefs :: List CommandOrDef
|
{ commandsAndDefs :: List CommandOrDef
|
||||||
}
|
}
|
||||||
deriving (Show, Generic)
|
deriving (Show, Generic, Data)
|
||||||
|
|
||||||
instance Each Program Program (Either Exp Def) (Either Exp Def) where
|
instance Each Program Program (Either Exp Def) (Either Exp Def) where
|
||||||
each = #commandsAndDefs . each . go
|
each = #commandsAndDefs . each . go
|
||||||
@@ -116,6 +129,8 @@ instance Each Program Program (Either Exp Def) (Either Exp Def) where
|
|||||||
go k (Definition d) = inj <$> k (Right d)
|
go k (Definition d) = inj <$> k (Right d)
|
||||||
go k (Begin xs) = Begin <$> traverse (go k) xs
|
go k (Begin xs) = Begin <$> traverse (go k) xs
|
||||||
|
|
||||||
|
makeBaseFunctor ''Exp
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
instance SexpIso Name where
|
instance SexpIso Name where
|
||||||
@@ -211,3 +226,41 @@ instance SexpIso CommandOrDef where
|
|||||||
$ End
|
$ End
|
||||||
where
|
where
|
||||||
bgn = list $ el (sym "begin") >>> rest sexpIso
|
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
|
||||||
|
|
||||||
|
-- | Unlawful!
|
||||||
|
freeVariables :: Traversal Exp Exp Name Exp
|
||||||
|
freeVariables k = \e -> cataA go e mempty where
|
||||||
|
go (ExpVarF x) bound
|
||||||
|
| not (x `HS.member` bound) = k x
|
||||||
|
| otherwise = pure $ ExpVar x
|
||||||
|
go (ExpLetF _ _) _ = error "todo lol"
|
||||||
|
go (ExpLambdaF bs e) bound = e $ insertFrom bs bound
|
||||||
|
go e bound = embed <$> traverse ($ bound) e
|
||||||
|
|||||||
+150
-5
@@ -4,6 +4,8 @@
|
|||||||
{-# LANGUAGE OverloadedLabels #-}
|
{-# LANGUAGE OverloadedLabels #-}
|
||||||
{-# LANGUAGE DerivingVia #-}
|
{-# LANGUAGE DerivingVia #-}
|
||||||
{-# LANGUAGE StandaloneDeriving #-}
|
{-# LANGUAGE StandaloneDeriving #-}
|
||||||
|
{-# LANGUAGE TemplateHaskellQuotes #-}
|
||||||
|
{-# LANGUAGE OrPatterns #-}
|
||||||
module Gyehoek.Sexp
|
module Gyehoek.Sexp
|
||||||
( let_
|
( let_
|
||||||
, sexp
|
, sexp
|
||||||
@@ -25,11 +27,18 @@ module Gyehoek.Sexp
|
|||||||
, encodePretty
|
, encodePretty
|
||||||
, UglySexpIso(..)
|
, UglySexpIso(..)
|
||||||
, AsSexpIso(..)
|
, AsSexpIso(..)
|
||||||
|
, parseSexpsWithPos
|
||||||
|
, parseSexpWithPos
|
||||||
|
, parseSexp
|
||||||
|
, sx
|
||||||
|
, sxs
|
||||||
|
, makeSx
|
||||||
|
, makeSxs
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
import Data.Text (Text)
|
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)
|
||||||
import Language.SexpGrammar qualified as Sexp
|
import Language.SexpGrammar qualified as Sexp
|
||||||
import Language.Sexp qualified as S
|
import Language.Sexp qualified as S
|
||||||
import Language.SexpGrammar.Generic
|
import Language.SexpGrammar.Generic
|
||||||
@@ -37,7 +46,8 @@ import Data.InvertibleGrammar.Base qualified as IGB
|
|||||||
import Data.InvertibleGrammar qualified as IG
|
import Data.InvertibleGrammar qualified as IG
|
||||||
import Data.InvertibleGrammar.Base ((:-)((:-)))
|
import Data.InvertibleGrammar.Base ((:-)((:-)))
|
||||||
import Data.List.NonEmpty (NonEmpty ((:|)))
|
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.Text.Encoding
|
||||||
import Data.Either (either)
|
import Data.Either (either)
|
||||||
import GHC.Generics (Generic)
|
import GHC.Generics (Generic)
|
||||||
@@ -47,10 +57,16 @@ import System.Process
|
|||||||
import GHC.IO.Unsafe (unsafePerformIO)
|
import GHC.IO.Unsafe (unsafePerformIO)
|
||||||
import qualified Data.Text.IO as TIO
|
import qualified Data.Text.IO as TIO
|
||||||
import Control.Monad (join)
|
import Control.Monad (join)
|
||||||
import qualified Language.Sexp.Located as SexpLoc
|
import qualified Language.Sexp.Located as SL
|
||||||
import Data.Void (absurd)
|
import Data.Void (absurd, Void)
|
||||||
import Data.Coerce (coerce)
|
import Data.Coerce (coerce)
|
||||||
import qualified Data.Map
|
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)
|
||||||
|
|
||||||
|
|
||||||
sexp :: SexpIso a => Iso' a Text
|
sexp :: SexpIso a => Iso' a Text
|
||||||
@@ -78,9 +94,23 @@ encodePrettyWith g =
|
|||||||
(_Right %~ decodeUtf8 . view strict) . Sexp.encodePrettyWith g
|
(_Right %~ decodeUtf8 . view strict) . Sexp.encodePrettyWith g
|
||||||
|
|
||||||
parseSexps :: SexpIso a => FilePath -> Text -> Either String (List a)
|
parseSexps :: SexpIso a => FilePath -> Text -> Either String (List a)
|
||||||
parseSexps f = marshal . SexpLoc.parseSexps f . view lazy . encodeUtf8
|
parseSexps f = marshal . SL.parseSexps f . view lazy . encodeUtf8
|
||||||
where marshal = join . traverseOf (_Right . each) (fromSexp sexpIso)
|
where marshal = join . traverseOf (_Right . each) (fromSexp sexpIso)
|
||||||
|
|
||||||
|
parseSexp :: SexpIso a => FilePath -> Text -> Either String a
|
||||||
|
parseSexp f = marshal . SL.parseSexp f . view lazy . encodeUtf8
|
||||||
|
where marshal = join . traverseOf _Right (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) (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 (fromSexp g)
|
||||||
|
|
||||||
nonEmptyGrammar :: Grammar p (NonEmpty x :- t) (List x :- x :- t)
|
nonEmptyGrammar :: Grammar p (NonEmpty x :- t) (List x :- x :- t)
|
||||||
nonEmptyGrammar = IGB.Iso
|
nonEmptyGrammar = IGB.Iso
|
||||||
(\((x:|xs) :- t) -> reverse xs :- x :- t)
|
(\((x:|xs) :- t) -> reverse xs :- x :- t)
|
||||||
@@ -183,3 +213,118 @@ instance UglySexpIso Int where uglySexpIso = sexpIso
|
|||||||
instance UglySexpIso Bool where uglySexpIso = sexpIso
|
instance UglySexpIso Bool where uglySexpIso = sexpIso
|
||||||
instance UglySexpIso Double where uglySexpIso = sexpIso
|
instance UglySexpIso Double where uglySexpIso = sexpIso
|
||||||
instance UglySexpIso () 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)
|
||||||
|
|
||||||
|
makeSxs :: Data b => SexpGrammar a -> (List a -> b) -> QuasiQuoter
|
||||||
|
makeSxs g f = QuasiQuoter
|
||||||
|
{ quoteExp = \str -> do
|
||||||
|
pos <- getPos
|
||||||
|
case parseSexpsWithPos g pos (T.pack str) of
|
||||||
|
Left e -> fail e
|
||||||
|
Right xs -> dataToExpQ (const Nothing) (f xs)
|
||||||
|
, quotePat = undefined
|
||||||
|
, quoteType = undefined
|
||||||
|
, quoteDec = undefined
|
||||||
|
}
|
||||||
|
|
||||||
|
toSexp :: SexpIso a => a -> Sexp
|
||||||
|
toSexp = either error id . Sexp.toSexp sexpIso
|
||||||
|
|
||||||
|
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
|
||||||
|
|
||||||
|
metaSexp :: Sexp.Sexp -> Maybe ExpQ
|
||||||
|
metaSexp (Unquote x) =
|
||||||
|
Just [| toSexp $(varE (mkName (T.unpack x))) |]
|
||||||
|
metaSexp (SL.ParenList xs)
|
||||||
|
| (_:_) <- xs ^.. each . _UnquoteSplicing
|
||||||
|
= Just [| SL.ParenList (mconcat $(listE spans)) |]
|
||||||
|
where
|
||||||
|
spans = xs
|
||||||
|
& groupBy \cases
|
||||||
|
(UnquoteSplicing _) _ -> False
|
||||||
|
_ (UnquoteSplicing _) -> False
|
||||||
|
_ _ -> True
|
||||||
|
& fmap \case
|
||||||
|
[UnquoteSplicing x] -> varE (mkName (T.unpack x))
|
||||||
|
x -> lift 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 [|Fix|] (lift1 inner)
|
||||||
|
|
||||||
|
instance (Lift1 f, Lift1 g) => Lift1 (SL.Compose f g) where
|
||||||
|
liftLift l (SL.Compose fga) = [|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)
|
||||||
|
|
||||||
|
makeSx :: Data a => SexpGrammar a -> QuasiQuoter
|
||||||
|
makeSx 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) x
|
||||||
|
, quotePat = undefined
|
||||||
|
, quoteType = undefined
|
||||||
|
, quoteDec = undefined
|
||||||
|
}
|
||||||
|
|
||||||
|
sxs = makeSxs (sexpIso @Sexp) id
|
||||||
|
sx = makeSx (sexpIso @Sexp)
|
||||||
|
|||||||
+21
-202
@@ -3,6 +3,7 @@
|
|||||||
{-# LANGUAGE DeepSubsumption #-}
|
{-# LANGUAGE DeepSubsumption #-}
|
||||||
{-# LANGUAGE NoFieldSelectors #-}
|
{-# LANGUAGE NoFieldSelectors #-}
|
||||||
{-# LANGUAGE OverloadedRecordDot #-}
|
{-# LANGUAGE OverloadedRecordDot #-}
|
||||||
|
{-# LANGUAGE RecordPuns #-}
|
||||||
{-# LANGUAGE DuplicateRecordFields #-}
|
{-# LANGUAGE DuplicateRecordFields #-}
|
||||||
{-# LANGUAGE QuasiQuotes #-}
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
{-# LANGUAGE OverloadedLabels #-}
|
{-# LANGUAGE OverloadedLabels #-}
|
||||||
@@ -10,29 +11,12 @@
|
|||||||
{-# LANGUAGE ImpredicativeTypes #-}
|
{-# LANGUAGE ImpredicativeTypes #-}
|
||||||
{-# LANGUAGE DerivingVia #-}
|
{-# LANGUAGE DerivingVia #-}
|
||||||
module Gyehoek.Wasm
|
module Gyehoek.Wasm
|
||||||
( defun
|
( Module
|
||||||
, deftype
|
|
||||||
, start
|
|
||||||
, runGenMod
|
|
||||||
, execGenMod
|
|
||||||
, renderModule
|
|
||||||
, Module
|
|
||||||
, Function
|
|
||||||
, Expr
|
|
||||||
, Instr
|
|
||||||
, GenMod
|
|
||||||
, i32
|
|
||||||
, export
|
|
||||||
, ins
|
|
||||||
, sxp
|
|
||||||
, result
|
|
||||||
, param
|
|
||||||
, if'
|
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
import Language.SexpGrammar
|
import Language.SexpGrammar
|
||||||
( SexpIso(..), list, el, (>>>), rest, sym, symbol )
|
( SexpIso(..), list, el, (>>>), rest, sym, symbol, (:-) )
|
||||||
import Language.SexpGrammar qualified as Sexp
|
import Language.SexpGrammar qualified as Sexp
|
||||||
import Language.SexpGrammar.Generic
|
import Language.SexpGrammar.Generic
|
||||||
import Data.List (List)
|
import Data.List (List)
|
||||||
@@ -59,199 +43,34 @@ import Language.Sexp.Located
|
|||||||
import qualified Gyehoek.Sexp
|
import qualified Gyehoek.Sexp
|
||||||
import GHC.IsList (IsList(..))
|
import GHC.IsList (IsList(..))
|
||||||
import Data.Coerce (coerce)
|
import Data.Coerce (coerce)
|
||||||
|
import qualified Control.Category
|
||||||
|
import Data.Functor (void)
|
||||||
|
|
||||||
|
|
||||||
data Module = MkModule
|
newtype Module = MkModule { inner :: Vector Sexp }
|
||||||
{ 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 }
|
|
||||||
deriving (Show, Generic)
|
deriving (Show, Generic)
|
||||||
deriving newtype (Semigroup, Monoid)
|
deriving newtype (Semigroup, Monoid)
|
||||||
|
|
||||||
newtype Instr = MkInstr { inner :: Sexp }
|
newtype Expr = MkExpr { inner :: Vector Sexp }
|
||||||
deriving (Show, Generic)
|
deriving (Show, Generic)
|
||||||
|
deriving newtype (Semigroup, Monoid)
|
||||||
|
|
||||||
newtype Type = MkType { inner :: Sexp }
|
newtype Idx = MkIdx { inner :: Natural }
|
||||||
deriving (Show, Generic)
|
deriving (Generic)
|
||||||
|
|
||||||
newtype Idx = MkIdx { getIdx :: Natural }
|
|
||||||
deriving newtype (Show)
|
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"
|
|
||||||
|
|
||||||
|
|
||||||
|
-- GenMod
|
||||||
|
|
||||||
instance SexpIso Idx where
|
-- | 'GenModState' is a 'Module' paired with the numbers of functions,
|
||||||
sexpIso = Sexp.integer >>> Sexp.partialOsi f g
|
-- types, globals, etc. defined in the module.
|
||||||
where
|
data GenModState = MkGenModState
|
||||||
f n | n < 0 = Left $ Sexp.unexpected "negative" <> Sexp.expected "natural"
|
{ mod :: Module
|
||||||
| otherwise = Right . MkIdx $ fromIntegral n
|
, funcs :: Natural
|
||||||
g (MkIdx n) = fromIntegral n
|
, types :: Natural
|
||||||
|
|
||||||
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
|
|
||||||
|
|
||||||
instance IsList Expr where
|
|
||||||
type Item Expr = Instr
|
|
||||||
fromList = MkExpr . V.fromList
|
|
||||||
toList e = V.toList e.inner
|
|
||||||
|
|
||||||
data ResultType = MkResultType
|
|
||||||
{ params :: List Type
|
|
||||||
, result :: List Type
|
|
||||||
}
|
}
|
||||||
deriving stock (Generic)
|
deriving (Show, Generic)
|
||||||
deriving (Semigroup, Monoid)
|
|
||||||
via Generically ResultType
|
|
||||||
|
|
||||||
param :: List Type -> ResultType
|
data GenMod :: Effect where
|
||||||
param ts = MkResultType ts mempty
|
DefineFunction :: Sexp -> GenMod m Idx
|
||||||
|
DefineType :: Sexp -> GenMod m Idx
|
||||||
result :: List Type -> ResultType
|
|
||||||
result ts = MkResultType mempty ts
|
|
||||||
|
|
||||||
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 ]
|
|
||||||
|
|
||||||
-- resultSexp :: ResultType -> Sexp
|
|
||||||
-- resultSexp rt = ParenList $ Symbol "param" : (coerce <$> rt.result)
|
|
||||||
|
|
||||||
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) ]
|
|
||||||
|
|||||||
@@ -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