qbe (empty) → 1.1.0.0

raw patch · 22 files changed

+936/−0 lines, 22 filesdep +basedep +bytestringdep +deepseq

Dependencies added: base, bytestring, deepseq, filepath, hashable, prettyprinter, qbe, tasty, tasty-silver, text, text-short

Files

• CHANGELOG.md +5/−0
• LICENSE +30/−0
• README.md +53/−0
• golden/call.qbe +1/−0
• golden/const.qbe +1/−0
• golden/data.qbe +3/−0
• golden/function.qbe +5/−0
• golden/hello_world.qbe +9/−0
• golden/ident.qbe +1/−0
• golden/inst.qbe +23/−0
• golden/jmp.qbe +1/−0
• golden/jnz.qbe +1/−0
• golden/linkage.qbe +1/−0
• golden/opaque.qbe +1/−0
• golden/phi.qbe +1/−0
• golden/ret.qbe +1/−0
• golden/type.qbe +1/−0
• golden/typedef.qbe +1/−0
• golden/val.qbe +1/−0
• qbe.cabal +78/−0
• src/Language/QBE.hs +596/−0
• test/Main.hs +122/−0

@@ -0,0 +1,5 @@+# Revision history for qbe-hs++## 1.1.0.0 -- 2022-07-10++* First version.

@@ -0,0 +1,30 @@+Copyright (c) 2022, Francesco Gazzetta++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Francesco Gazzetta nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,53 @@+# qbe-hs++[![Hackage](https://img.shields.io/hackage/v/qbe.svg)](https://hackage.haskell.org/package/qbe)+[![builds.sr.ht status](https://builds.sr.ht/~fgaz/qbe-hs/commits/master.svg)](https://builds.sr.ht/~fgaz/qbe-hs/commits/master?)++Haskell types and prettyprinter for the [IL](https://c9x.me/compile/doc/il.html)+of the [QBE](https://c9x.me/compile/) compiler backend++## Example++```haskell+helloWorld :: Program+helloWorld = Program [] [helloString] [helloMain]+  where+    helloString = DataDef [] "str" Nothing+      [ FieldExtTy Byte $ String "hello world" :| []+      , FieldExtTy Byte $ Const (CInt False 0) :| []+      ]+    helloMain = FuncDef [Export] (Just $ AbiBaseTy Word) "main"+      Nothing [] NoVariadic $+      Block "start"+        []+        [ Call (Just ("r", AbiBaseTy Word)) (ValGlobal "puts")+            Nothing+            [Arg (AbiBaseTy Long) $ ValGlobal "str"]+            []+        ]+        (Ret $ Just $ ValConst $ CInt False 0)+      :| []+```++Gets rendered to++```+data $str =+{b "hello world", b 0}+export+function w $main () {+@start+    %r =w call $puts (l $str)+    ret 0+}+```++## Contributing++You can send patches to my+[public-inbox mailing list](https://lists.sr.ht/~fgaz/public-inbox)+or to any of the contacts listed at [fgaz.me/about](https://fgaz.me/about).+Or you can send a pull request to the+[GitHub mirror](https://github.com/fgaz/qbe-hs).++Issues are tracked at https://todo.sr.ht/~fgaz/qbe-hs

@@ -0,0 +1,1 @@+%r =w call $f (env 1, w 2, :t %a, ..., w 3, :t1 %b)

@@ -0,0 +1,1 @@+[-1, 2, s_0.1, d_-0.2, $global]

@@ -0,0 +1,3 @@+export+data $d = align 8+{z 16, b $g + 32 "foo\nbar\NULbaz" -1}

@@ -0,0 +1,5 @@+export+function :t $f (env %env, w %a, d %b, ...) {+@l+    ret +}

@@ -0,0 +1,9 @@++data $str =+{b "hello world", b 0}+export+function w $main () {+@start+    %r =w call $puts (l $str)+    ret 0+}

