{-# 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 (Int -> Sigil -> ShowS
[Sigil] -> ShowS
Sigil -> String
(Int -> Sigil -> ShowS)
-> (Sigil -> String) -> ([Sigil] -> ShowS) -> Show Sigil
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Sigil] -> ShowS
$cshowList :: [Sigil] -> ShowS
show :: Sigil -> String
$cshow :: Sigil -> String
showsPrec :: Int -> Sigil -> ShowS
$cshowsPrec :: Int -> Sigil -> ShowS
Show, Sigil -> Sigil -> Bool
(Sigil -> Sigil -> Bool) -> (Sigil -> Sigil -> Bool) -> Eq Sigil
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Sigil -> Sigil -> Bool
$c/= :: Sigil -> Sigil -> Bool
== :: Sigil -> Sigil -> Bool
$c== :: Sigil -> Sigil -> Bool
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 (Int -> Ident t -> ShowS
[Ident t] -> ShowS
Ident t -> String
(Int -> Ident t -> ShowS)
-> (Ident t -> String) -> ([Ident t] -> ShowS) -> Show (Ident t)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (t :: Sigil). Int -> Ident t -> ShowS
forall (t :: Sigil). [Ident t] -> ShowS
forall (t :: Sigil). Ident t -> String
showList :: [Ident t] -> ShowS
$cshowList :: forall (t :: Sigil). [Ident t] -> ShowS
show :: Ident t -> String
$cshow :: forall (t :: Sigil). Ident t -> String
showsPrec :: Int -> Ident t -> ShowS
$cshowsPrec :: forall (t :: Sigil). Int -> Ident t -> ShowS
Show, Ident t -> Ident t -> Bool
(Ident t -> Ident t -> Bool)
-> (Ident t -> Ident t -> Bool) -> Eq (Ident t)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (t :: Sigil). Ident t -> Ident t -> Bool
/= :: Ident t -> Ident t -> Bool
$c/= :: forall (t :: Sigil). Ident t -> Ident t -> Bool
== :: Ident t -> Ident t -> Bool
$c== :: forall (t :: Sigil). Ident t -> Ident t -> Bool
Eq, Eq (Ident t)
Eq (Ident t)
-> (Ident t -> Ident t -> Ordering)
-> (Ident t -> Ident t -> Bool)
-> (Ident t -> Ident t -> Bool)
-> (Ident t -> Ident t -> Bool)
-> (Ident t -> Ident t -> Bool)
-> (Ident t -> Ident t -> Ident t)
-> (Ident t -> Ident t -> Ident t)
-> Ord (Ident t)
Ident t -> Ident t -> Bool
Ident t -> Ident t -> Ordering
Ident t -> Ident t -> Ident t
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall (t :: Sigil). Eq (Ident t)
forall (t :: Sigil). Ident t -> Ident t -> Bool
forall (t :: Sigil). Ident t -> Ident t -> Ordering
forall (t :: Sigil). Ident t -> Ident t -> Ident t
min :: Ident t -> Ident t -> Ident t
$cmin :: forall (t :: Sigil). Ident t -> Ident t -> Ident t
max :: Ident t -> Ident t -> Ident t
$cmax :: forall (t :: Sigil). Ident t -> Ident t -> Ident t
>= :: Ident t -> Ident t -> Bool
$c>= :: forall (t :: Sigil). Ident t -> Ident t -> Bool
> :: Ident t -> Ident t -> Bool
$c> :: forall (t :: Sigil). Ident t -> Ident t -> Bool
<= :: Ident t -> Ident t -> Bool
$c<= :: forall (t :: Sigil). Ident t -> Ident t -> Bool
< :: Ident t -> Ident t -> Bool
$c< :: forall (t :: Sigil). Ident t -> Ident t -> Bool
compare :: Ident t -> Ident t -> Ordering
$ccompare :: forall (t :: Sigil). Ident t -> Ident t -> Ordering
$cp1Ord :: forall (t :: Sigil). Eq (Ident t)
Ord, String -> Ident t
(String -> Ident t) -> IsString (Ident t)
forall a. (String -> a) -> IsString a
forall (t :: Sigil). String -> Ident t
fromString :: String -> Ident t
$cfromString :: forall (t :: Sigil). String -> Ident t
IsString, Ident t -> ()
(Ident t -> ()) -> NFData (Ident t)
forall a. (a -> ()) -> NFData a
forall (t :: Sigil). Ident t -> ()
rnf :: Ident t -> ()
$crnf :: forall (t :: Sigil). Ident t -> ()
NFData, Eq (Ident t)
Eq (Ident t)
-> (Int -> Ident t -> Int)
-> (Ident t -> Int)
-> Hashable (Ident t)
Int -> Ident t -> Int
Ident t -> Int
forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
forall (t :: Sigil). Eq (Ident t)
forall (t :: Sigil). Int -> Ident t -> Int
forall (t :: Sigil). Ident t -> Int
hash :: Ident t -> Int
$chash :: forall (t :: Sigil). Ident t -> Int
hashWithSalt :: Int -> Ident t -> Int
$chashWithSalt :: forall (t :: Sigil). Int -> Ident t -> Int
$cp1Hashable :: forall (t :: Sigil). Eq (Ident t)
Hashable)

