.gitignore

.cabal-sandbox/
dist/
cabal.config
cabal.sandbox.config

.*.swp

AnyValue.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}

module AnyValue where

import Value
import ValueOf

data AnyValue (a :: *) where
  AnyValue :: ValueOf (Value const a) => Value const a -> AnyValue a

BasicBlock.hs

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module BasicBlock where

import Control.Applicative
import Control.Monad.Fix
import Control.Monad.RWS.Lazy
import Data.Maybe (fromJust)
import qualified LLVM.General.AST as AST

import FunctionDefinition

newtype BasicBlock a = BasicBlock{runBasicBlock :: RWST () [AST.Named AST.Instruction] BasicBlockState FunctionDefinition a}
  deriving (Functor, Applicative, Monad, MonadFix, MonadState BasicBlockState, MonadWriter [AST.Named AST.Instruction])

liftFunctionDefinition :: FunctionDefinition a -> BasicBlock a
liftFunctionDefinition = BasicBlock . lift

data BasicBlockState = BasicBlockState
  { basicBlockName         :: AST.Name
  , basicBlockTerminator   :: Maybe (AST.Named AST.Terminator)
  } deriving (Show)

setTerminator :: AST.Terminator -> BasicBlock ()
setTerminator term = do
  st <- get
  put $! st{basicBlockTerminator = Just (AST.Do term)}

data Label = Label AST.Name

newtype Terminator a = Terminator a deriving (Functor, Show)

instance Applicative Terminator where
  pure = Terminator
  Terminator f <*> x = f <$> x

evalBasicBlock :: AST.Name -> BasicBlock (Terminator a) -> FunctionDefinition (a, AST.BasicBlock)
evalBasicBlock n bb = do
  -- pattern match must be lazy to support the MonadFix instance
  ~(Terminator a, st, instr) <- runRWST (runBasicBlock bb) () (BasicBlockState n Nothing)
  return (a, AST.BasicBlock (basicBlockName st) instr (fromJust (basicBlockTerminator st)))

CallingConv.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}

module CallingConv where

import GHC.TypeLits

data CallingConv where
  CallingConv :: Nat -> CallingConv

type C            = 'CallingConv 0
type Fast         = 'CallingConv 8
type Cold         = 'CallingConv 9
type GHC          = 'CallingConv 10
type HiPE         = 'CallingConv 11
type X86_StdCall  = 'CallingConv 64
type X86_FastCall = 'CallingConv 65
type X86_64_Win64 = 'CallingConv 79

DefineBasicBlock.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecursiveDo #-}

module DefineBasicBlock where

import Control.Monad.RWS.Lazy
import Data.List as List
import qualified LLVM.General.AST as AST

import BasicBlock
import FreshName
import FunctionDefinition

basicBlock :: (DefineBasicBlock f, FreshName f, Monad f) => BasicBlock (Terminator ()) -> f Label
basicBlock bb = do
  n <- freshName
  namedBasicBlock n bb

class DefineBasicBlock f where
  namedBasicBlock :: AST.Name -> BasicBlock (Terminator ()) -> f Label

instance DefineBasicBlock FunctionDefinition where
  namedBasicBlock n bb = do
    ~FunctionDefinitionState{functionDefinitionBasicBlocks = originalBlocks} <- get
    ~(_, newBlock) <- evalBasicBlock n bb
    ~st@FunctionDefinitionState{functionDefinitionBasicBlocks = extraBlocks} <- get
    -- splice in the new block before any blocks defined while lifting
    put st{functionDefinitionBasicBlocks = originalBlocks <> (newBlock:List.drop (List.length originalBlocks) extraBlocks)}
    return $ Label n

instance DefineBasicBlock BasicBlock where
  namedBasicBlock n bb =
    liftFunctionDefinition (namedBasicBlock n bb)

FreshName.hs

{-# LANGUAGE KindSignatures #-}

module FreshName where

import Control.Monad.RWS.Lazy
import qualified LLVM.General.AST as AST

import BasicBlock
import FunctionDefinition

class FreshName (f :: * -> *) where
  freshName :: f AST.Name

instance FreshName BasicBlock where
  freshName =
    liftFunctionDefinition freshName

instance FreshName FunctionDefinition where
  freshName = do
    st@FunctionDefinitionState{functionDefinitionFreshId = fresh} <- get
    put $! st{functionDefinitionFreshId = fresh + 1}
    return $ AST.UnName fresh

nameInstruction :: AST.Instruction -> BasicBlock AST.Operand
nameInstruction instr = do
  n <- freshName
  tell [n AST.:= instr]
  return $ AST.LocalReference n

nameInstruction2
  :: (AST.Operand -> AST.Operand -> AST.InstructionMetadata -> AST.Instruction)
  -> AST.Operand
  -> AST.Operand
  -> BasicBlock AST.Operand
nameInstruction2 f x y = nameInstruction (f x y [])

Function.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}