@@ -0,0 +1,1 @@+[:aggregateTy, $global, %temporary, @label]

@@ -0,0 +1,23 @@+@l+    %a =w add 1, 2+    %a =w neg 1+    storeb 1, 2+    %a =w loadw 1+    %a =w loadsw 1+    %a =w loadsh 1+    %a =w loadsb 1+    %a =w culew 1, 2+    %a =w extuw 1+    %a =w extuh 1+    %a =w extub 1+    %a =d exts s_1.2+    %a =s truncd d_1.2+    %a =w stoui s_1.2+    %a =w dtoui d_1.2+    %a =w uwtof 1+    %a =w ultof 1+    %a =w cast 1+    %a =w copy 1+    vastart %va+    %a =w vaarg %va+    ret 

@@ -0,0 +1,1 @@+jmp @target

@@ -0,0 +1,1 @@+jnz 0, @target1, @target2

@@ -0,0 +1,1 @@+(export, section secName, section secName flag1 flag2)

@@ -0,0 +1,1 @@+type :t = align 8 {16}

@@ -0,0 +1,1 @@+%a =w phi @b 1, @c 2

@@ -0,0 +1,1 @@+ret %x

@@ -0,0 +1,1 @@+([w, l, s, d], [w, b, h])

@@ -0,0 +1,1 @@+type :t = 8 {h 16, :t1}

@@ -0,0 +1,1 @@+[0, %temporary, $global]