instance Pretty (Ident 'AggregateTy) where
  pretty :: Ident 'AggregateTy -> Doc ann
pretty (Ident RawIdent
raw) = Char -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Char
':' Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (RawIdent -> Text
TS.toText RawIdent
raw)
instance Pretty (Ident 'Global) where
  pretty :: Ident 'Global -> Doc ann
pretty (Ident RawIdent
raw) = Char -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Char
'$' Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (RawIdent -> Text
TS.toText RawIdent
raw)
instance Pretty (Ident 'Temporary) where
  pretty :: Ident 'Temporary -> Doc ann
pretty (Ident RawIdent
raw) = Char -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Char
'%' Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (RawIdent -> Text
TS.toText RawIdent
raw)
instance Pretty (Ident 'Label) where
  pretty :: Ident 'Label -> Doc ann
pretty (Ident RawIdent
raw) = Char -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Char
'@' Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (RawIdent -> Text
TS.toText RawIdent
raw)

-- * Types
----------

-- | Base types
data BaseTy
  = Word -- ^ @w@
  | Long -- ^ @l@
  | Single -- ^ @s@
  | Double -- ^ @d@
  deriving (Int -> BaseTy -> ShowS
[BaseTy] -> ShowS
BaseTy -> String
(Int -> BaseTy -> ShowS)
-> (BaseTy -> String) -> ([BaseTy] -> ShowS) -> Show BaseTy
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BaseTy] -> ShowS
$cshowList :: [BaseTy] -> ShowS
show :: BaseTy -> String
$cshow :: BaseTy -> String
showsPrec :: Int -> BaseTy -> ShowS
$cshowsPrec :: Int -> BaseTy -> ShowS
Show, BaseTy -> BaseTy -> Bool
(BaseTy -> BaseTy -> Bool)
-> (BaseTy -> BaseTy -> Bool) -> Eq BaseTy
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BaseTy -> BaseTy -> Bool
$c/= :: BaseTy -> BaseTy -> Bool
== :: BaseTy -> BaseTy -> Bool
$c== :: BaseTy -> BaseTy -> Bool
Eq)

instance Pretty BaseTy where
  pretty :: BaseTy -> Doc ann
pretty BaseTy
Word   = Char -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Char
'w'
  pretty BaseTy
Long   = Char -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Char
'l'
  pretty BaseTy
Single = Char -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Char
's'
  pretty BaseTy
Double = Char -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Char
'd'

-- | Extended types
data ExtTy
  = BaseTy BaseTy
  | Byte -- ^ @b@
  | HalfWord -- ^ @h@
  deriving (Int -> ExtTy -> ShowS
[ExtTy] -> ShowS
ExtTy -> String
(Int -> ExtTy -> ShowS)
-> (ExtTy -> String) -> ([ExtTy] -> ShowS) -> Show ExtTy
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ExtTy] -> ShowS
$cshowList :: [ExtTy] -> ShowS
show :: ExtTy -> String
$cshow :: ExtTy -> String
showsPrec :: Int -> ExtTy -> ShowS
$cshowsPrec :: Int -> ExtTy -> ShowS
Show, ExtTy -> ExtTy -> Bool
(ExtTy -> ExtTy -> Bool) -> (ExtTy -> ExtTy -> Bool) -> Eq ExtTy
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ExtTy -> ExtTy -> Bool
$c/= :: ExtTy -> ExtTy -> Bool
== :: ExtTy -> ExtTy -> Bool
$c== :: ExtTy -> ExtTy -> Bool
Eq)

instance Pretty ExtTy where
  pretty :: ExtTy -> Doc ann
pretty (BaseTy BaseTy
baseTy) = BaseTy -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty BaseTy
baseTy
  pretty ExtTy
Byte = Char -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Char
'b'
  pretty ExtTy
HalfWord = Char -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Char
'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 (Int -> Const -> ShowS
[Const] -> ShowS
Const -> String
(Int -> Const -> ShowS)
-> (Const -> String) -> ([Const] -> ShowS) -> Show Const
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Const] -> ShowS
$cshowList :: [Const] -> ShowS
show :: Const -> String
$cshow :: Const -> String
showsPrec :: Int -> Const -> ShowS
$cshowsPrec :: Int -> Const -> ShowS
Show, Const -> Const -> Bool
(Const -> Const -> Bool) -> (Const -> Const -> Bool) -> Eq Const
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Const -> Const -> Bool
$c/= :: Const -> Const -> Bool
== :: Const -> Const -> Bool
$c== :: Const -> Const -> Bool
Eq)

instance Pretty Const where
  pretty :: Const -> Doc ann
pretty (CInt Bool
negative Word64
int) | Bool
negative = Char -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Char
'-' Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Word64 -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Word64
int
                             | Bool
otherwise = Word64 -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Word64
int
  pretty (CSingle Float
float) = Doc ann
"s_" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Float -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Float
float
  pretty (CDouble Double
double) = Doc ann
"d_" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Double -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Double
double
  pretty (CGlobal Ident 'Global
ident) = Ident 'Global -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Ident 'Global
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 (Int -> Linkage -> ShowS
[Linkage] -> ShowS
Linkage -> String
(Int -> Linkage -> ShowS)
-> (Linkage -> String) -> ([Linkage] -> ShowS) -> Show Linkage
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Linkage] -> ShowS
$cshowList :: [Linkage] -> ShowS
show :: Linkage -> String
$cshow :: Linkage -> String
showsPrec :: Int -> Linkage -> ShowS
$cshowsPrec :: Int -> Linkage -> ShowS
Show, Linkage -> Linkage -> Bool
(Linkage -> Linkage -> Bool)
-> (Linkage -> Linkage -> Bool) -> Eq Linkage
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Linkage -> Linkage -> Bool
$c/= :: Linkage -> Linkage -> Bool
== :: Linkage -> Linkage -> Bool
$c== :: Linkage -> Linkage -> Bool
Eq)

instance Pretty Linkage where
  pretty :: Linkage -> Doc ann
pretty Linkage
Export = Doc ann
"export"
  pretty (Section RawIdent
secName Maybe Text
Nothing) = Doc ann
"section" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (RawIdent -> Text
TS.toText RawIdent
secName)
  pretty (Section RawIdent
secName (Just Text
secFlags)) =
    Doc ann
"section" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (RawIdent -> Text
TS.toText RawIdent
secName) Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
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 (Int -> TypeDef -> ShowS
[TypeDef] -> ShowS
TypeDef -> String
(Int -> TypeDef -> ShowS)
-> (TypeDef -> String) -> ([TypeDef] -> ShowS) -> Show TypeDef
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TypeDef] -> ShowS
$cshowList :: [TypeDef] -> ShowS
show :: TypeDef -> String
$cshow :: TypeDef -> String
showsPrec :: Int -> TypeDef -> ShowS
$cshowsPrec :: Int -> TypeDef -> ShowS
Show, TypeDef -> TypeDef -> Bool
(TypeDef -> TypeDef -> Bool)
-> (TypeDef -> TypeDef -> Bool) -> Eq TypeDef
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TypeDef -> TypeDef -> Bool
$c/= :: TypeDef -> TypeDef -> Bool
== :: TypeDef -> TypeDef -> Bool
$c== :: TypeDef -> TypeDef -> Bool
Eq)

instance Pretty TypeDef where
  pretty :: TypeDef -> Doc ann
pretty (TypeDef Ident 'AggregateTy
ident Maybe Word64
alignment [(SubTy, Maybe Word64)]
def) =
    Doc ann
"type" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Ident 'AggregateTy -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Ident 'AggregateTy
ident Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
forall ann. Doc ann
equals
    Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann -> (Word64 -> Doc ann) -> Maybe Word64 -> Doc ann
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc ann
forall a. Monoid a => a
mempty (\Word64
x -> Doc ann
forall ann. Doc ann
space Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Word64 -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Word64
x) Maybe Word64
alignment
    Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
