app/Gyehoek/QBE.hs

@@ -3,15 +3,19 @@
 {-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ApplicativeDo #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE TemplateHaskellQuotes #-}
 module Gyehoek.QBE
-  ( Unique
+  ( GenSym
-  , runUnique
+  , runGenSym
-  , unique
+  , 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
+data GenSym :: Effect where
-  Unique :: Unique m (Ident s)
+  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)
+gensym :: forall s es. GenSym :> es => Eff es (Ident s)
-unique = send Unique
+gensym = send GenSym
 
-runUnique :: Eff (Unique : es) a -> Eff es a
+runGenSym :: Eff (GenSym : es) a -> Eff es a
-runUnique = reinterpret (evalStateLocal (0 :: Natural)) \_ Unique ->
+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
+parseQuoteExp
--- sigilChar s = sigilChar' (Proxy @s)
+  :: (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
+fn :: QuasiQuoter
-
+fn = makeQQ (type FuncDef)
-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

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

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
+data Value
-  = Var Name
+  = ValInt Int
-  | App Expr (List Expr)
+  | ValNil
-  | Lam Name Expr
+  | ValPrim Prim
-  | Progn (List Expr)
-  | UsePrim 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

cabal.project

@@ -3,5 +3,5 @@ packages: *.cabal
 source-repository-package
     type: git
     location: https://git.deertopia.net/msyds/qbe-hs.git
-    tag: 25b62cb69d8e3bd51f32c4bfe494fa78094f8fc2
+    tag: ab7cc053a4d58fde841e910f251b8e48b54466ad
-    --sha256: 04w91dppjq44w50imw0ifj480ijkjy28428s3zyj39pmk6hlvkvz
+    --sha256: 0n2jqr6vymlyr0gwzbv3cljhqxnzcq1pzf7m92b16jalkymbcwgy

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