From 82927608d4037779c6d3fd7158f553102cef262d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Madeleine=20Sydney=20=C5=9Alaga?= Date: Fri, 10 Jul 2026 17:37:24 -0600 Subject: [PATCH] fuckeverythingggg --- app/Gyehoek/CPS/Lower.hs | 29 ---- app/Gyehoek/Wasm.hs | 28 ++++ app/Gyehoek/Wasm/Build.hs | 6 - app/Gyehoek/Wasm/Syntax.hs | 307 ------------------------------------- gyehoek.cabal | 2 +- 5 files changed, 29 insertions(+), 343 deletions(-) create mode 100644 app/Gyehoek/Wasm.hs delete mode 100644 app/Gyehoek/Wasm/Build.hs delete mode 100644 app/Gyehoek/Wasm/Syntax.hs diff --git a/app/Gyehoek/CPS/Lower.hs b/app/Gyehoek/CPS/Lower.hs index 3075706..1952724 100644 --- a/app/Gyehoek/CPS/Lower.hs +++ b/app/Gyehoek/CPS/Lower.hs @@ -30,11 +30,6 @@ import qualified Data.Vector.Strict as V import Data.IntMap.Strict (IntMap) -type Emit = Writer (Vector Text) - -runEmit :: Eff (Emit : es) a -> Eff es (a, Text) -runEmit = (mapped . _2 %~ fold) . runWriter - data Env = MkEnv { vars :: Vector Name } deriving (Show, Generic) @@ -49,35 +44,11 @@ instance Ixed Env where --- countLocals :: Exp -> Int - --- countLocals (ExpPrim p rs es) = length rs + sumOf (each . to countLocals) es - --- countLocals (ExpFix bs e) = --- sumOf (each . _2 . _MkKappa . ((_1 . each . to (const 1)) --- <> (_2 . to countLocals))) bs --- + countLocals e - --- countLocals (ExpApply _ _) = 0 - tshow :: Show a => a -> Text tshow = T.pack . show -data Module = MkModule - { funcs :: IntMap Func - } - deriving (Show, Generic) - -data Func = MkFunc - { code :: Text - , numLocals :: Int - } - deriving (Show, Generic) - - - lowerVal :: Env -> Val -> Vector Text lowerVal g (ValLit l) = diff --git a/app/Gyehoek/Wasm.hs b/app/Gyehoek/Wasm.hs new file mode 100644 index 0000000..335949f --- /dev/null +++ b/app/Gyehoek/Wasm.hs @@ -0,0 +1,28 @@ +{- HLINT ignore "Use newtype instead of data" -} +module Gyehoek.Wasm + () + where + +import Data.List (List) +import GHC.Generics (Generic) + + +data Module = MkModule + { typeSection :: List Type + } + deriving (Show, Generic) + +data Type + deriving (Show, Generic) + +data Function = MkFunction + { params :: List Type + , result :: List Type + , locals :: List Type + , body :: Expr + } + deriving (Show, Generic) + +type Expr = List Instr + +type Instr = ByteString diff --git a/app/Gyehoek/Wasm/Build.hs b/app/Gyehoek/Wasm/Build.hs deleted file mode 100644 index 8e4a83f..0000000 --- a/app/Gyehoek/Wasm/Build.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Gyehoek.Wasm.Build - () where - -import Gyehoek.Wasm.Syntax -import Control.Lens - diff --git a/app/Gyehoek/Wasm/Syntax.hs b/app/Gyehoek/Wasm/Syntax.hs deleted file mode 100644 index f46a4c9..0000000 --- a/app/Gyehoek/Wasm/Syntax.hs +++ /dev/null @@ -1,307 +0,0 @@ -{-# 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 c90751f..c8fac5f 100644 --- a/gyehoek.cabal +++ b/gyehoek.cabal @@ -43,7 +43,7 @@ executable gyehoek Gyehoek.Options Gyehoek.Scheme.Syntax Gyehoek.Sexp - Gyehoek.Wasm.Syntax + Gyehoek.Wasm build-depends: , base ^>=4.21.2.0