doc

doc/index.org

@@ -0,0 +1,53 @@
+#+title: Gyehoek Scheme
+
+#+begin_center
+(this document is written in present tense as if the project is complete, but Gyehoek is a work-in-progress.)
+#+end_center
+
+Gyehoek is an R⁷RS-compliant Scheme compiler targeting WebAssembly 3.0, relying principally on the recently standardised garbage collector and tail call proposals. the Gyehoek compiler is implemented in Haskell, and the Gyehoek runtime is a Rust program providing primitive routines and WebAssembly execution via the Wasmtime library.
+
+primitives are implemented as native Rust functions made available to the guest by Wasmtime. in the future, it would be ideal to provide the primitives as a WASI interface to help decouple ourselves from a specific Wasm runtime, but it is not a priority.
+
+Gyehoek allows separate compilation, ~eval~, first-class continuations, and so on.
+
+* pipeline
+
+a Scheme program's journey through Gyehoek is as follows:
+1. read (source code → Scheme data)
+2. parse (Scheme data → AST)
+3. expand(?) (AST → AST)
+4. contify (AST → CPS)
+5. close (CPS → CPS)
+6. lower (CPS → Wasm)
+
+** read
+
+in the read phase, Gyehoek's reader serialises textual source code into a sequence of tokens, which are then parsed into S-expressions. this phase is completely agnostic towards any interpretation of the data — it's just data, not code (yet). this distinction between reading and parsing is made so that the reader can easily be shared amongst many parsers, allowing convenient definition of human-readable representations for all sorts of compiler internals. Gyehoek's intermediate languages and WebAssembly text format are of particular interest.
+
+the reader may be configured to extend R⁷RS's syntax with a special "antiquotation" notation, used internally in the compiler to elegantly interpolate and splice S-expression literals via Haskell's quasiquotation.
+#+begin_src haskell
+  let meta = 123 :: Int
+  in [sx|(a b c #{meta} d)|] -- ⇒ (a b c 123 d)
+
+  let metas = ["c","d"] :: List Text
+  in [sx|(a b ##{metas} e f)|] -- ⇒ (a b "c" "d" e f)
+#+end_src
+
+Gyehoek's lexer and parser are generated by Alex and Happy, respectively.
+
+unless otherwise noted, the term "parse" will be used in reference to the phase taking S-expressions to ASTs, while "read" refers to the combined Alex/Happy process. if the tokenisation process (Alex) must be distinguished from the "parse" process (Happy), the former is called "lexical analysis" and the latter "syntactic analysis."
+
+** parse
+
+- use invertible-grammar library
+
+** expand
+
+** contify
+
+- procedures are distinguished from continuations, and procedure applications are distinguished from continuation jumps.
+- all continuations and lambda will be named i think. the exception is continuations for primitive calls.
+
+** close
+
+** lower

gyehoek.cabal

@@ -66,7 +66,7 @@ library
     , base                  ^>=4.21.2.0
     , binary
     , containers
-    , cradle
+    , typed-process
     , effectful
     , effectful-core
     , effectful-plugin
@@ -89,6 +89,7 @@ library
     , text-short
     , unordered-containers
     , vector
+    , bytestring
 
   hs-source-dirs:   src
   default-language: GHC2024

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
@@ -182,10 +183,10 @@ lower' g e@(ExpApply f xs ktail) = do
     (ref.cast (ref $closure))
     (struct.get $closure $code)
     (return_call_ref $cont-type)
-    ;; (@gyehoek todo
-    ;;  (f' ##{f'})
-    ;;  (ktail #{l}))
-     |]
+    (@gyehoek todo
+     (f' ##{f'})
+     (ktail #{l}))
+  |]
 
 lower' g e@(ExpContinue k xs) = do
   let nargs = length xs

src/Gyehoek/CPS/Syntax.hs

@@ -2,6 +2,8 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FunctionalDependencies #-}
 module Gyehoek.CPS.Syntax
   ( Val(..)
   , Kappa(..)
@@ -18,10 +20,17 @@ module Gyehoek.CPS.Syntax
   , _ExpPrim
   , _ExpLetRec
   , _ExpApply
+  , binders
+  , body
+  , op
+  , args
+  , cont
   , cps
   , pattern AbsLambda'
   , pattern AbsKappa'
   , Abs(..)
+  , free
+  , free'
   )
   where
 
@@ -41,6 +50,11 @@ 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)
+import Data.Containers.ListUtils (nubOrd)
 
 -- Data types
 
@@ -49,10 +63,10 @@ data Val
   | ValLit Lit
   deriving (Show, Generic, Data, Eq)
 
-data Kappa = MkKappa (List Name) Exp
+data Kappa = MkKappa { binders :: List Name, body :: Exp }
   deriving (Show, Generic, Data, Eq)
 
-data Lambda = MkLambda (List Name) Name Exp
+data Lambda = MkLambda { binders :: List Name, ktail :: Name, body :: Exp }
   deriving (Show, Generic, Data, Eq)
 
 data Abs
@@ -65,7 +79,7 @@ pattern AbsLambda' xs e ktail = AbsLambda (MkLambda xs e ktail)
 
 data Exp
   = ExpPrim (Prim Val) Kappa
-  | ExpLetRec (NonEmpty (Name, Abs)) Exp
+  | ExpLetRec { binders :: NonEmpty (Name, Abs), body :: Exp }
   | ExpContinue Name (List Val)
   | ExpIf Val Exp Exp
   | ExpApply
@@ -90,14 +104,30 @@ data Program = MkProgram
   deriving (Show, Generic, Data)
 
 makePrisms ''Kappa
+-- makeLenses ''Kappa
 makePrisms ''Exp
+-- makeLenses ''Exp
+-- makeFieldsNoPrefix ''Exp
+-- makeFieldsNoPrefix ''Kappa
+-- makeLensesWith abbreviatedFields ''Exp
+-- makeLensesFor [("binders", "_binders"), ("body", "_body")] ''Exp
+makeFieldsId ''Exp
+makeFieldsId ''Kappa
+makeFieldsId ''Lambda
+
+instance HasBinders Abs (List Name) where
+  binders k (AbsKappa kap) = AbsKappa <$> binders k kap
+  binders k (AbsLambda lam) = AbsLambda <$> binders k lam
+
+instance HasBody Abs Exp where
+  body k (AbsKappa kap) = AbsKappa <$> body k kap
+  body k (AbsLambda lam) = AbsLambda <$> body k lam
 
 
 -- SexpIso instances
 
 instance S.SexpIso Val where
   sexpIso = match
-    --  $ With (. label)
     $ With (\var -> var . S.sexpIso)
     $ With (\lit -> lit . S.sexpIso)
     $ End
@@ -192,3 +222,61 @@ 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' = nubOrd . goFree HS.empty where
+
+goFreeKap bound (MkKappa xs m) = goFree (bound & insertFrom xs) m
+goFreeLam bound (MkLambda xs k m) = goFree (bound & insertFrom (k:xs)) m
+goFreeAbs bound = \case
+  AbsKappa kap -> goFreeKap bound kap
+  AbsLambda lam -> goFreeLam bound lam
+
+goFree :: HashSet Name -> Exp -> List Name
+goFree bound = \case
+  ExpPrim p k ->
+    p & toListOf (folded . #ValVar . filtered (`notElem` bound))
+      & (<> goFreeKap bound k)
+  ExpLetRec bs m ->
+    foldMapOf (each . _2) (goFreeAbs bound') bs <> goFree 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))
+    <> goFree bound t <> goFree bound f
+  ExpApply f xs k ->
+    (f:xs) ^.. (each . #ValVar . filtered (`notElem` bound))
+    <> (k ^.. filtered (`notElem` bound))
+
+freeLambda :: Lambda -> List Name
+freeLambda (MkLambda {binders,ktail,body}) = _

src/Gyehoek/Driver.hs

@@ -16,11 +16,18 @@ import qualified Gyehoek.Sexp as Sexp
 import qualified Gyehoek.Scheme.Syntax as Scm
 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.CPS.Syntax qualified as Cps
 import Control.Monad
 import Text.Pretty.Simple (pShowNoColor)
+import System.Process.Typed
+import Data.Text.Encoding (encodeUtf8)
+import System.Environment.Blank (getEnvDefault)
+import GHC.Conc (atomically)
+import qualified Data.Text.IO as TIO
+import qualified Data.ByteString.Lazy as BS
 
 
 main :: IO ()
@@ -59,6 +66,31 @@ readScm f =
     Sexp.parseSexps @Scm.CommandOrDef (fileName f) <$> hGetContents h
      >>= either error (pure . Scm.MkProgram)
 
+inspectWasm :: IOE :> es => Text -> Eff es ()
+inspectWasm wat = do
+  pager_cmd <- liftIO $ getEnvDefault "PAGER" "less"
+  let wasmtools_cfg
+        = proc "wasm-tools" ["print", "-pf", "--print-operand-stack"
+                            ,"--color", "always", "-"]
+          -- & setStdin (byteStringInput . view lazy . encodeUtf8 $ wat)
+          -- & setStdout byteStringOutput
+          & setStdin createPipe
+          & setStdout createPipe
+          & setStderr inherit
+  let pager_cfg = proc pager_cmd []
+                & setStdin createPipe
+                & setStdout inherit
+                & setStderr inherit
+  liftIO $ withProcessWait_ wasmtools_cfg \wasmtools -> do
+    TIO.hPutStrLn (getStdin wasmtools) wat
+    IO.hFlush (getStdin wasmtools)
+    IO.hClose (getStdin wasmtools)
+    withProcessWait_ pager_cfg \pager -> do
+      t <- BS.hGetContents (getStdout wasmtools)
+      BS.hPut (getStdin pager) t
+      IO.hFlush (getStdin pager)
+      IO.hClose (getStdin pager)
+
 driver
   :: (GenSym :> es, FileSystem :> es, IOE :> es)
   => Options -> Eff es ()
@@ -70,8 +102,11 @@ driver opts = do
   when opts.dumpCPS do
     hPutStrLn FS.stdout $ Sexp.encodePretty cps ^?! _Right
   wat <- lowerProgram cps
-  withFile opts.output FS.WriteMode \h ->
-    hPutStrLn h wat
+  if not opts.inspectWasm then
+    withFile opts.output FS.WriteMode \h ->
+      hPutStrLn h wat
+  else
+    inspectWasm wat
 
 parse_e2e :: FilePath -> IO Scm.Program
 parse_e2e = runEff . runFileSystem . readScm

src/Gyehoek/Options.hs

@@ -19,6 +19,7 @@ data Options = MkOptions
   -- , dumpQBE :: Maybe FilePath
   dumpCPS :: Bool
   , dumpParsed :: Bool
+  , inspectWasm :: Bool
   , output :: FilePath
   , sourceFile :: FilePath
   }
@@ -49,10 +50,12 @@ parseOutput = strOption
 
 parseDumpCPS = switch (long "dump-cps")
 parseDumpParsed = switch (long "dump-parsed")
+parseInspectWasm = switch $ long "inspect-wasm" <> short 'p'
 
 parser :: Parser Options
 parser = MkOptions
   <$> parseDumpCPS
   <*> parseDumpParsed
+  <*> parseInspectWasm
   <*> parseOutput
   <*> argument str (metavar "FILE")

src/Gyehoek/Scheme/Syntax.hs

@@ -52,7 +52,7 @@ import Language.Haskell.TH.Quote (QuasiQuoter)
 
 
 newtype Name = MkName { inner :: Text }
-  deriving newtype (Show, Eq, IsString, Gen, Hashable)
+  deriving newtype (Show, Eq, Ord, IsString, Gen, Hashable)
   deriving stock (Generic, Data)
 
 getName :: Name -> Text

t.scm

@@ -0,0 +1 @@
+(values 1 2)

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)))))

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