braced ((SubTy, Maybe Word64) -> Doc ann
forall a a ann. (Pretty a, Pretty a) => (a, Maybe a) -> Doc ann
prettyItem ((SubTy, Maybe Word64) -> Doc ann)
-> [(SubTy, Maybe Word64)] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(SubTy, Maybe Word64)]
def)
    where
      prettyItem :: (a, Maybe a) -> Doc ann
prettyItem (a
subTy, Maybe a
Nothing    ) = a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a
subTy
      prettyItem (a
subTy, Just a
amount) = a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a
subTy Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a
amount
  pretty (Opaque Ident 'AggregateTy
ident Word64
alignment Word64
size) =
    Doc ann
"type" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Ident 'AggregateTy -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Ident 'AggregateTy
ident Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
forall ann. Doc ann
equals
    Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"align" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Word64 -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Word64
alignment Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
braces (Word64 -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Word64
size)

-- | A type that can be part of an aggregate type
data SubTy
  = SubExtTy ExtTy
  | SubAggregateTy (Ident 'AggregateTy)
  deriving (Int -> SubTy -> ShowS
[SubTy] -> ShowS
SubTy -> String
(Int -> SubTy -> ShowS)
-> (SubTy -> String) -> ([SubTy] -> ShowS) -> Show SubTy
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SubTy] -> ShowS
$cshowList :: [SubTy] -> ShowS
show :: SubTy -> String
$cshow :: SubTy -> String
showsPrec :: Int -> SubTy -> ShowS
$cshowsPrec :: Int -> SubTy -> ShowS
Show, SubTy -> SubTy -> Bool
(SubTy -> SubTy -> Bool) -> (SubTy -> SubTy -> Bool) -> Eq SubTy
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SubTy -> SubTy -> Bool
$c/= :: SubTy -> SubTy -> Bool
== :: SubTy -> SubTy -> Bool
$c== :: SubTy -> SubTy -> Bool
Eq)

instance Pretty SubTy where
  pretty :: SubTy -> Doc ann
pretty (SubExtTy ExtTy
extTy) = ExtTy -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ExtTy
extTy
  pretty (SubAggregateTy Ident 'AggregateTy
ident) = Ident 'AggregateTy -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Ident 'AggregateTy
ident

-- ** Data
----------

-- | Global object definition
data DataDef = DataDef [Linkage] (Ident 'Global) (Maybe Alignment) [Field]
  deriving (Int -> DataDef -> ShowS
[DataDef] -> ShowS
DataDef -> String
(Int -> DataDef -> ShowS)
-> (DataDef -> String) -> ([DataDef] -> ShowS) -> Show DataDef
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DataDef] -> ShowS
$cshowList :: [DataDef] -> ShowS
show :: DataDef -> String
$cshow :: DataDef -> String
showsPrec :: Int -> DataDef -> ShowS
$cshowsPrec :: Int -> DataDef -> ShowS
Show, DataDef -> DataDef -> Bool
(DataDef -> DataDef -> Bool)
-> (DataDef -> DataDef -> Bool) -> Eq DataDef
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DataDef -> DataDef -> Bool
$c/= :: DataDef -> DataDef -> Bool
== :: DataDef -> DataDef -> Bool
$c== :: DataDef -> DataDef -> Bool
Eq)

instance Pretty DataDef where
  pretty :: DataDef -> Doc ann
pretty (DataDef [Linkage]
linkage Ident 'Global
ident Maybe Word64
alignment [Field]
fields) = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep
    [ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ Linkage -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Linkage -> Doc ann) -> [Linkage] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Linkage]
linkage
    , [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ (Doc ann
"data" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Ident 'Global -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Ident 'Global
ident Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
forall ann. Doc ann
equals)
           Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
: Maybe (Doc ann) -> [Doc ann]
forall a. Maybe a -> [a]
maybeToList ((Doc ann
"align" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+>) (Doc ann -> Doc ann) -> (Word64 -> Doc ann) -> Word64 -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Word64 -> Doc ann) -> Maybe Word64 -> Maybe (Doc ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Word64
alignment)
    , [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
braced (Field -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Field -> Doc ann) -> [Field] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Field]
fields)
    ]

data DataItem
  = Symbol (Ident 'Global) (Maybe Alignment)
  | String ByteString
  | Const Const
  deriving (Int -> DataItem -> ShowS
[DataItem] -> ShowS
DataItem -> String
(Int -> DataItem -> ShowS)
-> (DataItem -> String) -> ([DataItem] -> ShowS) -> Show DataItem
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DataItem] -> ShowS
$cshowList :: [DataItem] -> ShowS
show :: DataItem -> String
$cshow :: DataItem -> String
showsPrec :: Int -> DataItem -> ShowS
$cshowsPrec :: Int -> DataItem -> ShowS
Show, DataItem -> DataItem -> Bool
(DataItem -> DataItem -> Bool)
-> (DataItem -> DataItem -> Bool) -> Eq DataItem
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DataItem -> DataItem -> Bool
$c/= :: DataItem -> DataItem -> Bool
== :: DataItem -> DataItem -> Bool
$c== :: DataItem -> DataItem -> Bool
Eq)

instance Pretty DataItem where
  pretty :: DataItem -> Doc ann
pretty (Symbol Ident 'Global
ident Maybe Word64
alignment) =
    [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ Ident 'Global -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Ident 'Global
ident Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
: Maybe (Doc ann) -> [Doc ann]
forall a. Maybe a -> [a]
maybeToList ((Char -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Char
'+' Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+>) (Doc ann -> Doc ann) -> (Word64 -> Doc ann) -> Word64 -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Word64 -> Doc ann) -> Maybe Word64 -> Maybe (Doc ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Word64
alignment)
  pretty (String ByteString
bs) = String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Doc ann) -> String -> Doc ann
forall a b. (a -> b) -> a -> b
$ ByteString -> String
forall a. Show a => a -> String
show ByteString
bs -- HACK: hoping that the escape sequences are the same...
  pretty (Const Const
c) = Const -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Const
c

data Field
  = FieldExtTy ExtTy (NonEmpty DataItem)
  | FieldZero Size
  deriving (Int -> Field -> ShowS
[Field] -> ShowS
Field -> String
(Int -> Field -> ShowS)
-> (Field -> String) -> ([Field] -> ShowS) -> Show Field
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Field] -> ShowS
$cshowList :: [Field] -> ShowS
show :: Field -> String
$cshow :: Field -> String
showsPrec :: Int -> Field -> ShowS
$cshowsPrec :: Int -> Field -> ShowS
Show, Field -> Field -> Bool
(Field -> Field -> Bool) -> (Field -> Field -> Bool) -> Eq Field
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Field -> Field -> Bool
$c/= :: Field -> Field -> Bool
== :: Field -> Field -> Bool
$c== :: Field -> Field -> Bool
Eq)

