From 03e106fbf99eb640125a056e7811c6a27cf14ce0 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 | 14 ++++ app/Gyehoek/Scheme/Syntax.hs | 2 +- app/Gyehoek/Wasm/Syntax.hs | 125 +++++++++++++++++++++++++++++++++++ gyehoek.cabal | 3 + 5 files changed, 158 insertions(+), 3 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..c9f7365 --- /dev/null +++ b/app/Gyehoek/CPS/Lower.hs @@ -0,0 +1,14 @@ +{-# 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 + + +lower = _ diff --git a/app/Gyehoek/Scheme/Syntax.hs b/app/Gyehoek/Scheme/Syntax.hs index d8949ff..e527cb1 100644 --- a/app/Gyehoek/Scheme/Syntax.hs +++ b/app/Gyehoek/Scheme/Syntax.hs @@ -156,6 +156,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..74389df --- /dev/null +++ b/app/Gyehoek/Wasm/Syntax.hs @@ -0,0 +1,125 @@ +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 +import Data.Bits +import Data.Int (Int8) +import Data.Binary + + +data Type +data Import +data Tag +data Global +data Mem +data Table +data Func +data Data +data Elem +data Export + +type Idx = Word32 +newtype TypeIdx = MkType Idx +newtype FuncIdx = MkFunc Idx +newtype GlobalIdx = MkGlobal Idx +newtype TableIdx = MkTable Idx +newtype MemIdx = MkMem Idx +newtype TagIdx = MkTag Idx +newtype ElemIdx = MkElem Idx +newtype DataIdx = MkData Idx +newtype LabelIdx = MkLabel Idx +newtype LocalIdx = MkLocal Idx +newtype FieldIdx = MkField Idx + +data Module = MkModule + { types :: Vector Type + , imports :: Vector Import + , tags :: Vector Tag + , globals :: Vector Global + , mems :: Vector Mem + , tables :: Vector Table + , funcs :: Vector Func + , datas :: Vector Data + , elems :: Vector Elem + , start :: Maybe FuncIdx + , exports :: Vector Export + } + + + +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) 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