higher-order

golden/apply-twice/source.scm

@@ -0,0 +1,5 @@
+;; apply `f' to `x' twice.
+((λ (f x)
+   (f (f x)))
+ (λ (x) (+ x 4))
+ 9)

golden/fn-of-fn/exec

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

golden/fn-of-fn/source.scm

@@ -0,0 +1 @@
+(((λ (f) f) (λ (x) (* x 4))) 32)

src/Gyehoek/CPS/Lower.hs

@@ -6,6 +6,7 @@
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE ApplicativeDo #-}
 {-# OPTIONS_GHC -Wno-incomplete-patterns #-}
+{-# LANGUAGE RecursiveDo #-}
 {- HLINT ignore "Use camelCase" -}
 module Gyehoek.CPS.Lower
   (lower, lowerProgram) where
@@ -50,6 +51,7 @@ tonat = fromIntegral
 -- of the stack into the SCM unitype.
 makeSmallFixnum :: Wasm.Expr
 makeSmallFixnum = [expr|
+    (@gyehoek "construct small fixnum")
     (i32.const 1)
     i32.shl
     ref.i31
@@ -60,6 +62,7 @@ makeSmallFixnum = [expr|
 -- result of @e@.
 pushArg :: Natural -> Wasm.Expr -> Wasm.Expr
 pushArg n e = [expr|
+    (@gyehoek "push argument")
     (global.get $arg-array)
     (i32.const #{n})
     ##{e}
@@ -69,6 +72,7 @@ pushArg n e = [expr|
 -- | Pop the nth arg from the arg-passing array onto the stack.
 popArg :: Int -> Wasm.Expr
 popArg n = [expr|
+  (@gyehoek "pop argument")
   (global.get $arg-array)
   (i32.const #{n})
   (array.get $arg-array-type)
@@ -113,10 +117,12 @@ lower' g (Halt [v]) = do
     (return_call $halt (i32.const 1))
   |]
 
-lower' g (ExpPrim p k) =
+lower' g e@(ExpPrim p k) =
-  case p of
+  ([expr|(@gyehoek :origin #{origin})|]<>)
+  <$> case p of
     PrimAdd x y -> lowerBinOp "i32.add" g x y k
     PrimMul x y -> lowerBinOp "i32.mul" g x y k
+  where origin = encodeOrShow @_ @Text e
 
 lower' g (ExpIf c t f) = do
   c' <- lowerVal g c
@@ -133,12 +139,14 @@ lower' g (ExpLetRec [(r,AbsKappa kap)] e) = do
   idx <- lowerKappa g kap
   let g' = g & #kvars <>~ [r]
   e' <- lower' g' e
+  let origin = encodeOrShow @_ @Text e
   pure [expr|
+    (@gyehoek :origin #{origin})
     (@gyehoek "push cont" :idx #{idx})
     (array.set $cont-stack-type
                (global.get $cont-stack)
                (global.get $cont-stack-top)
-               (ref.func 4))
+               (ref.func #{idx}))
     (global.set $cont-stack-top
                 (i32.add (global.get $cont-stack-top)
                          (i32.const 1)))
@@ -158,13 +166,15 @@ lower' g (ExpLetRec [(r,AbsLambda lam)] e) = do
     ##{e'}
   |]
 
-lower' g (ExpApply f xs ktail) = do
+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
+  let origin = encodeOrShow @_ @Text e
   pure [expr|
+    (@gyehoek :origin #{origin})
     (@gyehoek "load args")
     ##{args}
     (i32.const 1)

t.wat

@@ -1,142 +0,0 @@
-(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)
-    (@gyehoek :origin (continue lambda-tail1 r2))
-    (@gyehoek "push args")
-    (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 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))
-    (call $gh-write (ref.as_non_null (global.get $result)))))