Pretty instance for Instr
This commit is contained in:
Francesco Gazzetta
23
golden/inst.qbe
Normal file
23
golden/inst.qbe
Normal file
@@ -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
|
||||
@@ -47,6 +47,7 @@ library
|
||||
GeneralizedNewtypeDeriving
|
||||
FlexibleInstances
|
||||
OverloadedStrings
|
||||
PatternSynonyms
|
||||
build-depends: base ^>= 4.16.1.0
|
||||
|| ^>= 4.14
|
||||
|| ^>= 4.15
|
||||
|
||||
@@ -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 (Neg assignment v) = undefined
|
||||
pretty (Store ty v address) = undefined
|
||||
pretty (Load assignment loadTy addr) = undefined
|
||||
pretty (LoadW assignment intRepr addr) = undefined
|
||||
pretty (LoadH assignment intRepr addr) = undefined
|
||||
pretty (LoadB assignment intRepr addr) = undefined
|
||||
pretty (Compare assignment comp compTy v1 v2) = undefined
|
||||
pretty (ExtW assignment intRepr v) = undefined
|
||||
pretty (ExtH assignment intRepr v) = undefined
|
||||
pretty (ExtB assignment intRepr v) = undefined
|
||||
pretty (Exts res v) = undefined
|
||||
pretty (Truncd res v) = undefined
|
||||
pretty (StoI assignment intRepr v) = undefined
|
||||
pretty (DtoI assignment intRepr v) = undefined
|
||||
pretty (WtoF assignment intRepr v) = undefined
|
||||
pretty (LtoF assignment intRepr v) = undefined
|
||||
pretty (Cast assignment v) = undefined
|
||||
pretty (Copy assignment v) = undefined
|
||||
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"
|
||||
@@ -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 (VaArg assignment argList) = undefined
|
||||
pretty (VaStart argList) = "vastart" <+> pretty argList
|
||||
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
|
||||
|
||||
|
||||
31
test/Main.hs
31
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
|
||||
|
||||
Reference in New Issue
Block a user