@@ -4,6 +4,9 @@
{- # LANGUAGE FlexibleInstances # -}
{- # LANGUAGE OverloadedStrings # -}
{- # LANGUAGE PatternSynonyms # -}
{- # LANGUAGE DeriveDataTypeable # -}
{- # LANGUAGE GADTs # -}
{- # LANGUAGE DuplicateRecordFields, NoFieldSelectors # -}
{- |
Module : Language.QBE
Description : Types and Pretty instances for the QBE IL
@@ -82,16 +85,21 @@ import Data.Text (Text)
import Data.Text.Short ( ShortText )
import qualified Data.Text.Short as TS
import Data.ByteString ( ByteString )
import qualified Data.ByteString as BS
import Data.ByteString.Internal ( w2c )
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 )
, space , encloseSep , tupled , comma , equals , braces , lbrace , rbrace , enclose )
-- Instances
import Data.Hashable ( Hashable )
import Control.DeepSeq ( NFData )
import Data.String ( IsString )
import Data.Data ( Data )
import Numeric ( showOct )
import Data.Char ( isPrint , isAscii )
-- * Identifiers
----------------
@@ -100,12 +108,12 @@ import Data.String (IsString)
type RawIdent = ShortText
-- | Sigils are used to differentiate the verious types of 'Ident'ifier.
data Sigil
= AggregateTy -- ^ @:@
| Global -- ^ @$@
| Temporary -- ^ @%@
| Label -- ^ @\@@
deriving ( Show , Eq )
data Sigil where
AggregateTy :: Sigil
Global :: Sigil
Temporary :: Sigil
Label :: Sigil
deriving ( Show , Eq , Data
-- | QBE identifiers. The sigil is represented at the type level, so that
-- mixing incompatible identifiers is impossible.
@@ -124,7 +132,7 @@ data Sigil
-- In the second argument of ‘ ’ ‘ ’
-- In the expression: pretty $ Jmp $ Ident @'Global "a"
newtype Ident ( t :: Sigil ) = Ident RawIdent
deriving ( Show , Eq , Ord , IsString , NFData , Hashable )
deriving ( Show , Eq , Ord , IsString , NFData , Hashable , Data
instance Pretty ( Ident 'AggregateTy ) where
pretty ( Ident raw ) = pretty ':' <> pretty ( TS . toText raw )
@@ -144,7 +152,7 @@ data BaseTy
| Long -- ^ @l@
| Single -- ^ @s@
| Double -- ^ @d@
deriving ( Show , Eq )
deriving ( Show , Eq , Data
instance Pretty BaseTy where
pretty Word = pretty 'w'
@@ -157,7 +165,7 @@ data ExtTy
= BaseTy BaseTy
| Byte -- ^ @b@
| HalfWord -- ^ @h@
deriving ( Show , Eq )
deriving ( Show , Eq , Data
instance Pretty ExtTy where
pretty ( BaseTy baseTy ) = pretty baseTy
@@ -170,15 +178,14 @@ instance Pretty ExtTy where
-- | Constant/immediate
data Const
-- MAYBE just use a signed type
= CInt Bool Word64 -- ^ 64 bit integer. The 'Bool' is whether to negate.
= CInt Integer -- ^ Integer
| CSingle Float -- ^ Single-precision float
| CDouble Double -- ^ Double-precision float
| CGlobal ( Ident 'Global ) -- ^ Global symbol
deriving ( Show , Eq )
deriving ( Show , Eq , Data
instance Pretty Const where
pretty ( CInt negative int ) | negative = pretty '-' <> pretty int
| otherwise = pretty int
pretty ( CInt int ) = pretty int
pretty ( CSingle float ) = " s_ " <> pretty float
pretty ( CDouble double ) = " d_ " <> pretty double
pretty ( CGlobal ident ) = pretty ident
@@ -189,7 +196,7 @@ instance Pretty Const where
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 )
deriving ( Show , Eq , Data
instance Pretty Linkage where
pretty Export = " export "
@@ -211,7 +218,7 @@ type Amount = Word64
data TypeDef
= TypeDef ( Ident 'AggregateTy ) ( Maybe Alignment ) [ ( SubTy , Maybe Amount ) ]
| Opaque ( Ident 'AggregateTy ) Alignment Size
deriving ( Show , Eq )
deriving ( Show , Eq , Data
instance Pretty TypeDef where
pretty ( TypeDef ident alignment def ) =
@@ -229,7 +236,7 @@ instance Pretty TypeDef where
data SubTy
= SubExtTy ExtTy
| SubAggregateTy ( Ident 'AggregateTy )
deriving ( Show , Eq )
deriving ( Show , Eq , Data
instance Pretty SubTy where
pretty ( SubExtTy extTy ) = pretty extTy
@@ -240,7 +247,7 @@ instance Pretty SubTy where
-- | Global object definition
data DataDef = DataDef [ Linkage ] ( Ident 'Global ) ( Maybe Alignment ) [ Field ]
deriving ( Show , Eq )
deriving ( Show , Eq , Data
instance Pretty DataDef where
pretty ( DataDef linkage ident alignment fields ) = vsep
@@ -254,18 +261,28 @@ data DataItem
= Symbol ( Ident 'Global ) ( Maybe Alignment )
| String ByteString
| Const Const
deriving ( Show , Eq )
deriving ( Show , Eq , Data
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...
-- ~~ HACK: hoping that the escape sequences are the same...~~
-- ↑ wrong bitch (it's undocumented; i don't blame you babe.)
pretty ( String bs ) =
enclose " \ " " " \ " " . pretty . showHexSequences . BS . unpack $ bs
where
showHexSequences =
foldr ( \ a acc -> char a <> acc ) " "
char c
| isAscii ( w2c c ) && isPrint ( w2c c ) = [ w2c c ]
| otherwise = " \ \ " <> pad 3 ( showOct c " " )
pad n s = replicate ( max 0 ( n - length s ) ) '0' <> s
pretty ( Const c ) = pretty c
data Field
= FieldExtTy ExtTy ( NonEmpty DataItem )
| FieldZero Size
deriving ( Show , Eq )
deriving ( Show , Eq , Data
instance Pretty Field where
pretty ( FieldExtTy extTy items ) = pretty extTy <+> hsep ( toList $ pretty <$> items )
@@ -276,8 +293,16 @@ instance Pretty Field where
-- 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 )
data FuncDef = FuncDef
{ linkage :: [ Linkage ]
, returnType :: Maybe AbiTy
, name :: Ident 'Global
, env :: Maybe ( Ident 'Temporary )
, params :: [ Param ]
, variadic :: Variadic
, code :: NonEmpty Block
}
deriving ( Show , Eq , Data )
instance Pretty FuncDef where
pretty ( FuncDef linkage abiTy ident env params variadic blocks ) = vsep
@@ -292,7 +317,7 @@ instance Pretty FuncDef where
]
data AbiTy = AbiBaseTy BaseTy | AbiAggregateTy ( Ident 'AggregateTy )
deriving ( Show , Eq )
deriving ( Show , Eq , Data
instance Pretty AbiTy where
pretty ( AbiBaseTy baseTy ) = pretty baseTy
@@ -300,14 +325,14 @@ instance Pretty AbiTy where
-- | Function parameter
data Param = Param AbiTy ( Ident 'Temporary )
deriving ( Show , Eq )
deriving ( Show , Eq , Data
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 )
deriving ( Show , Eq , Data
-- | 'Variadic' → @Just "..."@
-- 'NoVariadic' → @Nothing@
@@ -323,7 +348,7 @@ data Val
= ValConst Const
| ValTemporary ( Ident 'Temporary )
| ValGlobal ( Ident 'Global )
deriving ( Show , Eq )
deriving ( Show , Eq , Data
instance Pretty Val where
pretty ( ValConst c ) = pretty c
@@ -331,8 +356,13 @@ instance Pretty Val where
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 )
data Block = Block
{ label :: Ident 'Label
, phis :: [ Phi ]
, insts :: [ Inst ]
, jump :: Jump
}
deriving ( Show , Eq , Data )
instance Pretty Block where
pretty ( Block ident phis insts jump ) = hang 4 $ vsep $ concat
@@ -347,7 +377,7 @@ data Jump
= Jmp ( Ident 'Label ) -- ^ Unconditional jump
| Jnz Val ( Ident 'Label ) ( Ident 'Label ) -- ^ Conditional jump
| Ret ( Maybe Val ) -- ^ Function return
deriving ( Show , Eq )
deriving ( Show , Eq , Data
instance Pretty Jump where
pretty ( Jmp ident ) = " jmp " <+> pretty ident
@@ -363,7 +393,7 @@ instance Pretty Jump where
-- MAYBE change [PhiArg] to Map (Ident 'Label) Val
-- | Phi instruction
data Phi = Phi Assignment [ PhiArg ]
deriving ( Show , Eq )
deriving ( Show , Eq , Data
instance Pretty Phi where
pretty ( Phi assignment args ) =
@@ -371,7 +401,7 @@ instance Pretty Phi where
-- | Phi instruction argument, associating a 'Val' to a 'Label'
data PhiArg = PhiArg ( Ident 'Label ) Val
deriving ( Show , Eq )
deriving ( Show , Eq , Data
instance Pretty PhiArg where
pretty ( PhiArg label val ) = pretty label <+> pretty val
@@ -430,7 +460,7 @@ data Inst
| VaStart ( Ident 'Temporary )
-- | @vaarg@, fetches the next argument from a variable argument list
| VaArg Assignment ( Ident 'Temporary )
deriving ( Show , Eq )
deriving ( Show , Eq , Data
instance Pretty Inst where
pretty ( BinaryOp assignment op v1 v2 ) =
@@ -479,7 +509,7 @@ instance Pretty Inst where
-- | Represents the @%x =t@ part of an instruction.
data Assignment = Assignment ( Ident 'Temporary ) BaseTy
deriving ( Show , Eq )
deriving ( Show , Eq , Data
-- | Infix synonym of 'Assignment'
pattern ( := ) :: Ident 'Temporary -> BaseTy -> Assignment
@@ -490,7 +520,7 @@ instance Pretty Assignment where
-- | Integer representation
data IntRepr = Signed | Unsigned
deriving ( Show , Eq )
deriving ( Show , Eq , Data
-- | Binary arithmetic and bit operations
data BinaryOp
@@ -517,7 +547,7 @@ data BinaryOp
| Shr
-- | @shl@
| Shl
deriving ( Show , Eq )
deriving ( Show , Eq , Data
instance Pretty BinaryOp where
pretty Add = " add "
@@ -549,7 +579,7 @@ data Comparison
-- 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 )
deriving ( Show , Eq , Data
instance Pretty Comparison where
pretty Eq = " eq "
@@ -567,7 +597,7 @@ instance Pretty IntRepr where
-- | Function argument
data Arg = Arg AbiTy Val
deriving ( Show , Eq )
deriving ( Show , Eq , Data
instance Pretty Arg where
pretty ( Arg abiTy val ) = pretty abiTy <+> pretty val
@@ -577,7 +607,7 @@ instance Pretty Arg where
-- | Datatypre representing a QBE IL source file
data Program = Program [ TypeDef ] [ DataDef ] [ FuncDef ]
deriving ( Show , Eq )
deriving ( Show , Eq , Data
instance Pretty Program where
pretty ( Program typeDefs dataDefs funcDefs ) = vsep $ concat
