@@ -28,6 +28,7 @@ import qualified Gyehoek.Sexp
|
||||
import Data.Text qualified as T
|
||||
import Data.Foldable (fold)
|
||||
import Gyehoek.Sexp (encodeOrShow, toSexp)
|
||||
import Debug.Pretty.Simple
|
||||
|
||||
|
||||
data Env = MkEnv
|
||||
|
||||
@@ -2,6 +2,7 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
module Gyehoek.CPS.Syntax
|
||||
( Val(..)
|
||||
, Kappa(..)
|
||||
@@ -22,6 +23,8 @@ module Gyehoek.CPS.Syntax
|
||||
, pattern AbsLambda'
|
||||
, pattern AbsKappa'
|
||||
, Abs(..)
|
||||
, free
|
||||
, free'
|
||||
)
|
||||
where
|
||||
|
||||
@@ -41,6 +44,10 @@ import Language.Sexp.Located (Sexp)
|
||||
import qualified Data.InvertibleGrammar.Base as IG
|
||||
import qualified Gyehoek.Scheme.Syntax as Gyehoek
|
||||
import Data.InvertibleGrammar.Base (type (:-)((:-)))
|
||||
import Data.HashSet (HashSet)
|
||||
import qualified Data.HashSet as HS
|
||||
import Data.Hashable (Hashable)
|
||||
import Data.Monoid (Endo)
|
||||
|
||||
-- Data types
|
||||
|
||||
@@ -97,7 +104,6 @@ makePrisms ''Exp
|
||||
|
||||
instance S.SexpIso Val where
|
||||
sexpIso = match
|
||||
-- $ With (. label)
|
||||
$ With (\var -> var . S.sexpIso)
|
||||
$ With (\lit -> lit . S.sexpIso)
|
||||
$ End
|
||||
@@ -192,3 +198,56 @@ instance CPS Abs where toCPS = Gyehoek.Sexp.fromSexp
|
||||
|
||||
cps :: QuasiQuoter
|
||||
cps = Gyehoek.Sexp.makeSx' [| toCPS |]
|
||||
|
||||
|
||||
|
||||
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
|
||||
|
||||
toHashSetOf :: Hashable a => Getting (Endo (HashSet a)) s a -> s -> HashSet a
|
||||
toHashSetOf l = foldrOf l HS.insert mempty
|
||||
|
||||
free :: Exp -> HashSet Name
|
||||
free = go where
|
||||
gokap (MkKappa xs m) = go m & deleteFrom xs
|
||||
golam (MkLambda xs k m) = go m & deleteFrom xs & sans k
|
||||
goabs = \case
|
||||
AbsKappa kap -> gokap kap
|
||||
AbsLambda lam -> golam lam
|
||||
go = \case
|
||||
ExpPrim p k ->
|
||||
p & toHashSetOf (folded . #ValVar)
|
||||
& HS.union (gokap k)
|
||||
ExpLetRec bs m ->
|
||||
foldMapOf (each . _2) goabs bs <> go m
|
||||
& deleteFrom (bs ^.. each . _1)
|
||||
ExpContinue k xs -> HS.fromList $ k : xs ^.. each . #ValVar
|
||||
ExpIf c t f -> toHashSetOf #ValVar c <> go t <> go f
|
||||
ExpApply f xs k -> toHashSetOf (each . #ValVar) (f:xs) <> HS.singleton k
|
||||
|
||||
-- | Free variables given in the order of their appearance.
|
||||
free' :: Exp -> List Name
|
||||
free' = go HS.empty where
|
||||
gokap bound (MkKappa xs m) = go (bound & insertFrom xs) m
|
||||
golam bound (MkLambda xs k m) = go (bound & insertFrom (k:xs)) m
|
||||
goabs bound = \case
|
||||
AbsKappa kap -> gokap bound kap
|
||||
AbsLambda lam -> golam bound lam
|
||||
go :: HashSet Name -> Exp -> List Name
|
||||
go bound = \case
|
||||
ExpPrim p k ->
|
||||
p & toListOf (folded . #ValVar . filtered (`notElem` bound))
|
||||
& (<> gokap bound k)
|
||||
ExpLetRec bs m ->
|
||||
foldMapOf (each . _2) (goabs bound') bs <> go bound' m
|
||||
where bound' = bound & insertFrom (bs ^.. each . _1)
|
||||
ExpContinue k xs -> filter (`notElem` bound) (k : xs ^.. each . #ValVar)
|
||||
ExpIf c t f ->
|
||||
(c ^.. #ValVar . filtered (`notElem` bound))
|
||||
<> go bound t <> go bound f
|
||||
ExpApply f xs k ->
|
||||
(f:xs) ^.. (each . #ValVar . filtered (`notElem` bound))
|
||||
<> (k ^.. filtered (`notElem` bound))
|
||||
|
||||
@@ -0,0 +1,265 @@
|
||||
(module
|
||||
(import
|
||||
"gyehoek"
|
||||
"write"
|
||||
(func $gh-write (param (ref eq))))
|
||||
(import
|
||||
"gyehoek"
|
||||
"truthy?"
|
||||
(func $gh-truthy? (param (ref eq)) (result i32)))
|
||||
(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)))))
|
||||
(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)))
|
||||
(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)))
|
||||
(global $result (mut (ref null eq)) (ref.null eq))
|
||||
(func
|
||||
$halt
|
||||
(param i32)
|
||||
(@gyehoek "pop argument")
|
||||
(global.get $arg-array)
|
||||
(i32.const 0)
|
||||
(array.get $arg-array-type)
|
||||
ref.as_non_null
|
||||
(global.set $result))
|
||||
(func
|
||||
(param i32)
|
||||
(@gyehoek :origin "(κ (x5) (continue λ-tail1 x5))")
|
||||
(local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
|
||||
(@gyehoek "pop argument")
|
||||
(global.get $arg-array)
|
||||
(i32.const 0)
|
||||
(array.get $arg-array-type)
|
||||
ref.as_non_null
|
||||
(local.set 1)
|
||||
(@gyehoek :origin "(continue λ-tail1 x5)")
|
||||
(@gyehoek "push args")
|
||||
(@gyehoek "push argument")
|
||||
(global.get $arg-array)
|
||||
(i32.const 0)
|
||||
(local.get 4)
|
||||
(array.set $arg-array-type)
|
||||
(@gyehoek "nargs")
|
||||
(i32.const 1)
|
||||
(@gyehoek "pop cont stack")
|
||||
(global.get $cont-stack-top)
|
||||
(i32.const 1)
|
||||
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))
|
||||
(elem declare funcref (ref.func 3))
|
||||
(func
|
||||
(param i32)
|
||||
(@gyehoek
|
||||
:origin
|
||||
"(κ (x3) (letrec ((r4 (κ (x5) (continue λ-tail1 x5)))) (f x3 r4)))")
|
||||
(local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
|
||||
(@gyehoek "pop argument")
|
||||
(global.get $arg-array)
|
||||
(i32.const 0)
|
||||
(array.get $arg-array-type)
|
||||
ref.as_non_null
|
||||
(local.set 1)
|
||||
(@gyehoek :origin "(f x3 r4)")
|
||||
(@gyehoek "push cont" :idx 3)
|
||||
(array.set
|
||||
$cont-stack-type
|
||||
(global.get $cont-stack)
|
||||
(global.get $cont-stack-top)
|
||||
(ref.func 3))
|
||||
(global.set
|
||||
$cont-stack-top
|
||||
(i32.add (global.get $cont-stack-top) (i32.const 1)))
|
||||
(@gyehoek :origin "(f x3 r4)")
|
||||
(@gyehoek "load args")
|
||||
(@gyehoek "push argument")
|
||||
(global.get $arg-array)
|
||||
(i32.const 0)
|
||||
(local.get 3)
|
||||
(array.set $arg-array-type)
|
||||
(i32.const 1)
|
||||
(local.get 1)
|
||||
(ref.cast (ref $closure))
|
||||
(struct.get $closure $code)
|
||||
(return_call_ref $cont-type))
|
||||
(elem declare funcref (ref.func 4))
|
||||
(func
|
||||
(param i32)
|
||||
(@gyehoek
|
||||
:origin
|
||||
"(λ (f x λ-tail1) (letrec ((r2 (κ (x3) (letrec ((r4 (κ (x5) (continue λ-tail1 x5)))) (f x3 r4))))) (f x r2)))")
|
||||
(local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
|
||||
(@gyehoek "pop argument")
|
||||
(global.get $arg-array)
|
||||
(i32.const 0)
|
||||
(array.get $arg-array-type)
|
||||
ref.as_non_null
|
||||
(local.set 1)
|
||||
(@gyehoek "pop argument")
|
||||
(global.get $arg-array)
|
||||
(i32.const 1)
|
||||
(array.get $arg-array-type)
|
||||
ref.as_non_null
|
||||
(local.set 2)
|
||||
(@gyehoek :origin "(f x r2)")
|
||||
(@gyehoek "push cont" :idx 4)
|
||||
(array.set
|
||||
$cont-stack-type
|
||||
(global.get $cont-stack)
|
||||
(global.get $cont-stack-top)
|
||||
(ref.func 4))
|
||||
(global.set
|
||||
$cont-stack-top
|
||||
(i32.add (global.get $cont-stack-top) (i32.const 1)))
|
||||
(@gyehoek :origin "(f x r2)")
|
||||
(@gyehoek "load args")
|
||||
(@gyehoek "push argument")
|
||||
(global.get $arg-array)
|
||||
(i32.const 0)
|
||||
(local.get 2)
|
||||
(array.set $arg-array-type)
|
||||
(i32.const 1)
|
||||
(local.get 1)
|
||||
(ref.cast (ref $closure))
|
||||
(struct.get $closure $code)
|
||||
(return_call_ref $cont-type))
|
||||
(elem declare funcref (ref.func 5))
|
||||
(func
|
||||
(param i32)
|
||||
(@gyehoek
|
||||
:origin
|
||||
"(λ (x λ-tail7) (prim (+ x 4) (κ (r8) (continue λ-tail7 r8))))")
|
||||
(local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
|
||||
(@gyehoek "pop argument")
|
||||
(global.get $arg-array)
|
||||
(i32.const 0)
|
||||
(array.get $arg-array-type)
|
||||
ref.as_non_null
|
||||
(local.set 1)
|
||||
(@gyehoek
|
||||
:origin
|
||||
"(prim (+ x 4) (κ (r8) (continue λ-tail7 r8)))")
|
||||
(local.get 1)
|
||||
(i31.get_s (ref.cast (ref i31)))
|
||||
(i32.const 1)
|
||||
i32.shr_u
|
||||
(i32.const 4)
|
||||
(@gyehoek "construct small fixnum")
|
||||
(i32.const 1)
|
||||
i32.shl
|
||||
ref.i31
|
||||
(i31.get_s (ref.cast (ref i31)))
|
||||
(i32.const 1)
|
||||
i32.shr_u
|
||||
i32.add
|
||||
(@gyehoek "construct small fixnum")
|
||||
(i32.const 1)
|
||||
i32.shl
|
||||
ref.i31
|
||||
(local.set 2)
|
||||
(@gyehoek :origin "(continue λ-tail7 r8)")
|
||||
(@gyehoek "push args")
|
||||
(@gyehoek "push argument")
|
||||
(global.get $arg-array)
|
||||
(i32.const 0)
|
||||
(local.get 2)
|
||||
(array.set $arg-array-type)
|
||||
(@gyehoek "nargs")
|
||||
(i32.const 1)
|
||||
(@gyehoek "pop cont stack")
|
||||
(global.get $cont-stack-top)
|
||||
(i32.const 1)
|
||||
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))
|
||||
(elem declare funcref (ref.func 6))
|
||||
(func
|
||||
(param i32)
|
||||
(@gyehoek :origin "(κ (x10) (continue halt x10))")
|
||||
(local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
|
||||
(@gyehoek "pop argument")
|
||||
(global.get $arg-array)
|
||||
(i32.const 0)
|
||||
(array.get $arg-array-type)
|
||||
ref.as_non_null
|
||||
(local.set 1)
|
||||
(@gyehoek "push argument")
|
||||
(global.get $arg-array)
|
||||
(i32.const 0)
|
||||
(local.get 3)
|
||||
(array.set $arg-array-type)
|
||||
(return_call $halt (i32.const 1)))
|
||||
(elem declare funcref (ref.func 7))
|
||||
(func
|
||||
$scm-entry
|
||||
(param i32)
|
||||
(@gyehoek
|
||||
:origin
|
||||
"(letrec ((λ-body0 (λ (f x λ-tail1) (letrec ((r2 (κ (x3) (letrec ((r4 (κ (x5) (continue λ-tail1 x5)))) (f x3 r4))))) (f x r2))))) (letrec ((λ-body6 (λ (x λ-tail7) (prim (+ x 4) (κ (r8) (continue λ-tail7 r8)))))) (letrec ((r9 (κ (x10) (continue halt x10)))) (λ-body0 λ-body6 9 r9))))")
|
||||
(local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
|
||||
(i32.const 0)
|
||||
(ref.func 5)
|
||||
(struct.new $closure)
|
||||
(local.set 1)
|
||||
(i32.const 0)
|
||||
(ref.func 6)
|
||||
(struct.new $closure)
|
||||
(local.set 2)
|
||||
(@gyehoek :origin "(λ-body0 λ-body6 9 r9)")
|
||||
(@gyehoek "push cont" :idx 7)
|
||||
(array.set
|
||||
$cont-stack-type
|
||||
(global.get $cont-stack)
|
||||
(global.get $cont-stack-top)
|
||||
(ref.func 7))
|
||||
(global.set
|
||||
$cont-stack-top
|
||||
(i32.add (global.get $cont-stack-top) (i32.const 1)))
|
||||
(@gyehoek :origin "(λ-body0 λ-body6 9 r9)")
|
||||
(@gyehoek "load args")
|
||||
(@gyehoek "push argument")
|
||||
(global.get $arg-array)
|
||||
(i32.const 0)
|
||||
(local.get 2)
|
||||
(array.set $arg-array-type)
|
||||
(@gyehoek "push argument")
|
||||
(global.get $arg-array)
|
||||
(i32.const 1)
|
||||
(i32.const 9)
|
||||
(@gyehoek "construct small fixnum")
|
||||
(i32.const 1)
|
||||
i32.shl
|
||||
ref.i31
|
||||
(array.set $arg-array-type)
|
||||
(i32.const 1)
|
||||
(local.get 1)
|
||||
(ref.cast (ref $closure))
|
||||
(struct.get $closure $code)
|
||||
(return_call_ref $cont-type))
|
||||
(func
|
||||
(export "main")
|
||||
(call $scm-entry (i32.const 0))
|
||||
(call $gh-write (ref.as_non_null (global.get $result)))))
|
||||
|
||||
@@ -1,3 +1,4 @@
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
module Gyehoek.Test.CPS.Syntax (root) where
|
||||
|
||||
import Test.Tasty (TestTree, testGroup)
|
||||
@@ -13,8 +14,20 @@ import Gyehoek.Test.Sexp (equivto)
|
||||
root :: IO TestTree
|
||||
root = pure . testGroup "cps syntax" $
|
||||
[ qqTree
|
||||
, freeTree
|
||||
]
|
||||
|
||||
freeTree :: TestTree
|
||||
freeTree = testCase "free" do
|
||||
Sut.free [cps|
|
||||
(letrec ((x (lambda (r k1) (continue k1 y)))
|
||||
(y (lambda (r k2) (continue k2 x))))
|
||||
(continue x y k3))|] @=? ["k3"]
|
||||
Sut.free' [cps|
|
||||
(letrec ((x (lambda (r k1) (continue k1 y)))
|
||||
(y (lambda (r k2) (continue k2 x))))
|
||||
(continue x y k3))|] @=? ["k3"]
|
||||
|
||||
qqTree :: TestTree
|
||||
qqTree = testGroup "parser"
|
||||
[ testCase "lambda" do
|
||||
|
||||
Reference in New Issue
Block a user