🌅

.gitignore

@@ -0,0 +1,7 @@
+cabal.project.local
+cabal.project.local~
+dist
+dist-newstyle
+*.o
+*.hi
+.ghc.environment.*

CHANGELOG.md

@@ -0,0 +1,5 @@
+# Revision history for qbe-hs
+
+## 0.1.0.0 -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.

LICENSE

@@ -0,0 +1,30 @@
+Copyright (c) 2022, Francesco Gazzetta
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Francesco Gazzetta nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

qbe.cabal

@@ -0,0 +1,32 @@
+cabal-version:      3.0
+name:               qbe
+-- First component matches the QBE major version
+version:            1.1.0.0
+-- synopsis:
+-- description:
+license:            BSD-3-Clause
+license-file:       LICENSE
+author:             Francesco Gazzetta
+maintainer:         fgaz@fgaz.me
+copyright:          2022 Francesco Gazzetta
+category:           Language
+build-type:         Simple
+extra-doc-files:    CHANGELOG.md
+-- extra-source-files:
+
+library
+    exposed-modules:  Language.QBE
+    -- other-modules:
+    other-extensions: DataKinds
+                      KindSignatures
+                      GeneralizedNewtypeDeriving
+    build-depends:    base ^>=4.16.1.0
+                    , text
+                    , text-short
+                    , bytestring
+                    , hashable
+                    , deepseq
+                    , binary
+    hs-source-dirs:   src
+    ghc-options: -Wall
+    default-language: Haskell2010

src/Language/QBE.hs

