msyds/gyehoek-hs
1
0
Fork 0
Code Issues Pull Requests 1 Actions Packages Projects Releases Wiki Activity

wasmslop

Browse Source
This commit is contained in:
Madeleine Sydney Slaga
2026-07-04 11:57:14 -06:00
parent 817b7530c1
commit a2c93938ca
5 changed files with 355 additions and 6 deletions
Download Patch File Download Diff File Expand all files Collapse all files
app/Gyehoek/CPS/Convert.hs
+15 -2
View File
@@ -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
app/Gyehoek/CPS/Lower.hs
+25
View File
@@ -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 = _
app/Gyehoek/Scheme/Syntax.hs
+5 -4
View File
@@ -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 )
app/Gyehoek/Wasm/Syntax.hs
+307
View File
@@ -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
gyehoek.cabal
+3
View File
@@ -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