lam

golden/lambda/source.scm

@@ -0,0 +1 @@
+(λ (x) x)

src/Gyehoek/CPS/Lower.hs

@@ -50,7 +50,8 @@ instance Ixed Env where
   ix i = #vars . ix (fromIntegral i)
 
 data Runtime = MkRuntime
-  { consIdx :: Idx
+  { argArrayIdx :: Idx
+  , contStackIdx :: Idx
   }
   deriving (Show, Generic)
 
@@ -100,6 +101,8 @@ lower' g (ExpIf c t f) = do
   pure $ lowerVal g c
     <> Wasm.if' (Wasm.result [i32]) t' f'
 
+lower' g (ExpLet [(r,MkLambda xs ktail m)] e) = _
+
 lowerBinOp
   :: (GenMod :> es)
   => Text -> Env -> Val -> Val -> Name -> Exp -> Eff es Wasm.Expr
@@ -129,17 +132,22 @@ scm = ref eq
 
 emitRuntime :: GenMod :> es => Eff es Runtime
 emitRuntime = do
-  Wasm.deftypeNamed "$heap-object" $ Wasm.sub [] $ Wasm.struct
+  heapObjectIdx <- Wasm.deftypeNamed "$heap-object" $ Wasm.sub [] $ Wasm.struct
     [ Wasm.mut i32 ]
-  consIdx <- Wasm.defun _ _ _ _
+  scmUnclosedIdx <- Wasm.deftype $ Wasm.func [i32] []
-  pure $ MkRuntime {consIdx}
+  argArrayType <- Wasm.deftype $ Wasm.array scm
+  argArrayIdx <- Wasm.defglobal $ ref (Wasm.fromIdx argArrayType)
+  contStackIdx <- Wasm.defglobal $ ref (Wasm.fromIdx argArrayType)
+  -- consIdx <- Wasm.defun _ _ _ _
+  pure $ MkRuntime {argArrayIdx,contStackIdx}
+  -- pure $ error "todo"
 
 lower :: Exp -> Eff es Text
 lower e = fmap Wasm.renderModule . Wasm.execGenMod $ do
-  -- runtime <- emitRuntime
+  runtime <- emitRuntime
-  let env = MkEnv _runtime mempty
+  let env = MkEnv runtime mempty
   main <- Wasm.defun [] [scm] [scm, scm, scm, scm, scm] \_ ->
-    lower' emptyEnv e
+    lower' env e
   Wasm.export "main" "func" main
 
 lowerProgram :: Program -> Eff es Text

src/Gyehoek/Wasm.hs

@@ -42,6 +42,10 @@ module Gyehoek.Wasm
   , namedType
   , type'
   , deftypeNamed
+  , defglobal
+  , array
+  , FromIdx(..)
+  , func
   )
   where
 
@@ -82,6 +86,7 @@ data Module = MkModule
   , functions :: Vector Function
   , start :: Maybe Idx
   , exports :: Vector Export
+  , globals :: Vector Type
   }
   deriving (Show, Generic)
 
@@ -94,7 +99,7 @@ instance Semigroup Module where
     }
 
 instance Monoid Module where
-  mempty = MkModule mempty mempty Nothing mempty
+  mempty = MkModule mempty mempty Nothing mempty mempty
 
 newtype RecType = MkRecType { inner :: Vector Type }
   deriving (Show, Generic)
@@ -131,6 +136,7 @@ data GenMod :: Effect where
         -> (Idx -> m Expr) -> GenMod m Idx
   Start :: Idx -> GenMod m ()
   Export :: Text -> Text -> Idx -> GenMod m ()
+  DefGlobal :: Type -> GenMod m Idx
 
 type instance DispatchOf GenMod = Dynamic
 
