From a2c93938ca569837bf5c2cb7d41d7bde0300fcf3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Madeleine=20Sydney=20=C5=9Alaga?= Date: Sat, 4 Jul 2026 11:57:14 -0600 Subject: [PATCH] wasmslop --- app/Gyehoek/CPS/Convert.hs | 17 +- app/Gyehoek/CPS/Lower.hs | 25 +++ app/Gyehoek/Scheme/Syntax.hs | 9 +- app/Gyehoek/Wasm/Syntax.hs | 307 +++++++++++++++++++++++++++++++++++ gyehoek.cabal | 3 + 5 files changed, 355 insertions(+), 6 deletions(-) create mode 100644 app/Gyehoek/CPS/Lower.hs create mode 100644 app/Gyehoek/Wasm/Syntax.hs diff --git a/app/Gyehoek/CPS/Convert.hs b/app/Gyehoek/CPS/Convert.hs index 2945f54..b13ad62 100644 --- a/app/Gyehoek/CPS/Convert.hs +++ b/app/Gyehoek/CPS/Convert.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedLists #-} module Gyehoek.CPS.Convert ( convert ) where @@ -29,9 +30,21 @@ convert (Scm.ExpPrim p) k = r <- gensym' "r" ExpPrim p' [r] . pure <$> k (ValVar r) +convert (Scm.ExpLambda xs e) k = do + f <- gensym' "f" + ktail <- gensym' "ktail" + m <- convert e $ \e' -> + pure $ ExpApply (ValVar ktail) [e'] + ExpFix [(f, MkKappa (xs ++ [ktail]) m)] <$> k (ValVar f) + convert (Scm.ExpApply f xs) k = telescope (convert @es) (f:|xs) \(f':|xs') -> do - _ - _ + r <- gensym' "r" + x <- gensym' "x" + m <- k (ValVar x) + pure $ ExpFix [(r, MkKappa [x] m)] $ ExpApply f' (xs' ++ [ValVar r]) convert _ k = _ + +halt :: Applicative f => Val -> f Exp +halt = pure . ExpApply (ValVar "halt") . pure diff --git a/app/Gyehoek/CPS/Lower.hs b/app/Gyehoek/CPS/Lower.hs new file mode 100644 index 0000000..2639f89 --- /dev/null +++ b/app/Gyehoek/CPS/Lower.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE OverloadedLists #-} +module Gyehoek.CPS.Lower + ( lower + ) where + +import Gyehoek.CPS.Syntax +import Gyehoek.Scheme.Syntax qualified as Scm +import Gyehoek.GenSym +import Data.List.NonEmpty (NonEmpty((:|))) +import Effectful +import Control.Monad.Cont qualified as Cont +import Effectful.Writer.Static.Local +import Data.Text (Text) +import Data.Vector.Strict (Vector) +import Control.Lens +import Data.Foldable + + +type Emit = Writer (Vector Text) + +runEmit :: Eff (Emit : es) a -> Eff es (a, Text) +runEmit = (mapped . _2 %~ fold) . runWriter + +lower :: Exp -> Eff _ _ +lower = _ diff --git a/app/Gyehoek/Scheme/Syntax.hs b/app/Gyehoek/Scheme/Syntax.hs index d8949ff..625fc78 100644 --- a/app/Gyehoek/Scheme/Syntax.hs +++ b/app/Gyehoek/Scheme/Syntax.hs @@ -108,9 +108,10 @@ primSexpIso namefn a = match $ With (. nullop "newline") $ End where - nullop s = list $ el (sym (namefn s)) - unop s = list $ el (sym (namefn s)) >>> el a - binop s = list $ el (sym (namefn s)) >>> el a >>> el a + idn s = el (sym (namefn s)) + nullop s = list $ idn s + unop s = list $ idn s >>> el a + binop s = list $ idn s >>> el a >>> el a instance SexpIso a => SexpIso (Prim a) where sexpIso = primSexpIso ("prim:"<>) sexpIso @@ -156,6 +157,6 @@ instance SexpIso Exp where where if_ = list $ el (sym "if") >>> el sexpIso >>> el sexpIso >>> el sexpIso lam = list - ( el (sym "lambda") + ( el Gyehoek.Sexp.lambdaKeyword >>> el (sexpIso @(List Name)) >>> el sexpIso ) diff --git a/app/Gyehoek/Wasm/Syntax.hs b/app/Gyehoek/Wasm/Syntax.hs new file mode 100644 index 0000000..f46a4c9 --- /dev/null +++ b/app/Gyehoek/Wasm/Syntax.hs @@ -0,0 +1,307 @@ +{-# LANGUAGE OverloadedRecordDot #-} +module Gyehoek.Wasm.Syntax + ( Module(..) + , Type + , Import + , Tag + , Global + , Mem + , Table + , Func + , Data + , Elem + , Export + , Idx + , TypeIdx + , FuncIdx + , GlobalIdx + , TableIdx + , MemIdx + , TagIdx + , ElemIdx + , DataIdx + , LabelIdx + , LocalIdx + , FieldIdx + ) where + +import Data.Vector (Vector) +import Data.Word (Word32) +import Data.Binary hiding (putList) +import Data.Bits +import Data.Int (Int8, Int32) +import Data.Binary hiding (putList) +import Data.List (List) +import Data.Generics.Labels +import Control.Lens +import Data.Text (Text) +import Control.Applicative (Alternative(..)) +import Data.Foldable (traverse_) +import Control.Monad +import Data.Binary.Put (runPut) +import GHC.Generics (Generic) +import Data.Coerce (coerce) + + +type Type = RecType +data Import +data Tag +data Global +data Mem +data Table +data Func +data Data +data Elem +data Export +data DataCount +data Code = MkCode { locals :: Vector Local, expr :: Expr } + +newtype Idx = MkIdx Word32 + deriving (Show, Generic) + +newtype TypeIdx = MkType Idx + deriving (Show, Generic) + deriving newtype (Binary) +newtype FuncIdx = MkFunc Idx + deriving (Show, Generic) + deriving newtype (Binary) +newtype GlobalIdx = MkGlobal Idx + deriving (Show, Generic) +newtype TableIdx = MkTable Idx + deriving (Show, Generic) +newtype MemIdx = MkMem Idx + deriving (Show, Generic) +newtype TagIdx = MkTag Idx + deriving (Show, Generic) +newtype ElemIdx = MkElem Idx + deriving (Show, Generic) +newtype DataIdx = MkData Idx + deriving (Show, Generic) +newtype LabelIdx = MkLabel Idx + deriving (Show, Generic) +newtype LocalIdx = MkLocal Idx + deriving (Show, Generic) +newtype FieldIdx = MkField Idx + deriving (Show, Generic) + +data Module = MkModule + { types :: Vector Type + , imports :: Vector Import + , funcs :: Vector Func + , tables :: Vector Table + , mems :: Vector Mem + , tags :: Vector Tag + , globals :: Vector Global + , exports :: Vector Export + , start :: Maybe FuncIdx + , elems :: Vector Elem + , dataCounts :: Vector DataCount + , code :: Vector Code + , datas :: Vector Data + } + +instance Semigroup Module where + m1 <> m2 = MkModule + { types = m1.types <> m2.types + , imports = m1.imports <> m2.imports + , tags = m1.tags <> m2.tags + , globals = m1.globals <> m2.globals + , mems = m1.mems <> m2.mems + , tables = m1.tables <> m2.tables + , funcs = m1.funcs <> m2.funcs + , datas = m1.datas <> m2.datas + , elems = m1.elems <> m2.elems + , start = m1.start <|> m2.start + , exports = m1.exports <> m2.exports + } + +instance Monoid Module where + mempty = MkModule + { types = mempty + , imports = mempty + , funcs = mempty + , tables = mempty + , mems = mempty + , tags = mempty + , globals = mempty + , exports = mempty + , start = Nothing + , elems = mempty + , datas = mempty + } + +newtype SectionId = MkSectionId Word8 + deriving newtype (Binary) + +pattern SectionCustom = MkSectionId 0 +pattern SectionType = MkSectionId 1 +pattern SectionImport = MkSectionId 2 +pattern SectionFunction = MkSectionId 3 +pattern SectionTable = MkSectionId 4 +pattern SectionMemory = MkSectionId 5 +pattern SectionGlobal = MkSectionId 6 +pattern SectionExport = MkSectionId 7 +pattern SectionStart = MkSectionId 8 +pattern SectionElement = MkSectionId 9 +pattern SectionCode = MkSectionId 10 +pattern SectionData = MkSectionId 11 +pattern SectionDataCount = MkSectionId 12 +pattern SectionTag = MkSectionId 13 + +newtype RecType = MkRecType { subtypes :: List SubType } + +data SubType + = MkSubType { final :: Bool, supertypes :: List TypeIdx, ct :: CompType } + deriving (Show, Generic) + +data CompType = CompTypeFunc { to :: List ValType, from :: List ValType } + deriving (Show, Generic) + +data ValType + = ValTypeNum NumType + deriving (Show, Generic) + +data NumType + = F64 | F32 | I64 | I32 + deriving (Show, Generic) + +data Local +data Expr + + + +getULEB128 :: (Integral a, Bits a) => Int -> Get a +getULEB128 bitsBudget = do + if bitsBudget > 0 then return () else fail "integer representation too long" + val <- getWord8 + if bitsBudget >= 7 || val .&. 0x7F < 1 `shiftL` bitsBudget then return () else fail "integer too large" + if not (testBit val 7) + then return $ fromIntegral val + else do + rest <- getULEB128 (bitsBudget - 7) + return $ (fromIntegral $ val .&. 0x7F) .|. (rest `shiftL` 7) + +putULEB128 :: (Integral a, Bits a) => a -> Put +putULEB128 val = + if val < 128 + then putWord8 $ fromIntegral val + else do + putWord8 $ 0x80 + (0x7F .&. fromIntegral val) + putULEB128 $ val `shiftR` 7 + +getSLEB128 :: (Integral a, Bits a) => Int -> Get a +getSLEB128 bitsBudget = do + if bitsBudget > 0 then return () else fail "integer representation too long" + let toInt8 :: Word8 -> Int8 + toInt8 = fromIntegral + a <- getWord8 + let mask = (0xFF `shiftL` (bitsBudget - 1)) .&. 0x7F + if bitsBudget >= 7 || a .&. mask == 0 || a .&. mask == mask then return () else fail "integer too large" + if not (testBit a 7) + then return . fromIntegral . toInt8 $ (a .&. 0x7f) .|. ((a .&. 0x40) `shiftL` 1) + else do + b <- getSLEB128 (bitsBudget - 7) + return $ (b `shiftL` 7) .|. (fromIntegral (a .&. 0x7f)) + +putSLEB128 :: (Integral a, Bits a) => a -> Put +putSLEB128 a = go a + where + ext = if a >= 0 then 0 else complement 0 + go x = do + let + r = x `shiftR` 7 + w = x .&. 0x7f + if r /= ext + then do + putWord8 (fromIntegral w .|. 0x80) + go r + else + if (testBit w 6 && a < 0) || (not (testBit w 6) && a >= 0) + then putWord8 (fromIntegral w) + else do + putWord8 (fromIntegral w .|. 0x80) + putWord8 (fromIntegral ext .&. 0x7F) + + + +putSection :: SectionId -> Put -> Put +putSection i contents = + unless (len == 0) $ do + put i + put (lengthOf each contents') + put contents' + where + contents' = runPut contents + len = lengthOf each contents' + +putU32 :: Word32 -> Put +putU32 = putULEB128 + +putI32 :: Int32 -> Put +putI32 = putSLEB128 + +putList :: Foldable f => (a -> Put) -> f a -> Put +putList f xs = do + putU32 (fromIntegral $ length xs) + traverse_ f xs + + + +putTypeSection :: Vector Type -> Put +putTypeSection = putSection SectionType . putList put + +putCodeSection :: Vector Type -> Put +putCodeSection = putSection SectionType . putList put + +putStartSection :: Maybe FuncIdx -> Put +putStartSection (Just x) = put x +putStartSection Nothing = pure () + +instance Binary Module where + get = _ + put m = do + -- magic + traverse_ putWord8 [0x00, 0x61, 0x73, 0x6d] + -- version + traverse_ putWord8 [0x01, 0x00, 0x00, 0x00] + -- sections + putTypeSection m.types + putStartSection m.start + +instance Binary RecType where + get = _ + put rt = case rt.subtypes of + [st] -> put st + sts -> do + putWord8 0x4e + putList put sts + +instance Binary SubType where + get = _ + put st = do + putWord8 $ if st.final then 0x4f else 0x50 + putList put st.supertypes + put st.ct + +instance Binary CompType where + get = _ + put = \case + CompTypeFunc s t -> do + putWord8 0x60 + traverseOf_ both (putList put) (s,t) + +instance Binary ValType where + put = \case + ValTypeNum nt -> put nt + +instance Binary NumType where + get = _ + put = putWord8 . \case + F64 -> 0x7c + F32 -> 0x7d + I64 -> 0x7e + I32 -> 0x7f + +instance Binary Idx where + get = _ + put = putU32 . coerce diff --git a/gyehoek.cabal b/gyehoek.cabal index 33ab1b5..c0beee3 100644 --- a/gyehoek.cabal +++ b/gyehoek.cabal @@ -36,14 +36,17 @@ executable gyehoek -- cabal-fmt: expand app -Main other-modules: Gyehoek.CPS.Convert + Gyehoek.CPS.Lower Gyehoek.CPS.Syntax Gyehoek.GenSym Gyehoek.Options Gyehoek.Scheme.Syntax Gyehoek.Sexp + Gyehoek.Wasm.Syntax build-depends: , base ^>=4.21.2.0 + , binary , containers , cradle , effectful