diff --git a/.gitignore b/.gitignore index 3323531..7263372 100644 --- a/.gitignore +++ b/.gitignore @@ -5,3 +5,4 @@ dist-newstyle *.o *.hi .ghc.environment.* +*.tix diff --git a/golden/const.qbe b/golden/const.qbe new file mode 100644 index 0000000..d7d547d --- /dev/null +++ b/golden/const.qbe @@ -0,0 +1 @@ +[-1, 2, s_0.1, d_-0.2, $global] \ No newline at end of file diff --git a/golden/ident.qbe b/golden/ident.qbe new file mode 100644 index 0000000..b931510 --- /dev/null +++ b/golden/ident.qbe @@ -0,0 +1 @@ +[:aggregateTy, $global, %temporary, @label] \ No newline at end of file diff --git a/golden/jmp.qbe b/golden/jmp.qbe new file mode 100644 index 0000000..281fd63 --- /dev/null +++ b/golden/jmp.qbe @@ -0,0 +1 @@ +jmp @target \ No newline at end of file diff --git a/golden/jnz.qbe b/golden/jnz.qbe new file mode 100644 index 0000000..0c212d0 --- /dev/null +++ b/golden/jnz.qbe @@ -0,0 +1 @@ +jnz 0, @target1, @target2 \ No newline at end of file diff --git a/golden/linkage.qbe b/golden/linkage.qbe new file mode 100644 index 0000000..92dc84c --- /dev/null +++ b/golden/linkage.qbe @@ -0,0 +1 @@ +(export, section secName, section secName flag1 flag2) \ No newline at end of file diff --git a/golden/opaque.qbe b/golden/opaque.qbe new file mode 100644 index 0000000..3c976d3 --- /dev/null +++ b/golden/opaque.qbe @@ -0,0 +1 @@ +type :t = align 8 {16} \ No newline at end of file diff --git a/golden/ret.qbe b/golden/ret.qbe new file mode 100644 index 0000000..0493486 --- /dev/null +++ b/golden/ret.qbe @@ -0,0 +1 @@ +ret %x \ No newline at end of file diff --git a/golden/type.qbe b/golden/type.qbe new file mode 100644 index 0000000..80de7f5 --- /dev/null +++ b/golden/type.qbe @@ -0,0 +1 @@ +([w, l, s, d], [w, b, h]) \ No newline at end of file diff --git a/golden/typedef.qbe b/golden/typedef.qbe new file mode 100644 index 0000000..7f4d820 --- /dev/null +++ b/golden/typedef.qbe @@ -0,0 +1 @@ +type :t = 8 {h 16, :t1} \ No newline at end of file diff --git a/golden/val.qbe b/golden/val.qbe new file mode 100644 index 0000000..452d108 --- /dev/null +++ b/golden/val.qbe @@ -0,0 +1 @@ +[0, %temporary, $global] \ No newline at end of file diff --git a/qbe.cabal b/qbe.cabal index aad248b..ae04710 100644 --- a/qbe.cabal +++ b/qbe.cabal @@ -14,12 +14,24 @@ build-type: Simple extra-doc-files: CHANGELOG.md -- extra-source-files: +common common + ghc-options: -Wall + -Wunused-packages + -Wmissing-home-modules + -Wredundant-constraints + -Wincomplete-uni-patterns + -Wincomplete-record-updates + default-language: Haskell2010 + library + import: common exposed-modules: Language.QBE -- other-modules: other-extensions: DataKinds KindSignatures GeneralizedNewtypeDeriving + FlexibleInstances + OverloadedStrings build-depends: base ^>=4.16.1.0 , text , text-short @@ -27,6 +39,21 @@ library , hashable , deepseq , binary + , prettyprinter hs-source-dirs: src - ghc-options: -Wall - default-language: Haskell2010 + +test-suite golden + import: common + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: base + , qbe + , filepath + , tasty + , tasty-silver + , prettyprinter + other-extensions: TypeApplications + OverloadedStrings + DataKinds + ExistentialQuantification diff --git a/src/Language/QBE.hs b/src/Language/QBE.hs index 18cc7d3..c709af0 100644 --- a/src/Language/QBE.hs +++ b/src/Language/QBE.hs @@ -1,13 +1,19 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} module Language.QBE where import Data.Text (Text) import Data.Text.Short (ShortText) +import qualified Data.Text.Short as TS import Data.ByteString (ByteString) import Data.Word (Word64) import Data.List.NonEmpty (NonEmpty) +import Prettyprinter + ( Pretty(pretty), (<+>) + , space, encloseSep, lbrace, rbrace, comma, equals, braces ) -- Instances import Data.Hashable (Hashable) import Control.DeepSeq (NFData) @@ -28,18 +34,52 @@ data Sigil -- | QBE identifiers. The sigil is represented at the type level, so that -- mixing incompatible identifiers is impossible. +-- +-- >>> :set -XOverloadedStrings +-- >>> :set -XDataKinds +-- >>> :set -XTypeApplications +-- >>> pretty $ Jmp $ Ident @'Label "a" +-- jmp @a +-- >>> pretty $ Jmp $ Ident @'Global "a" +-- :5:16: error: +-- • Couldn't match type ‘'Global’ with ‘'Label’ +-- Expected: Ident 'Label +-- Actual: Ident 'Global +-- • In the second argument of ‘($)’, namely ‘Ident @'Global "a"’ +-- In the second argument of ‘($)’, namely ‘Jmp $ Ident @'Global "a"’ +-- In the expression: pretty $ Jmp $ Ident @'Global "a" newtype Ident (t :: Sigil) = Ident RawIdent deriving (Show, Eq, Ord, IsString, Binary, NFData, Hashable) +instance Pretty (Ident 'AggregateTy) where + pretty (Ident raw) = pretty ':' <> pretty (TS.toText raw) +instance Pretty (Ident 'Global) where + pretty (Ident raw) = pretty '$' <> pretty (TS.toText raw) +instance Pretty (Ident 'Temporary) where + pretty (Ident raw) = pretty '%' <> pretty (TS.toText raw) +instance Pretty (Ident 'Label) where + pretty (Ident raw) = pretty '@' <> pretty (TS.toText raw) + -- * Types ---------- data BaseTy = Word | Long | Single | Double deriving (Show, Eq) +instance Pretty BaseTy where + pretty Word = pretty 'w' + pretty Long = pretty 'l' + pretty Single = pretty 's' + pretty Double = pretty 'd' + data ExtTy = BaseTy BaseTy | Byte | HalfWord deriving (Show, Eq) +instance Pretty ExtTy where + pretty (BaseTy baseTy) = pretty baseTy + pretty Byte = pretty 'b' + pretty HalfWord = pretty 'h' + -- * Constants -------------- @@ -50,6 +90,13 @@ data Const | CGlobal (Ident 'Global) deriving (Show, Eq) +instance Pretty Const where + pretty (CInt negative int) | negative = pretty '-' <> pretty int + | otherwise = pretty int + pretty (CSingle float) = "s_" <> pretty float + pretty (CDouble double) = "d_" <> pretty double + pretty (CGlobal ident) = pretty ident + -- * Linkage ------------ @@ -58,6 +105,12 @@ data Linkage | Section ShortText (Maybe Text) deriving (Show, Eq) +instance Pretty Linkage where + pretty Export = "export" + pretty (Section secName Nothing) = "section" <+> pretty (TS.toText secName) + pretty (Section secName (Just secFlags)) = + "section" <+> pretty (TS.toText secName) <+> pretty secFlags + -- * Definitions ---------------- @@ -73,11 +126,27 @@ data Typedef | Opaque (Ident 'AggregateTy) Alignment Size deriving (Show, Eq) +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) + where + prettyItem (subTy, Nothing ) = pretty subTy + prettyItem (subTy, Just amount) = pretty subTy <+> pretty amount + pretty (Opaque ident alignment size) = + "type" <+> pretty ident <+> equals + <+> "align" <+> pretty alignment <+> braces (pretty size) + data SubTy - = SubExtTy + = SubExtTy ExtTy | SubAggregateTy (Ident 'AggregateTy) deriving (Show, Eq) +instance Pretty SubTy where + pretty (SubExtTy extTy) = pretty extTy + pretty (SubAggregateTy ident) = pretty ident + -- ** Data ---------- @@ -120,6 +189,11 @@ data Val | ValGlobal (Ident 'Global) deriving (Show, Eq) +instance Pretty Val where + pretty (ValConst c) = pretty c + pretty (ValTemporary ident) = pretty ident + pretty (ValGlobal ident) = pretty ident + data Block = Block (Ident 'Label) [Phi] [Inst] Jump deriving (Show, Eq) @@ -129,6 +203,14 @@ data Jump | Ret (Maybe Val) deriving (Show, Eq) +instance Pretty Jump where + pretty (Jmp ident) = "jmp" <+> pretty ident + pretty (Jnz val label1 label2) = + "jnz" <+> pretty val <> comma + <+> pretty label1 <> comma + <+> pretty label2 + pretty (Ret val) = "ret" <+> pretty val + -- * Instructions ----------------- diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 index 0000000..1f03c94 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExistentialQuantification #-} +module Main (main) where + +import Language.QBE + +import Test.Tasty (TestTree, defaultMain, testGroup) +import Test.Tasty.Silver (goldenVsAction) +import System.FilePath ((), (<.>)) +import Prettyprinter (Pretty(pretty), layoutPretty, defaultLayoutOptions) +import Prettyprinter.Render.Text (renderStrict) + + +data P = forall a. Pretty a => P a +instance Pretty P where + pretty (P x) = pretty x + +main :: IO () +main = defaultMain goldenTests + +goldenTests :: TestTree +goldenTests = testGroup "golden tests" + [ t "ident" + [ P $ Ident @'AggregateTy "aggregateTy" + , P $ Ident @'Global "global" + , P $ Ident @'Temporary "temporary" + , P $ Ident @'Label "label" + ] + , t "type" ([Word, Long, Single, Double], [BaseTy Word, Byte, HalfWord]) + , t "const" + [ CInt True 1 + , CInt False 2 + , CSingle 0.1 + , CDouble (-0.2) + , CGlobal $ Ident "global" + ] + , t "linkage" (Export, Section "secName" Nothing, Section "secName" $ Just "flag1 flag2") + , t "typedef" $ Typedef (Ident "t") (Just 8) + [ (SubExtTy HalfWord, Just 16) + , (SubAggregateTy (Ident "t1"), Nothing) + ] + , t "opaque" $ Opaque (Ident "t") 8 16 + , t "val" [ValConst (CInt False 0), ValTemporary $ Ident "temporary", ValGlobal $ Ident "global"] + , t "jmp" $ Jmp $ Ident "target" + , t "jnz" $ Jnz (ValConst $ CInt False 0) (Ident "target1") (Ident "target2") + , t "ret" $ Ret $ Just $ ValTemporary $ Ident "x" + ] + where + t name value = goldenVsAction + name + ("golden" name <.> "qbe") + (pure $ pretty value) + (renderStrict . layoutPretty defaultLayoutOptions)