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..281a656 100644 --- a/src/Gyehoek/CPS/Lower.hs +++ b/src/Gyehoek/CPS/Lower.hs @@ -30,7 +30,7 @@ import qualified Data.Vector.Strict as V import Data.IntMap.Strict (IntMap) import Data.String.Interpolate import Gyehoek.Wasm qualified as Wasm -import Gyehoek.Wasm (i32, ins, sxp, eq, ref, i31, Type (..), Idx, GenMod) +import Gyehoek.Wasm hiding (Expr) import Language.Sexp.Located (pattern ParenList) @@ -50,7 +50,11 @@ instance Ixed Env where ix i = #vars . ix (fromIntegral i) data Runtime = MkRuntime - { consIdx :: Idx + { argArrayIdx :: Idx + , contType :: Idx + , contStackType :: Idx + , contStackIndexIdx :: Idx + , contStackIdx :: Idx } deriving (Show, Generic) @@ -100,6 +104,26 @@ 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) = do + _ <- defun [i32] [] [] \_ -> do + let stack = g.runtime.contStackIdx + let index = g.runtime.contStackIndexIdx + m' <- lower' g m + pure . mconcat $ + [ m' + , ins "global.get" [sxp index] + , ins "i32.const" [sxp @Int 1] + , ins "i32.sub" [] + , ins "global.set" [sxp index] + , ins "global.get" [sxp stack] + , ins "global.get" [sxp index] + , ins "array.get" [sxp g.runtime.contStackType] + , ins "return_call_ref" [sxp g.runtime.contType] + ] + _ + +lower' g e = error . show $ e + lowerBinOp :: (GenMod :> es) => Text -> Env -> Val -> Val -> Name -> Exp -> Eff es Wasm.Expr @@ -129,17 +153,30 @@ 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} + -- cont stack + contType <- Wasm.deftype $ Wasm.func [i32] [] + contStackType <- Wasm.deftype $ array (refnull (fromIdx contType)) + contStackIndexIdx <- Wasm.defglobal i32 $ ins "i32.const" [sxp @Int 0] + contStackIdx <- 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 scm + argArrayIdx <- Wasm.defglobal (ref (Wasm.fromIdx argArrayType)) _ + -- consIdx <- Wasm.defun _ _ _ _ + pure $ MkRuntime + {argArrayIdx + ,contStackIdx,contStackIndexIdx,contStackType,contType} + -- 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..4c665ae 100644 --- a/src/Gyehoek/Wasm.hs +++ b/src/Gyehoek/Wasm.hs @@ -42,6 +42,11 @@ module Gyehoek.Wasm , namedType , type' , deftypeNamed + , defglobal + , array + , FromIdx(..) + , func + , refnull ) where @@ -82,6 +87,7 @@ data Module = MkModule , functions :: Vector Function , start :: Maybe Idx , exports :: Vector Export + , globals :: Vector Global } deriving (Show, Generic) @@ -94,7 +100,13 @@ instance Semigroup Module where } instance Monoid Module where - mempty = MkModule mempty mempty Nothing mempty + mempty = MkModule mempty mempty Nothing mempty mempty + +data Global = MkGlobal + { ty :: Type + , body :: Expr + } + deriving (Show, Generic) newtype RecType = MkRecType { inner :: Vector Type } deriving (Show, Generic) @@ -131,6 +143,7 @@ data GenMod :: Effect where -> (Idx -> m Expr) -> GenMod m Idx Start :: Idx -> GenMod m () Export :: Text -> Text -> Idx -> GenMod m () + DefGlobal :: Type -> Expr -> GenMod m Idx type instance DispatchOf GenMod = Dynamic @@ -151,6 +164,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 -> Expr -> Eff es Idx +defglobal t e = send $ DefGlobal t e + defun :: (GenMod :> es) => List Type -> List Type -> List Type @@ -191,6 +207,10 @@ runGenMod = let func = MkFunction {params,result,locals,body} let m' = m & #functions <>~ V.singleton func pure (idx, m') + _ (DefGlobal t e) -> state \m -> + let prev_n = IdxNumeric . fromIntegral . V.length $ m.globals + m' = m & #globals <>~ V.singleton (MkGlobal t e) + in (prev_n, m') execGenMod = fmap snd . runGenMod @@ -200,10 +220,16 @@ renderModule = (^?! _Right) . Gyehoek.Sexp.encodePretty ref :: Type -> Type ref (MkType x) = MkType . ParenList $ [Symbol "ref", x] +refnull :: Type -> Type +refnull (MkType x) = MkType . ParenList $ ["ref", "null", x] + 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 +238,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 @@ -261,6 +303,14 @@ type' e = MkType . ParenList $ [ "type", e ] namedType :: Text -> Sexp -> Type namedType name e = MkType . ParenList $ [ "type", Symbol name, e ] +instance SexpIso Global where + sexpIso = with \glob -> + list ( el (sym "global") + >>> el (sexpIso @Type) + >>> restCode + ) + >>> glob + instance SexpIso Instr where sexpIso = Sexp.iso coerce coerce @@ -270,22 +320,26 @@ instance SexpIso Type where instance SexpIso Export where sexpIso = Sexp.iso coerce coerce +restCode :: Sexp.Grammar Position (Sexp.List :- t) (Sexp.List :- (Expr :- t)) +restCode = + rest (sexpIso @Instr) + >>> Sexp.onTail + (Sexp.iso + (view instrsExpr) + (review instrsExpr)) + where + instrsExpr :: Iso' (List Instr) Expr + instrsExpr = vector . coerced + instance SexpIso Function where sexpIso = with \func -> list ( el (sym "func") >>> el (list $ el (sym "param") >>> rest (sexpIso @Type)) >>> el (list $ el (sym "result") >>> rest (sexpIso @Type)) >>> el (list $ el (sym "local") >>> rest (sexpIso @Type)) - >>> rest (sexpIso @Instr) - >>> Sexp.onTail - (Sexp.iso - (view instrsExpr) - (review instrsExpr)) + >>> restCode ) >>> func - where - instrsExpr :: Iso' (List Instr) Expr - instrsExpr = vector . coerced instance SexpIso Module where sexpIso = Sexp.partialOsi (const $ Left mempty) \m -> diff --git a/t.wat b/t.wat index 3968ec8..5f4e3bf 100644 --- a/t.wat +++ b/t.wat @@ -1,47 +1,14 @@ (module (type $heap-object (sub (struct (field (mut i32))))) + (type (func (param i32) (result))) + (type (array (ref null 1))) + (type (array (ref eq))) (func (param) (result (ref eq)) (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq)) - (i32.const 3) + (i32.const 1) (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)) + ref.i31) (export "main" (func 0))) diff --git a/u.wat b/u.wat new file mode 100644 index 0000000..f34484c --- /dev/null +++ b/u.wat @@ -0,0 +1,7 @@ +(module + (type $cont (func (param i32))) + (type $cont-stack-type (array (ref null $cont))) + (global $cont-stack (ref $cont-stack-type) + (array.new_default $cont-stack-type (i32.const 128))) + (func (export "main") (result (ref eq)) + (ref.i31 (i32.const 123))))