higher-order

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) =
-  case p of
+lower' g e@(ExpPrim p k) =
+  ([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)