This commit is contained in:
@@ -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)
|
||||
|
||||
Reference in New Issue
Block a user