instance Pretty Field where
  pretty :: Field -> Doc ann
pretty (FieldExtTy ExtTy
extTy NonEmpty DataItem
items) = ExtTy -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ExtTy
extTy Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep (NonEmpty (Doc ann) -> [Doc ann]
forall a. NonEmpty a -> [a]
toList (NonEmpty (Doc ann) -> [Doc ann])
-> NonEmpty (Doc ann) -> [Doc ann]
forall a b. (a -> b) -> a -> b
$ DataItem -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (DataItem -> Doc ann) -> NonEmpty DataItem -> NonEmpty (Doc ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty DataItem
items)
  pretty (FieldZero Word64
size) = Char -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Char
'z' Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Word64 -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Word64
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 (Int -> FuncDef -> ShowS
[FuncDef] -> ShowS
FuncDef -> String
(Int -> FuncDef -> ShowS)
-> (FuncDef -> String) -> ([FuncDef] -> ShowS) -> Show FuncDef
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FuncDef] -> ShowS
$cshowList :: [FuncDef] -> ShowS
show :: FuncDef -> String
$cshow :: FuncDef -> String
showsPrec :: Int -> FuncDef -> ShowS
$cshowsPrec :: Int -> FuncDef -> ShowS
Show, FuncDef -> FuncDef -> Bool
(FuncDef -> FuncDef -> Bool)
-> (FuncDef -> FuncDef -> Bool) -> Eq FuncDef
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FuncDef -> FuncDef -> Bool
$c/= :: FuncDef -> FuncDef -> Bool
== :: FuncDef -> FuncDef -> Bool
$c== :: FuncDef -> FuncDef -> Bool
Eq)

instance Pretty FuncDef where
  pretty :: FuncDef -> Doc ann
pretty (FuncDef [Linkage]
linkage Maybe AbiTy
abiTy Ident 'Global
ident Maybe (Ident 'Temporary)
env [Param]
params Variadic
variadic NonEmpty Block
blocks) = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep
    [ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ Linkage -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Linkage -> Doc ann) -> [Linkage] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Linkage]
linkage
    , Doc ann
"function" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Maybe AbiTy -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Maybe AbiTy
abiTy Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Ident 'Global -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Ident 'Global
ident Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
tupled (
        Maybe (Doc ann) -> [Doc ann]
forall a. Maybe a -> [a]
maybeToList ((Doc ann
"env" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+>) (Doc ann -> Doc ann)
-> (Ident 'Temporary -> Doc ann) -> Ident 'Temporary -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident 'Temporary -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Ident 'Temporary -> Doc ann)
-> Maybe (Ident 'Temporary) -> Maybe (Doc ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Ident 'Temporary)
env)
        [Doc ann] -> [Doc ann] -> [Doc ann]
forall a. [a] -> [a] -> [a]
++ (Param -> Doc ann) -> [Param] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Param -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty [Param]
params
        [Doc ann] -> [Doc ann] -> [Doc ann]
forall a. [a] -> [a] -> [a]
++ Maybe (Doc ann) -> [Doc ann]
forall a. Maybe a -> [a]
maybeToList (Variadic -> Maybe (Doc ann)
forall a. Variadic -> Maybe (Doc a)
prettyVariadic Variadic
variadic)
      ) Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
forall ann. Doc ann
lbrace
    , [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ NonEmpty (Doc ann) -> [Doc ann]
forall a. NonEmpty a -> [a]
toList (NonEmpty (Doc ann) -> [Doc ann])
-> NonEmpty (Doc ann) -> [Doc ann]
forall a b. (a -> b) -> a -> b
$ Block -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Block -> Doc ann) -> NonEmpty Block -> NonEmpty (Doc ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty Block
blocks
    , Doc ann
forall ann. Doc ann
rbrace
    ]

data AbiTy = AbiBaseTy BaseTy | AbiAggregateTy (Ident 'AggregateTy)
  deriving (Int -> AbiTy -> ShowS
[AbiTy] -> ShowS
AbiTy -> String
(Int -> AbiTy -> ShowS)
-> (AbiTy -> String) -> ([AbiTy] -> ShowS) -> Show AbiTy
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AbiTy] -> ShowS
$cshowList :: [AbiTy] -> ShowS
show :: AbiTy -> String
$cshow :: AbiTy -> String
showsPrec :: Int -> AbiTy -> ShowS
$cshowsPrec :: Int -> AbiTy -> ShowS
Show, AbiTy -> AbiTy -> Bool
(AbiTy -> AbiTy -> Bool) -> (AbiTy -> AbiTy -> Bool) -> Eq AbiTy
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AbiTy -> AbiTy -> Bool
$c/= :: AbiTy -> AbiTy -> Bool
== :: AbiTy -> AbiTy -> Bool
$c== :: AbiTy -> AbiTy -> Bool
Eq)

instance Pretty AbiTy where
  pretty :: AbiTy -> Doc ann
pretty (AbiBaseTy BaseTy
baseTy) = BaseTy -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty BaseTy
baseTy
  pretty (AbiAggregateTy Ident 'AggregateTy
ident) = Ident 'AggregateTy -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Ident 'AggregateTy
ident

-- | Function parameter
data Param = Param AbiTy (Ident 'Temporary)
  deriving (Int -> Param -> ShowS
[Param] -> ShowS
Param -> String
(Int -> Param -> ShowS)
-> (Param -> String) -> ([Param] -> ShowS) -> Show Param
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Param] -> ShowS
$cshowList :: [Param] -> ShowS
show :: Param -> String
$cshow :: Param -> String
showsPrec :: Int -> Param -> ShowS
$cshowsPrec :: Int -> Param -> ShowS
Show, Param -> Param -> Bool
(Param -> Param -> Bool) -> (Param -> Param -> Bool) -> Eq Param
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Param -> Param -> Bool
$c/= :: Param -> Param -> Bool
== :: Param -> Param -> Bool
$c== :: Param -> Param -> Bool
Eq)

instance Pretty Param where
  pretty :: Param -> Doc ann
pretty (Param AbiTy
abiTy Ident 'Temporary
ident) = AbiTy -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty AbiTy
abiTy Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Ident 'Temporary -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Ident 'Temporary
ident

