appy

.dir-locals.el

@@ -2,4 +2,6 @@
   . ((eval
       . (progn (defun apply-cabal-fmt-h ()
                  (haskell-mode-buffer-apply-command "cabal-fmt"))
-               (add-hook 'before-save-hook #'apply-cabal-fmt-h nil t))))))
+               (add-hook 'before-save-hook #'apply-cabal-fmt-h nil t)
+               (add-to-list 'haskell-font-lock-quasi-quote-modes
+                            '("cps" . scheme-mode)))))))

golden/square/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > 25

src/Gyehoek/CPS/Convert.hs

@@ -54,11 +54,10 @@ convert (Scm.ExpLambda xs e) k = do
 
 convert (Scm.ExpApply f xs) k =
   telescope (convert @es) (f:|xs) \(f':|xs') -> do
-    -- r <- gensym' "r"
+    r <- gensym' "r"
     x <- gensym' "x"
     m <- k (ValVar x)
-    -- pure $ ExpFix [(r, MkKappa [x] m)] $ ExpApply f' (xs' ++ [ValVar r])
+    pure $ ExpLetRec [(r, AbsKappa' [x] m)] $ ExpApply f' xs' r
-    _
 
 convert (Scm.ExpBegin xs) k = _
 

src/Gyehoek/CPS/Lower.hs

@@ -25,6 +25,8 @@ import Language.Sexp.Located qualified as SL
 import Control.Monad.Fix
 import qualified Gyehoek.Sexp
 import Data.Text qualified as T
+import Data.Foldable (fold)
+import Gyehoek.Sexp (encodeOrShow, toSexp)
 
 
 data Env = MkEnv
@@ -41,6 +43,9 @@ instance Ixed Env where
 
 
 
+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
@@ -56,7 +61,7 @@ makeSmallFixnum = [expr|
 pushArg :: Natural -> Wasm.Expr -> Wasm.Expr
 pushArg n e = [expr|
     (global.get $arg-array)
-    (global.get #{n})
+    (i32.const #{n})
     ##{e}
     (array.set $arg-array-type)
   |]
@@ -124,6 +129,22 @@ lower' g (ExpIf c t f) = do
         (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 4))
+    (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]
@@ -137,19 +158,45 @@ lower' g (ExpLetRec [(r,AbsLambda lam)] e) = do
     ##{e'}
   |]
 
-lower' g (ExpContinue k [x]) = do
+lower' g (ExpApply f xs ktail) = do
-  arg <- pushArg 0 <$> lowerVal g x
+  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|
-    ##{arg}
+    (@gyehoek "load args")
+    ##{args}
     (i32.const 1)
-    (global.get $cont-stack)
+    ##{f'}
-    (global.get $cont-stack-top)
+    (ref.cast (ref $closure))
-    (array.get $cont-stack-type)
+    (struct.get $closure $code)
-    ref.as_non_null
+    (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
+  let origin = encodeOrShow @_ @Text e
+  pure [expr|
+    (@gyehoek :origin #{origin})
+    (@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
@@ -159,8 +206,28 @@ lower' g e = error $ case Gyehoek.Sexp.encode e of
   Left _ -> show e
   Right x -> T.unpack x
 
+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
+  let body = mconcat
+        [ xs & ifoldMap \n _ ->
+            let n' = succ n
+            in popArg n <> [expr|(local.set #{n'})|]
+        , m'
+        ]
+  let origin = encodeOrShow @_ @Text e
+  idx <- Wasm.defineFunction [wat|
+    (func (param i32)
+      (@gyehoek :origin #{origin})
+      (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+      ##{body})
+  |]
+  Wasm.emit [wats|(elem declare funcref (ref.func #{idx}))|]
+  pure idx
+
 lowerLambda :: GenMod :> es => Env -> Lambda -> Eff es Idx
-lowerLambda g (MkLambda xs ktail m) = do
+lowerLambda g e@(MkLambda xs ktail m) = do
   let g' = g & #vars .~ V.fromList xs
              & #kvars <>~ [ktail]
   m' <- lower' g' m
@@ -170,8 +237,10 @@ lowerLambda g (MkLambda xs ktail m) = do
             in popArg n <> [expr|(local.set #{n'})|]
         , m'
         ]
+  let origin = encodeOrShow @_ @Text e
   idx <- Wasm.defineFunction [wat|
     (func (param i32)
+      (@gyehoek :origin #{origin})
       (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
       ##{body})
   |]
@@ -253,8 +322,10 @@ lower e = fmap Wasm.renderModule . Wasm.execGenMod $ do
   runtime <- emitRuntime
   let g = MkEnv mempty mempty
   e' <- lower' g e
+  let origin = encodeOrShow @_ @Text e
   Wasm.defineFunction [wat|
     (func $scm-entry (param i32)
+      (@gyehoek :origin #{origin})
       (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
       ##{e'})
   |]

t.wat

@@ -37,33 +37,105 @@
     ref.as_non_null
     (global.set $result))
   (func
-    $scm-entry
     (param i32)
+    (@gyehoek
+      :origin
+      (lambda
+        (x lambda-tail1)
+        (prim (* x x) (kappa (r2) (continue lambda-tail1 r2)))))
     (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
-    (i32.const 123)
+    (global.get $arg-array)
+    (i32.const 0)
+    (array.get $arg-array-type)
+    ref.as_non_null
+    (local.set 1)
+    (local.get 1)
+    (i31.get_s (ref.cast (ref i31)))
+    (i32.const 1)
+    i32.shr_u
+    (local.get 1)
+    (i31.get_s (ref.cast (ref i31)))
+    (i32.const 1)
+    i32.shr_u
+    i32.mul
     (i32.const 1)
     i32.shl
     ref.i31
-    (call $gh-truthy?)
+    (local.set 2)
-    (if
+    (@gyehoek :origin (continue lambda-tail1 r2))
-      (then
+    (@gyehoek "push args")
-        (global.get $arg-array)
+    (global.get $arg-array)
-        (global.get 0)
+    (i32.const 0)
-        (i32.const 777)
+    (local.get 2)
-        (i32.const 1)
+    (array.set $arg-array-type)
-        i32.shl
+    (@gyehoek "nargs")
-        ref.i31
+    (i32.const 1)
-        (array.set $arg-array-type)
+    (@gyehoek "pop cont stack")
-        (return_call $halt (i32.const 1)))
+    (global.get $cont-stack-top)
-      (else
+    (i32.const 1)
-        (global.get $arg-array)
+    i32.sub
-        (global.get 0)
+    (global.set $cont-stack-top)
-        (i32.const 555)
+    (global.get $cont-stack)
-        (i32.const 1)
+    (global.get $cont-stack-top)
-        i32.shl
+    (array.get $cont-stack-type)
-        ref.i31
+    ref.as_non_null
-        (array.set $arg-array-type)
+    (return_call_ref $cont-type))
-        (return_call $halt (i32.const 1)))))
+  (elem declare funcref (ref.func 3))
+  (func
+    (param i32)
+    (@gyehoek :origin (kappa (x4) (continue halt x4)))
+    (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+    (global.get $arg-array)
+    (i32.const 0)
+    (array.get $arg-array-type)
+    ref.as_non_null
+    (local.set 1)
+    (global.get $arg-array)
+    (i32.const 0)
+    (local.get 1)
+    (array.set $arg-array-type)
+    (return_call $halt (i32.const 1)))
+  (elem declare funcref (ref.func 4))
+  (func
+    $scm-entry
+    (param i32)
+    (@gyehoek
+      :origin
+      (letrec
+        ((lambda-body0
+           (lambda
+             (x lambda-tail1)
+             (prim (* x x) (kappa (r2) (continue lambda-tail1 r2))))))
+        (letrec
+          ((r3 (kappa (x4) (continue halt x4))))
+          (lambda-body0 5 r3))))
+    (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+    (i32.const 0)
+    (ref.func 3)
+    (struct.new $closure)
+    (local.set 1)
+    (@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 "load args")
+    (global.get $arg-array)
+    (i32.const 0)
+    (i32.const 5)
+    (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))

u.wat

@@ -0,0 +1,127 @@
+(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)
+  (global.get $arg-array)
+  (i32.const 0)
+  (array.get $arg-array-type)
+  ref.as_non_null
+  (global.set $result))
+ (func
+  (param i32)
+  (@gyehoek
+   :origin
+   (lambda (x lambda-tail1)
+     (prim (* x x) (kappa (r2) (continue lambda-tail1 r2)))))
+  (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+  (global.get $arg-array)
+  (i32.const 0)
+  (array.get $arg-array-type)
+  ref.as_non_null
+  (local.set 1)
+  (local.get 1)
+  (i31.get_s (ref.cast (ref i31)))
+  (i32.const 1)
+  i32.shr_u
+  (local.get 1)
+  (i31.get_s (ref.cast (ref i31)))
+  (i32.const 1)
+  i32.shr_u
+  i32.mul
+  (i32.const 1)
+  i32.shl
+  ref.i31
+  (local.set 2)
+  (global.get $arg-array)
+  (i32.const 0)
+  (local.get 2)
+  (array.set $arg-array-type)
+  (i32.const 1)
+  (global.get $cont-stack)
+  (global.get $cont-stack-top)
+  (array.get $cont-stack-type)
+  ref.as_non_null
+  (global.get $cont-stack-top)
+  (i32.const 1)
+  i32.sub
+  (global.set $cont-stack-top)
+  (return_call_ref $cont-type))
+ (elem declare funcref (ref.func 3))
+ (func
+  (param i32)
+  (@gyehoek :origin (kappa (x4) (continue halt x4)))
+  (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+  (global.get $arg-array)
+  (i32.const 0)
+  (array.get $arg-array-type)
+  ref.as_non_null
+  (local.set 1)
+  (global.get $arg-array)
+  (i32.const 0)
+  (local.get 1)
+  (array.set $arg-array-type)
+  (return_call $halt (i32.const 1)))
+ (func
+  $scm-entry
+  (param i32)
+  (@gyehoek
+   :origin
+   (letrec ((lambda-body0
+             (lambda (x lambda-tail1)
+               (prim (* x x) (kappa (r2) (continue lambda-tail1 r2))))))
+     (letrec ((r3 (kappa (x4) (continue halt x4))))
+       (lambda-body0 5 r3))))
+  (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+  (i32.const 0)
+  (ref.func 3)
+  (struct.new $closure)
+  (local.set 1)
+  (@gyehoek "push return 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 "load args")
+  (global.get $arg-array)
+  (i32.const 0)
+  (i32.const 5)
+  (i32.const 1)
+  i32.shl
+  ref.i31
+  (array.set $arg-array-type)
+  (@gyehoek todo (f' (local.get 1)) (ktail 1))
+  (return_call_ref $cont-type
+                   (i32.const 1)
+                   (struct.get $closure $code
+                               (ref.cast (ref $closure) (local.get 1)))))
+ (elem declare funcref (ref.func 4))
+ (func
+  (export "main")
+  (call $scm-entry (i32.const 0))
+  (call $gh-write (ref.as_non_null (global.get $result)))))