@@ -0,0 +1,78 @@+cabal-version:      3.0+name:               qbe+-- First component matches the QBE major version+version:            1.1.0.0+synopsis:           Types and prettyprinter for the IL of the QBE compiler backend+description:+  This library provides types representing+  the [intermediate language](https://c9x.me/compile/doc/il.html)+  of the [QBE](https://c9x.me/compile/) compiler backend.+  It also provides pretty-printing instances based on+  the [@prettyprinter@](https://hackage.haskell.org/package/prettyprinter)+  library, that emit the textual representation of the IL.+homepage:           https://sr.ht/~fgaz/qbe-hs+bug-reports:        https://todo.sr.ht/~fgaz/qbe-hs+license:            BSD-3-Clause+license-file:       LICENSE+author:             Francesco Gazzetta+maintainer:         Francesco Gazzetta <fgaz@fgaz.me>+copyright:          2022 Francesco Gazzetta+category:           Language+build-type:         Simple+extra-doc-files:    CHANGELOG.md+extra-source-files: README.md golden/*.qbe+tested-with:+    , GHC == 8.10.7+    , GHC == 9.0.2+    , GHC == 9.2.2++source-repository head+    type:     git+    location: https://git.sr.ht/~fgaz/qbe-hs++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+                      PatternSynonyms+    build-depends:    base              ^>= 4.16.1.0+                                     || ^>= 4.14+                                     || ^>= 4.15+                    , text              ^>= 1.2.5+                                     || ^>= 2.0+                    , text-short        ^>= 0.1+                    , bytestring        ^>= 0.11.3+                    , hashable          ^>= 1.4.0+                    , deepseq           ^>= 1.4.4+                    , prettyprinter     ^>= 1.7.1+    hs-source-dirs:   src++test-suite golden+    import:           common+    type:             exitcode-stdio-1.0+    hs-source-dirs:   test+    main-is:          Main.hs+    build-depends:    base+                    , qbe+                    , prettyprinter+                    , filepath          ^>= 1.4.2.2+                    , tasty             ^>= 1.4.2.3+                    , tasty-silver      ^>= 3.3.1.1+    other-extensions: TypeApplications+                      OverloadedStrings+                      DataKinds+                      ExistentialQuantification

@@ -0,0 +1,596 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-|+Module      : Language.QBE+Description : Types and Pretty instances for the QBE IL+Copyright   : (c) Francesco Gazzetta, 2022+License     : BSD-3-Clause+Maintainer  : Francesco Gazzetta <fgaz@fgaz.me>++This module contains datatypes representing the various structures of+the [intermediate language](https://c9x.me/compile/doc/il.html)+of the [QBE](https://c9x.me/compile/) compiler backend.++All datatypes also have 'Pretty' instances from+the [@prettyprinter@](https://hackage.haskell.org/package/prettyprinter)+library.+You can render QBE IL source files, or any part of them, with something like:++> render :: Pretty a => a -> Text+> render = renderStrict . layoutPretty defaultLayoutOptions . pretty++>>> render $ Ret $ Just $ ValTemporary "a"+"ret %a"+>>> Text.putStrLn $ render $ Program [] [] [FuncDef [] Nothing "main" …+function w $main () {+@start+⋮+-}+module Language.QBE+(+-- * Identifiers+RawIdent+, Sigil(..)+, Ident(..)+-- * Types+, BaseTy(..)+, ExtTy(..)+-- * Constants+, Const(..)+-- * Linkage+, Linkage(..)+-- * Definitions+, Alignment+, Size+, Amount+-- ** Aggregate types+, TypeDef(..)+, SubTy(..)+-- ** Data+, DataDef(..)+, DataItem(..)+, Field(..)+-- ** Functions+, FuncDef(..)+, AbiTy(..)+, Param(..)+, Variadic(..)+, prettyVariadic+-- * Control+, Val(..)+, Block(..)+, Jump(..)+-- * Instructions+, Phi(..)+, PhiArg(..)+, Inst(..)+, Assignment(..)+, pattern (:=)+, IntRepr(..)+, BinaryOp(..)+, Comparison(..)+, Arg(..)+-- * Program+, Program(..)+) 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, toList)+import Data.Maybe (maybeToList)+import Prettyprinter+  ( Pretty(pretty), Doc, (<+>), vsep, hsep, hang, punctuate, group, flatAlt+  , space, encloseSep, tupled, comma, equals, braces, lbrace, rbrace )+-- Instances+import Data.Hashable (Hashable)+import Control.DeepSeq (NFData)+import Data.String (IsString)++-- * Identifiers+----------------++-- | A raw identifier string, with no sigil information attached+type RawIdent = ShortText++-- | Sigils are used to differentiate the verious types of 'Ident'ifier.+data Sigil+  = AggregateTy -- ^ @:@+  | Global -- ^ @$@+  | Temporary -- ^ @%@+  | Label -- ^ @\@@+  deriving (Show, Eq)++-- | 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"+-- <interactive>: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, 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+----------++-- | Base types+data BaseTy+  = Word -- ^ @w@+  | Long -- ^ @l@+  | Single -- ^ @s@+  | Double -- ^ @d@+  deriving (Show, Eq)++instance Pretty BaseTy where+  pretty Word   = pretty 'w'+  pretty Long   = pretty 'l'+  pretty Single = pretty 's'+  pretty Double = pretty 'd'++-- | Extended types+data ExtTy+  = BaseTy BaseTy+  | Byte -- ^ @b@+  | HalfWord -- ^ @h@+  deriving (Show, Eq)++instance Pretty ExtTy where+  pretty (BaseTy baseTy) = pretty baseTy+  pretty Byte = pretty 'b'+  pretty HalfWord = pretty 'h'++-- * Constants+--------------++-- | Constant/immediate+data Const+  -- MAYBE just use a signed type+  = CInt Bool Word64 -- ^ 64 bit integer. The 'Bool' is whether to negate.+  | CSingle Float -- ^ Single-precision float+  | CDouble Double -- ^ Double-precision float+  | CGlobal (Ident 'Global) -- ^ Global symbol+  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+------------++data Linkage+  = Export -- ^ Marks the defined item as visible outside the current file's scope+  | Section ShortText (Maybe Text) -- ^ Section name, with optional linker flags+  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+----------------++type Alignment = Word64+type Size = Word64+type Amount = Word64++-- ** Aggregate types+---------------------++-- | Aggregate type+data TypeDef+  = TypeDef (Ident 'AggregateTy) (Maybe Alignment) [(SubTy, Maybe Amount)]+  | 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+    <+> braced (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)++-- | A type that can be part of an aggregate type+data SubTy+  = SubExtTy ExtTy+  | SubAggregateTy (Ident 'AggregateTy)+  deriving (Show, Eq)++instance Pretty SubTy where+  pretty (SubExtTy extTy) = pretty extTy+  pretty (SubAggregateTy ident) = pretty ident++-- ** Data+----------++-- | Global object definition+data DataDef = DataDef [Linkage] (Ident 'Global) (Maybe Alignment) [Field]+  deriving (Show, Eq)++instance Pretty DataDef where+  pretty (DataDef linkage ident alignment fields) = vsep+    [ vsep $ pretty <$> linkage+    , hsep $ ("data" <+> pretty ident <+> equals)+           : maybeToList (("align" <+>) . pretty <$> alignment)+    , braced (pretty <$> fields)+    ]++data DataItem+  = Symbol (Ident 'Global) (Maybe Alignment)+  | String ByteString+  | Const Const+  deriving (Show, Eq)++instance Pretty DataItem where+  pretty (Symbol ident alignment) =+    hsep $ pretty ident : maybeToList ((pretty '+' <+>) . pretty <$> alignment)+  pretty (String bs) = pretty $ show bs -- HACK: hoping that the escape sequences are the same...+  pretty (Const c) = pretty c++data Field+  = FieldExtTy ExtTy (NonEmpty DataItem)+  | FieldZero Size+  deriving (Show, Eq)++instance Pretty Field where+  pretty (FieldExtTy extTy items) = pretty extTy <+> hsep (toList $ pretty <$> items)+  pretty (FieldZero size) = pretty 'z' <+> pretty size++-- ** Functions+---------------++-- TODO use record syntax on long types like this one+-- | Function definition. The 'Maybe (Ident \'Temporary)' is the environment+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)+      ) <+> lbrace+    , vsep $ toList $ pretty <$> blocks+    , rbrace+    ]++data AbiTy = AbiBaseTy BaseTy | AbiAggregateTy (Ident 'AggregateTy)+  deriving (Show, Eq)++instance Pretty AbiTy where+  pretty (AbiBaseTy baseTy) = pretty baseTy+  pretty (AbiAggregateTy ident) = pretty ident++-- | Function parameter+data Param = Param AbiTy (Ident 'Temporary)+  deriving (Show, Eq)++instance Pretty Param where+  pretty (Param abiTy ident) = pretty abiTy <+> pretty ident++-- | Indicates the presence or absence of a variadic marker+data Variadic = Variadic | NoVariadic+  deriving (Show, Eq)++-- | 'Variadic' → @Just "..."@+-- 'NoVariadic' → @Nothing@+prettyVariadic :: Variadic -> Maybe (Doc a)+prettyVariadic Variadic = Just "..."+prettyVariadic NoVariadic = Nothing++-- * Control+------------++-- | Value, either an immediate or a global or temporary identifier.+data Val+  = ValConst Const+  | ValTemporary (Ident 'Temporary)+  | 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++-- | Block of instructions beginning with a label and ending with a jump+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]+    ]++-- | Jump instructions+data Jump+  = Jmp (Ident 'Label) -- ^ Unconditional jump+  | Jnz Val (Ident 'Label) (Ident 'Label) -- ^ Conditional jump+  | Ret (Maybe Val) -- ^ Function return+  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+-----------------++-- MAYBE change [PhiArg] to Map (Ident 'Label) Val+-- | Phi instruction+data Phi = Phi Assignment [PhiArg]+  deriving (Show, Eq)++instance Pretty Phi where+  pretty (Phi assignment args) =+    pretty assignment <+> "phi" <+> hsep (punctuate comma $ pretty <$> args)++-- | Phi instruction argument, associating a 'Val' to a 'Label'+data PhiArg = PhiArg (Ident 'Label) Val+  deriving (Show, Eq)++instance Pretty PhiArg where+  pretty (PhiArg label val) = pretty label <+> pretty val++-- | Instruction+data Inst+  -- Arithmetic and Bits+  = BinaryOp Assignment BinaryOp Val Val -- ^ Binary arithmetic and bit operations+  | Neg Assignment Val -- ^ @neg@+  -- Memory+  -- | @stored@/@stores@/@storel@/@storew@/@storeh@/@storeb@+  | Store ExtTy Val Val+  -- MAYBE collapse all the Loads in a single Load constructor and just discard+  -- the intrepr when unused.+  -- | @loadw@/@loadl@/@loads@/@loadd@+  | Load Assignment BaseTy Val+  -- | @loadsw@/@loaduw@+  | LoadW Assignment IntRepr Val+  -- | @loadsh@/@loaduh@+  | LoadH Assignment IntRepr Val+  -- | @loadsb@/@loadub@+  | LoadB Assignment IntRepr Val+  -- Comparisons+  | Compare Assignment Comparison BaseTy Val Val+  -- Conversions+  -- | @extsw@/@extuw@+  | ExtW Assignment IntRepr Val+  -- | @extsh@/@extuh@+  | ExtH Assignment IntRepr Val+  -- | @extsb@/@extub@+  | ExtB Assignment IntRepr Val+  -- | @exts@. There is only one possible instruction type, so there's+  -- only an 'Ident' instead of a full 'Assignment'+  | ExtS (Ident 'Temporary) Val+  -- | @truncd@. There is only one possible instruction type, so there's+  -- only an 'Ident' instead of a full 'Assignment'+  | TruncD (Ident 'Temporary) Val+  -- | @stosi@/@stoui@+  | StoI Assignment IntRepr Val+  -- | @dtosi@/@dtoui@+  | DtoI Assignment IntRepr Val+  -- | @swtof@/@uwtof@+  | WtoF Assignment IntRepr Val+  -- | @sltof@/@ultof@+  | LtoF Assignment IntRepr Val+  -- Cast and Copy+  -- | @cast@+  | Cast Assignment Val+  -- | @copy@+  | Copy Assignment Val+  -- Calls+  -- | @call@. The fields are: assignment, function name, environment, arguments, variadic arguments+  | Call (Maybe (Ident 'Temporary, AbiTy)) Val (Maybe Val) [Arg] [Arg]+  -- Variadic+  -- | @vastart@, initializes a variable argument list+  | VaStart (Ident 'Temporary)+  -- | @vaarg@, fetches the next argument from a variable argument list+  | VaArg Assignment (Ident 'Temporary)+  deriving (Show, Eq)++instance Pretty Inst where+  pretty (BinaryOp assignment op v1 v2) =+    pretty assignment <+> pretty op <+> pretty v1 <> comma <+> pretty v2+  pretty (Neg assignment v) =+    pretty assignment <+> "neg" <+> pretty v+  pretty (Store ty v address) =+    "store" <> pretty ty <+> pretty v <> comma <+> pretty address+  pretty (Load  assignment loadTy addr) =+    pretty assignment <+> "load" <> pretty loadTy <+> pretty addr+  pretty (LoadW assignment intRepr addr) =+    pretty assignment <+> "load" <> pretty intRepr <> pretty 'w' <+> pretty addr+  pretty (LoadH assignment intRepr addr) =+    pretty assignment <+> "load" <> pretty intRepr <> pretty 'h' <+> pretty addr+  pretty (LoadB assignment intRepr addr) =+    pretty assignment <+> "load" <> pretty intRepr <> pretty 'b' <+> pretty addr+  pretty (Compare assignment comp compTy v1 v2) =+    pretty assignment <+> pretty 'c' <> pretty comp <> pretty compTy <+> pretty v1 <> comma <+> pretty v2+  pretty (ExtW assignment intRepr v) =+    pretty assignment <+> "ext" <> pretty intRepr <> pretty 'w' <+> pretty v+  pretty (ExtH assignment intRepr v) =+    pretty assignment <+> "ext" <> pretty intRepr <> pretty 'h' <+> pretty v+  pretty (ExtB assignment intRepr v) =+    pretty assignment <+> "ext" <> pretty intRepr <> pretty 'b' <+> pretty v+  pretty (ExtS res v) = pretty res <+> equals <> pretty 'd' <+> "exts" <+> pretty v+  pretty (TruncD res v) = pretty res <+> equals <> pretty 's' <+> "truncd" <+> pretty v+  pretty (StoI assignment intRepr v) = pretty assignment <+> "sto" <> pretty intRepr <> pretty 'i' <+> pretty v+  pretty (DtoI assignment intRepr v) = pretty assignment <+> "dto" <> pretty intRepr <> pretty 'i' <+> pretty v+  pretty (WtoF assignment intRepr v) = pretty assignment <+> pretty intRepr <> "wtof" <+> pretty v+  pretty (LtoF assignment intRepr v) = pretty assignment <+> pretty intRepr <> "ltof" <+> pretty v+  pretty (Cast assignment v) = pretty assignment <+> "cast" <+> pretty v+  pretty (Copy assignment v) = pretty assignment <+> "copy" <+> pretty v+  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) = "vastart" <+> pretty argList+  pretty (VaArg assignment argList) = pretty assignment <+> "vaarg" <+> pretty argList++-- | Represents the @%x =t@ part of an instruction.+data Assignment = Assignment (Ident 'Temporary) BaseTy+  deriving (Show, Eq)++-- | Infix synonym of 'Assignment'+pattern (:=) :: Ident 'Temporary -> BaseTy -> Assignment+pattern (:=) ident ty = Assignment ident ty++instance Pretty Assignment where+  pretty (Assignment ident ty) = pretty ident <+> equals <> pretty ty++-- | Integer representation+data IntRepr = Signed | Unsigned+  deriving (Show, Eq)++-- | Binary arithmetic and bit operations+data BinaryOp+  -- | @add@+  = Add+  -- | @sub@+  | Sub+  -- | @div@/@udiv@. @Div Signed@ gets translated to @div@, so it will work+  -- also on floats+  | Div IntRepr+  -- | @mul@+  | Mul+  -- | @rem@/@urem@+  | Rem IntRepr+  -- | @or@+  | Or+  -- | @xor@+  | Xor+  -- | @and@+  | And+  -- | @sar@+  | Sar+  -- | @shr@+  | Shr+  -- | @shl@+  | 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+-- (@sle@, @ule@, @slt@, @ult@...)+data Comparison+  -- Universal comparison+  = Eq -- ^ equality+  | Ne -- ^ inequality+  | Le (Maybe IntRepr) -- ^ lower or equal+  | Lt (Maybe IntRepr) -- ^ lower+  | Ge (Maybe IntRepr) -- ^ greater or equal+  | Gt (Maybe IntRepr) -- ^ greater+  -- Floating point only comparison+  | O -- ^ ordered (no operand is a NaN) (floating point only)+  | Uo -- ^ unordered (at least one operand is a NaN) (floating point only)+  deriving (Show, Eq)++instance Pretty Comparison where+  pretty Eq = "eq"+  pretty Ne = "ne"+  pretty (Le intRepr) = pretty intRepr <> "le"+  pretty (Lt intRepr) = pretty intRepr <> "lt"+  pretty (Ge intRepr) = pretty intRepr <> "ge"+  pretty (Gt intRepr) = pretty intRepr <> "gt"+  pretty O = "o"+  pretty Uo = "uo"++instance Pretty IntRepr where+  pretty Signed = pretty 's'+  pretty Unsigned = pretty 'u'++-- | Function argument+data Arg = Arg AbiTy Val+  deriving (Show, Eq)++instance Pretty Arg where+  pretty (Arg abiTy val) = pretty abiTy <+> pretty val++-- * Program+------------++-- | Datatypre representing a QBE IL source file+data Program = Program [TypeDef] [DataDef] [FuncDef]+  deriving (Show, Eq)++instance Pretty Program where+  pretty (Program typeDefs dataDefs funcDefs) = vsep $ concat+    [ pretty <$> typeDefs+    , pretty <$> dataDefs+    , pretty <$> funcDefs+    ]++-- * Utilities+--------------++-- | Like 'list' and 'tupled', but with braces+braced :: [Doc ann] -> Doc ann+braced = group . encloseSep (flatAlt "{ " "{")+                            (flatAlt " }" "}")+                            ", "

@@ -0,0 +1,122 @@+{-# 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)+import Data.List.NonEmpty (NonEmpty((:|)))+++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 "global"+      ]+  , t "linkage" (Export, Section "secName" Nothing, Section "secName" $ Just "flag1 flag2")+  , t "typedef" $ TypeDef "t" (Just 8)+      [ (SubExtTy HalfWord, Just 16)+      , (SubAggregateTy "t1", Nothing)+      ]+  , t "opaque" $ Opaque "t" 8 16+  , t "data" $ DataDef [Export] "d" (Just 8)+      [ FieldZero 16+      , FieldExtTy Byte $ Symbol "g" (Just 32) :| [String "foo\nbar\0baz", Const $ CInt True 1]+      ]+  , 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 (valInt 0) "target1" "target2"+  , t "ret" $ Ret $ Just $ ValTemporary "x"+  , t "phi" $ Phi (Assignment "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"]+  , t "inst" $ Block "l" []+      [ BinaryOp assignA Add one two+      , Neg assignA one+      , Store Byte one two+      , Load assignA Word one+      , LoadW assignA Signed one+      , LoadH assignA Signed one+      , LoadB assignA Signed one+      , Compare assignA (Le $ Just Unsigned) Word one two+      , ExtW assignA Unsigned one+      , ExtH assignA Unsigned one+      , ExtB assignA Unsigned one+      , ExtS "a" $ ValConst $ CSingle 1.2+      , TruncD "a" $ ValConst $ CDouble 1.2+      , StoI assignA Unsigned $ ValConst $ CSingle 1.2+      , DtoI assignA Unsigned $ ValConst $ CDouble 1.2+      , WtoF assignA Unsigned one+      , LtoF assignA Unsigned one+      , Cast assignA one+      , Copy assignA one+      , VaStart "va"+      , VaArg assignA "va"+      ]+      (Ret Nothing)+  , t "hello_world" helloWorld+  ]+  where+    t name value = goldenVsAction+      name+      ("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++one, two :: Val+one = valInt 1+two = valInt 2++assignA :: Assignment+assignA = Assignment "a" Word++helloWorld :: Program+helloWorld = Program [] [helloString] [helloMain]+  where+    helloString = DataDef [] "str" Nothing+      [ FieldExtTy Byte $ String "hello world" :| []+      , FieldExtTy Byte $ Const (CInt False 0) :| []+      ]+    helloMain = FuncDef [Export] (Just $ AbiBaseTy Word) "main"+      Nothing [] NoVariadic $+      Block "start"+        []+        [ Call (Just ("r", AbiBaseTy Word)) (ValGlobal "puts")+            Nothing+            [Arg (AbiBaseTy Long) $ ValGlobal "str"]+            []+        ]+        (Ret $ Just $ ValConst $ CInt False 0)+      :| []