-- | Indicates the presence or absence of a variadic marker
data Variadic = Variadic | NoVariadic
  deriving (Int -> Variadic -> ShowS
[Variadic] -> ShowS
Variadic -> String
(Int -> Variadic -> ShowS)
-> (Variadic -> String) -> ([Variadic] -> ShowS) -> Show Variadic
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Variadic] -> ShowS
$cshowList :: [Variadic] -> ShowS
show :: Variadic -> String
$cshow :: Variadic -> String
showsPrec :: Int -> Variadic -> ShowS
$cshowsPrec :: Int -> Variadic -> ShowS
Show, Variadic -> Variadic -> Bool
(Variadic -> Variadic -> Bool)
-> (Variadic -> Variadic -> Bool) -> Eq Variadic
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Variadic -> Variadic -> Bool
$c/= :: Variadic -> Variadic -> Bool
== :: Variadic -> Variadic -> Bool
$c== :: Variadic -> Variadic -> Bool
Eq)

-- | 'Variadic' → @Just "..."@
-- 'NoVariadic' → @Nothing@
prettyVariadic :: Variadic -> Maybe (Doc a)
prettyVariadic :: Variadic -> Maybe (Doc a)
prettyVariadic Variadic
Variadic = Doc a -> Maybe (Doc a)
forall a. a -> Maybe a
Just Doc a
"..."
prettyVariadic Variadic
NoVariadic = Maybe (Doc a)
forall a. Maybe a
Nothing

-- * Control
------------

-- | Value, either an immediate or a global or temporary identifier.
data Val
  = ValConst Const
  | ValTemporary (Ident 'Temporary)
  | ValGlobal (Ident 'Global)
  deriving (Int -> Val -> ShowS
[Val] -> ShowS
Val -> String
(Int -> Val -> ShowS)
-> (Val -> String) -> ([Val] -> ShowS) -> Show Val
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Val] -> ShowS
$cshowList :: [Val] -> ShowS
show :: Val -> String
$cshow :: Val -> String
showsPrec :: Int -> Val -> ShowS
$cshowsPrec :: Int -> Val -> ShowS
Show, Val -> Val -> Bool
(Val -> Val -> Bool) -> (Val -> Val -> Bool) -> Eq Val
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Val -> Val -> Bool
$c/= :: Val -> Val -> Bool
== :: Val -> Val -> Bool
$c== :: Val -> Val -> Bool
Eq)

instance Pretty Val where
  pretty :: Val -> Doc ann
pretty (ValConst Const
c) = Const -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Const
c
  pretty (ValTemporary Ident 'Temporary
ident) = Ident 'Temporary -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Ident 'Temporary
ident
  pretty (ValGlobal Ident 'Global
ident) = Ident 'Global -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Ident 'Global
ident

-- | Block of instructions beginning with a label and ending with a jump
data Block = Block (Ident 'Label) [Phi] [Inst] Jump
  deriving (Int -> Block -> ShowS
[Block] -> ShowS
Block -> String
(Int -> Block -> ShowS)
-> (Block -> String) -> ([Block] -> ShowS) -> Show Block
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Block] -> ShowS
$cshowList :: [Block] -> ShowS
show :: Block -> String
$cshow :: Block -> String
showsPrec :: Int -> Block -> ShowS
$cshowsPrec :: Int -> Block -> ShowS
Show, Block -> Block -> Bool
(Block -> Block -> Bool) -> (Block -> Block -> Bool) -> Eq Block
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Block -> Block -> Bool
$c/= :: Block -> Block -> Bool
== :: Block -> Block -> Bool
$c== :: Block -> Block -> Bool
Eq)

instance Pretty Block where
  pretty :: Block -> Doc ann
pretty (Block Ident 'Label
ident [Phi]
phis [Inst]
insts Jump
jump) = Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
hang Int
4 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ [[Doc ann]] -> [Doc ann]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [Ident 'Label -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Ident 'Label
ident]
    , Phi -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Phi -> Doc ann) -> [Phi] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Phi]
phis
    , Inst -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Inst -> Doc ann) -> [Inst] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Inst]
insts
    , [Jump -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Jump
jump]
    ]

-- | Jump instructions
data Jump
  = Jmp (Ident 'Label) -- ^ Unconditional jump
  | Jnz Val (Ident 'Label) (Ident 'Label) -- ^ Conditional jump
  | Ret (Maybe Val) -- ^ Function return
  deriving (Int -> Jump -> ShowS
[Jump] -> ShowS
Jump -> String
(Int -> Jump -> ShowS)
-> (Jump -> String) -> ([Jump] -> ShowS) -> Show Jump
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Jump] -> ShowS
$cshowList :: [Jump] -> ShowS
show :: Jump -> String
$cshow :: Jump -> String
showsPrec :: Int -> Jump -> ShowS
$cshowsPrec :: Int -> Jump -> ShowS
Show, Jump -> Jump -> Bool
(Jump -> Jump -> Bool) -> (Jump -> Jump -> Bool) -> Eq Jump
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Jump -> Jump -> Bool
$c/= :: Jump -> Jump -> Bool
== :: Jump -> Jump -> Bool
$c== :: Jump -> Jump -> Bool
Eq)

instance Pretty Jump where
  pretty :: Jump -> Doc ann
pretty (Jmp Ident 'Label
ident) = Doc ann
"jmp" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Ident 'Label -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Ident 'Label
ident
  pretty (Jnz Val
val Ident 'Label
label1 Ident 'Label
label2) =
    Doc ann
"jnz" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Val -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Val
val Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
comma
    Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Ident 'Label -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Ident 'Label
label1 Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
comma
    Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Ident 'Label -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Ident 'Label
label2
  pretty (Ret Maybe Val
val) = Doc ann
"ret" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Maybe Val -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Maybe Val
val

-- * Instructions
-----------------

-- MAYBE change [PhiArg] to Map (Ident 'Label) Val
-- | Phi instruction
data Phi = Phi Assignment [PhiArg]
  deriving (Int -> Phi -> ShowS
[Phi] -> ShowS
Phi -> String
(Int -> Phi -> ShowS)
-> (Phi -> String) -> ([Phi] -> ShowS) -> Show Phi
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Phi] -> ShowS
$cshowList :: [Phi] -> ShowS
show :: Phi -> String
$cshow :: Phi -> String
showsPrec :: Int -> Phi -> ShowS
$cshowsPrec :: Int -> Phi -> ShowS
Show, Phi -> Phi -> Bool
(Phi -> Phi -> Bool) -> (Phi -> Phi -> Bool) -> Eq Phi
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Phi -> Phi -> Bool
$c/= :: Phi -> Phi -> Bool
== :: Phi -> Phi -> Bool
$c== :: Phi -> Phi -> Bool
Eq)

