diff --git a/golden/inst.qbe b/golden/inst.qbe new file mode 100644 index 0000000..4ddbf16 --- /dev/null +++ b/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 \ No newline at end of file diff --git a/qbe.cabal b/qbe.cabal index 667045e..4168bb2 100644 --- a/qbe.cabal +++ b/qbe.cabal @@ -47,6 +47,7 @@ library GeneralizedNewtypeDeriving FlexibleInstances OverloadedStrings + PatternSynonyms build-depends: base ^>= 4.16.1.0 || ^>= 4.14 || ^>= 4.15 diff --git a/src/Language/QBE.hs b/src/Language/QBE.hs index 80a80ad..cd252ac 100644 --- a/src/Language/QBE.hs +++ b/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 -- ^ @\ =\ load\ \@ | LoadW Assignment IntRepr Val -- ^ @\ =\ load\w \@ | 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 diff --git a/test/Main.hs b/test/Main.hs index d071ace..3a7610c 100644 --- a/test/Main.hs +++ b/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