lambda and if-number }:3

src/Gyehoek/CPS/Lower.hs

@@ -54,18 +54,6 @@ type instance IxValue Env = Name
 instance Ixed Env where
   ix i = #vars . ix (fromIntegral i)
 
--- data Runtime = MkRuntime
---   { argArrayType :: Idx
---   , argArray :: Idx
---   , contType :: Idx
---   , contStackType :: Idx
---   , contStackTop :: Idx
---   , contStack :: Idx
---   , result :: Idx
---   , halt :: Idx
---   }
---   deriving (Show, Generic)
-
 
 
 -- | @makeSmallFixnum@ emits an expression injecting the i32 on top
@@ -139,18 +127,43 @@ lower' g (ExpIf c t f) = do
   let c' = lowerVal g c
   pure [expr|
     ##{c'}
-    (call $gh-to-bool)
+    (call $gh-truthy?)
     (if (then ##{t'})
         (else ##{f'}))
   |]
 
-lower' g e = error . show $ e
+lower' g (ExpLet [(r,lam)] e) = do
+  idx <- lowerLambda g lam
+  let g' = g & #vars <>~ [r]
+  let n = succ $ length g.vars
+  e' <- lower' g' e
+  pure [expr|
+    (i32.const 0)
+    (ref.func #{idx})
+    (struct.new $closure)
+    (local.set #{n})
+    ##{e'}
+  |]
 
--- lower' g (ExpIf c t f) = do
---   t' <- lower' g t
---   f' <- lower' g f
---   pure $ lowerVal g c
---     <> Wasm.if' (Wasm.result [i32]) t' f'
+lower' g (ExpContinue k [x]) = pure . mconcat $
+  [ pushArg 0 (lowerVal g x)
+  , [expr|
+      (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 #{l})
+      i32.sub
+      (global.set $cont-stack-top)
+      (return_call_ref $cont-type)
+    |]
+  ]
+  where
+    l = succ $ V.elemIndex k g.kvars ^?! _Just
+
+lower' g e = error . show $ e
 
 -- lower' g (ExpContinue k [x]) = pure . mconcat $
 --   [ pushArg rt 0 (lowerVal g x)
@@ -171,27 +184,24 @@ lower' g e = error . show $ e
 --     rt = g.runtime
 --     l = V.elemIndex k g.kvars ^?! _Just
 
--- lower' g (ExpLet [(r,MkLambda xs ktail m)] e) = do
---   idx <- defun [i32] [] (replicate 5 scm) \_ -> do
---     let g' = g & #vars <>~ V.fromList xs
---                & #kvars <>~ [ktail]
---     m' <- lower' g' m
---     pure . mconcat $
---       [ xs & ifoldMap \n _ ->
---           popArg g.runtime n <> ins "local.set" [sxp (1+n)]
---       , m'
---       ]
---   declareFuncref idx
---   let g' = g & #vars <>~ [r]
---   let n = length g.vars
---   e' <- lower' g' e
---   pure . mconcat $
---     [ ins "ref.func" [sxp idx]
---     , ins "local.set" [sxp (n+1)]
---     , e'
---     ]
-
--- lower' g e = error . show $ e
+lowerLambda :: GenMod :> es => Env -> Lambda -> Eff es Idx
+lowerLambda g (MkLambda xs ktail m) = do
+  let g' = g & #vars .~ V.fromList xs
+             & #kvars <>~ [ktail]
+  m' <- lower' g' m
+  let body = mconcat
+        [ xs & ifoldMap \n _ ->
+            let n' = succ n
+            in popArg n <> [expr|(local.set #{n'})|]
+        , m'
+        ]
+  idx <- Wasm.defineFunction [wat|
+    (func (param i32)
+      (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+      ##{body})
+  |]
+  Wasm.emit [wats|(elem declare funcref (ref.func #{idx}))|]
+  pure idx
 
 lowerBinOp
   :: (GenMod :> es)
@@ -220,60 +230,24 @@ lowerBinOp op g x y r e = do
 
 
 
--- scm = ref eq
-
-
-
--- emitRuntime :: GenMod :> es => Eff es Runtime
--- emitRuntime = mfix \runtime -> do
---   heapObjectIdx <- Wasm.deftypeNamed "$heap-object" $ Wasm.sub [] $ Wasm.struct
---     [ Wasm.mut i32 ]
---   -- cont stack
---   contType <- Wasm.deftype $ Wasm.func [i32] []
---   contStackType <- Wasm.deftype $ array $ mut $ refnull (fromIdx contType)
---   contStackTop <- Wasm.defglobal (mut i32) $ ins "i32.const" [sxp @Int 0]
---   contStack <- Wasm.defglobal (ref (Wasm.fromIdx contStackType)) $
---     ins "i32.const" [sxp @Int 128]
---     <> ins "array.new_default" [sxp contStackType]
---   -- arg array
---   argArrayType <- Wasm.deftype $ Wasm.array $ mut $ refnull eq
---   argArray <- Wasm.defglobal (ref (Wasm.fromIdx argArrayType)) $
---     ins "i32.const" [sxp @Int 32]
---     <> ins "array.new_default" [sxp argArrayType]
---   -- consIdx <- Wasm.defun _ _ _ _
---   result <- Wasm.defglobal (mut (refnull eq)) $ ins "ref.null" [sxp eq]
---   halt <- Wasm.defun [i32] [] (replicate 5 scm) \_ ->
---     pure . mconcat $
---       [ popArg runtime 0
---       , ins "global.set" [sxp result]
---       ]
---   pure $ MkRuntime
---     {argArray,argArrayType
---     ,contStack,contStackTop,contStackType,contType
---     ,result,halt}
---   -- pure $ error "todo"
-
 emitRuntime :: GenMod :> es => Eff es ()
 emitRuntime = mfix \runtime -> do
-  Wasm.emit [wats|
+  Wasm.defineFunctions [wats|
     (import "gyehoek" "write" (func $gh-write (param (ref eq))))
-    (import "gyehoek" "to-bool" (func $gh-to-bool (param (ref eq))
+    (import "gyehoek" "truthy?" (func $gh-truthy? (param (ref eq))
                                   (result i32)))
   |]
   -- cont stack
-  Wasm.defineType [wat|
+  Wasm.defineTypes [wats|
     (type $heap-object (sub (struct (field $hash (mut i32)))))
-  |]
-  Wasm.defineType [wat|
     (type $cont-type (func (param i32)))
-  |]
-  Wasm.defineType [wat|
     (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.defineGlobal [wat|
+  Wasm.defineGlobals [wats|
     (global $cont-stack-top (mut i32) (i32.const 0))
-  |]
-  Wasm.defineGlobal [wat|
     (global $cont-stack (ref $cont-stack-type)
             (array.new_default $cont-stack-type (i32.const 128)))
   |]

src/Gyehoek/Wasm.hs

@@ -32,6 +32,9 @@ module Gyehoek.Wasm
   , renderModule
   , wat
   , wats
+  , defineFunctions
+  , defineTypes
+  , defineGlobals
   )
   where
 
@@ -133,12 +136,21 @@ type instance DispatchOf GenMod = Dynamic
 defineFunction :: GenMod :> es => Sexp -> Eff es Idx
 defineFunction = send . DefineFunction
 
+defineFunctions :: GenMod :> es => List Sexp -> Eff es (List Idx)
+defineFunctions = traverse (send . DefineFunction)
+
 defineType :: GenMod :> es => Sexp -> Eff es Idx
 defineType = send . DefineType
 
+defineTypes :: GenMod :> es => List Sexp -> Eff es (List Idx)
+defineTypes = traverse (send . DefineType)
+
 defineGlobal :: GenMod :> es => Sexp -> Eff es Idx
 defineGlobal = send . DefineGlobal
 
+defineGlobals :: GenMod :> es => List Sexp -> Eff es (List Idx)
+defineGlobals = traverse (send . DefineGlobal)
+
 emit :: GenMod :> es => List Sexp -> Eff es ()
 emit = traverse_ (send . Emit)