instance Pretty Phi where
  pretty :: Phi -> Doc ann
pretty (Phi Assignment
assignment [PhiArg]
args) =
    Assignment -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Assignment
assignment Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"phi" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep (Doc ann -> [Doc ann] -> [Doc ann]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc ann
forall ann. Doc ann
comma ([Doc ann] -> [Doc ann]) -> [Doc ann] -> [Doc ann]
forall a b. (a -> b) -> a -> b
$ PhiArg -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (PhiArg -> Doc ann) -> [PhiArg] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PhiArg]
args)

-- | Phi instruction argument, associating a 'Val' to a 'Label'
data PhiArg = PhiArg (Ident 'Label) Val
  deriving (Int -> PhiArg -> ShowS
[PhiArg] -> ShowS
PhiArg -> String
(Int -> PhiArg -> ShowS)
-> (PhiArg -> String) -> ([PhiArg] -> ShowS) -> Show PhiArg
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PhiArg] -> ShowS
$cshowList :: [PhiArg] -> ShowS
show :: PhiArg -> String
$cshow :: PhiArg -> String
showsPrec :: Int -> PhiArg -> ShowS
$cshowsPrec :: Int -> PhiArg -> ShowS
Show, PhiArg -> PhiArg -> Bool
(PhiArg -> PhiArg -> Bool)
-> (PhiArg -> PhiArg -> Bool) -> Eq PhiArg
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PhiArg -> PhiArg -> Bool
$c/= :: PhiArg -> PhiArg -> Bool
== :: PhiArg -> PhiArg -> Bool
$c== :: PhiArg -> PhiArg -> Bool
Eq)

instance Pretty PhiArg where
  pretty :: PhiArg -> Doc ann
pretty (PhiArg Ident 'Label
label Val
val) = Ident 'Label -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Ident 'Label
label Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Val -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Val
val

