Pretty instance for Instr

golden/inst.qbe

@@ -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 

qbe.cabal

@@ -47,6 +47,7 @@ library
                       GeneralizedNewtypeDeriving
                       FlexibleInstances
                       OverloadedStrings
+                      PatternSynonyms
     build-depends:    base              ^>= 4.16.1.0
                                      || ^>= 4.14
                                      || ^>= 4.15

src/Language/QBE.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
 module Language.QBE where
 
 import Data.Text (Text)
@@ -281,6 +282,8 @@ data Inst
   | Neg Assignment Val
   -- Memory
   | Store ExtTy Val Val
+  -- MAYBE collapse all the Loads in a single Load constructor and just discard
+  -- the intrepr when unused.
   | Load Assignment BaseTy Val -- ^ @\<ident\> =\<baseTy\> load\<baseTy\> \<val\>@
   | LoadW Assignment IntRepr Val -- ^ @\<ident\> =\<baseTy\> load\<intRepr\>w \<val\>@
   | LoadH Assignment IntRepr Val
@@ -296,10 +299,10 @@ data Inst
   | 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
+  | 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
+  | TruncD (Ident 'Temporary) Val
   -- | @stosi@/@stoui@
   | StoI Assignment IntRepr Val
   -- | @dtosi@/@dtoui@
@@ -320,25 +323,36 @@ data Inst
   deriving (Show, Eq)
 
 instance Pretty Inst where
-  pretty (BinaryOp assignment op v1 v2) = undefined
+  pretty (BinaryOp assignment op v1 v2) =
-  pretty (Neg assignment v) = undefined
+    pretty assignment <+> pretty op <+> pretty v1 <> comma <+> pretty v2
-  pretty (Store ty v address) = undefined
+  pretty (Neg assignment v) =
-  pretty (Load  assignment loadTy addr) = undefined
+    pretty assignment <+> "neg" <+> pretty v
-  pretty (LoadW assignment intRepr addr) = undefined
+  pretty (Store ty v address) =
-  pretty (LoadH assignment intRepr addr) = undefined
+    "store" <> pretty ty <+> pretty v <> comma <+> pretty address
-  pretty (LoadB assignment intRepr addr) = undefined
+  pretty (Load  assignment loadTy addr) =
-  pretty (Compare assignment comp compTy v1 v2) = undefined
+    pretty assignment <+> "load" <> pretty loadTy <+> pretty addr
-  pretty (ExtW assignment intRepr v) = undefined
+  pretty (LoadW assignment intRepr addr) =
-  pretty (ExtH assignment intRepr v) = undefined
+    pretty assignment <+> "load" <> pretty intRepr <> pretty 'w' <+> pretty addr
-  pretty (ExtB assignment intRepr v) = undefined
+  pretty (LoadH assignment intRepr addr) =
-  pretty (Exts res v) = undefined
+    pretty assignment <+> "load" <> pretty intRepr <> pretty 'h' <+> pretty addr
-  pretty (Truncd res v) = undefined
+  pretty (LoadB assignment intRepr addr) =
-  pretty (StoI assignment intRepr v) = undefined
+    pretty assignment <+> "load" <> pretty intRepr <> pretty 'b' <+> pretty addr
-  pretty (DtoI assignment intRepr v) = undefined
+  pretty (Compare assignment comp compTy v1 v2) =
-  pretty (WtoF assignment intRepr v) = undefined
+    pretty assignment <+> pretty 'c' <> pretty comp <> pretty compTy <+> pretty v1 <> comma <+> pretty v2
-  pretty (LtoF assignment intRepr v) = undefined
+  pretty (ExtW assignment intRepr v) =
-  pretty (Cast assignment v) = undefined
+    pretty assignment <+> "ext" <> pretty intRepr <> pretty 'w' <+> pretty v
-  pretty (Copy assignment v) = undefined
+  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"
@@ -350,12 +364,16 @@ instance Pretty Inst where
     where
       prettyAssignment (ident, ty) = pretty ident <+> equals <> pretty ty
       variadics' = if null variadics then [] else "..." : fmap pretty variadics
-  pretty (VaStart argList) = undefined
+  pretty (VaStart argList) = "vastart" <+> pretty argList
-  pretty (VaArg assignment argList) = undefined
+  pretty (VaArg assignment argList) = pretty assignment <+> "vaarg" <+> pretty argList
 
 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
 

test/Main.hs

@@ -58,6 +58,30 @@ goldenTests = testGroup "golden tests"
   , 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)
   ]
   where
     t name value = goldenVsAction
@@ -69,3 +93,10 @@ goldenTests = testGroup "golden tests"
 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