diff --git a/golden/call.qbe b/golden/call.qbe new file mode 100644 index 0000000..fdf18bc --- /dev/null +++ b/golden/call.qbe @@ -0,0 +1 @@ +%r =w call $f (env 1, w 2, :t %a, ..., w 3, :t1 %b) \ No newline at end of file diff --git a/golden/function.qbe b/golden/function.qbe new file mode 100644 index 0000000..dc5f78d --- /dev/null +++ b/golden/function.qbe @@ -0,0 +1,5 @@ +export +function :t $f +(env %env, w %a, d %b, ...) +{@l + ret } \ No newline at end of file diff --git a/golden/phi.qbe b/golden/phi.qbe new file mode 100644 index 0000000..7e914d6 --- /dev/null +++ b/golden/phi.qbe @@ -0,0 +1 @@ +%a =w phi @b 1, @c 2 \ No newline at end of file diff --git a/src/Language/QBE.hs b/src/Language/QBE.hs index 15867b7..a73be3d 100644 --- a/src/Language/QBE.hs +++ b/src/Language/QBE.hs @@ -13,8 +13,8 @@ import Data.Word (Word64) import Data.List.NonEmpty (NonEmpty, toList) import Data.Maybe (maybeToList) import Prettyprinter - ( Pretty(pretty), (<+>), vsep, hsep - , space, encloseSep, lbrace, rbrace, comma, equals, braces ) + ( Pretty(pretty), Doc, (<+>), vsep, hsep, hang, punctuate, group, flatAlt + , space, encloseSep, tupled, comma, equals, braces ) -- Instances import Data.Hashable (Hashable) import Control.DeepSeq (NFData) @@ -130,7 +130,7 @@ instance Pretty Typedef where pretty (Typedef ident alignment def) = "type" <+> pretty ident <+> equals <> maybe mempty (\x -> space <> pretty x) alignment - <+> encloseSep lbrace rbrace (comma <> space) (prettyItem <$> def) + <+> braced (prettyItem <$> def) where prettyItem (subTy, Nothing ) = pretty subTy prettyItem (subTy, Just amount) = pretty subTy <+> pretty amount @@ -158,7 +158,7 @@ instance Pretty DataDef where [ vsep $ pretty <$> linkage , hsep $ ("data" <+> pretty ident <+> equals) : maybeToList (("align" <+>) . pretty <$> alignment) - , encloseSep lbrace rbrace (comma <> space) (pretty <$> fields) + , braced (pretty <$> fields) ] data DataItem @@ -189,15 +189,37 @@ instance Pretty Field where data FuncDef = FuncDef [Linkage] (Maybe AbiTy) (Ident 'Global) (Maybe (Ident 'Temporary)) [Param] Variadic (NonEmpty Block) deriving (Show, Eq) +instance Pretty FuncDef where + pretty (FuncDef linkage abiTy ident env params variadic blocks) = vsep + [ vsep $ pretty <$> linkage + , "function" <+> pretty abiTy <+> pretty ident + , tupled $ + maybeToList (("env" <+>) . pretty <$> env) + ++ fmap pretty params + ++ maybeToList (prettyVariadic variadic) + , braces $ vsep $ toList $ pretty <$> blocks + ] + data AbiTy = AbiBaseTy BaseTy | AbiAggregateTy (Ident 'AggregateTy) deriving (Show, Eq) +instance Pretty AbiTy where + pretty (AbiBaseTy baseTy) = pretty baseTy + pretty (AbiAggregateTy ident) = pretty ident + data Param = Param AbiTy (Ident 'Temporary) deriving (Show, Eq) +instance Pretty Param where + pretty (Param abiTy ident) = pretty abiTy <+> pretty ident + data Variadic = Variadic | NoVariadic deriving (Show, Eq) +prettyVariadic :: Variadic -> Maybe (Doc a) +prettyVariadic Variadic = Just "..." +prettyVariadic NoVariadic = Nothing + -- * Control ------------ @@ -215,6 +237,14 @@ instance Pretty Val where data Block = Block (Ident 'Label) [Phi] [Inst] Jump deriving (Show, Eq) +instance Pretty Block where + pretty (Block ident phis insts jump) = hang 4 $ vsep $ concat + [ [pretty ident] + , pretty <$> phis + , pretty <$> insts + , [pretty jump] + ] + data Jump = Jmp (Ident 'Label) | Jnz Val (Ident 'Label) (Ident 'Label) @@ -232,9 +262,21 @@ instance Pretty Jump where -- * Instructions ----------------- -data Phi = Phi (Ident 'Temporary) BaseTy [(Ident 'Label, Val)] +data Phi = Phi (Ident 'Temporary) BaseTy [PhiArg] deriving (Show, Eq) +instance Pretty Phi where + pretty (Phi ident baseTy args) = + pretty ident <+> equals <> pretty baseTy <+> "phi" + <+> hsep (punctuate comma $ pretty <$> args) + +data PhiArg = PhiArg (Ident 'Label) Val + deriving (Show, Eq) + +instance Pretty PhiArg where + pretty (PhiArg label val) = pretty label <+> pretty val + +-- MAYBE tuple the Ident + *Ty or make it into an Assignment type data Inst -- Arithmetic and Bits = BinaryOp (Ident 'Temporary) BaseTy BinaryOp Val Val @@ -280,6 +322,40 @@ data Inst | VaArg (Ident 'Temporary) BaseTy (Ident 'Temporary) deriving (Show, Eq) +instance Pretty Inst where + pretty (BinaryOp res resTy op v1 v2) = undefined + pretty (Neg res resTy v) = undefined + pretty (Store ty v address) = undefined + pretty (Load res resTy loadTy addr) = undefined + pretty (LoadW res resTy intRepr addr) = undefined + pretty (LoadH res resTy intRepr addr) = undefined + pretty (LoadB res resTy intRepr addr) = undefined + pretty (Compare res resTy comp compTy v1 v2) = undefined + pretty (ExtW res intRepr v) = undefined + pretty (ExtH res resTy intRepr v) = undefined + pretty (ExtB res resTy intRepr v) = undefined + pretty (Exts res v) = undefined + pretty (Truncd res v) = undefined + pretty (StoI res resTy intRepr v) = undefined + pretty (DtoI res resTy intRepr v) = undefined + pretty (WtoF res resTy intRepr v) = undefined + pretty (LtoF res resTy intRepr v) = undefined + pretty (Cast res resTy v) = undefined + pretty (Copy res resTy v) = undefined + pretty (Call assignment func env args variadics) = hsep $ + maybeToList (prettyAssignment <$> assignment) ++ + [ "call" + , pretty func + , tupled $ maybeToList (("env" <+>) . pretty <$> env) + ++ fmap pretty args + ++ variadics' + ] + where + prettyAssignment (ident, ty) = pretty ident <+> equals <> pretty ty + variadics' = if null variadics then [] else "..." : fmap pretty variadics + pretty (VaStart argList) = undefined + pretty (VaArg res resTy argList) = undefined + data IntRepr = Signed | Unsigned deriving (Show, Eq) @@ -309,6 +385,21 @@ data BinaryOp | Shl deriving (Show, Eq) +instance Pretty BinaryOp where + pretty Add = "add" + pretty Sub = "sub" + pretty (Div Signed) = "div" + pretty (Div Unsigned) = "udiv" + pretty Mul = "mul" + pretty (Rem Signed) = "rem" + pretty (Rem Unsigned) = "rem" + pretty Or = "or" + pretty Xor = "xor" + pretty And = "and" + pretty Sar = "sar" + pretty Shr = "shr" + pretty Shl = "shl" + -- | Comparison operators. -- Where there's a @'Maybe' 'IntRepr'@, 'Nothing' means floating point -- (@le@, @lt@, @ge@, @gt@), while @'Just' r@ means integer @@ -326,5 +417,34 @@ data Comparison | Uo -- ^ unordered (at least one operand is a NaN) (floating point only) deriving (Show, Eq) +-- | This is not a 'Pretty' instance because it only builds _part_ of the +-- instruction (for example "ule" instead of "culew" +prettyComparison :: Comparison -> Doc ann +prettyComparison Eq = "eq" +prettyComparison Ne = "ne" +prettyComparison (Le intRepr) = prettyMaybeIntRepr intRepr <> "le" +prettyComparison (Lt intRepr) = prettyMaybeIntRepr intRepr <> "lt" +prettyComparison (Ge intRepr) = prettyMaybeIntRepr intRepr <> "ge" +prettyComparison (Gt intRepr) = prettyMaybeIntRepr intRepr <> "gt" +prettyComparison O = "o" +prettyComparison Uo = "uo" + +prettyMaybeIntRepr :: Maybe IntRepr -> Doc ann +prettyMaybeIntRepr Nothing = mempty +prettyMaybeIntRepr (Just Signed) = pretty 's' +prettyMaybeIntRepr (Just Unsigned) = pretty 'u' + data Arg = Arg AbiTy Val deriving (Show, Eq) + +instance Pretty Arg where + pretty (Arg abiTy val) = pretty abiTy <+> pretty val + +-- * Utilities +-------------- + +-- like 'list' and 'tupled' +braced :: [Doc ann] -> Doc ann +braced = group . encloseSep (flatAlt "{ " "{") + (flatAlt " }" "}") + ", " diff --git a/test/Main.hs b/test/Main.hs index 1ac8a32..6248364 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -47,10 +47,17 @@ goldenTests = testGroup "golden tests" [ FieldZero 16 , FieldExtTy Byte $ Symbol "g" (Just 32) :| [String "foo\nbar\0baz", Const $ CInt True 1] ] - , t "val" [ValConst (CInt False 0), ValTemporary "temporary", ValGlobal "global"] + , t "function" $ FuncDef [Export] (Just $ AbiAggregateTy "t") "f" + (Just "env") [Param (AbiBaseTy Word) "a", Param (AbiBaseTy Double) "b"] Variadic $ + Block "l" [] [] (Ret Nothing) :| [] + , t "val" [valInt 0, ValTemporary "temporary", ValGlobal "global"] , t "jmp" $ Jmp "target" - , t "jnz" $ Jnz (ValConst $ CInt False 0) "target1" "target2" + , t "jnz" $ Jnz (valInt 0) "target1" "target2" , t "ret" $ Ret $ Just $ ValTemporary "x" + , t "phi" $ Phi "a" Word [PhiArg "b" $ valInt 1, PhiArg "c" $ valInt 2] + , t "call" $ Call (Just ("r", AbiBaseTy Word)) (ValGlobal "f") (Just $ valInt 1) + [Arg (AbiBaseTy Word) $ valInt 2, Arg (AbiAggregateTy "t") $ ValTemporary "a"] + [Arg (AbiBaseTy Word) $ valInt 3, Arg (AbiAggregateTy "t1") $ ValTemporary "b"] ] where t name value = goldenVsAction @@ -58,3 +65,7 @@ goldenTests = testGroup "golden tests" ("golden" name <.> "qbe") (pure $ pretty value) (renderStrict . layoutPretty defaultLayoutOptions) + +valInt :: Int -> Val +valInt i | i >= 0 = ValConst $ CInt False $ fromIntegral i + | otherwise = ValConst $ CInt True $ fromIntegral $ negate i