diff --git a/golden/apply-twice/source.scm b/golden/apply-twice/source.scm new file mode 100644 index 0000000..9516f71 --- /dev/null +++ b/golden/apply-twice/source.scm @@ -0,0 +1,5 @@ +;; apply `f' to `x' twice. +((λ (f x) + (f (f x))) + (λ (x) (+ x 4)) + 9) diff --git a/golden/fn-of-fn/exec b/golden/fn-of-fn/exec new file mode 100644 index 0000000..d9b9c91 --- /dev/null +++ b/golden/fn-of-fn/exec @@ -0,0 +1,2 @@ +ret > ExitSuccess +out > 128 diff --git a/golden/fn-of-fn/source.scm b/golden/fn-of-fn/source.scm new file mode 100644 index 0000000..23de627 --- /dev/null +++ b/golden/fn-of-fn/source.scm @@ -0,0 +1 @@ +(((λ (f) f) (λ (x) (* x 4))) 32) diff --git a/src/Gyehoek/CPS/Lower.hs b/src/Gyehoek/CPS/Lower.hs index 5abd3b5..308d16c 100644 --- a/src/Gyehoek/CPS/Lower.hs +++ b/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) diff --git a/t.wat b/t.wat index d944f56..e69de29 100644 --- a/t.wat +++ b/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)))))