pass continuations as arguments, use normal stack

flake.nix

@@ -26,6 +26,7 @@
           gyehoek = final.haskell-nix.project' {
             src = ./.;
             compiler-nix-name = "ghc912";
+            configureArgs = "-f-doctest";
             modules = [({ pkgs, lib, ...}: {
               packages.gyehoek.components.tests.test.preCheck =
                 let

golden/exec/factorial/exec

@@ -1,2 +1,2 @@
 ret > ExitSuccess
-out > 720
+out > 2432902008176640000

golden/exec/factorial/source.scm

@@ -2,4 +2,4 @@
                 (if (zero? n)
                     1
                     (* n (fac (- n 1)))))))
-  (fac 6))
+  (fac 20))

gyehoek.cabal

@@ -13,6 +13,11 @@ build-type:    Simple
 -- extra-doc-files:    CHANGELOG.md
 -- extra-source-files:
 
+flag doctest
+  description: enable the doctest suite
+  default:     True
+  manual:      True
+
 common ghcstuffs-dev
   ghc-options:
     -Wno-unused-matches -Wno-missing-signatures -Wno-typed-holes
@@ -55,7 +60,6 @@ library
     Gyehoek.CPS.Close
     Gyehoek.CPS.Convert
     Gyehoek.CPS.Eval
-    Gyehoek.CPS.Lower
     Gyehoek.CPS.Stackify
     Gyehoek.CPS.Syntax
     Gyehoek.Driver
@@ -72,6 +76,7 @@ library
     Gyehoek.Sexp.QQ
     Gyehoek.Sexp.Read
     Gyehoek.Sexp.Syntax
+    Gyehoek.Stack.Lower
     Gyehoek.Stack.Syntax
     Gyehoek.Stack.VM
     Gyehoek.Wasm
@@ -156,11 +161,16 @@ test-suite test
   default-language:   GHC2024
 
 -- https://github.com/martijnbastiaan/doctest-parallel/pull/66
--- test-suite doctest
---   import:         ghcstuffs, ghcstuffs-dev
---   type:           exitcode-stdio-1.0
---   hs-source-dirs: test
---   main-is:        doctest.hs
---   build-depends:
---     , base
---     , doctest-parallel  >=0.1
+test-suite doctest
+  import:             ghcstuffs, ghcstuffs-dev
+  type:               exitcode-stdio-1.0
+  hs-source-dirs:     test
+  build-depends:      base
+  default-extensions: CPP
+  main-is:            doctest.hs
+
+  if flag(doctest)
+    build-depends: doctest-parallel >=0.1
+
+  else
+    cpp-options: -DGYEHOEK_NO_DOCTEST

src/Gyehoek/CPS/Close.hs

@@ -38,4 +38,4 @@ close = transformM \case
   e -> pure e
 
 closeProgram :: GenSym :> es => Program -> Eff es Program
