From fbdc12744e1ee04ab3b9e4e2cd033c3249779518 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Madeleine=20Sydney=20=C5=9Alaga?= Date: Fri, 1 May 2026 00:05:56 -0600 Subject: [PATCH] --- app/Gyehoek/QBE.hs | 197 +++++++++------------------------------ app/Gyehoek/QBE/Parse.hs | 194 ++++++++++++++++++++++++++++++++++++++ app/Main.hs | 77 +++++++++++++-- cabal.project | 4 +- gyehoek.cabal | 6 +- 5 files changed, 314 insertions(+), 164 deletions(-) create mode 100644 app/Gyehoek/QBE/Parse.hs diff --git a/app/Gyehoek/QBE.hs b/app/Gyehoek/QBE.hs index 8f12f8b..a466ae6 100644 --- a/app/Gyehoek/QBE.hs +++ b/app/Gyehoek/QBE.hs @@ -3,15 +3,19 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE TemplateHaskellQuotes #-} module Gyehoek.QBE - ( Unique - , runUnique - , unique + ( GenSym + , runGenSym + , gensym , module QBE , render + , fn ) where - + +import Gyehoek.QBE.Parse import Language.QBE as QBE import Effectful.State.Dynamic import Effectful.Dispatch.Dynamic @@ -20,6 +24,7 @@ import Numeric.Natural import Data.String (IsString(fromString)) import Prettyprinter (Pretty(pretty), layoutPretty, defaultLayoutOptions) import Data.Text (Text) +import Data.Data import Prettyprinter.Render.Text (renderStrict) import Text.Megaparsec import Text.Megaparsec.Char @@ -34,166 +39,50 @@ import Data.List (List) import Data.Foldable (fold) import Data.Maybe (isJust, fromMaybe) import Control.Monad.Fix (MonadFix(mfix)) - +import Data.List.NonEmpty (fromList) +import Language.Haskell.TH qualified as TH +import Language.Haskell.TH.Quote +import Data.Proxy +import Data.Kind (Type) + render :: Pretty a => a -> Text render = renderStrict . layoutPretty defaultLayoutOptions . pretty -data Unique :: Effect where - Unique :: Unique m (Ident s) +data GenSym :: Effect where + GenSym :: GenSym m (Ident s) -type instance DispatchOf Unique = Dynamic +type instance DispatchOf GenSym = Dynamic -unique :: forall s es. Unique :> es => Eff es (Ident s) -unique = send Unique +gensym :: forall s es. GenSym :> es => Eff es (Ident s) +gensym = send GenSym -runUnique :: Eff (Unique : es) a -> Eff es a -runUnique = reinterpret (evalStateLocal (0 :: Natural)) \_ Unique -> +runGenSym :: Eff (GenSym : es) a -> Eff es a +runGenSym = reinterpret (evalStateLocal (0 :: Natural)) \_ GenSym -> state \n -> (Ident . fromString $ '.' : show n, succ n) --- class SigilChar (s :: Sigil) where --- sigilChar' :: Proxy s -> Char --- instance SigilChar AggregateTy where sigilChar' _ = ':' --- instance SigilChar Global where sigilChar' _ = '$' --- instance SigilChar Temporary where sigilChar' _ = '%' --- instance SigilChar Label where sigilChar' _ = '@' + --- sigilChar :: forall (s :: Sigil) -> SigilChar s => Char --- sigilChar s = sigilChar' (Proxy @s) +parseQuoteExp + :: (TH.Quote m, MonadFail m, Data a) => P a -> String -> m TH.Exp +parseQuoteExp p s = + case parse (space *> p <* space <* eof) "qq" (fromString s) of + Left es -> fail . foldMap f . bundleErrors $ es + where f e = parseErrorPretty e ++ "\n\n" + Right x -> dataToExpQ (\_ -> Nothing) x +-- quoteExp :: TH.Quote m => forall (t :: Type) -> (Parser t) => String -> m TH.Exp +-- quoteExp t s = case parse (parser @t) "qq" (fromString s) of +-- Left es -> _ +-- Right x -> dataToExpQ (\_ -> Nothing) x +makeQQ :: forall (t :: Type) -> Parser t => QuasiQuoter +makeQQ t = QuasiQuoter + { quoteExp = parseQuoteExp (parser @t) + , quotePat = _ + , quoteType = undefined + , quoteDec = undefined + } -type P = Parsec Void Text - -sc :: P () -sc = L.space hspace1 (L.skipLineComment "#") empty - -lexeme :: P a -> P a -lexeme = L.lexeme sc - -symbol :: Text -> P Text -symbol = L.symbol sc - -infixr 8 .: -(.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d -(.:) f g x y = f (g x y) - -rawIdent :: P QBE.RawIdent -rawIdent = (fromString .: (:) <$> lead <*> trail) "ident" - where - lead = satisfy \x -> isAlpha x || (x=='.') || (x=='_') - trail = fmap T.unpack . takeWhileP Nothing $ \x -> - isAlphaNum x || (x=='.') || (x=='_') - -class ParseIdent (s :: Sigil) where - ident :: P (QBE.Ident s) - -rawIdentWithSigil :: Char -> P (Ident t) -rawIdentWithSigil c = Ident <$> lexeme (char c *> rawIdent) - -instance ParseIdent AggregateTy where ident = rawIdentWithSigil ':' -instance ParseIdent Global where ident = rawIdentWithSigil '$' -instance ParseIdent Temporary where ident = rawIdentWithSigil '%' -instance ParseIdent QBE.Label where ident = rawIdentWithSigil '@' - -const :: P QBE.Const -const = cint <|> csingle <|> cdouble <|> cglobal "const" - where - cint = CInt <$> lexeme (L.signed empty L.decimal) "integer" - csingle = empty "single-precision float" - cdouble = empty "double-precision float" - cglobal = CGlobal <$> ident "global symbol" - -val :: P QBE.Val -val = vconst <|> vtemp "val" - where - vconst = ValConst <$> Gyehoek.QBE.const - vtemp = ValTemporary <$> ident "temporary symbol" - -assignment :: P QBE.Assignment -assignment = - Assignment <$> ident <*> (char '=' *> basety) - -basety :: P QBE.BaseTy -basety = lexeme $ char 'w' $> Word - <|> char 'l' $> Long - <|> char 's' $> Single - <|> char 'd' $> Double - -abity :: P AbiTy -abity = AbiBaseTy <$> basety - <|> AbiAggregateTy <$> ident - -binaryOp :: P QBE.BinaryOp -binaryOp = lexeme $ "add" $> Add - <|> "sub" $> Sub - <|> "mul" $> Mul - <|> "div" $> Div Signed - -comma :: P a -> P a -comma p = symbol "," *> p - -inst :: P QBE.Inst -inst = try binaryOpInst <|> negInst "inst" - where - binaryOpInst = - BinaryOp - <$> assignment - <*> binaryOp - <*> val <*> comma val - negInst = Neg <$> assignment <*> (symbol "neg" *> val) - -jump :: P QBE.Jump -jump = jmp <|> jnz <|> ret <|> hlt "jump" - where - jmp = symbol "jmp" *> (Jmp <$> ident) - jnz = symbol "jnz" *> (Jnz <$> val <*> ident <*> comma ident) - ret = symbol "ret" *> (Ret <$> optional val) - hlt = empty - -nl :: P () -nl = void (some (newline *> sc)) "newline" - -phi :: P QBE.Phi -phi = empty - -block :: P QBE.Block -block = Block - <$> (ident <* nl) - <*> sepBy phi nl - <*> sepBy inst nl - <*> jump - -sepByTry :: MonadParsec e s m => m a -> m sep -> m (List a) -sepByTry p sep = do - x <- p - xs <- many (try $ sep *> p) - pure (x:xs) - -params :: P (Maybe (Ident Temporary), List Param, Variadic) -params = between (symbol "(") (symbol ")") do - e <- optional env - ps <- optional . try $ do - commaIf (isJust e) - sepByTry reg (symbol ",") - v <- optional do - commaIf (isJust e || isJust ps) - variadic - pure (e, fromMaybe [] ps, fromMaybe NoVariadic v) - where - continue d m = fromMaybe d <$> optional (symbol "," *> m) - commaIf True = void $ symbol "," - commaIf False = pure () - env = symbol "env" *> ident @Temporary "environment parameter" - reg = Param <$> abity <*> ident "regular parameter" - variadic = symbol "..." $> Variadic "variadic parameter" - -funcdef :: P QBE.FuncDef -funcdef = do - linkages <- _ - symbol "function" - returnTy <- optional abity - name <- ident @Global - (env,params,variadic) <- params - code <- _ - pure $ FuncDef linkages returnTy name env params variadic code +fn :: QuasiQuoter +fn = makeQQ (type FuncDef) diff --git a/app/Gyehoek/QBE/Parse.hs b/app/Gyehoek/QBE/Parse.hs new file mode 100644 index 0000000..098bffc --- /dev/null +++ b/app/Gyehoek/QBE/Parse.hs @@ -0,0 +1,194 @@ +{-# LANGUAGE RequiredTypeArguments #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE PartialTypeSignatures #-} +module Gyehoek.QBE.Parse where + +import Language.QBE as QBE +import Effectful.State.Dynamic +import Effectful.Dispatch.Dynamic +import Effectful +import Numeric.Natural +import Data.String (IsString(fromString)) +import Prettyprinter (Pretty(pretty), layoutPretty, defaultLayoutOptions) +import Data.Text (Text) +import Data.Data +import Prettyprinter.Render.Text (renderStrict) +import Text.Megaparsec +import Text.Megaparsec.Char +import Text.Megaparsec.Char.Lexer qualified as L +import Data.Void (Void) +import Data.Char (isAlpha, isAlphaNum) +import Control.Lens.Wrapped +import Data.Functor.Contravariant (Predicate(Predicate)) +import qualified Data.Text as T +import Data.Functor +import Data.List (List) +import Data.Foldable (fold) +import Data.Maybe (isJust, fromMaybe) +import Control.Monad.Fix (MonadFix(mfix)) +import Data.List.NonEmpty (fromList) +import Language.Haskell.TH qualified as TH +import Language.Haskell.TH.Quote +import Data.Proxy +import Data.Kind (Type) + + +type P = Parsec Void Text + +sc :: P () +sc = L.space hspace1 (L.skipLineComment "#") empty + +lexeme :: P a -> P a +lexeme = L.lexeme sc + +symbol :: Text -> P Text +symbol = L.symbol sc + +infixr 8 .: +(.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d +(.:) f g x y = f (g x y) + +rawIdent :: P QBE.RawIdent +rawIdent = (fromString .: (:) <$> lead <*> trail) "ident" + where + lead = satisfy \x -> isAlpha x || (x=='.') || (x=='_') + trail = fmap T.unpack . takeWhileP Nothing $ \x -> + isAlphaNum x || (x=='.') || (x=='_') + +class ParseIdent (s :: Sigil) where + ident :: P (QBE.Ident s) + +rawIdentWithSigil :: Char -> P (Ident t) +rawIdentWithSigil c = Ident <$> lexeme (char c *> rawIdent) + +instance ParseIdent AggregateTy where ident = rawIdentWithSigil ':' +instance ParseIdent Global where ident = rawIdentWithSigil '$' +instance ParseIdent Temporary where ident = rawIdentWithSigil '%' +instance ParseIdent QBE.Label where ident = rawIdentWithSigil '@' + +const :: P QBE.Const +const = cint <|> csingle <|> cdouble <|> cglobal "const" + where + cint = CInt <$> lexeme (L.signed empty L.decimal) "integer" + csingle = empty "single-precision float" + cdouble = empty "double-precision float" + cglobal = CGlobal <$> ident "global symbol" + +val :: P QBE.Val +val = vconst <|> vtemp "val" + where + vconst = ValConst <$> Gyehoek.QBE.Parse.const + vtemp = ValTemporary <$> ident "temporary symbol" + +assignment :: P QBE.Assignment +assignment = + Assignment <$> ident <*> (char '=' *> basety) + +basety :: P QBE.BaseTy +basety = lexeme $ char 'w' $> Word + <|> char 'l' $> Long + <|> char 's' $> Single + <|> char 'd' $> Double + +abity :: P AbiTy +abity = AbiBaseTy <$> basety + <|> AbiAggregateTy <$> ident + +binaryOp :: P QBE.BinaryOp +binaryOp = lexeme $ "add" $> Add + <|> "sub" $> Sub + <|> "mul" $> Mul + <|> "div" $> Div Signed + +comma :: P a -> P a +comma p = symbol "," *> p + +inst :: P QBE.Inst +inst = try binaryOpInst <|> negInst "inst" + where + binaryOpInst = + BinaryOp + <$> assignment + <*> binaryOp + <*> val <*> comma val + negInst = Neg <$> assignment <*> (symbol "neg" *> val) + +jump :: P QBE.Jump +jump = jmp <|> jnz <|> ret <|> hlt "jump" + where + jmp = symbol "jmp" *> (Jmp <$> ident) + jnz = symbol "jnz" *> (Jnz <$> val <*> ident <*> comma ident) + ret = symbol "ret" *> (Ret <$> optional val) + hlt = empty + +nl :: P () +nl = void (some (newline *> sc)) "newline" + +phi :: P QBE.Phi +phi = empty + +block :: P QBE.Block +block = Block + <$> (ident <* nl) + <*> sepBy phi nl + <*> sepBy inst nl + <*> jump + +sepByTry :: MonadParsec e s m => m a -> m sep -> m (List a) +sepByTry p sep = do + x <- p + xs <- many (try $ sep *> p) + pure (x:xs) + +paramList :: P (Maybe (Ident Temporary), List Param, Variadic) +paramList = label "parameter list" $ between (symbol "(") (symbol ")") do + e <- optional env + ps <- optional . try $ do + commaIf (isJust e) + sepByTry reg (symbol ",") + v <- optional do + commaIf (isJust e || isJust ps) + variadic + pure (e, fromMaybe [] ps, fromMaybe NoVariadic v) + where + commaIf True = void $ symbol "," + commaIf False = pure () + env = symbol "env" *> ident @Temporary "environment parameter" + reg = Param <$> abity <*> ident "regular parameter" + variadic = symbol "..." $> Variadic "variadic parameter" + +funcdef :: P QBE.FuncDef +funcdef = do + linkages <- many linkage + symbol "function" + returnTy <- optional abity + name <- ident @Global + (env,params,variadic) <- paramList + code <- fmap fromList . between (symbol "{" *> nl) (symbol "}") $ + sepEndBy1 block nl + pure $ FuncDef linkages returnTy name env params variadic code + +linkage :: P Linkage +linkage = symbol "export" $> Export + +-- stripped :: P a -> P a +-- stripped p = optional nl *> + + + +class Data a => Parser a where + parser :: P a + +instance Parser FuncDef where parser = funcdef + +class ParseSeparator a where + parseSeparator :: Proxy a -> P () + +instance (Parser a, ParseSeparator a) => Parser (List a) where + parser = sepBy parser (parseSeparator @a Proxy) + +instance ParseSeparator FuncDef where parseSeparator _ = nl +instance ParseSeparator Block where parseSeparator _ = nl diff --git a/app/Main.hs b/app/Main.hs index 8ef68a0..fa0c5f7 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,27 +1,90 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE OverloadedLists #-} module Main (main) where import Data.Text (Text) import Effectful -import Gyehoek.QBE +import Gyehoek.QBE as QBE import Data.List (List) +import Data.Text.IO qualified as TIO +import Control.Lens +import Data.Vector (Vector) +import Data.Function (fix) +import Effectful.Writer.Static.Local type Name = Text -data Expr - = Var Name - | App Expr (List Expr) - | Lam Name Expr - | Progn (List Expr) - | UsePrim Prim +data Value + = ValInt Int + | ValNil + | ValPrim Prim deriving (Show) +data Sexp + -- | Cons + = Sexp :. Sexp + | UseVal Value + deriving (Show) + +infixr 5 :. +pattern Cons :: Sexp -> Sexp -> Sexp +pattern Cons x y = x :. y + data Prim = PrimAdd | PrimSub | PrimMul | PrimDiv deriving (Show) +mapcar :: Traversal' Sexp Sexp +mapcar k (Cons x xs) = Cons <$> k x <*> mapcar k xs +mapcar k x = pure x + +type CodeGen = Writer (Vector Inst) + +runCodeGen :: Eff (CodeGen : es) a -> Eff es (a, Vector Inst) +runCodeGen = runWriter + +emit :: CodeGen :> es => Inst -> Eff es () +emit = tell . pure + +compile + :: (GenSym :> es, CodeGen :> es) + => Sexp + -> (QBE.Val -> Eff es Jump) + -> Eff es Jump + +compile (UseVal (ValInt n)) k = + k . ValConst . CInt . fromIntegral $ n + +compile (UseVal (ValPrim p) :. args) k = f (args ^.. mapcar) + where + f [x,y] = + compile x \x' -> + compile y \y' -> do + r <- gensym + emit $ BinaryOp (r := Long) bop x' y' + k (ValTemporary r) + f _ = _ + bop = case p of + PrimAdd -> Add + PrimMul -> Mul + _ -> _ + +compile _ _ = _ + +compile' :: (GenSym :> es) => Ident Label -> Sexp -> Eff es Block +compile' l e = do + (j,is) <- runCodeGen $ compile e (pure . Ret . Just) + pure $ Block l [] (is ^.. each) j + main :: IO () main = putStrLn "Hello, Haskell!" +expr = UseVal (ValPrim PrimAdd) + :. UseVal (ValInt 1) + :. UseVal (ValInt 2) + -- :. UseVal (ValInt 3) + :. UseVal ValNil diff --git a/cabal.project b/cabal.project index 13e43fb..48b9e47 100644 --- a/cabal.project +++ b/cabal.project @@ -3,5 +3,5 @@ packages: *.cabal source-repository-package type: git location: https://git.deertopia.net/msyds/qbe-hs.git - tag: 25b62cb69d8e3bd51f32c4bfe494fa78094f8fc2 - --sha256: 04w91dppjq44w50imw0ifj480ijkjy28428s3zyj39pmk6hlvkvz + tag: ab7cc053a4d58fde841e910f251b8e48b54466ad + --sha256: 0n2jqr6vymlyr0gwzbv3cljhqxnzcq1pzf7m92b16jalkymbcwgy diff --git a/gyehoek.cabal b/gyehoek.cabal index 7b2af14..de9322b 100644 --- a/gyehoek.cabal +++ b/gyehoek.cabal @@ -28,7 +28,9 @@ executable gyehoek main-is: Main.hs -- cabal-fmt: expand app -Main - other-modules: Gyehoek.QBE + other-modules: + Gyehoek.QBE + Gyehoek.QBE.Parse -- other-extensions: build-depends: @@ -41,7 +43,9 @@ executable gyehoek , prettyprinter , qbe , recursion-schemes + , template-haskell , text + , vector hs-source-dirs: app default-language: GHC2024