continue takes var
This commit is contained in:
+13
-11
@@ -14,9 +14,9 @@ build-type: Simple
|
||||
-- extra-source-files:
|
||||
|
||||
flag doctest
|
||||
description: enable the doctest suite
|
||||
default: True
|
||||
manual: True
|
||||
description: enable the doctest suite
|
||||
default: True
|
||||
manual: True
|
||||
|
||||
common ghcstuffs-dev
|
||||
ghc-options:
|
||||
@@ -60,7 +60,6 @@ library
|
||||
Gyehoek.CPS.Close
|
||||
Gyehoek.CPS.Convert
|
||||
Gyehoek.CPS.Eval
|
||||
Gyehoek.CPS.Lower
|
||||
Gyehoek.CPS.Stackify
|
||||
Gyehoek.CPS.Syntax
|
||||
Gyehoek.Driver
|
||||
@@ -77,6 +76,7 @@ library
|
||||
Gyehoek.Sexp.QQ
|
||||
Gyehoek.Sexp.Read
|
||||
Gyehoek.Sexp.Syntax
|
||||
Gyehoek.Stack.Lower
|
||||
Gyehoek.Stack.Syntax
|
||||
Gyehoek.Stack.VM
|
||||
Gyehoek.Wasm
|
||||
@@ -162,13 +162,15 @@ test-suite test
|
||||
|
||||
-- https://github.com/martijnbastiaan/doctest-parallel/pull/66
|
||||
test-suite doctest
|
||||
import: ghcstuffs, ghcstuffs-dev
|
||||
type: exitcode-stdio-1.0
|
||||
hs-source-dirs: test
|
||||
build-depends: base
|
||||
import: ghcstuffs, ghcstuffs-dev
|
||||
type: exitcode-stdio-1.0
|
||||
hs-source-dirs: test
|
||||
build-depends: base
|
||||
default-extensions: CPP
|
||||
main-is: doctest.hs
|
||||
main-is: doctest.hs
|
||||
|
||||
if flag(doctest)
|
||||
build-depends: doctest-parallel >=0.1
|
||||
build-depends: doctest-parallel >=0.1
|
||||
|
||||
else
|
||||
cpp-options: "-DGYEHOEK_NO_DOCTEST"
|
||||
cpp-options: -DGYEHOEK_NO_DOCTEST
|
||||
|
||||
@@ -105,7 +105,7 @@ convertLambda
|
||||
=> List Name -> Scm.Exp -> Eff es Lambda
|
||||
convertLambda bs m = do
|
||||
ktail <- gensym' "lambda-tail"
|
||||
m' <- convert m $ pure . ExpContinue ktail . (:[])
|
||||
m' <- convert m $ pure . ExpContinue (ValVar ktail) . (:[])
|
||||
pure [cps|(λ (##{bs} #{ktail}) #{m'})|]
|
||||
|
||||
convertProgram :: forall es. (GenSym :> es) => Scm.Program -> Eff es Program
|
||||
|
||||
@@ -1,325 +0,0 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE OverloadedRecordDot #-}
|
||||
{-# LANGUAGE OverloadedLabels #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE MultilineStrings #-}
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
{-# LANGUAGE ApplicativeDo #-}
|
||||
{-# LANGUAGE RecursiveDo #-}
|
||||
{- HLINT ignore "Use camelCase" -}
|
||||
module Gyehoek.CPS.Lower
|
||||
(lower, lowerProgram) where
|
||||
|
||||
import Gyehoek.CPS.Syntax
|
||||
import Data.Vector.Strict (Vector)
|
||||
import Control.Lens hiding (op)
|
||||
import Numeric.Natural
|
||||
import qualified Data.Vector.Strict as V
|
||||
import Gyehoek.Wasm qualified as Wasm
|
||||
import Gyehoek.Wasm hiding (Expr)
|
||||
import Control.Monad.Fix
|
||||
import Data.Text qualified as T
|
||||
import Data.Foldable (fold)
|
||||
import Gyehoek.Jalmot
|
||||
import Gyehoek.Sexp qualified as S
|
||||
import Gyehoek.Prelude
|
||||
|
||||
|
||||
data Env = MkEnv
|
||||
{ vars :: Vector Name
|
||||
, kvars :: Vector Name
|
||||
}
|
||||
deriving (Show, Generic)
|
||||
|
||||
type instance Index Env = Natural
|
||||
type instance IxValue Env = Name
|
||||
|
||||
instance Ixed Env where
|
||||
ix i = #vars . ix (fromIntegral i)
|
||||
|
||||
|
||||
|
||||
tonat :: Integral a => a -> Natural
|
||||
tonat = fromIntegral
|
||||
|
||||
-- | @makeSmallFixnum@ emits an expression injecting the i32 on top
|
||||
-- of the stack into the SCM unitype.
|
||||
makeSmallFixnum :: Wasm.Expr
|
||||
makeSmallFixnum = [expr|
|
||||
(@gyehoek "construct small fixnum")
|
||||
(i32.const 1)
|
||||
i32.shl
|
||||
ref.i31
|
||||
|]
|
||||
|
||||
getArgRegister :: Natural -> S.Datum
|
||||
getArgRegister n = S.Symbol [i|$arg#{n}|]
|
||||
|
||||
-- | 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 :: Natural -> Wasm.Expr -> Wasm.Expr
|
||||
pushArg n e = [expr|
|
||||
(@gyehoek begin pushArg)
|
||||
##{e}
|
||||
(global.set #{reg})
|
||||
(@gyehoek end pushArg)
|
||||
|]
|
||||
where reg = getArgRegister n
|
||||
|
||||
-- | Pop the nth arg from the arg-passing array onto the stack.
|
||||
popArg :: Natural -> Wasm.Expr
|
||||
popArg n = [expr|
|
||||
(@gyehoek begin popArg)
|
||||
(global.get #{reg})
|
||||
ref.as_non_null
|
||||
(@gyehoek end popArg)
|
||||
|]
|
||||
where reg = getArgRegister n
|
||||
|
||||
|
||||
|
||||
lowerVal :: (HasCallStack, GenMod :> es) => Env -> Val -> Eff es Wasm.Expr
|
||||
|
||||
lowerVal g (ValImm imm) =
|
||||
pure $ case imm of
|
||||
ImmInt n -> [expr|
|
||||
(i32.const #{n})
|
||||
##{makeSmallFixnum}
|
||||
|]
|
||||
ImmBool b -> [expr|
|
||||
(i32.const #{b'})
|
||||
ref.i31
|
||||
|]
|
||||
where b' :: Int = if b then 0b11 else 0b01
|
||||
_ -> _
|
||||
|
||||
lowerVal g (ValVar x) = do
|
||||
pure [expr|(global.get #{l})|]
|
||||
where
|
||||
l = getArgRegister . fromIntegral . succ $ V.elemIndex x g.vars ^?! _Just
|
||||
|
||||
lower' :: (GenMod :> es) => Env -> Exp -> Eff es Wasm.Expr
|
||||
|
||||
lower' g (Halt [v]) = do
|
||||
arg <- pushArg 0 <$> lowerVal g v
|
||||
pure [expr|
|
||||
##{arg}
|
||||
(return_call $halt (i32.const 1))
|
||||
|]
|
||||
|
||||
lower' g e@(ExpPrim p k) =
|
||||
case p of
|
||||
PrimAdd x y -> lowerBinOp "i32.add" g x y k
|
||||
PrimMul x y -> lowerBinOp "i32.mul" g x y k
|
||||
|
||||
lower' g (ExpIf c t f) = do
|
||||
c' <- lowerVal g c
|
||||
t' <- lower' g t
|
||||
f' <- lower' g f
|
||||
pure [expr|
|
||||
##{c'}
|
||||
(call $gh-truthy?)
|
||||
(if (then ##{t'})
|
||||
(else ##{f'}))
|
||||
|]
|
||||
|
||||
lower' g (ExpLetRec [(r,AbsKappa kap)] e) = do
|
||||
idx <- lowerKappa g kap
|
||||
let g' = g & #kvars <>~ [r]
|
||||
e' <- lower' g' e
|
||||
pure [expr|
|
||||
(@gyehoek "push cont" :idx #{idx})
|
||||
(array.set $cont-stack-type
|
||||
(global.get $cont-stack)
|
||||
(global.get $cont-stack-top)
|
||||
(ref.func #{idx}))
|
||||
(global.set $cont-stack-top
|
||||
(i32.add (global.get $cont-stack-top)
|
||||
(i32.const 1)))
|
||||
##{e'}
|
||||
|]
|
||||
|
||||
lower' g (ExpLetRec [(r,AbsLambda lam)] e) = do
|
||||
idx <- lowerLambda g lam
|
||||
let g' = g & #vars <>~ [r]
|
||||
let n = succ $ length g.vars
|
||||
e' <- lower' g' e
|
||||
let reg = getArgRegister . fromIntegral $ n
|
||||
pure [expr|
|
||||
(i32.const 0)
|
||||
(ref.func #{idx})
|
||||
(struct.new $closure)
|
||||
(global.set #{reg})
|
||||
##{e'}
|
||||
|]
|
||||
|
||||
lower' g e@(ExpApply f xs ktail) = do
|
||||
let nargs = length xs
|
||||
f' <- lowerVal g f
|
||||
let l = succ $ V.elemIndex ktail g.kvars ^?! _Just
|
||||
args <- fold <$>
|
||||
itraverse (\i -> fmap (pushArg $ tonat i) . lowerVal g) xs
|
||||
pure [expr|
|
||||
(@gyehoek "load args")
|
||||
##{args}
|
||||
(i32.const 1)
|
||||
##{f'}
|
||||
(ref.cast (ref $closure))
|
||||
(struct.get $closure $code)
|
||||
(return_call_ref $cont-type)
|
||||
(@gyehoek todo
|
||||
(f' ##{f'})
|
||||
(ktail #{l}))
|
||||
|]
|
||||
|
||||
lower' g e@(ExpContinue k xs) = do
|
||||
let nargs = length xs
|
||||
args <- fold <$>
|
||||
itraverse (\i -> fmap (pushArg $ tonat i) . lowerVal g) xs
|
||||
pure [expr|
|
||||
(@gyehoek "push args")
|
||||
##{args}
|
||||
(@gyehoek "nargs")
|
||||
(i32.const #{nargs})
|
||||
(@gyehoek "pop cont stack")
|
||||
(global.get $cont-stack-top)
|
||||
(i32.const #{l})
|
||||
i32.sub
|
||||
(global.set $cont-stack-top)
|
||||
(global.get $cont-stack)
|
||||
(global.get $cont-stack-top)
|
||||
(array.get $cont-stack-type)
|
||||
ref.as_non_null
|
||||
(return_call_ref $cont-type)
|
||||
|]
|
||||
where
|
||||
l = succ $ V.elemIndex k g.kvars ^?! _Just
|
||||
|
||||
lower' g e = error . S.encodeOrShow' S.datumIso $ e
|
||||
|
||||
lowerKappa :: GenMod :> es => Env -> Kappa -> Eff es Idx
|
||||
lowerKappa g e@(MkKappa xs m) = do
|
||||
let g' = g & #vars <>~ V.fromList xs
|
||||
m' <- lower' g' m
|
||||
idx <- Wasm.defineFunction [wat|
|
||||
(func (param i32)
|
||||
(local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
|
||||
##{m'})
|
||||
|]
|
||||
Wasm.emit [wats|(elem declare funcref (ref.func #{idx}))|]
|
||||
pure idx
|
||||
|
||||
lowerLambda :: GenMod :> es => Env -> Lambda -> Eff es Idx
|
||||
lowerLambda g e@(MkLambda xs ktail m) = do
|
||||
let g' = g & #vars .~ V.fromList xs
|
||||
& #kvars <>~ [ktail]
|
||||
m' <- lower' g' m
|
||||
idx <- Wasm.defineFunction [wat|
|
||||
(func (param i32)
|
||||
(local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
|
||||
##{m'})
|
||||
|]
|
||||
Wasm.emit [wats|(elem declare funcref (ref.func #{idx}))|]
|
||||
pure idx
|
||||
|
||||
lowerBinOp
|
||||
:: (GenMod :> es)
|
||||
=> Text -> Env -> Val -> Val -> Kappa -> Eff es Wasm.Expr
|
||||
lowerBinOp op g x y (MkKappa [r] e) = do
|
||||
let op' = S.Symbol op
|
||||
let g' = g & #vars <>~ [r]
|
||||
let n = succ $ length (g ^. #vars)
|
||||
let reg = getArgRegister . fromIntegral $ n
|
||||
x' <- lowerVal g x
|
||||
y' <- lowerVal g y
|
||||
e' <- lower' g' e
|
||||
pure [expr|
|
||||
##{x'}
|
||||
(i31.get_s (ref.cast (ref i31)))
|
||||
(i32.const 1)
|
||||
i32.shr_u
|
||||
##{y'}
|
||||
(i31.get_s (ref.cast (ref i31)))
|
||||
(i32.const 1)
|
||||
i32.shr_u
|
||||
#{op'}
|
||||
##{makeSmallFixnum}
|
||||
(global.set #{reg})
|
||||
##{e'}
|
||||
|]
|
||||
|
||||
|
||||
|
||||
emitRuntime :: GenMod :> es => Eff es ()
|
||||
emitRuntime = mfix \runtime -> do
|
||||
Wasm.defineFunctions [wats|
|
||||
(import "gyehoek" "write" (func $gh-write (param (ref eq))))
|
||||
(import "gyehoek" "truthy?" (func $gh-truthy? (param (ref eq))
|
||||
(result i32)))
|
||||
|]
|
||||
-- cont stack
|
||||
Wasm.defineTypes [wats|
|
||||
(type $heap-object (sub (struct (field $hash (mut i32)))))
|
||||
(type $cont-type (func (param i32)))
|
||||
(type $cont-stack-type (array (mut (ref null $cont-type))))
|
||||
(type $closure (sub $heap-object
|
||||
(struct (field $hash (mut i32))
|
||||
(field $code (ref $cont-type)))))
|
||||
|]
|
||||
Wasm.defineGlobals [wats|
|
||||
(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)))
|
||||
|]
|
||||
-- arg registers
|
||||
Wasm.defineGlobals [wats|
|
||||
(global $arg0 (mut (ref null eq)) (ref.null eq))
|
||||
(global $arg1 (mut (ref null eq)) (ref.null eq))
|
||||
(global $arg2 (mut (ref null eq)) (ref.null eq))
|
||||
(global $arg3 (mut (ref null eq)) (ref.null eq))
|
||||
(global $arg4 (mut (ref null eq)) (ref.null eq))
|
||||
(global $arg5 (mut (ref null eq)) (ref.null eq))
|
||||
(global $arg6 (mut (ref null eq)) (ref.null eq))
|
||||
(global $arg7 (mut (ref null eq)) (ref.null eq))
|
||||
(global $arg8 (mut (ref null eq)) (ref.null eq))
|
||||
(global $arg9 (mut (ref null eq)) (ref.null eq))
|
||||
(global $arg10 (mut (ref null eq)) (ref.null eq))
|
||||
(global $arg11 (mut (ref null eq)) (ref.null eq))
|
||||
(global $arg12 (mut (ref null eq)) (ref.null eq))
|
||||
(global $arg13 (mut (ref null eq)) (ref.null eq))
|
||||
(global $arg14 (mut (ref null eq)) (ref.null eq))
|
||||
(global $arg15 (mut (ref null eq)) (ref.null eq))
|
||||
|]
|
||||
-- other things 😼
|
||||
Wasm.defineGlobal [wat|
|
||||
(global $result (mut (ref null eq))
|
||||
(ref.null eq))
|
||||
|]
|
||||
-- procedures
|
||||
let arg = popArg 0
|
||||
Wasm.defineFunction [wat|
|
||||
(func $halt (param i32)
|
||||
##{arg}
|
||||
(global.set $result))
|
||||
|]
|
||||
pure ()
|
||||
|
||||
lower :: Exp -> Eff es Text
|
||||
lower e = fmap Wasm.renderModule . Wasm.execGenMod $ do
|
||||
runtime <- emitRuntime
|
||||
let g = MkEnv mempty mempty
|
||||
e' <- lower' g e
|
||||
Wasm.defineFunction [wat|
|
||||
(func $scm-entry (param i32)
|
||||
(local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
|
||||
##{e'})
|
||||
|]
|
||||
Wasm.defineFunction [wat|
|
||||
(func (export "main")
|
||||
(call $scm-entry (i32.const 0))
|
||||
(call $gh-write (ref.as_non_null (global.get $result))))
|
||||
|]
|
||||
|
||||
lowerProgram :: Program -> Eff es Text
|
||||
lowerProgram (MkProgram e) = lower e
|
||||
@@ -102,7 +102,7 @@ pattern AbsLambda' xs e ktail = AbsLambda (MkLambda xs e ktail)
|
||||
data Exp
|
||||
= ExpPrim (Prim Val) Kappa
|
||||
| ExpLetRec { binders :: List (Name, Abs), body :: Exp }
|
||||
| ExpContinue Name (List Val)
|
||||
| ExpContinue Val (List Val)
|
||||
| ExpIf Val Exp Exp
|
||||
| ExpApply
|
||||
{ op :: Val
|
||||
@@ -112,10 +112,10 @@ data Exp
|
||||
deriving (Show, Generic, Data, Eq)
|
||||
|
||||
pattern Halt :: List Val -> Exp
|
||||
pattern Halt xs = ExpContinue "halt" xs
|
||||
pattern Halt xs = ExpContinue (ValLabel "halt") xs
|
||||
|
||||
pattern Halt1 :: Val -> Exp
|
||||
pattern Halt1 x = ExpContinue "halt" [x]
|
||||
pattern Halt1 x = ExpContinue (ValLabel "halt") [x]
|
||||
|
||||
data Def = DefConstant Name Exp
|
||||
deriving (Show, Generic, Data)
|
||||
@@ -315,7 +315,7 @@ instance Free Exp where
|
||||
foldMapOf (each . _2) (freeWithBound' bound') bs
|
||||
<> freeWithBound' bound' m
|
||||
where bound' = bound & insertFrom (bs ^.. each . _1)
|
||||
ExpContinue k xs -> filter (`notElem` bound) (k : xs ^.. each . #ValVar)
|
||||
ExpContinue k xs -> filter (`notElem` bound) ((k:xs) ^.. each . #ValVar)
|
||||
ExpIf c t f ->
|
||||
(c ^.. #ValVar . filtered (`notElem` bound))
|
||||
<> freeWithBound' bound t <> freeWithBound' bound f
|
||||
@@ -330,21 +330,3 @@ instance Free Kappa where
|
||||
instance Free Lambda where
|
||||
freeWithBound' bound (MkLambda xs k m) =
|
||||
freeWithBound' (bound & insertFrom (k:xs)) m
|
||||
|
||||
|
||||
|
||||
class Vars a where
|
||||
-- | Traverse the immediate variables of an expression.
|
||||
vars :: Traversal' a Name
|
||||
|
||||
instance Vars Val where
|
||||
vars k (ValVar x) = ValVar <$> k x
|
||||
vars _ x = pure x
|
||||
|
||||
instance Vars a => Vars (Prim a) where
|
||||
vars k p = traverseOf (each . vars) k p
|
||||
|
||||
instance Vars Exp where
|
||||
vars k (ExpPrim p kap) = ExpPrim <$> vars k p <*> pure kap
|
||||
vars k (ExpContinue kname xs) = ExpContinue <$> k kname <*> pure xs
|
||||
vars _ e = pure e
|
||||
|
||||
@@ -1,7 +1,7 @@
|
||||
module Gyehoek.Driver
|
||||
(main, lower_e2e, convert_e2e, parse_e2e, readScm, eval_e2e)
|
||||
where
|
||||
|
||||
|
||||
import Gyehoek.Options
|
||||
import Prelude hiding (readFile)
|
||||
import Options.Applicative
|
||||
@@ -17,7 +17,7 @@ import qualified Data.Text.Encoding as T
|
||||
import System.IO (Handle)
|
||||
import System.IO qualified as IO
|
||||
import Gyehoek.CPS.Convert
|
||||
import Gyehoek.CPS.Lower
|
||||
import Gyehoek.Stack.Lower
|
||||
import Gyehoek.CPS.Eval qualified as CPS
|
||||
import Control.Monad
|
||||
import Text.Pretty.Simple (pShowNoColor)
|
||||
@@ -35,14 +35,14 @@ import Control.Arrow ((>>>))
|
||||
import Gyehoek.Prelude
|
||||
import Gyehoek.Jalmot
|
||||
import qualified Gyehoek.Sexp as S
|
||||
|
||||
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
opts <- execParser $ info (helper <*> parser) fullDesc
|
||||
runJalmotIO . runFileSystem . runGenSym . driver $ opts
|
||||
|
||||
|
||||
|
||||
|
||||
-- hPutStr :: FileSystem :> es => Handle -> Text -> Eff es ()
|
||||
-- hPutStr h = FB.hPutStr h . T.encodeUtf8
|
||||
@@ -135,10 +135,10 @@ driver opts = do
|
||||
& fmap writeObj
|
||||
& T.unwords
|
||||
& hPutStrLn FS.stdout
|
||||
dumpOrRun opts.inspectWasm (rt_is #Wasm)
|
||||
(lowerProgram cps)
|
||||
inspectWasm
|
||||
(\wat -> withFile opts.output FS.WriteMode \h -> hPutStrLn h wat)
|
||||
-- dumpOrRun opts.inspectWasm (rt_is #Wasm)
|
||||
-- (lowerProgram cps)
|
||||
-- inspectWasm
|
||||
-- (\wat -> withFile opts.output FS.WriteMode \h -> hPutStrLn h wat)
|
||||
|
||||
parse_e2e :: FilePath -> IO Scm.Program
|
||||
parse_e2e = runJalmotIO . runFileSystem . readScm
|
||||
|
||||
@@ -150,14 +150,3 @@ instance DatumIso a => DataIso (V.Vector a) where
|
||||
|
||||
instance (DatumIso a, DatumIso b) => DatumIso (a, b) where
|
||||
datumIso = with \tup2 -> list (el datumIso >>> el datumIso) >>> tup2
|
||||
|
||||
data Example = MkExample (List Int) Text
|
||||
deriving (Generic, Show)
|
||||
|
||||
instance DataIso Example where
|
||||
dataIso = with \g ->
|
||||
flipped snoced
|
||||
>>> onHead (traversed $ sealed int)
|
||||
>>> onTail (onHead $ sealed symbol)
|
||||
>>> swap
|
||||
>>> g
|
||||
|
||||
@@ -40,7 +40,7 @@ module Gyehoek.Sexp.Grammar.Base
|
||||
, lambdaLike
|
||||
, lambdaKeyword
|
||||
, kappaKeyword
|
||||
, beginLike
|
||||
, beginLike, headTagged2'
|
||||
) where
|
||||
|
||||
import Data.InvertibleGrammar
|
||||
@@ -325,6 +325,13 @@ headTagged2
|
||||
-> G (Datum :- t) (b :- a :- t)
|
||||
headTagged2 s g1 g2 = list $ el (symProcedure s) >>> el g1 >>> el g2
|
||||
|
||||
headTagged2'
|
||||
:: Text
|
||||
-> DatumGrammar a -> DatumGrammar b -> DatumGrammar c
|
||||
-> G (Datum :- t) (List c :- b :- a :- t)
|
||||
headTagged2' s g1 g2 gt =
|
||||
list $ el (symProcedure s) >>> el g1 >>> el g2 >>> rest gt
|
||||
|
||||
ifLike
|
||||
-- | keyword
|
||||
:: Text
|
||||
|
||||
@@ -0,0 +1,29 @@
|
||||
module Gyehoek.Stack.Lower
|
||||
( lowerProgram
|
||||
) where
|
||||
|
||||
import Gyehoek.Stack.Syntax
|
||||
import Gyehoek.Wasm qualified as Wasm
|
||||
import Gyehoek.Prelude
|
||||
import Gyehoek.Wasm (wat, watM)
|
||||
|
||||
|
||||
lowerRoutine :: Routine -> Wasm.Function
|
||||
lowerRoutine rt = _
|
||||
|
||||
lowerBlock :: Block -> Wasm.Expr
|
||||
lowerBlock = _
|
||||
|
||||
lowerInstr :: Instr -> Wasm.Expr
|
||||
lowerInstr = \case
|
||||
PopCont ktail -> [wat|
|
||||
|
||||
|]
|
||||
|
||||
lowerProgram :: Program -> Eff es Wasm.Module
|
||||
lowerProgram p = pure [watM|
|
||||
(module
|
||||
##{rs})
|
||||
|]
|
||||
where
|
||||
rs = p ^.. #routines . each . to lowerRoutine
|
||||
+18
-159
@@ -6,182 +6,41 @@ module Gyehoek.Wasm
|
||||
(
|
||||
-- * syntax
|
||||
Module
|
||||
, Idx
|
||||
, Program
|
||||
, Function
|
||||
, Expr
|
||||
-- ** quasiquoters
|
||||
, expr
|
||||
, S.sx
|
||||
, S.sxs
|
||||
-- * GenMod effect
|
||||
, GenMod
|
||||
, runGenMod
|
||||
, execGenMod
|
||||
, defineFunction
|
||||
, defineType
|
||||
, defineGlobal
|
||||
, emit
|
||||
, renderModule
|
||||
, watM
|
||||
, wat
|
||||
, wats
|
||||
, defineFunctions
|
||||
, defineTypes
|
||||
, defineGlobals
|
||||
)
|
||||
where
|
||||
|
||||
import Data.List (List)
|
||||
import GHC.Generics (Generic)
|
||||
import Data.Text (Text)
|
||||
import Effectful
|
||||
import Numeric.Natural (Natural)
|
||||
import Effectful.Dispatch.Dynamic
|
||||
import Effectful.State.Dynamic
|
||||
import Control.Lens
|
||||
import Data.Vector.Strict (Vector)
|
||||
import qualified Data.Vector.Strict as V
|
||||
import GHC.IsList (IsList(..))
|
||||
import Language.Haskell.TH.Quote (QuasiQuoter)
|
||||
import Data.Data (Data)
|
||||
import Gyehoek.Sexp qualified as S
|
||||
import Gyehoek.Sexp (Datum, sx, (>>>))
|
||||
import Data.Foldable (traverse_)
|
||||
import Data.Coerce (coerce)
|
||||
import Gyehoek.Sexp (Datum, (>>>))
|
||||
import Data.Data (Data)
|
||||
|
||||
|
||||
newtype Module = MkModule { inner :: Vector Datum }
|
||||
deriving (Show, Generic)
|
||||
type Program = Module
|
||||
type Function = Datum
|
||||
type Expr = List Datum
|
||||
|
||||
newtype Module = MkModule { inner :: List Datum }
|
||||
deriving (Show, Generic, Data)
|
||||
deriving newtype (Semigroup, Monoid)
|
||||
|
||||
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 = V.toList . view #inner
|
||||
|
||||
newtype Instr = MkInstr { inner :: Datum }
|
||||
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 (Show, Generic)
|
||||
|
||||
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
|
||||
}
|
||||
|
||||
instance Monoid GenModState where
|
||||
mempty = MkGenModState
|
||||
{ mod = mempty
|
||||
, funcs = 0
|
||||
, types = 0
|
||||
, globals = 0
|
||||
}
|
||||
|
||||
data GenMod :: Effect where
|
||||
DefineFunction :: Datum -> GenMod m Idx
|
||||
DefineType :: Datum -> GenMod m Idx
|
||||
DefineGlobal :: Datum -> GenMod m Idx
|
||||
Emit :: Datum -> GenMod m ()
|
||||
|
||||
type instance DispatchOf GenMod = Dynamic
|
||||
|
||||
defineFunction :: GenMod :> es => Datum -> Eff es Idx
|
||||
defineFunction = send . DefineFunction
|
||||
|
||||
defineFunctions :: GenMod :> es => List Datum -> Eff es (List Idx)
|
||||
defineFunctions = traverse (send . DefineFunction)
|
||||
|
||||
defineType :: GenMod :> es => Datum -> Eff es Idx
|
||||
defineType = send . DefineType
|
||||
|
||||
defineTypes :: GenMod :> es => List Datum -> Eff es (List Idx)
|
||||
defineTypes = traverse (send . DefineType)
|
||||
|
||||
defineGlobal :: GenMod :> es => Datum -> Eff es Idx
|
||||
defineGlobal = send . DefineGlobal
|
||||
|
||||
defineGlobals :: GenMod :> es => List Datum -> Eff es (List Idx)
|
||||
defineGlobals = traverse (send . DefineGlobal)
|
||||
|
||||
emit :: GenMod :> es => List Datum -> Eff es ()
|
||||
emit = traverse_ (send . Emit)
|
||||
|
||||
appendAndIncrement
|
||||
:: State GenModState :> es
|
||||
=> LensLike' ((,) Natural) GenModState Natural
|
||||
-> Datum
|
||||
-> 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
|
||||
_ (Emit s) -> #mod . #inner <>= V.singleton s
|
||||
|
||||
execGenMod :: Eff (GenMod : es) a -> Eff es Module
|
||||
execGenMod = fmap snd . runGenMod
|
||||
|
||||
renderModule :: Module -> Text
|
||||
renderModule (MkModule ss) = S.encodeWith' S.datumIso [sx|
|
||||
(module ##{ss})
|
||||
|]
|
||||
|
||||
|
||||
-- DatumIso instances
|
||||
|
||||
instance S.DatumIso Idx where
|
||||
datumIso = S.with \idx ->
|
||||
S.integer >>> S.partialOsi f g
|
||||
>>> idx
|
||||
where
|
||||
f n | n < 0 = Left $ S.unexpected "negative"
|
||||
<> S.expected "natural"
|
||||
| otherwise = Right $ fromIntegral n
|
||||
g = fromIntegral
|
||||
|
||||
instance S.DatumIso Instr where
|
||||
datumIso = S.with S.id
|
||||
|
||||
instance S.DataIso Expr where
|
||||
dataIso = S.dataIso @(Vector Instr) >>> S.iso coerce coerce
|
||||
instance S.DatumIso Module where
|
||||
datumIso = S.with \g ->
|
||||
S.list (S.el (S.sym "module") >>> S.rest S.datumIso)
|
||||
>>> g
|
||||
|
||||
|
||||
-- quasiquoters
|
||||
|
||||
expr :: QuasiQuoter
|
||||
expr = S.makeSxs
|
||||
[|| MkExpr . V.fromList . fmap (S.fromDatumUnsafe $ S.datumIso @Instr) ||]
|
||||
|
||||
wat :: QuasiQuoter
|
||||
wat = S.makeSx [|| id ||]
|
||||
wat = S.makeSxs [|| S.fromDataUnsafe (S.dataIso @(List Datum)) ||]
|
||||
|
||||
wats :: QuasiQuoter
|
||||
wats = S.makeSxs [|| id ||]
|
||||
watM :: QuasiQuoter
|
||||
watM = S.makeSx [|| S.fromDatumUnsafe (S.datumIso @Module) ||]
|
||||
|
||||
@@ -29,14 +29,14 @@ qq :: TestTree
|
||||
qq = testGroup "parser"
|
||||
[ testCase "lambda" do
|
||||
assertEqual "" (Sut.MkLambda ["x","y"] "ktail"
|
||||
(Sut.ExpContinue "ktail" [Sut.ValVar "x"]))
|
||||
(Sut.ExpContinue (Sut.ValLabel "ktail") [Sut.ValVar "x"]))
|
||||
[cps|(λ (x y ktail) (continue ktail x))|]
|
||||
assertEqual "" (Sut.MkLambda [] "ktail"
|
||||
(Sut.ExpContinue "ktail" [Sut.ValVar "x"]))
|
||||
(Sut.ExpContinue (Sut.ValLabel "ktail") [Sut.ValVar "x"]))
|
||||
[cps|(λ (ktail) (continue ktail x))|]
|
||||
, testCase "kappa" do
|
||||
assertEqual "" (Sut.MkKappa ["x","y"]
|
||||
(Sut.ExpContinue "k123" [Sut.ValVar "x", Sut.ValVar "y"]))
|
||||
(Sut.ExpContinue (Sut.ValLabel "k123") [Sut.ValVar "x", Sut.ValVar "y"]))
|
||||
[cps|(κ (x y) (continue k123 x y))|]
|
||||
, testCase "application" do
|
||||
assertEqual "" (Sut.ExpApply (Sut.ValVar "f")
|
||||
|
||||
Reference in New Issue
Block a user