-- | Instruction
data Inst
  -- Arithmetic and Bits
  = BinaryOp Assignment BinaryOp Val Val -- ^ Binary arithmetic and bit operations
  | Neg Assignment Val -- ^ @neg@
  -- 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
  | LoadW Assignment IntRepr Val
  | LoadH Assignment IntRepr Val
  | 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 Assignment Val
  | Copy Assignment Val
  -- Calls
  -- | the fields are: assignment, function name, environment, arguments, variadic arguments
  | Call (Maybe (Ident 'Temporary, AbiTy)) Val (Maybe Val) [Arg] [Arg]
  -- Variadic
  | VaStart (Ident 'Temporary)
  | VaArg Assignment (Ident 'Temporary)
  deriving (Int -> Inst -> ShowS
[Inst] -> ShowS
Inst -> String
(Int -> Inst -> ShowS)
-> (Inst -> String) -> ([Inst] -> ShowS) -> Show Inst
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Inst] -> ShowS
$cshowList :: [Inst] -> ShowS
show :: Inst -> String
$cshow :: Inst -> String
showsPrec :: Int -> Inst -> ShowS
$cshowsPrec :: Int -> Inst -> ShowS
Show, Inst -> Inst -> Bool
(Inst -> Inst -> Bool) -> (Inst -> Inst -> Bool) -> Eq Inst
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Inst -> Inst -> Bool
$c/= :: Inst -> Inst -> Bool
== :: Inst -> Inst -> Bool
$c== :: Inst -> Inst -> Bool
Eq)

instance Pretty Inst where
  pretty :: Inst -> Doc ann
pretty (BinaryOp Assignment
assignment BinaryOp
op Val
v1 Val
v2) =
    Assignment -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Assignment
assignment Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> BinaryOp -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty BinaryOp
op Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Val -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Val
v1 Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
comma Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Val -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Val
v2
  pretty (Neg Assignment
assignment Val
v) =
    Assignment -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Assignment
assignment Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"neg" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Val -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Val
v
  pretty (Store ExtTy
ty Val
v Val
address) =
    Doc ann
"store" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> ExtTy -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ExtTy
ty Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Val -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Val
v Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
comma Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Val -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Val
address
  pretty (Load  Assignment
assignment BaseTy
loadTy Val
addr) =
    Assignment -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Assignment
assignment Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"load" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> BaseTy -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty BaseTy
loadTy Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Val -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Val
addr
  pretty (LoadW Assignment
assignment IntRepr
intRepr Val
addr) =
    Assignment -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Assignment
assignment Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"load" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> IntRepr -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty IntRepr
intRepr Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Char -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Char
'w' Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Val -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Val
addr
  pretty (LoadH Assignment
assignment IntRepr
intRepr Val
addr) =
    Assignment -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Assignment
assignment Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"load" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> IntRepr -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty IntRepr
intRepr Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Char -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Char
'h' Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Val -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Val
addr
  pretty (LoadB Assignment
assignment IntRepr
intRepr Val
addr) =
    Assignment -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Assignment
assignment Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"load" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> IntRepr -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty IntRepr
intRepr Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Char -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Char
'b' Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Val -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Val
addr
  pretty (Compare Assignment
assignment Comparison
comp BaseTy
compTy Val
v1 Val
v2) =
    Assignment -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Assignment
assignment Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Char -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Char
'c' Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Comparison -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Comparison
comp Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> BaseTy -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty BaseTy
compTy Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Val -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Val
v1 Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
comma Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Val -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Val
v2
  pretty (ExtW Assignment
assignment IntRepr
intRepr Val
v) =
    Assignment -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Assignment
assignment Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"ext" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> IntRepr -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty IntRepr
intRepr Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Char -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Char
'w' Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Val -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Val
v
  pretty (ExtH Assignment
assignment IntRepr
intRepr Val
v) =
    Assignment -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Assignment
assignment Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"ext" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> IntRepr -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty IntRepr
intRepr Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Char -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Char
'h' Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Val -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Val
v
  pretty (ExtB Assignment
assignment IntRepr
intRepr Val
v) =
    Assignment -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Assignment
assignment Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"ext" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> IntRepr -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty IntRepr
intRepr Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Char -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Char
'b' Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Val -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Val
v
  pretty (ExtS Ident 'Temporary
res Val
v) = Ident 'Temporary -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Ident 'Temporary
res Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
forall ann. Doc ann
equals Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Char -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Char
'd' Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"exts" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Val -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Val
v
  pretty (TruncD Ident 'Temporary
res Val
v) = Ident 'Temporary -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Ident 'Temporary
res Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
forall ann. Doc ann
equals Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Char -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Char
's' Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"truncd" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Val -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Val
v
  pretty (StoI Assignment
assignment IntRepr
intRepr Val
v) = Assignment -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Assignment
assignment Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"sto" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> IntRepr -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty IntRepr
intRepr Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Char -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Char
'i' Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Val -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Val
v
  pretty (DtoI Assignment
assignment IntRepr
intRepr Val
v) = Assignment -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Assignment
assignment Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"dto" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> IntRepr -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty IntRepr
intRepr Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Char -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Char
'i' Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Val -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Val
v
  pretty (WtoF Assignment
assignment IntRepr
intRepr Val
v) = Assignment -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Assignment
assignment Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> IntRepr -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty IntRepr
intRepr Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"wtof" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Val -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Val
v
  pretty (LtoF Assignment
assignment IntRepr
intRepr Val
v) = Assignment -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Assignment
assignment Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> IntRepr -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty IntRepr
intRepr Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"ltof" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Val -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Val
v
  pretty (Cast Assignment
assignment Val
v) = Assignment -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Assignment
assignment Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"cast" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Val -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Val
v
  pretty (Copy Assignment
assignment Val
v) = Assignment -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Assignment
assignment Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"copy" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Val -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Val
v
  pretty (Call Maybe (Ident 'Temporary, AbiTy)
assignment Val
func Maybe Val
env [Arg]
args [Arg]
variadics) = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$
    Maybe (Doc ann) -> [Doc ann]
forall a. Maybe a -> [a]
maybeToList ((Ident 'Temporary, AbiTy) -> Doc ann
forall a a ann. (Pretty a, Pretty a) => (a, a) -> Doc ann
prettyAssignment ((Ident 'Temporary, AbiTy) -> Doc ann)
-> Maybe (Ident 'Temporary, AbiTy) -> Maybe (Doc ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Ident 'Temporary, AbiTy)
assignment) [Doc ann] -> [Doc ann] -> [Doc ann]
forall a. [a] -> [a] -> [a]
++
    [ Doc ann
"call"
    , Val -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Val
func
    , [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
tupled ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ Maybe (Doc ann) -> [Doc ann]
forall a. Maybe a -> [a]
maybeToList ((Doc ann
"env" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+>) (Doc ann -> Doc ann) -> (Val -> Doc ann) -> Val -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Val -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Val -> Doc ann) -> Maybe Val -> Maybe (Doc ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Val
env)
            [Doc ann] -> [Doc ann] -> [Doc ann]
forall a. [a] -> [a] -> [a]
++ (Arg -> Doc ann) -> [Arg] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Arg -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty [Arg]
args
            [Doc ann] -> [Doc ann] -> [Doc ann]
forall a. [a] -> [a] -> [a]
++ [Doc ann]
forall ann. [Doc ann]
variadics'
    ]
    where
      prettyAssignment :: (a, a) -> Doc ann
prettyAssignment (a
ident, a
ty) = a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a
ident Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
forall ann. Doc ann
equals Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a
ty
      variadics' :: [Doc ann]
variadics' = if [Arg] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Arg]
variadics then [] else Doc ann
"..." Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
: (Arg -> Doc ann) -> [Arg] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Arg -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty [Arg]
variadics
  pretty (VaStart Ident 'Temporary
argList) = Doc ann
"vastart" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Ident 'Temporary -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Ident 'Temporary
argList
  pretty (VaArg Assignment
assignment Ident 'Temporary
argList) = Assignment -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Assignment
assignment Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"vaarg" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Ident 'Temporary -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Ident 'Temporary
argList

-- | Represents the @%x =t@ part of an instruction.
data Assignment = Assignment (Ident 'Temporary) BaseTy
  deriving (Int -> Assignment -> ShowS
[Assignment] -> ShowS
Assignment -> String
(Int -> Assignment -> ShowS)
-> (Assignment -> String)
-> ([Assignment] -> ShowS)
-> Show Assignment
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Assignment] -> ShowS
$cshowList :: [Assignment] -> ShowS
show :: Assignment -> String
$cshow :: Assignment -> String
showsPrec :: Int -> Assignment -> ShowS
$cshowsPrec :: Int -> Assignment -> ShowS
Show, Assignment -> Assignment -> Bool
(Assignment -> Assignment -> Bool)
-> (Assignment -> Assignment -> Bool) -> Eq Assignment
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Assignment -> Assignment -> Bool
$c/= :: Assignment -> Assignment -> Bool
== :: Assignment -> Assignment -> Bool
$c== :: Assignment -> Assignment -> Bool
Eq)

-- | Infix synonym of 'Assignment'
pattern (:=) :: Ident 'Temporary -> BaseTy -> Assignment
pattern $b:= :: Ident 'Temporary -> BaseTy -> Assignment
$m:= :: forall r.
Assignment
-> (Ident 'Temporary -> BaseTy -> r) -> (Void# -> r) -> r
(:=) ident ty = Assignment ident ty

instance Pretty Assignment where
  pretty :: Assignment -> Doc ann
pretty (Assignment Ident 'Temporary
ident BaseTy
ty) = Ident 'Temporary -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Ident 'Temporary
ident Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
forall ann. Doc ann
equals Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> BaseTy -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty BaseTy
ty

-- | Integer representation
data IntRepr = Signed | Unsigned
  deriving (Int -> IntRepr -> ShowS
[IntRepr] -> ShowS
IntRepr -> String
(Int -> IntRepr -> ShowS)
-> (IntRepr -> String) -> ([IntRepr] -> ShowS) -> Show IntRepr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [IntRepr] -> ShowS
$cshowList :: [IntRepr] -> ShowS
show :: IntRepr -> String
$cshow :: IntRepr -> String
showsPrec :: Int -> IntRepr -> ShowS
$cshowsPrec :: Int -> IntRepr -> ShowS
Show, IntRepr -> IntRepr -> Bool
(IntRepr -> IntRepr -> Bool)
-> (IntRepr -> IntRepr -> Bool) -> Eq IntRepr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IntRepr -> IntRepr -> Bool
$c/= :: IntRepr -> IntRepr -> Bool
== :: IntRepr -> IntRepr -> Bool
$c== :: IntRepr -> IntRepr -> Bool
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 (Int -> BinaryOp -> ShowS
[BinaryOp] -> ShowS
BinaryOp -> String
(Int -> BinaryOp -> ShowS)
-> (BinaryOp -> String) -> ([BinaryOp] -> ShowS) -> Show BinaryOp
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BinaryOp] -> ShowS
$cshowList :: [BinaryOp] -> ShowS
show :: BinaryOp -> String
$cshow :: BinaryOp -> String
showsPrec :: Int -> BinaryOp -> ShowS
$cshowsPrec :: Int -> BinaryOp -> ShowS
Show, BinaryOp -> BinaryOp -> Bool
(BinaryOp -> BinaryOp -> Bool)
-> (BinaryOp -> BinaryOp -> Bool) -> Eq BinaryOp
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BinaryOp -> BinaryOp -> Bool
$c/= :: BinaryOp -> BinaryOp -> Bool
== :: BinaryOp -> BinaryOp -> Bool
$c== :: BinaryOp -> BinaryOp -> Bool
Eq)

instance Pretty BinaryOp where
  pretty :: BinaryOp -> Doc ann
pretty BinaryOp
Add            = Doc ann
"add"
  pretty BinaryOp
Sub            = Doc ann
"sub"
  pretty (Div IntRepr
Signed)   = Doc ann
"div"
  pretty (Div IntRepr
Unsigned) = Doc ann
"udiv"
  pretty BinaryOp
Mul            = Doc ann
"mul"
  pretty (Rem IntRepr
Signed)   = Doc ann
"rem"
  pretty (Rem IntRepr
Unsigned) = Doc ann
"rem"
  pretty BinaryOp
Or             = Doc ann
"or"
  pretty BinaryOp
Xor            = Doc ann
"xor"
  pretty BinaryOp
And            = Doc ann
"and"
  pretty BinaryOp
Sar            = Doc ann
"sar"
  pretty BinaryOp
Shr            = Doc ann
"shr"
  pretty BinaryOp
Shl            = Doc ann
"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 (Int -> Comparison -> ShowS
[Comparison] -> ShowS
Comparison -> String
(Int -> Comparison -> ShowS)
-> (Comparison -> String)
-> ([Comparison] -> ShowS)
-> Show Comparison
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Comparison] -> ShowS
$cshowList :: [Comparison] -> ShowS
show :: Comparison -> String
$cshow :: Comparison -> String
showsPrec :: Int -> Comparison -> ShowS
$cshowsPrec :: Int -> Comparison -> ShowS
Show, Comparison -> Comparison -> Bool
(Comparison -> Comparison -> Bool)
-> (Comparison -> Comparison -> Bool) -> Eq Comparison
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Comparison -> Comparison -> Bool
$c/= :: Comparison -> Comparison -> Bool
== :: Comparison -> Comparison -> Bool
$c== :: Comparison -> Comparison -> Bool
Eq)

instance Pretty Comparison where
  pretty :: Comparison -> Doc ann
pretty Comparison
Eq = Doc ann
"eq"
  pretty Comparison
Ne = Doc ann
"ne"
  pretty (Le Maybe IntRepr
intRepr) = Maybe IntRepr -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Maybe IntRepr
intRepr Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"le"
  pretty (Lt Maybe IntRepr
intRepr) = Maybe IntRepr -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Maybe IntRepr
intRepr Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"lt"
  pretty (Ge Maybe IntRepr
intRepr) = Maybe IntRepr -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Maybe IntRepr
intRepr Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"ge"
  pretty (Gt Maybe IntRepr
intRepr) = Maybe IntRepr -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Maybe IntRepr
intRepr Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"gt"
  pretty Comparison
O = Doc ann
"o"
  pretty Comparison
Uo = Doc ann
"uo"

instance Pretty IntRepr where
  pretty :: IntRepr -> Doc ann
pretty IntRepr
Signed = Char -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Char
's'
  pretty IntRepr
Unsigned = Char -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Char
'u'

-- | Function argument
data Arg = Arg AbiTy Val
  deriving (Int -> Arg -> ShowS
[Arg] -> ShowS
Arg -> String
(Int -> Arg -> ShowS)
-> (Arg -> String) -> ([Arg] -> ShowS) -> Show Arg
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Arg] -> ShowS
$cshowList :: [Arg] -> ShowS
show :: Arg -> String
$cshow :: Arg -> String
showsPrec :: Int -> Arg -> ShowS
$cshowsPrec :: Int -> Arg -> ShowS
Show, Arg -> Arg -> Bool
(Arg -> Arg -> Bool) -> (Arg -> Arg -> Bool) -> Eq Arg
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Arg -> Arg -> Bool
$c/= :: Arg -> Arg -> Bool
== :: Arg -> Arg -> Bool
$c== :: Arg -> Arg -> Bool
Eq)

instance Pretty Arg where
  pretty :: Arg -> Doc ann
pretty (Arg AbiTy
abiTy Val
val) = AbiTy -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty AbiTy
abiTy Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Val -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Val
val

-- * Program
------------

-- | Datatypre representing a QBE IL source file
data Program = Program [TypeDef] [DataDef] [FuncDef]
  deriving (Int -> Program -> ShowS
[Program] -> ShowS
Program -> String
(Int -> Program -> ShowS)
-> (Program -> String) -> ([Program] -> ShowS) -> Show Program
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Program] -> ShowS
$cshowList :: [Program] -> ShowS
show :: Program -> String
$cshow :: Program -> String
showsPrec :: Int -> Program -> ShowS
$cshowsPrec :: Int -> Program -> ShowS
Show, Program -> Program -> Bool
(Program -> Program -> Bool)
-> (Program -> Program -> Bool) -> Eq Program
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Program -> Program -> Bool
$c/= :: Program -> Program -> Bool
== :: Program -> Program -> Bool
$c== :: Program -> Program -> Bool
Eq)

instance Pretty Program where
  pretty :: Program -> Doc ann
pretty (Program [TypeDef]
typeDefs [DataDef]
dataDefs [FuncDef]
funcDefs) = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ [[Doc ann]] -> [Doc ann]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ TypeDef -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (TypeDef -> Doc ann) -> [TypeDef] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TypeDef]
typeDefs
    , DataDef -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (DataDef -> Doc ann) -> [DataDef] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [DataDef]
dataDefs
    , FuncDef -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (FuncDef -> Doc ann) -> [FuncDef] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FuncDef]
funcDefs
    ]

-- * Utilities
--------------

-- | Like 'list' and 'tupled', but with braces
braced :: [Doc ann] -> Doc ann
braced :: [Doc ann] -> Doc ann
braced = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
group (Doc ann -> Doc ann)
-> ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc ann -> Doc ann -> Doc ann -> [Doc ann] -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann -> [Doc ann] -> Doc ann
encloseSep (Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
flatAlt Doc ann
"{ " Doc ann
"{")
                            (Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
flatAlt Doc ann
" }" Doc ann
"}")
                            Doc ann
", "