@@ -0,0 +1,230 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Language.QBE where
+
+import Data.Text (Text)
+import Data.Text.Short (ShortText)
+import Data.ByteString (ByteString)
+import Data.Word (Word64)
+import Data.List.NonEmpty (NonEmpty)
+-- Instances
+import Data.Hashable (Hashable)
+import Control.DeepSeq (NFData)
+import Data.Binary (Binary)
+import Data.String (IsString)
+
+-- * Identifiers
+----------------
+
+type RawIdent = ShortText
+
+data Sigil
+  = AggregateTy -- ^ @:@
+  | Global -- ^ @$@
+  | Temporary -- ^ @%@
+  | Label -- ^ @\@@
+  deriving (Show, Eq)
+
+-- | QBE identifiers. The sigil is represented at the type level, so that
+-- mixing incompatible identifiers is impossible.
+newtype Ident (t :: Sigil) = Ident RawIdent
+  deriving (Show, Eq, Ord, IsString, Binary, NFData, Hashable)
+
+-- * Types
+----------
+
+data BaseTy = Word | Long | Single | Double
+  deriving (Show, Eq)
+
+data ExtTy = BaseTy BaseTy | Byte | HalfWord
+  deriving (Show, Eq)
+
+-- * Constants
+--------------
+
+data Const
+  = CInt Bool Word64 -- ^ The 'Bool' is whether to negate
+  | CSingle Float
+  | CDouble Double
+  | CGlobal (Ident 'Global)
+  deriving (Show, Eq)
+
+-- * Linkage
+------------
+
+data Linkage
+  = Export
+  | Section ShortText (Maybe Text)
+  deriving (Show, Eq)
+
+-- * Definitions
+----------------
+
+type Alignment = Word64
+type Size = Word64
+type Amount = Word64
+
+-- ** Aggregate types
+---------------------
+
+data Typedef
+  = Typedef (Ident 'AggregateTy) (Maybe Alignment) [(SubTy, Maybe Amount)]
+  | Opaque (Ident 'AggregateTy) Alignment Size
+  deriving (Show, Eq)
+
+data SubTy
+  = SubExtTy
+  | SubAggregateTy (Ident 'AggregateTy)
+  deriving (Show, Eq)
+
+-- ** Data
+----------
+
+data DataDef = DataDef [Linkage] (Ident 'Global) (Maybe Alignment) [Field]
+  deriving (Show, Eq)
+
+data DataItem
+  = Symbol (Ident 'Global) Alignment
+  | String ByteString
+  | Const Const
+  deriving (Show, Eq)
+
+data Field
+  = FieldExtTy ExtTy (NonEmpty DataItem)
+  | FieldZero Size
+  deriving (Show, Eq)
+
+-- ** Functions
+---------------
+
+-- | 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 AbiTy = AbiBaseTy BaseTy | AbiAggregateTy (Ident 'AggregateTy)
+  deriving (Show, Eq)
+
+data Param = Param AbiTy (Ident 'Temporary)
+  deriving (Show, Eq)
+
+data Variadic = Variadic | NoVariadic
+  deriving (Show, Eq)
+
+-- * Control
+------------
+
+data Val
+  = ValConst Const
+  | ValTemporary (Ident 'Temporary)
+  | ValGlobal (Ident 'Global)
+  deriving (Show, Eq)
+
+data Block = Block (Ident 'Label) [Phi] [Inst] Jump
+  deriving (Show, Eq)
+
+data Jump
+  = Jmp (Ident 'Label)
+  | Jnz Val (Ident 'Label) (Ident 'Label)
+  | Ret (Maybe Val)
+  deriving (Show, Eq)
+
+-- * Instructions
+-----------------
+
+data Phi = Phi (Ident 'Temporary) BaseTy [(Ident 'Label, Val)]
+  deriving (Show, Eq)
+
+data Inst
+  -- Arithmetic and Bits
+  = BinaryOp (Ident 'Temporary) BaseTy BinaryOp Val Val
+  | Neg (Ident 'Temporary) BaseTy Val
+  -- Memory
+  | Store ExtTy Val Val
+  | Load (Ident 'Temporary) BaseTy BaseTy Val -- ^ @\<ident\> =\<baseTy\> load\<baseTy\> \<val\>@
+  | LoadW (Ident 'Temporary) BaseTy IntRepr Val -- ^ @\<ident\> =\<baseTy\> load\<intRepr\>w \<val\>@
+  | LoadH (Ident 'Temporary) BaseTy IntRepr Val
+  | LoadB (Ident 'Temporary) BaseTy IntRepr Val
+  -- Comparisons
+  | Compare (Ident 'Temporary) BaseTy Comparison BaseTy Val Val
+  -- Conversions
+  -- | @extsw@/@extuw@. There is only one possible instruction type, so there's
+  -- no 'BaseTy' argument
+  | ExtW (Ident 'Temporary)        IntRepr Val
+  -- | @extsh@/@extuh@
+  | ExtH (Ident 'Temporary) BaseTy IntRepr Val
+  -- | @extsb@/@extub@
+  | ExtB (Ident 'Temporary) BaseTy IntRepr Val
+  -- | @exts@. There is only one possible instruction type, so there's
+  -- no 'BaseTy' argument
+  | Exts (Ident 'Temporary) Val
+  -- | @truncd@. There is only one possible instruction type, so there's
+  -- no 'BaseTy' argument
+  | Truncd (Ident 'Temporary) Val
+  -- | @stosi@/@stoui@
+  | StoI (Ident 'Temporary) BaseTy IntRepr Val
+  -- | @dtosi@/@dtoui@
+  | DtoI (Ident 'Temporary) BaseTy IntRepr Val
+  -- | @swtof@/@uwtof@
+  | WtoF (Ident 'Temporary) BaseTy IntRepr Val
+  -- | @sltof@/@ultof@
+  | LtoF (Ident 'Temporary) BaseTy IntRepr Val
+  -- Cast and Copy
+  | Cast (Ident 'Temporary) BaseTy Val
+  | Copy (Ident 'Temporary) BaseTy 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 (Ident 'Temporary) BaseTy (Ident 'Temporary)
+  deriving (Show, Eq)
+
+data IntRepr = Signed | Unsigned
+  deriving (Show, Eq)
+
+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 (Show, Eq)
+
+-- | 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 (Show, Eq)
+
+data Arg = Arg AbiTy Val
+  deriving (Show, Eq)