diff --git a/golden/lambda/source.scm b/golden/lambda/source.scm new file mode 100644 index 0000000..bf31d15 --- /dev/null +++ b/golden/lambda/source.scm @@ -0,0 +1 @@ +(λ (x) x) diff --git a/src/Gyehoek/CPS/Lower.hs b/src/Gyehoek/CPS/Lower.hs index 188b092..4c53c95 100644 --- a/src/Gyehoek/CPS/Lower.hs +++ b/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 _ _ _ _ - pure $ MkRuntime {consIdx} + scmUnclosedIdx <- Wasm.deftype $ Wasm.func [i32] [] + 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 - let env = MkEnv _runtime mempty + runtime <- emitRuntime + 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 diff --git a/src/Gyehoek/Wasm.hs b/src/Gyehoek/Wasm.hs index e524d12..2b235c7 100644 --- a/src/Gyehoek/Wasm.hs +++ b/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 diff --git a/t.wat b/t.wat index 3968ec8..43532a3 100644 --- a/t.wat +++ b/t.wat @@ -1,47 +1,16 @@ (module - (type $heap-object (sub (struct (field (mut i32))))) - (func - (param) - (result (ref eq)) - (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq)) - (i32.const 3) - (i32.const 2) - i32.shl - ref.i31 - (ref.cast (ref i31)) - i31.get_s - (i32.const 4) - (i32.const 2) - i32.shl - ref.i31 - (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))) + (type $heap-object (sub (struct (field (mut i32))))) + (type $unclosure + (func (param i32) + (result (ref eq)))) + (type $closure + (sub $heap-object + (struct (field (mut i32)) + (field (ref $unclosure)) + (field $arg1 (ref eq))))) + (func $make-adder-inner (param $self (ref $closure)) (result (ref eq)) + ) + (func $make-adder (param (ref eq)) (result $closure) + ) + (func (export "main") (result (ref eq)) + (ref.i31 (i32.const 123))))