-closeProgram = traverseOf #body close
+closeProgram = traverseOf (#body . #body) close

src/Gyehoek/CPS/Convert.hs

@@ -105,12 +105,15 @@ 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
-convertProgram p =
-  MkProgram <$> telescope (convert @es) (p ^.. each . _Left) (pure . Halt)
+convertProgram p = do
+  ktail <- gensym' "start-ktail"
+  m <- telescope (convert @es) (p ^.. each . _Left)
+        (pure . ExpContinue (ValVar ktail))
+  pure . MkProgram $ MkLambda [] ktail m
 
 convertExp :: forall es. (GenSym :> es) => Scm.Exp -> Eff es Exp
 convertExp e = convert e (pure . Halt1)

src/Gyehoek/CPS/Eval.hs

@@ -2,6 +2,7 @@
 module Gyehoek.CPS.Eval
   ( evalProgram
   , module Gyehoek.CPS.Syntax
+  , evalExp
   ) where
 
 import Gyehoek.CPS.Syntax
@@ -22,7 +23,7 @@ eval :: Env -> Exp -> List Obj
 
 eval g (Halt xs) = evalVal g <$> xs
 
-eval g (ExpContinue k xs) =
+eval g (ExpContinue ((^?! #ValVar) -> k) xs) =
   case g ^. #labels . at k of
     Just (h, AbsKappa' bs m) -> eval h' m
       where h' = h & #vars <>~ envOfBinds bs (evalVal g <$> xs)
@@ -75,5 +76,11 @@ emptyEnv = MkEnv
     )
   }
 
+evalExp :: Exp -> List Obj
+evalExp = eval emptyEnv
+
 evalProgram :: Program -> List Obj
-evalProgram (MkProgram e) = eval emptyEnv e
+evalProgram (MkProgram lam) = eval emptyEnv [cps|
+  (letrec ((start #{lam}))
+    (apply start halt))
+|]

src/Gyehoek/CPS/Lower.hs

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

src/Gyehoek/CPS/Stackify.hs

@@ -1,7 +1,6 @@
 {-# LANGUAGE OverloadedLists #-}
 module Gyehoek.CPS.Stackify
-  ( stackifyExp
-  , stackifyProgram
+  ( stackifyProgram
   , module Gyehoek.CPS.Syntax
   ) where
 
@@ -13,8 +12,11 @@ import Gyehoek.GenSym
 import Effectful.Writer.Static.Shared
 import Data.Foldable
 import qualified Data.HashMap.Strict as H
-import Data.List (elemIndex)
+import Data.List (elemIndex, nub)
+import Data.Text qualified as T
 import Gyehoek.Prelude
+import Debug.Pretty.Simple
+import qualified Gyehoek.Sexp as S
 
 
 type Stackify = Writer Stk.Program
@@ -23,9 +25,10 @@ runStackify :: Eff (Stackify : es) a -> Eff es (a, Stk.Program)
 runStackify = runWriter
 
 live :: Free a => Env -> a -> List Name
-live g e = free' e & filter \x ->
+-- TODO: free' should return an OSet lol
+live g e = nub (free' e) & filter \x ->
   x `H.member` g.bound
-  && not (x `elem` g.contStack)
+  -- && not (x `elem` g.contStack)
 
 data BlockBuilder
   = Code (List Stk.Instr) BlockBuilder
@@ -47,20 +50,18 @@ stackify
 stackify g (ExpLetRec [(f, kap@(AbsKappa' xs m))] e) = do
   let vs = (f, Stk.ValLabel f) : (bindReg <$> xs)
   let ls = live g kap
-  m' <- stackify (g & #bound .~ H.fromList (vs ++ (bindReg <$> ls))) m
+  m' <- stackify (g & #bound <>~ H.fromList (vs ++ (bindReg <$> ls))) m
   emitRoutine $
     Stk.MkRoutine f xs . buildBlock $
-      Code [Stk.Pop x | x <- ls] m'
+      -- pop in the opposite order we push
+      Code [Stk.Pop x | x <- reverse ls] m'
   let g' = g & #bound . at f ?~ Stk.ValLabel f
              & #liveness . at f ?~ ls
   stackify g' e
 
-stackify g (ExpLetRec [(f, AbsLambda' xs k m)] e) = do
-  let vs = (k:xs) <&> \x -> (x, Stk.ValReg x)
-  m' <- stackify (g & #bound .~ H.fromList vs
-                    & #contStack %~ (k:)) m
-  emitRoutine $ Stk.MkRoutine f xs (buildBlock m')
-  stackify g e
+stackify g (ExpLetRec [(f, AbsLambda lam)] e) = do
+  emitRoutine =<< stackifyLambda g f lam
+  stackify (g & #bound . at f ?~ Stk.ValLabel f) e
 
 stackify g (ExpIf c t f) = do
   let c' = stackifyVal g c
@@ -69,36 +70,41 @@ stackify g (ExpIf c t f) = do
   pure . Tail $ Stk.If c' t' f'
 
 stackify g (ExpApply f xs ktail) = pure $
-    Code [ Stk.PushCont k ] $
     Code [ Stk.Push (Stk.ValReg l) | l <- ls ] $
-    Tail (Stk.TailCall (stackifyVal g f) (stackifyVal g <$> xs))
+    Tail (Stk.TailCall (stackifyVal g f) (k : (stackifyVal g <$> xs)))
   where
     k = var g ktail
     ls = fold $ (k ^? #ValImm . #ImmLabel)
       >>= \klbl -> g ^. #liveness . at klbl
 
-stackify g (ExpContinue k xs) =
-  -- return continuations require popping the stack. how do we know
-  -- when a continuation is a return continuation? is this a correct
-  -- test?
-  case elemIndex k g.contStack of
-    Nothing -> pure . Tail $ Stk.TailCall (Stk.ValLabel k) xs'
-    Just j -> do
-      ktail <- gensym' @Name $ k ^. _Wrapped'
-      pure $
-        Code (replicate j $ Stk.PopCont "_") $
-        Code [Stk.PopCont ktail] $
-        Tail (Stk.TailCall (Stk.ValReg ktail) xs')
-  where xs' = stackifyVal g <$> xs
+stackify g e@(ExpContinue k xs) = do
+  pure $
+    Code [ Stk.Push (Stk.ValReg l) | l <- ls ] $
+    Tail (Stk.TailCall k' (stackifyVal g <$> xs))
+  where
+    k' = stackifyVal g k
+    ls = fold $ (k' ^? #ValImm . #ImmLabel)
+      >>= \klbl -> g ^. #liveness . at klbl
 
 stackify g (ExpPrim p (MkKappa [x] e)) = do
   e' <- stackify (g & #bound . at x ?~ Stk.ValReg x) e
   pure $
-    Code [ Stk.Prim x (stackifyVal g <$> p) ] $
-    e'
+    Code [ Stk.Prim x (stackifyVal g <$> p) ] e'
 
 stackify _ e = error [i|unimplemented exp: #{e}|]
 
+-- affine
+_ValName :: Traversal' Val Name
+_ValName = failing #ValVar (#ValImm . #ImmLabel)
+
+stackifyLambda
+  :: (Stackify :> es, GenSym :> es)
+  => Env -> Name -> Lambda -> Eff es Stk.Routine
+stackifyLambda g name (MkLambda xs k m) = do
+  let vs = [ (x, Stk.ValReg x) | x <- k:xs ]
+  m' <- stackify (g & #bound <>~ H.fromList vs) m
+  pure $ Stk.MkRoutine name (k:xs) (buildBlock m')
+
 stackifyVal :: Env -> Val -> Stk.Val
 stackifyVal g = \case
   ValImm imm -> Stk.ValImm imm
@@ -121,39 +127,30 @@ data Env = MkEnv
   -- entry @(k,ls)@ where @ls@ is the sequence of registers @k@
   -- expects to find saved on the stack.
   , liveness :: HashMap Name (List Name)
-  , contStack :: List Name
   }
   deriving (Show, Generic)
 
 emptyEnv :: Env
-emptyEnv = MkEnv mempty mempty ["halt"]
+emptyEnv = MkEnv mempty mempty
 
 
 
-stackifyExp :: GenSym :> es => Name -> Exp -> Eff es Stk.Program
-stackifyExp lbl e = do
-  (code,p) <- runStackify $ stackify emptyEnv e
-  pure $ p <> [ Stk.MkRoutine lbl [] (buildBlock code) ]
-
 stackifyProgram :: GenSym :> es => Program -> Eff es Stk.Program
-stackifyProgram (MkProgram e) = stackifyExp "main" e
+stackifyProgram (MkProgram lam) = do
+  let g = emptyEnv
+  (start,p) <- runStackify $ stackifyLambda g "start" lam
+  pure $ p <> [ start ]
 
-
-
-fac :: Program
-fac = [cps|
-  (letrec ((fac (λ (n ktail)
-                  (prim (zero? n)
-                        (κ (x0)
-                           (if x0
-                               (continue ktail 1)
-                               (prim (- n 1)
-                                 (κ (x1)
-                                    (letrec ((fac-k0
-                                              (κ (x2)
-                                                 (prim (* n x2)
-                                                   (κ (x3)
-                                                     (continue ktail x3))))))
-                                      (fac x1 fac-k0))))))))))
-    (fac 6 halt))
+letfn :: Program
+letfn = [cps|
+(λ (start-ktail0)
+  (letrec ((lambda-body1
+            (λ (x lambda-tail2)
+              (prim (* x x) (κ (r3) (continue lambda-tail2 r3))))))
+    (letrec ((let-body6
+              (κ (square)
+                (letrec ((r4 (κ (x5) (continue start-ktail0 x5))))
+                  (square 4 r4)))))
+      (continue let-body6 lambda-body1))))
 |]
+

src/Gyehoek/CPS/Syntax.hs

@@ -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,16 +112,16 @@ 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)
 
 data Program = MkProgram
-  { body :: Exp
+  { body :: Lambda
   }
   deriving (Show, Generic, Data)
 
@@ -190,28 +190,23 @@ instance S.DatumIso Hob where
         (const . Left $ mempty)
 
 instance S.DatumIso Lambda where
-  datumIso = S.match
-    $ S.With (. lambda)
-    $ S.End
+  datumIso = S.with (lam >>>)
     where
-      lambda = S.list $
-        S.el S.lambdaKeyword
-        >>> S.el binders
-        >>> S.el S.datumIso
+      lam :: forall t. G (Datum :- t) (Exp :- Name :- List Name :- t)
+      lam = S.lambdaLike
+        S.lambdaKeyword
+        binders
+        (S.el $ S.datumIso @Exp)
       binders :: forall t. G (Datum :- t) (Name :- List Name :- t)
-      binders = S.list $
-        S.rest (S.datumIso @Name)
-        >>> S.onTail (S.flipped $ IG.PartialIso
-                     (\(ktail:-args:-t) -> (args ++ [ktail]) :- t)
-                     (\(args:-t) -> case args ^? _Snoc of
-                         Just (args',ktail) -> Right $ ktail :- args' :- t
-                         Nothing -> Left $ S.expected "cont param")
-                     )
+      binders =
+        S.list (S.rest $ S.datumIso @Name)
+        >>> S.flipped S.snoced
+        >>> S.swap
 
 instance S.DatumIso Kappa where
   datumIso = S.with \g ->
     S.lambdaLike S.kappaKeyword
-      (S.list $ S.rest (S.datumIso @Name))
+      (S.datumIso @(List Name))
       (S.el $ S.datumIso @Exp)
     >>> g
 
@@ -260,7 +255,7 @@ instance S.DatumIso Exp where
         >>> S.el S.datumIso
 
 instance S.DatumIso Program where
-  datumIso = S.with \prog -> S.datumIso @Exp >>> prog
+  datumIso = S.with \prog -> S.datumIso @Lambda >>> prog
 
 
 -- quasiquoters
@@ -315,7 +310,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 +325,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

src/Gyehoek/Driver.hs

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

src/Gyehoek/Sexp/Grammar.hs

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

src/Gyehoek/Sexp/Grammar/Base.hs

@@ -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
@@ -358,9 +365,9 @@ letLike kw name rhs e = listWithIndentation (NSpecial 1) $
 
 lambdaLike
   :: (forall t. G (Datum :- t) t)
-  -> DatumGrammar a
-  -> G (ListContext :- a :- t) (ListContext :- t')
-  -> G (Datum :- t) t'
+  -> G (Datum :- t1) (a :- t2)
+  -> G (ListContext :- a :- t2) (ListContext :- t3)
+  -> G (Datum :- t1) t3
 lambdaLike kw formals body = listWithIndentation (NSpecial 1) $
   el (decorate SynBuiltin >>> kw)
   >>> el formals

src/Gyehoek/Stack/Lower.hs

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

src/Gyehoek/Stack/Syntax.hs

@@ -60,6 +60,7 @@ data Block = MkBlock
 
 data Tail
   = TailCall Val (List Val)
+  | PushCall Val Val (List Val)
   | If Val Block Block
   deriving stock (Show, Generic, Data)
   deriving anyclass (NFData)
@@ -67,8 +68,6 @@ data Tail
 data Instr
   = Pop Name
   | Push Val
-  | PopCont Name
-  | PushCont Val
   | Prim Name (Prim Val)
   deriving stock (Show, Generic, Data)
   deriving anyclass (NFData)
@@ -91,8 +90,6 @@ instance S.DatumIso Instr where
   datumIso = S.match
     $ S.With (S.headTagged1 "pop!" regName >>>)
     $ S.With (S.headTagged1 "push!" S.datumIso >>>)
-    $ S.With (S.headTagged1 "pop-cont!" regName >>>)
-    $ S.With (S.headTagged1 "push-cont!" S.datumIso >>>)
     $ S.With (S.headTagged2 "prim" regName S.datumIso >>>)
     $ S.End
     where
@@ -107,7 +104,8 @@ instance S.DataIso Block where
 
 instance S.DatumIso Tail where
   datumIso = S.match
-    $ S.With (S.headTagged1' "tail-call!" S.datumIso S.datumIso >>>)
+    $ S.With (S.headTagged1' "tail-call" S.datumIso S.datumIso >>>)
+    $ S.With (S.headTagged2' "push-call" S.datumIso S.datumIso S.datumIso >>>)
     $ S.With (if_ >>>)
     $ S.End
     where

src/Gyehoek/Stack/VM.hs

@@ -17,7 +17,6 @@ import Gyehoek.Prelude
 
 data VM = MkVM
   { stack :: List Obj
-  , kstack :: List Name
   , code :: List Instr
   , tail :: Tail
   , registers :: HashMap Name Obj
@@ -40,8 +39,6 @@ stepI :: Env -> VM -> Instr -> VM
 
 stepI e vm (Push v) = vm & #stack %~ (evalVal e vm v :)
 
-stepI e vm (PushCont k) = vm & #kstack %~ (evalToLabel e vm k :)
-
 stepI e vm (Prim r p) = case evalVal e vm <$> p of
   PrimZeroP x -> case x of
     ObjImm (ImmInt n) -> ret . ObjImm . ImmBool $ n == 0
@@ -74,11 +71,6 @@ stepI e vm (Pop r) = case vm ^. #stack of
   (x:xs) -> vm & #registers . at r ?~ x
                & #stack .~ xs
 
-stepI e vm ins@(PopCont r) = case vm ^. #kstack of
-  [] -> error [i|empty cont stack: #{ins}|]
-  (x:xs) -> vm & #registers . at r ?~ ObjImm (ImmLabel x)
-               & #kstack .~ xs
-
 stepI e vm ins = error [i|unimplemented instruction: #{ins}|]
 
 stepT :: Env -> VM -> Tail -> VM
@@ -95,6 +87,9 @@ stepT g vm (TailCall f xs) =
           Nothing -> error [i|undefined label: #{l}|]
           Just x -> x
 
+stepT g vm (PushCall k f xs) =
+  _
+
 stepT g vm (If c t f) = vm & #code .~ branch.code & #tail .~ branch.tail
   where
     branch = case evalVal g vm c of
@@ -116,9 +111,8 @@ evalVal e vm = \case
 initialVM :: VM
 initialVM = MkVM
   { stack = []
-  , kstack = ["halt"]
   , code = []
-  , tail = TailCall (ValLabel "main") []
+  , tail = TailCall (ValLabel "start") [ValLabel "halt"]
   , registers = mempty
   , stdout = ""
   , result = Nothing
@@ -154,3 +148,23 @@ writeObj (ObjImm im) = case im of
   ImmLabel l -> "#<procedure>"
 writeObj (ObjHob h) = case h of
   HobClosure code env -> "#<procedure>"
+
+blah = [stkP|
+(define ($lambda-body0-code7 %lambda-tail1 %lambda-body0 %x)
+  (prim %r2 (* %x %x))
+  (tail-call %lambda-tail1 %r2))
+
+(define ($r3 %x4)
+  (pop! %main-ktail)
+  (tail-call %main-ktail %x4))
+
+(define ($main %main-ktail)
+  (prim %lambda-body0 (make-closure $lambda-body0-code7))
+  (tail-call $let-body5 %lambda-body0))
+
+(define ($let-body5 %square)
+  (pop! %main-ktail)
+  (prim %code6 (env-code %square))
+  (push! %main-ktail)
+  (tail-call %code6 $r3 %square 4))
+|]

src/Gyehoek/Wasm.hs

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

test/Gyehoek/Test/CPS/Eval.hs

@@ -34,8 +34,8 @@ test_cpsInterpreter = testGroup "cps interpreter" $
       |]
   ]
 
-evalsTo :: HasCallStack => List Obj -> Sut.Program -> Assertion
-evalsTo rs p = Sut.evalProgram p @?= rs
+evalsTo :: HasCallStack => List Obj -> Sut.Exp -> Assertion
+evalsTo rs e = Sut.evalExp e @?= rs
 
 primitives = testGroup "primitives"
   [ testGroup "arith"

test/Gyehoek/Test/CPS/Stackify.hs

@@ -4,10 +4,11 @@ import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.HUnit
 import qualified Gyehoek.CPS.Stackify as Sut
 import Gyehoek.Stack.VM as Stk
-import Data.List (List)
 import Gyehoek.CPS.Syntax (cps)
+import Gyehoek.CPS.Syntax qualified as CPS
 import Gyehoek.GenSym (runGenSym)
 import Effectful
+import Gyehoek.Prelude
 
 
 test_stackify =
@@ -19,9 +20,11 @@ test_stackify =
   ]
 
 evalsTo :: List Obj -> Sut.Exp -> Assertion
-evalsTo rs e =
-  Stk.eval e' @?= rs
-  where e' = runPureEff . runGenSym $ Sut.stackifyExp "main" e
+evalsTo rs e = Stk.eval e' @?= rs
+  where
+    e' = e & CPS.MkLambda [] "_ktail"
+      & CPS.MkProgram
+      & Sut.stackifyProgram & runGenSym & runPureEff
 
 trivialReturn = testGroup "trivial return"
   [ testCase "return int" do

test/Gyehoek/Test/CPS/Syntax.hs

@@ -28,15 +28,20 @@ free = testGroup "free"
 qq :: TestTree
 qq = testGroup "parser"
   [ testCase "lambda" do
-      assertEqual "" (Sut.MkLambda ["x","y"] "ktail"
-               (Sut.ExpContinue "ktail" [Sut.ValVar "x"]))
+      assertEqual ""
+        (Sut.MkLambda ["x","y"] "ktail"
+         (Sut.ExpContinue (Sut.ValVar "ktail") [Sut.ValVar "x"]))
         [cps|(λ (x y ktail) (continue ktail x))|]
-      assertEqual "" (Sut.MkLambda [] "ktail"
-               (Sut.ExpContinue "ktail" [Sut.ValVar "x"]))
+      assertEqual ""
+        (Sut.MkLambda [] "ktail"
+         (Sut.ExpContinue (Sut.ValVar "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"]))
+      assertEqual ""
+        (Sut.MkKappa ["x","y"]
+         (Sut.ExpContinue
+          (Sut.ValVar "k123")
+          [Sut.ValVar "x", Sut.ValVar "y"]))
         [cps|(κ (x y) (continue k123 x y))|]
   , testCase "application" do
       assertEqual "" (Sut.ExpApply (Sut.ValVar "f")

test/Gyehoek/Test/Stack/VM.hs

@@ -14,58 +14,58 @@ evalsTo rs p = Sut.eval p @?= rs
 test_root = testGroup "stack machine"
   [ testCase "lit int" do
       evalsTo [ObjImm (ImmInt 3)] [stkP|
-        (define ($main)
-          (pop-cont! %ktail)
-          (tail-call! %ktail 3))
+        (define ($start %ktail)
+          (tail-call %ktail 3))
       |]
   , testCase "return constant" do
       evalsTo [ObjImm (ImmInt 123)] [stkP|
-        (define ($main)
-          (tail-call! $silly))
-        (define ($silly)
-          (pop-cont! %ktail)
-          (tail-call! %ktail 123))
+        (define ($start %ktail)
+          (tail-call $silly %ktail))
+        (define ($silly %ktail)
+          (tail-call %ktail 123))
+      |]
+  , testCase "identity continuation" do
+      evalsTo [ObjImm (ImmInt 45)] [stkP|
+        (define ($start %ktail)
+          (push! %ktail)
+          (tail-call $id 45))
+        (define ($id %x)
+          (pop! %ktail)
+          (tail-call %ktail %x))
       |]
   , testCase "identity function" do
       evalsTo [ObjImm (ImmInt 45)] [stkP|
-        (define ($main)
-          (tail-call! $id 45))
-        (define ($id %x)
-          (pop-cont! %ktail)
-          (tail-call! %ktail %x))
+        (define ($start %ktail)
+          (tail-call $id 45 %ktail))
+        (define ($id %x %ktail)
+          (tail-call %ktail %x))
       |]
-  -- , testCase "square" do
-  --     evalsTo [ObjImm (ImmInt 16)] [stkP|
-  --       (define ($main))
-  --     |]
   , testCase "square" do
       evalsTo [ObjImm (ImmInt 16)] [stkP|
-        (define ($main)
-          (tail-call! $square 4))
-        (define ($square %x)
+        (define ($start %ktail)
+          (tail-call $square 4 %ktail))
+        (define ($square %x %ktail)
           (prim %x2 (* %x %x))
-          (pop-cont! %ktail)
-          (tail-call! %ktail %x2))
+          (tail-call %ktail %x2))
       |]
   , testCase "factorial" do
       let hsfac (n :: Int) = foldr (*) (1) [1..n]
       let fac (n :: Int) = [stkP|
-            (define ($fac %n)
+            (define ($fac %n %ktail)
               (prim %x0 (zero? %n))
               (if %x0
-                (then (pop-cont! %ktail)
-                      (tail-call! %ktail 1))
+                (then (tail-call %ktail 1))
                 (else (push! %n)
+                      (push! %ktail)
                       (prim %x1 (- %n 1))
-                      (push-cont! $fac-k0)
-                      (tail-call! $fac %x1))))
+                      (tail-call $fac %x1 $fac-k0))))
             (define ($fac-k0 %x2)
+              (pop! %ktail)
               (pop! %n)
               (prim %x3 (* %x2 %n))
-              (pop-cont! %ktail)
-              (tail-call! %ktail %x3))
-            (define ($main)
-              (tail-call! $fac #{n}))
+              (tail-call %ktail %x3))
+            (define ($start %ktail)
+              (tail-call $fac #{n} %ktail))
           |]
       evalsTo [ObjImm (ImmInt 1)] $ fac 0
       evalsTo [ObjImm (ImmInt 1)] $ fac 1
@@ -73,32 +73,3 @@ test_root = testGroup "stack machine"
       -- 20 is the greatest `n` for which n! ≤ maxBount @Int
       evalsTo [ObjImm (ImmInt 2432902008176640000)] $ fac 20
   ]
-
---   ]
-
--- prims = testGroup "prims"
---   [ arith
---   , testCase "zero?" do
---       trivialPrimTest [ObjImm (ImmBool True)] $
---         PrimZeroP $ ValImm $ ImmInt 0
---       trivialPrimTest [ObjImm (ImmBool False)] $
---         PrimZeroP $ ValImm $ ImmInt 12
---   ]
-
--- trivialPrimTest rs p =
---   evalsTo rs
---   [ MkRoutine "main" []
---     [ PopCont "ktail"
---     , Prim "x1" p
---     , Call (ValReg "ktail") [ValReg "x1"]
---     ]
---   ]
-
--- arith = testGroup "arith"
---   [ testCase "multipy" do
---       trivialPrimTest [ObjImm (ImmInt 12)]
---         (PrimMul (ValImm $ ImmInt 3) (ValImm $ ImmInt 4))
---   , testCase "subtract" do
---       trivialPrimTest [ObjImm (ImmInt 14)]
---         (PrimSub (ValImm $ ImmInt 20) (ValImm $ ImmInt 6))
---   ]

test/doctest.hs

@@ -1,10 +1,16 @@
-{-# LANGUAGE DoAndIfThenElse #-}
 module Main where
 
+#ifndef GYEHOEK_NO_DOCTEST
 import Test.DocTest (mainFromCabal)
-import System.Environment (getArgs, lookupEnv)
+#endif
+import System.Environment (getArgs)
 import System.IO (stderr, hPutStrLn)
 
 
 main :: IO ()
-main = mainFromCabal "gyehoek" =<< getArgs
+main =
+#ifndef GYEHOEK_NO_DOCTEST
+  mainFromCabal "gyehoek" =<< getArgs
+#else
+  hPutStrLn stderr "skipping doctests due to broken nix environment."
+#endif