@@ -151,6 +157,9 @@ deftype (MkType t) = send (DefRecType [type' t]) <&> \case
 deftypeNamed :: (GenMod :> es) => Text -> Type -> Eff es ()
 deftypeNamed name (MkType t) = void $ send (DefRecType [namedType name t])
 
+defglobal :: (GenMod :> es) => Type -> Eff es Idx
+defglobal = send . DefGlobal
+
 defun
   :: (GenMod :> es)
   => List Type -> List Type -> List Type
@@ -191,6 +200,10 @@ runGenMod =
           let func = MkFunction {params,result,locals,body}
           let m' = m & #functions <>~ V.singleton func
           pure (idx, m')
+    _ (DefGlobal t) -> state \m ->
+      let prev_n = IdxNumeric . fromIntegral . V.length $ m.globals
+          m' = m & #globals <>~ V.singleton t
+      in (prev_n, m')
 
 execGenMod = fmap snd . runGenMod
 
@@ -204,6 +217,9 @@ sub :: List Idx -> Type -> Type
 sub supers (MkType x) = MkType . ParenList $
   Symbol "sub" : (sxp <$> supers) ++ [x]
 
+array :: Type -> Type
+array (MkType x) = MkType . ParenList $ [Symbol "array", x]
+
 mut :: Type -> Type
 mut (MkType x) = MkType . ParenList $ [Symbol "mut", x]
 
@@ -212,12 +228,28 @@ struct xs = MkType . ParenList $
   Symbol "struct" : (xs ^.. each . #inner . to field)
   where field x = ParenList [Symbol "field", x]
 
+func :: List Type -> List Type -> Type
+func params results =
+  MkType . ParenList $
+    [ Symbol "func"
+    , wrap "param" params
+    , wrap "result" results
+    ]
+  where
+    wrap s xs = ParenList $ Symbol s : xs ^.. each . #inner
+
 i32, i31ref, eq, i31 :: Type
 i32 = MkType $ Symbol "i32"
 i31ref = MkType $ Symbol "i31ref"
 eq = MkType $ Symbol "eq"
 i31 = MkType $ Symbol "i31"
 
+class FromIdx a where
+  fromIdx :: Idx -> a
+
+instance FromIdx Type where
+  fromIdx (IdxNumeric n) = MkType . Symbol . T.pack . show $ n
+
 
 
 instance SexpIso Idx where

t.wat

@@ -1,47 +1,16 @@
 (module
-  (type $heap-object (sub (struct (field (mut i32)))))
+ (type $heap-object (sub (struct (field (mut i32)))))
-  (func
+ (type $unclosure
-    (param)
+       (func (param i32)
-    (result (ref eq))
+             (result (ref eq))))
-    (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+ (type $closure
-    (i32.const 3)
+       (sub $heap-object
-    (i32.const 2)
+            (struct (field (mut i32))
-    i32.shl
+                    (field (ref $unclosure))
-    ref.i31
+                    (field $arg1 (ref eq)))))
-    (ref.cast (ref i31))
+ (func $make-adder-inner (param $self (ref $closure)) (result (ref eq))
-    i31.get_s
+       )
-    (i32.const 4)
+ (func $make-adder (param (ref eq)) (result $closure)
-    (i32.const 2)
+       )
-    i32.shl
+ (func (export "main") (result (ref eq))
-    ref.i31
+       (ref.i31 (i32.const 123))))
-    (ref.cast (ref i31))
-    i31.get_s
-    i32.mul
-    ref.i31
-    (local.set 0)
-    (i32.const 2)
-    (i32.const 2)
-    i32.shl
-    ref.i31
-    (ref.cast (ref i31))
-    i31.get_s
-    (i32.const 5)
-    (i32.const 2)
-    i32.shl
-    ref.i31
-    (ref.cast (ref i31))
-    i31.get_s
-    i32.mul
-    ref.i31
-    (local.set 1)
-    (local.get 0)
-    (ref.cast (ref i31))
-    i31.get_s
-    (local.get 1)
-    (ref.cast (ref i31))
-    i31.get_s
-    i32.add
-    ref.i31
-    (local.set 2)
-    (local.get 2))
-  (export "main" (func 0)))