module Function where

import CallingConv

data Function (cconv :: CallingConv) (a :: *)

FunctionDefinition.hs

{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module FunctionDefinition where

import Control.Applicative
import Control.Monad.Fix
import Control.Monad.RWS.Lazy
import Control.Monad.State.Lazy
import Data.Word
import qualified LLVM.General.AST as AST

newtype FunctionDefinition a = FunctionDefinition{runFunctionDefinition :: State FunctionDefinitionState a}
  deriving (Functor, Applicative, Monad, MonadFix, MonadState FunctionDefinitionState)

data FunctionDefinitionState = FunctionDefinitionState
  { functionDefinitionBasicBlocks :: [AST.BasicBlock]
  , functionDefinitionFreshId     :: {-# UNPACK #-} !Word
  }

Instructions.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

module Instructions where

import Control.Applicative
import Control.Monad.RWS.Lazy
import Data.Proxy
import Data.Traversable
import Foreign.Ptr (Ptr)
import GHC.TypeLits
import qualified LLVM.General.AST as AST
import qualified LLVM.General.AST.Attribute as Attribute
import qualified LLVM.General.AST.Constant as Constant
import qualified LLVM.General.AST.FloatingPointPredicate as FloatingPointPredicate
import qualified LLVM.General.AST.IntegerPredicate as IntegerPredicate

import AnyValue
import BasicBlock
import FreshName
import Function
import Value
import ValueOf
import VMap

ret
  :: ValueOf (Value const a)
  => Value const a
  -> BasicBlock (Terminator ())
ret value = do
  -- name the value, emitting instructions as necessary
  valueOp <- asOp value
  setTerminator $ AST.Ret (Just valueOp) []
  -- @TODO: replace with LocalReference ?
  return $ Terminator ()

ret_ :: BasicBlock (Terminator ())
ret_ = do
  setTerminator $ AST.Ret Nothing []
  return $ Terminator ()

condBr
  :: Value const Bool
  -> Label
  -> Label
  -> BasicBlock (Terminator ())
condBr condition (Label trueDest) (Label falseDest) = do
  conditionOp <- asOp condition
  setTerminator $ AST.CondBr conditionOp trueDest falseDest []
  return $ Terminator ()

br :: Label -> BasicBlock (Terminator ())
br (Label dest) = do
  setTerminator $ AST.Br dest []
  return $ Terminator ()

switch
  :: ( ClassificationOf (Value const a)     ~ IntegerClass,
       ClassificationOf (Value 'Constant a) ~ IntegerClass)
  => Value const a
  -> Label -- default
  -> [(Value 'Constant a, Label)]
  -> BasicBlock (Terminator ())
switch value (Label defaultDest) dests = do
  valueOp <- asOp value
  let dests' = [(val, dest) | (ValueConstant val, Label dest) <- dests]
  setTerminator $ AST.Switch valueOp defaultDest dests' []
  return $ Terminator ()

indirectBr = undefined

invoke = undefined

resume = undefined

unreachable
  :: BasicBlock (Terminator ())
unreachable = do
  setTerminator $ AST.Unreachable []
  return $ Terminator ()

undef
  :: forall a .
     ValueOf (Value 'Constant a)
  => BasicBlock (Value 'Constant a)
undef = do
  let val = Constant.Undef $ valueType (Proxy :: Proxy (Value 'Constant a))
  return $ ValueConstant val

class Phi (f :: * -> *) where
  phi :: ValueOf (Value 'Mutable a) => [(f a, Label)] -> BasicBlock (Value 'Mutable a)

instance Phi (Value const) where
  phi :: forall a . ValueOf (Value 'Mutable a) => [(Value const a, Label)] -> BasicBlock (Value 'Mutable a)
  phi incomingValues = do
    -- @TODO: make sure we have evaluated all of the values in the list...
    incomingValues' <- for incomingValues $ \ (val, Label origin) -> do
      valOp <- asOp val
      return (valOp, origin)

    let ty = valueType (Proxy :: Proxy (Value 'Mutable a))
    ValueOperand . return <$> nameInstruction (AST.Phi ty incomingValues' [])

instance Phi AnyValue where
  phi :: forall a . ValueOf (Value 'Mutable a) => [(AnyValue a, Label)] -> BasicBlock (Value 'Mutable a)
  phi incomingValues = do
    -- @TODO: make sure we have evaluated all of the values in the list...
    incomingValues' <- for incomingValues $ \ (AnyValue val, Label origin) -> do
      valOp <- asOp val
      return (valOp, origin)

    let ty = valueType (Proxy :: Proxy (Value 'Mutable a))
    ValueOperand . return <$> nameInstruction (AST.Phi ty incomingValues' [])

alloca
  :: forall a .
     ( ValueOf (Value 'Mutable a)
     , KnownNat (ElementsOf (Value 'Mutable a)))
  => BasicBlock (Value 'Mutable (Ptr a))
alloca = do
  let ty = valueType (Proxy :: Proxy (Value 'Mutable a))
      ne = natVal (Proxy :: Proxy (ElementsOf (Value 'Mutable a)))
  -- @TODO: the hardcoded 64 should probably be the target word size?
      inst = AST.Alloca ty (Just (AST.ConstantOperand (Constant.Int 64 ne))) 0 []
  ValueOperand . return <$> nameInstruction inst

load
  :: Value const (Ptr a)
  -> BasicBlock (Value 'Mutable a)
load x = do
  x' <- asOp x
  ValueOperand . return <$> nameInstruction (AST.Load False x' Nothing 0 [])

store
  :: Value cx (Ptr a)
  -> Value cy a
  -> BasicBlock ()
store address value = do
  address' <- asOp address
  value' <- asOp value
  let instr = AST.Store False address' value' Nothing 0 []
  tell [AST.Do instr]

{-
type family ResultType a :: *

class BundleArgs f where
  xxxx :: f -> BasicBlock [(AST.Operand, [Attribute.ParameterAttribute])]
  xxxx = undefined

call :: Function cconv ty -> args -> BasicBlock (ResultType ty)
call = error "call"
-}

data InBounds
  = InBounds
  | OutOfBounds
    deriving (Eq, Ord, Show)

class GetElementPtr a (i :: [*]) where
  type GetElementPtrType a i :: *
  getElementIndex :: a -> proxy i -> [AST.Operand]

getElementPtr
  :: (GetElementPtr (Value const a) i, ValueJoin const)
  => InBounds
  -> Value const a
  -> proxy i
  -> BasicBlock (Value const (Ptr (GetElementPtrType a i)))
getElementPtr bounds value indices =
  let inbounds = case bounds of InBounds -> True; OutOfBounds -> False
      idx = getElementIndex value indices
      f y = Constant.GetElementPtr inbounds y [error "damn"]
      g x = nameInstruction $ AST.GetElementPtr inbounds x idx []
  in vmap1' f g value

getElementPtr0
  :: forall a const i proxy . (GetElementPtr (Value const a) (Proxy 0 ': i), ValueJoin const)
  => InBounds
  -> Value const a
  -> proxy i
  -> BasicBlock (Value const (Ptr (GetElementPtrType a (Proxy 0 ': i))))
getElementPtr0 bounds val _ = getElementPtr bounds val (Proxy :: Proxy (Proxy 0 ': i))

class Name (const :: Constness) where
  name :: Value const a -> BasicBlock (Value const a)

instance Name 'Constant where
  name = return

instance Name 'Mutable where
  name val = do
    n <- freshName
    undefined

{-
name :: String -> Value const a -> BasicBlock (Value const a)
name = undefined

name_ :: Value const a -> BasicBlock (Value const a)
name_ = undefined
-}

trunc
  :: forall a b const .
     ( ClassificationOf (Value const a) ~ IntegerClass, ClassificationOf (Value const b) ~ IntegerClass
     , ValueOf (Value const b)
     , BitsOf (Value const b) + 1 <= BitsOf (Value const a)
     , ValueJoin const)
  => Value const a
  -> BasicBlock (Value const b)
trunc = vmap1' f g where
  vt = valueType (Proxy :: Proxy (Value const b))
  f v = Constant.Trunc v vt
  g v = nameInstruction $ AST.Trunc v vt []

bitcast
  :: forall a b const .
     ( BitsOf (Value const a) ~ BitsOf (Value const b)
     , ValueOf (Value const b)
     , ValueJoin const)
  => Value const a
  -> BasicBlock (Value const b)
bitcast = vmap1' f g where
  vt = valueType (Proxy :: Proxy (Value const b))
  f v = Constant.BitCast v vt
  g v = nameInstruction $ AST.BitCast v vt []

class Add (classification :: Classification) where
  vadd
    :: ClassificationOf (Value (cx `Weakest` cy) a) ~ classification
    => Value cx a
    -> Value cy a
    -> Value (cx `Weakest` cy) a

instance Add 'IntegerClass where
 vadd = vmap2 f g where
   f = Constant.Add False False
   g x y = nameInstruction $ AST.Add False False x y []

instance Add 'FloatingPointClass where
 vadd = vmap2 f g where
   f = Constant.FAdd
   g x y = nameInstruction $ AST.FAdd x y []


add
  :: ( Add (ClassificationOf (Value (cx `Weakest` cy) a))
     , ValueJoin (cx `Weakest` cy))
  => Value cx a
  -> Value cy a
  -> BasicBlock (Value (cx `Weakest` cy) a)
add x y = vjoin $ vadd x y

-- the condition constness must match the result constness. this implies that
-- if both true and false values are constant the switch condition must also be
-- a constant. if you want a constant condition but mutable values (for some reason...)
-- just wrap the condition with 'mutable'
select
  :: (ValueJoin (cc `Weakest` ct `Weakest` cf))
  => Value cc Bool
  -> Value ct a
  -> Value cf a
  -> BasicBlock (Value (cc `Weakest` ct `Weakest` cf) a)
select = vmap3' f g where
  f = Constant.Select
  g c t f' = nameInstruction $ AST.Select c t f' []

icmp
  :: ( ClassificationOf (Value (cx `Weakest` cy) a) ~ IntegerClass
     , ValueJoin (cx `Weakest` cy))
  => IntegerPredicate.IntegerPredicate
  -> Value cx a
  -> Value cy a
  -> BasicBlock (Value (cx `Weakest` cy) Bool)
icmp p = vmap2' f g where
  f = Constant.ICmp p
  g x y = nameInstruction $ AST.ICmp p x y []

fcmp
  :: ( ClassificationOf (Value (cx `Weakest` cy) a) ~ FloatingPointClass
     , ValueJoin (cx `Weakest` cy))
  => FloatingPointPredicate.FloatingPointPredicate
  -> Value cx a
  -> Value cy a
  -> BasicBlock (Value (cx `Weakest` cy) Bool)
fcmp p = vmap2' f g where
  f = Constant.FCmp p
  g x y = nameInstruction $ AST.FCmp p x y []

class Cmp (classification :: Classification) where
  cmp
    :: ( ClassificationOf (Value (cx `Weakest` cy) a) ~ classification
       , ValueJoin (cx `Weakest` cy))
    => Value cx a
    -> Value cy a
    -> BasicBlock (Value (cx `Weakest` cy) Bool)

instance Cmp 'IntegerClass where
  cmp = vmap2' f g where
    f = Constant.ICmp IntegerPredicate.EQ
    g x y = nameInstruction $ AST.ICmp IntegerPredicate.EQ x y []

instance Cmp 'FloatingPointClass where
  cmp = vmap2' f g where
    f = Constant.FCmp FloatingPointPredicate.OEQ
    g x y = nameInstruction $ AST.FCmp FloatingPointPredicate.OEQ x y []

Num.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Num where

import Data.Int
import Data.Proxy
import Data.Word
import GHC.TypeLits

import qualified LLVM.General.AST as AST
import qualified LLVM.General.AST.Constant as Constant
import qualified LLVM.General.AST.Float as Float
import qualified LLVM.General.AST.FloatingPointPredicate as FloatingPointPredicate
import qualified LLVM.General.AST.IntegerPredicate as IntegerPredicate

import BasicBlock
import FreshName
import Instructions
import Value
import ValueOf
import VMap

signumSigned
  :: forall const a .
     ( KnownNat (BitsOf (Value const a))
     , ClassificationOf (Value const a) ~ IntegerClass
     , Num (Value const a))
  => Value const a
  -> Value const a
signumSigned v =
  case v of
    x@ValueConstant{} -> evalConstantBasicBlock (f x)
    x@ValueMutable{}  -> ValueOperand (f x >>= asOp)
    x@ValueOperand{}  -> ValueOperand (f x >>= asOp)
 where
  f :: (ValueJoin const, Weakest const const ~ const)
    => Value const a
    -> BasicBlock (Value const a)
  f x = do
    gt <- icmp IntegerPredicate.SGT x (0 :: Value const a)
    lt <- icmp IntegerPredicate.SLT x (0 :: Value const a)
    il <- select lt (-1 :: Value const a) (0 :: Value const a)
    ig <- select gt ( 1 :: Value const a) il
    return ig

signumUnsigned
  :: forall const a .
     ( KnownNat (BitsOf (Value const a))
     , ClassificationOf (Value const a) ~ IntegerClass
     , Num (Value const a))
  => Value const a
  -> Value const a
signumUnsigned v =
  case v of
    x@ValueConstant{} -> evalConstantBasicBlock (f x)
    x@ValueMutable{}  -> ValueOperand (f x >>= asOp)
    x@ValueOperand{}  -> ValueOperand (f x >>= asOp)
 where
  f :: (ValueJoin const, Weakest const const ~ const)
    => Value const a
    -> BasicBlock (Value const a)
  f x = do
    gt <- icmp IntegerPredicate.UGT x (0 :: Value const a)
    select gt (1 :: Value const a) (0 :: Value const a)

signumFloating
  :: forall const a .
     ( KnownNat (BitsOf (Value const a))
     , ClassificationOf (Value const a) ~ FloatingPointClass
     , Num (Value const a))
  => Value const a
  -> Value const a
signumFloating v =
  case v of
    x@ValueConstant{} -> evalConstantBasicBlock (f x)
    x@ValueMutable{}  -> ValueOperand (f x >>= asOp)
    x@ValueOperand{}  -> ValueOperand (f x >>= asOp)
 where
  f :: (ValueJoin const, Weakest const const ~ const)
    => Value const a
    -> BasicBlock (Value const a)
  f x = do
    gt <- fcmp FloatingPointPredicate.OGT x (0 :: Value const a)
    lt <- fcmp FloatingPointPredicate.OLT x (0 :: Value const a)
    il <- select lt (-1 :: Value const a) (0 :: Value const a)
    select gt ( 1 :: Value const a) il

absSigned
  :: forall const a .
     ( KnownNat (BitsOf (Value const a))
     , ClassificationOf (Value const a) ~ IntegerClass
     , Num (Value const a))
  => Value const a
  -> Value const a
absSigned v = do
  case v of
    x@ValueConstant{} -> evalConstantBasicBlock (f x)
    x@ValueMutable{}  -> ValueOperand (f x >>= asOp)
    x@ValueOperand{}  -> ValueOperand (f x >>= asOp)
 where
  f :: (ValueJoin const, Weakest const const ~ const)
    => Value const a
    -> BasicBlock (Value const a)
  f x = do
    gt <- icmp IntegerPredicate.SGT x (0 :: Value const a)
    select gt (0 - x) x

absFloating
  :: forall const a .
     ( KnownNat (BitsOf (Value const a))
     , ClassificationOf (Value const a) ~ FloatingPointClass
     , Num (Value const a))
  => Value const a
  -> Value const a
absFloating v = do
  case v of
    x@ValueConstant{} -> evalConstantBasicBlock (f x)
    x@ValueMutable{}  -> ValueOperand (f x >>= asOp)
    x@ValueOperand{}  -> ValueOperand (f x >>= asOp)
 where
  f :: (ValueJoin const, Weakest const const ~ const)
    => Value const a
    -> BasicBlock (Value const a)
  f x = do
    gt <- fcmp FloatingPointPredicate.OGT x (0 :: Value const a)
    select gt (0 - x) x

fromIntegerConst
  :: forall a const . (KnownNat (BitsOf (Value const a)), InjectConstant const)
  => Integer
  -> Value const a
fromIntegerConst = injectConstant . Constant.Int bits where
  bits = fromIntegral $ natVal (Proxy :: Proxy (BitsOf (Value const a)))

instance (InjectConstant const, Weakest const const ~ const) => Num (Value const Float) where
  fromInteger = injectConstant . Constant.Float . Float.Single . fromIntegral
  abs = absFloating
  (+) = vmap2 Constant.FAdd (nameInstruction2 AST.FAdd)
  (-) = vmap2 Constant.FSub (nameInstruction2 AST.FSub)
  (*) = vmap2 Constant.FMul (nameInstruction2 AST.FMul)
  signum = signumFloating

instance (InjectConstant const, Weakest const const ~ const) => Num (Value const Double) where
  fromInteger = injectConstant . Constant.Float . Float.Double . fromIntegral
  abs = absFloating
  (+) = vmap2 Constant.FAdd (nameInstruction2 AST.FAdd)
  (-) = vmap2 Constant.FSub (nameInstruction2 AST.FSub)
  (*) = vmap2 Constant.FMul (nameInstruction2 AST.FMul)
  signum = signumFloating

instance (InjectConstant const, Weakest const const ~ const, Num (Value const Float)) => Fractional (Value const Float) where
  fromRational = injectConstant . Constant.Float . Float.Single . fromRational
  (/) = vmap2 Constant.FDiv (nameInstruction2 AST.FDiv)

instance (InjectConstant const, Weakest const const ~ const, Num (Value const Double)) => Fractional (Value const Double) where
  fromRational = injectConstant . Constant.Float . Float.Double . fromRational
  (/) = vmap2 Constant.FDiv (nameInstruction2 AST.FDiv)

instance (InjectConstant const, Weakest const const ~ const) => Num (Value const Int8) where
  fromInteger = fromIntegerConst
  abs = absSigned
  (+) = vmap2 (Constant.Add False False) (nameInstruction2 (AST.Add False False))
  (-) = vmap2 (Constant.Sub False False) (nameInstruction2 (AST.Sub False False))
  (*) = vmap2 (Constant.Mul False False) (nameInstruction2 (AST.Mul False False))
  signum = signumSigned

instance (InjectConstant const, Weakest const const ~ const) => Num (Value const Int16) where
  fromInteger = fromIntegerConst
  abs = absSigned
  (+) = vmap2 (Constant.Add False False) (nameInstruction2 (AST.Add False False))
  (-) = vmap2 (Constant.Sub False False) (nameInstruction2 (AST.Sub False False))
  (*) = vmap2 (Constant.Mul False False) (nameInstruction2 (AST.Mul False False))
  signum = signumSigned

instance (InjectConstant const, Weakest const const ~ const) => Num (Value const Int32) where
  fromInteger = fromIntegerConst
  abs = absSigned
  (+) = vmap2 (Constant.Add False False) (nameInstruction2 (AST.Add False False))
  (-) = vmap2 (Constant.Sub False False) (nameInstruction2 (AST.Sub False False))
  (*) = vmap2 (Constant.Mul False False) (nameInstruction2 (AST.Mul False False))
  signum = signumSigned

instance (InjectConstant const, Weakest const const ~ const) => Num (Value const Int64) where
  fromInteger = fromIntegerConst
  abs = absSigned
  (+) = vmap2 (Constant.Add False False) (nameInstruction2 (AST.Add False False))
  (-) = vmap2 (Constant.Sub False False) (nameInstruction2 (AST.Sub False False))
  (*) = vmap2 (Constant.Mul False False) (nameInstruction2 (AST.Mul False False))
  signum = signumSigned

instance (InjectConstant const, Weakest const const ~ const) => Num (Value const Word8) where
  fromInteger = fromIntegerConst
  abs = id
  (+) = vmap2 (Constant.Add False False) (nameInstruction2 (AST.Add False False))
  (-) = vmap2 (Constant.Sub False False) (nameInstruction2 (AST.Sub False False))
  (*) = vmap2 (Constant.Mul False False) (nameInstruction2 (AST.Mul False False))
  signum = signumUnsigned

instance (InjectConstant const, Weakest const const ~ const) => Num (Value const Word16) where
  fromInteger = fromIntegerConst
  abs = id
  (+) = vmap2 (Constant.Add False False) (nameInstruction2 (AST.Add False False))
  (-) = vmap2 (Constant.Sub False False) (nameInstruction2 (AST.Sub False False))
  (*) = vmap2 (Constant.Mul False False) (nameInstruction2 (AST.Mul False False))
  signum = signumUnsigned

instance (InjectConstant const, Weakest const const ~ const) => Num (Value const Word32) where
  fromInteger = fromIntegerConst
  abs = id
  (+) = vmap2 (Constant.Add False False) (nameInstruction2 (AST.Add False False))
  (-) = vmap2 (Constant.Sub False False) (nameInstruction2 (AST.Sub False False))
  (*) = vmap2 (Constant.Mul False False) (nameInstruction2 (AST.Mul False False))
  signum = signumUnsigned

instance (InjectConstant const, Weakest const const ~ const) => Num (Value const Word64) where
  fromInteger = fromIntegerConst
  abs = id
  (+) = vmap2 (Constant.Add False False) (nameInstruction2 (AST.Add False False))
  (-) = vmap2 (Constant.Sub False False) (nameInstruction2 (AST.Sub False False))
  (*) = vmap2 (Constant.Mul False False) (nameInstruction2 (AST.Mul False False))
  signum = signumUnsigned

Setup.hs

import Distribution.Simple
main = defaultMain

Value.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

module Value where

import Control.Monad.RWS.Lazy
import Control.Monad.State.Lazy

import qualified LLVM.General.AST as AST
import qualified LLVM.General.AST.Constant as Constant

import BasicBlock
import FunctionDefinition

data Constness = Constant | Mutable

type family Weakest (x :: k) (y :: k) :: k where
  Weakest 'Constant 'Constant = 'Constant
  Weakest x         y         = 'Mutable

data Value (const :: Constness) (a :: *) where
  ValueMutable     :: Value 'Constant a      -> Value 'Mutable a
  ValueOperand     :: BasicBlock AST.Operand -> Value 'Mutable a
  ValueConstant    :: Constant.Constant      -> Value 'Constant a

mutable :: Value 'Constant a -> Value 'Mutable a
mutable = ValueMutable

constant :: Value 'Constant a -> Value 'Constant a
constant = id

class Weaken (const :: Constness) where
  weaken :: Value const a -> Value 'Mutable a

instance Weaken 'Constant where
  weaken = mutable

instance Weaken 'Mutable where
  weaken = id

class InjectConstant (const :: Constness) where
  injectConstant :: Constant.Constant -> Value const a

instance InjectConstant 'Mutable where
  injectConstant = ValueMutable . injectConstant

instance InjectConstant 'Constant where
  injectConstant = ValueConstant

class ValueJoin (const :: Constness) where
  vjoin :: Value const a -> BasicBlock (Value const a)

instance ValueJoin 'Mutable where
  vjoin (ValueOperand a) = a >>= return . ValueOperand . return
  vjoin a = return a

instance ValueJoin 'Constant where
  vjoin a = return a

evalConstantBasicBlock
  :: BasicBlock (Value 'Constant a)
  -> Value 'Constant a
evalConstantBasicBlock (BasicBlock v) =
  let m = evalRWST v () (BasicBlockState (error "name") Nothing)
  in fst $ evalState (runFunctionDefinition m) (FunctionDefinitionState [] 0)

asOp
  :: Value const a
  -> BasicBlock AST.Operand
asOp (ValueConstant x) = return $ AST.ConstantOperand x
asOp (ValueMutable x) = asOp x
asOp (ValueOperand x) = x

ValueOf.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module ValueOf where

import Data.Int
import Data.Word
import GHC.TypeLits
import qualified LLVM.General.AST as AST

import Value

data Classification
  = IntegerClass
  | FloatingPointClass
  | PointerClass
  | VectorClass
  | StructureClass
  | LabelClass
  | MetadataClass

class ValueOf (a :: *) where
  type WordsOf a :: Nat
  type BitsOf a :: Nat
  type BitsOf a = WordsOf a * 8
  type ElementsOf a :: Nat
  type ElementsOf a = 1
  type ClassificationOf a :: Classification
  valueType :: proxy a -> AST.Type

instance ValueOf (Value const Int8) where
  type WordsOf (Value const Int8) = 1
  type ClassificationOf (Value const Int8) = IntegerClass
  valueType _ = AST.IntegerType 8

instance ValueOf (Value const Int16) where
  type WordsOf (Value const Int16) = 2
  type ClassificationOf (Value const Int16) = IntegerClass
  valueType _ = AST.IntegerType 16

instance ValueOf (Value const Int32) where
  type WordsOf (Value const Int32) = 4
  type ClassificationOf (Value const Int32) = IntegerClass
  valueType _ = AST.IntegerType 32

instance ValueOf (Value const Int64) where
  type WordsOf (Value const Int64) = 8
  type ClassificationOf (Value const Int64) = IntegerClass
  valueType _ = AST.IntegerType 64

instance ValueOf (Value const Word8) where
  type WordsOf (Value const Word8) = 1
  type ClassificationOf (Value const Word8) = IntegerClass
  valueType _ = AST.IntegerType 8

instance ValueOf (Value const Word16) where
  type WordsOf (Value const Word16) = 2
  type ClassificationOf (Value const Word16) = IntegerClass
  valueType _ = AST.IntegerType 16

instance ValueOf (Value const Word32) where
  type WordsOf (Value const Word32) = 4
  type ClassificationOf (Value const Word32) = IntegerClass
  valueType _ = AST.IntegerType 32

instance ValueOf (Value const Word64) where
  type WordsOf (Value const Word64) = 8
  type ClassificationOf (Value const Word64) = IntegerClass
  valueType _ = AST.IntegerType 64

instance ValueOf (Value const Float) where
  type WordsOf (Value const Float) = 4
  type ClassificationOf (Value const Float) = FloatingPointClass
  valueType _ = AST.FloatingPointType 32 AST.IEEE

instance ValueOf (Value const Double) where
  type WordsOf (Value const Double) = 8
  type ClassificationOf (Value const Double) = FloatingPointClass
  valueType _ = AST.FloatingPointType 64 AST.IEEE

VMap.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-}

module VMap where

import Control.Applicative
import Control.Monad

import LLVM.General.AST (Operand)
import LLVM.General.AST.Constant (Constant)

import BasicBlock
import Value

vmap1
  :: (Constant -> Constant)
  -> (Operand -> BasicBlock Operand)
  -> Value const a
  -> Value const b
vmap1 f _ (ValueConstant x) = ValueConstant (f x)
vmap1 f g (ValueMutable x)  = weaken (vmap1 f g x)
vmap1 _ g x@ValueOperand{}  = ValueOperand (join (g <$> asOp x))

vmap1'
  :: (ValueJoin const)
  => (Constant -> Constant)
  -> (Operand -> BasicBlock Operand)
  -> Value const a
  -> BasicBlock (Value const b)
vmap1' f g a = vjoin (vmap1 f g a)

vmap2
  :: forall a b cx cy r .
     (Constant -> Constant -> Constant)
  -> (Operand -> Operand -> BasicBlock Operand)
  -> Value cx a
  -> Value cy b
  -> Value (cx `Weakest` cy) r
vmap2 f g = k where
  j :: Value cx a -> Value cy b -> Value 'Mutable r
  j x y = ValueOperand (join (g <$> asOp x <*> asOp y))
  k (ValueConstant x) (ValueConstant y) = ValueConstant (f x y)
  k (ValueMutable x)  (ValueMutable y)  = weaken (vmap2 f g x y)
  -- prepare to experience many pleasures of the GADT
  k x@ValueOperand{} y = j x y
  k x y@ValueOperand{} = j x y
  k x@ValueMutable{} y = j x y
  k x y@ValueMutable{} = j x y

vmap2'
  :: (ValueJoin (cx `Weakest` cy))
  => (Constant -> Constant -> Constant)
  -> (Operand -> Operand -> BasicBlock Operand)
  -> Value cx a
  -> Value cy b
  -> BasicBlock (Value (cx `Weakest` cy) r)
vmap2' f g a b = vjoin (vmap2 f g a b)

vmap3
  :: forall a b c cx cy cz r .
     (Constant -> Constant -> Constant -> Constant)
  -> (Operand -> Operand -> Operand -> BasicBlock Operand)
  -> Value cx a
  -> Value cy b
  -> Value cz c
  -> Value (cx `Weakest` cy `Weakest` cz) r
vmap3 f g = k where
  j :: Value cx a -> Value cy b -> Value cz c -> Value 'Mutable r
  j x y z = ValueOperand (join (g <$> asOp x <*> asOp y <*> asOp z))
  k (ValueConstant x) (ValueConstant y) (ValueConstant z) = ValueConstant (f x y z)
  k (ValueMutable x)  (ValueMutable y)  (ValueMutable z)  = weaken (vmap3 f g x y z)
  -- prove we're dealing with a mutable result type
  k x@ValueOperand{} y z = j x y z
  k x y@ValueOperand{} z = j x y z
  k x y z@ValueOperand{} = j x y z
  k x@ValueMutable{} y z = j x y z
  k x y@ValueMutable{} z = j x y z
  k x y z@ValueMutable{} = j x y z

vmap3'
  :: (ValueJoin (cx `Weakest` cy `Weakest` cz))
  => (Constant -> Constant -> Constant -> Constant)
  -> (Operand -> Operand -> Operand -> BasicBlock Operand)
  -> Value cx a
  -> Value cy b
  -> Value cz c
  -> BasicBlock (Value (cx `Weakest` cy `Weakest` cz) r)
vmap3' f g a b c = vjoin (vmap3 f g a b c)

x.cabal

-- Initial x.cabal generated by cabal init.  For further documentation, see
--  http://haskell.org/cabal/users-guide/

name:                x
version:             0.1.0.0
-- synopsis:            
-- description:         
-- license:             
license-file:        LICENSE
author:              Nathan Howell
maintainer:          nhowell@alphaheavy.com
-- copyright:           
-- category:            
build-type:          Simple
-- extra-source-files:  
cabal-version:       >=1.10

executable x
  main-is:             x.hs
  -- other-modules:       
  -- other-extensions:    
  build-depends:       base >=4.7 && <4.8, llvm-general, llvm-general-pure, void, transformers, mtl
  -- hs-source-dirs:      
  default-language:    Haskell2010

x.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecursiveDo #-}

module Main where

import Control.Applicative
import Control.Monad
import Control.Monad.Fix
import Control.Monad.RWS.Lazy
import Control.Monad.State.Lazy
import Data.Int
import qualified LLVM.General.AST as AST
import qualified LLVM.General.AST.Global as Global
import LLVM.General.PrettyPrint (showPretty)

import DefineBasicBlock
import Function
import FunctionDefinition
import Instructions
import Num ()
import Value

newtype Module a = Module{runModule :: State ModuleState a}
  deriving (Functor, Applicative, Monad, MonadFix, MonadState ModuleState)

data ModuleState = ModuleState
  { moduleName        :: String
  , moduleDefinitions :: [AST.Definition]
  }

newtype Globals a = Globals{runGlobals :: State [AST.Global] a}
  deriving (Functor, Applicative, Monad, MonadFix, MonadState [AST.Global])

evalModule :: Module a -> (AST.Module, a)
evalModule (Module a) = (m, a') where
  m = AST.Module n Nothing Nothing defs
  n = moduleName st'
  defs = moduleDefinitions st'
  st = ModuleState{moduleName = "unnamed module", moduleDefinitions = []}
  ~(a', st') = runState a st

namedModule :: String -> Globals a -> Module a
namedModule n body = do
  let ~(a, defs) = runState (runGlobals body) []
  st <- get
  put $!  st{moduleName = n, moduleDefinitions = fmap AST.GlobalDefinition defs}
  return a

namedFunction :: String -> FunctionDefinition a -> Globals (Function cconv ty, a)
namedFunction n defn = do
  let defnSt = FunctionDefinitionState{functionDefinitionBasicBlocks = [], functionDefinitionFreshId = 0}
      ~(a, defSt') = runState (runFunctionDefinition defn) defnSt
      x = AST.functionDefaults
           { Global.basicBlocks = functionDefinitionBasicBlocks defSt'
           , Global.name = AST.Name n
           , Global.returnType = AST.IntegerType 8
           }
  st <- get
  put $! x:st
  return (error "foo", a)

externalFunction :: String -> Globals ty
externalFunction = error "externalFunction"

foo :: Module ()
foo = do
  let val :: Value 'Constant Int8
      val = 42 + 9

  namedModule "foo" $ do
    void . namedFunction "bar" $ mdo
      entryBlock <- basicBlock $ do
        br secondBlock

      secondBlock <- namedBasicBlock (AST.Name "second") $ do
        someLocalPtr <- alloca
        store someLocalPtr (99 :: Value 'Constant Int8)
        someLocal <- load someLocalPtr
        x <- val `add` someLocal
        join $ condBr
          <$> cmp someLocal (mutable 99)
          <*> basicBlock (ret $ abs x * someLocal + mutable (val - signum 8))
          <*> basicBlock (br entryBlock)

      return ()

main :: IO ()
main = do
  putStrLn . showPretty . fst $ evalModule foo