From be1d7566f4169b57ecf3acfb84747cfd87db3d53 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Madeleine=20Sydney=20=C5=9Alaga?= Date: Mon, 20 Jul 2026 13:09:51 -0600 Subject: [PATCH] idk ^w^ --- src/Gyehoek/CPS/Lower.hs | 1 + src/Gyehoek/CPS/Syntax.hs | 61 +++++++- t.scm | 1 + t.wat | 265 ++++++++++++++++++++++++++++++++ test/Gyehoek/Test/CPS/Syntax.hs | 13 ++ 5 files changed, 340 insertions(+), 1 deletion(-) create mode 100644 t.scm diff --git a/src/Gyehoek/CPS/Lower.hs b/src/Gyehoek/CPS/Lower.hs index 308d16c..f8f1186 100644 --- a/src/Gyehoek/CPS/Lower.hs +++ b/src/Gyehoek/CPS/Lower.hs @@ -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 diff --git a/src/Gyehoek/CPS/Syntax.hs b/src/Gyehoek/CPS/Syntax.hs index aae9b8d..5baa2d8 100644 --- a/src/Gyehoek/CPS/Syntax.hs +++ b/src/Gyehoek/CPS/Syntax.hs @@ -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)) diff --git a/t.scm b/t.scm new file mode 100644 index 0000000..fe84f87 --- /dev/null +++ b/t.scm @@ -0,0 +1 @@ +(values 1 2) diff --git a/t.wat b/t.wat index e69de29..8b4601f 100644 --- a/t.wat +++ b/t.wat @@ -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))))) diff --git a/test/Gyehoek/Test/CPS/Syntax.hs b/test/Gyehoek/Test/CPS/Syntax.hs index 96e3816..d866891 100644 --- a/test/Gyehoek/Test/CPS/Syntax.hs +++ b/test/Gyehoek/Test/CPS/Syntax.hs @@ -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