{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TypeApplications           #-}
{-# OPTIONS_HADDOCK hide #-}
-- |
-- Module      : Data.Array.Accelerate.LLVM.CodeGen.Monad
-- Copyright   : [2015..2020] The Accelerate Team
-- License     : BSD3
--
-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>
-- Stability   : experimental
-- Portability : non-portable (GHC extensions)
--

module Data.Array.Accelerate.LLVM.CodeGen.Monad (

  CodeGen,
  evalCodeGen,
  liftCodeGen,

  -- declarations
  fresh, freshName,
  declare,
  intrinsic,

  -- basic blocks
  Block,
  newBlock, setBlock, beginBlock, createBlocks,

  -- instructions
  instr, instr', do_, return_, retval_, br, cbr, switch, phi, phi', phi1,
  instr_,

  -- metadata
  addMetadata,

) where

import Data.Array.Accelerate.Error
import Data.Array.Accelerate.LLVM.CodeGen.IR
import Data.Array.Accelerate.LLVM.CodeGen.Intrinsic
import Data.Array.Accelerate.LLVM.CodeGen.Module
import Data.Array.Accelerate.LLVM.CodeGen.Sugar                     ( IROpenAcc(..) )
import Data.Array.Accelerate.LLVM.State                             ( LLVM )
import Data.Array.Accelerate.LLVM.Target
import Data.Array.Accelerate.Representation.Tag
import Data.Array.Accelerate.Representation.Type
import qualified Data.Array.Accelerate.Debug                        as Debug

import LLVM.AST.Type.Constant
import LLVM.AST.Type.Downcast
import LLVM.AST.Type.Instruction
import LLVM.AST.Type.Metadata
import LLVM.AST.Type.Name
import LLVM.AST.Type.Operand
import LLVM.AST.Type.Representation
import LLVM.AST.Type.Terminator
import qualified LLVM.AST                                           as LLVM
import qualified LLVM.AST.Global                                    as LLVM

import Control.Applicative
import Control.Monad.State
import Data.ByteString.Short                                        ( ShortByteString )
import Data.Function
import Data.HashMap.Strict                                          ( HashMap )
import Data.Map                                                     ( Map )
import Data.Sequence                                                ( Seq )
import Data.String
import Prelude
import Text.Printf
import qualified Data.Foldable                                      as F
import qualified Data.HashMap.Strict                                as HashMap
import qualified Data.Map                                           as Map
import qualified Data.Sequence                                      as Seq
import qualified Data.ByteString.Short                              as B


-- Code generation
-- ===============

-- | The code generation state for scalar functions and expressions.
--
-- We use two records: one to hold all the code generation state as it walks the
-- AST, and one for each of the basic blocks that are generated during the walk.
--
data CodeGenState = CodeGenState
  { CodeGenState -> Seq Block
blockChain          :: Seq Block                                      -- blocks for this function
  , CodeGenState -> Map Label Global
symbolTable         :: Map Label LLVM.Global                          -- global (external) function declarations
  , CodeGenState -> HashMap ShortByteString (Seq [Maybe Metadata])
metadataTable       :: HashMap ShortByteString (Seq [Maybe Metadata]) -- module metadata to be collected
  , CodeGenState -> HashMap ShortByteString Label
intrinsicTable      :: HashMap ShortByteString Label                  -- standard math intrinsic functions
  , CodeGenState -> Word
next                :: {-# UNPACK #-} !Word                           -- a name supply
  }

data Block = Block
  { Block -> Label
blockLabel          :: {-# UNPACK #-} !Label                          -- block label
  , Block -> Seq (Named Instruction)
instructions        :: Seq (LLVM.Named LLVM.Instruction)              -- stack of instructions
  , Block -> Terminator
terminator          :: LLVM.Terminator                                -- block terminator
  }

newtype CodeGen target a = CodeGen { CodeGen target a -> StateT CodeGenState (LLVM target) a
runCodeGen :: StateT CodeGenState (LLVM target) a }
  deriving (a -> CodeGen target b -> CodeGen target a
(a -> b) -> CodeGen target a -> CodeGen target b
(forall a b. (a -> b) -> CodeGen target a -> CodeGen target b)
-> (forall a b. a -> CodeGen target b -> CodeGen target a)
-> Functor (CodeGen target)
forall a b. a -> CodeGen target b -> CodeGen target a
forall a b. (a -> b) -> CodeGen target a -> CodeGen target b
forall target a b. a -> CodeGen target b -> CodeGen target a
forall target a b. (a -> b) -> CodeGen target a -> CodeGen target b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> CodeGen target b -> CodeGen target a
$c<$ :: forall target a b. a -> CodeGen target b -> CodeGen target a
fmap :: (a -> b) -> CodeGen target a -> CodeGen target b
$cfmap :: forall target a b. (a -> b) -> CodeGen target a -> CodeGen target b
Functor, Functor (CodeGen target)
a -> CodeGen target a
Functor (CodeGen target)
-> (forall a. a -> CodeGen target a)
-> (forall a b.
    CodeGen target (a -> b) -> CodeGen target a -> CodeGen target b)
-> (forall a b c.
    (a -> b -> c)
    -> CodeGen target a -> CodeGen target b -> CodeGen target c)
-> (forall a b.
    CodeGen target a -> CodeGen target b -> CodeGen target b)
-> (forall a b.
    CodeGen target a -> CodeGen target b -> CodeGen target a)
-> Applicative (CodeGen target)
CodeGen target a -> CodeGen target b -> CodeGen target b
CodeGen target a -> CodeGen target b -> CodeGen target a
CodeGen target (a -> b) -> CodeGen target a -> CodeGen target b
(a -> b -> c)
-> CodeGen target a -> CodeGen target b -> CodeGen target c
forall target. Functor (CodeGen target)
forall a. a -> CodeGen target a
forall target a. a -> CodeGen target a
forall a b.
CodeGen target a -> CodeGen target b -> CodeGen target a
forall a b.
CodeGen target a -> CodeGen target b -> CodeGen target b
forall a b.
CodeGen target (a -> b) -> CodeGen target a -> CodeGen target b
forall target a b.
CodeGen target a -> CodeGen target b -> CodeGen target a
forall target a b.
CodeGen target a -> CodeGen target b -> CodeGen target b
forall target a b.
CodeGen target (a -> b) -> CodeGen target a -> CodeGen target b
forall a b c.
(a -> b -> c)
-> CodeGen target a -> CodeGen target b -> CodeGen target c
forall target a b c.
(a -> b -> c)
-> CodeGen target a -> CodeGen target b -> CodeGen target c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: CodeGen target a -> CodeGen target b -> CodeGen target a
$c<* :: forall target a b.
CodeGen target a -> CodeGen target b -> CodeGen target a
*> :: CodeGen target a -> CodeGen target b -> CodeGen target b
$c*> :: forall target a b.
CodeGen target a -> CodeGen target b -> CodeGen target b
liftA2 :: (a -> b -> c)
-> CodeGen target a -> CodeGen target b -> CodeGen target c
$cliftA2 :: forall target a b c.
(a -> b -> c)
-> CodeGen target a -> CodeGen target b -> CodeGen target c
<*> :: CodeGen target (a -> b) -> CodeGen target a -> CodeGen target b
$c<*> :: forall target a b.
CodeGen target (a -> b) -> CodeGen target a -> CodeGen target b
pure :: a -> CodeGen target a
$cpure :: forall target a. a -> CodeGen target a
$cp1Applicative :: forall target. Functor (CodeGen target)
Applicative, Applicative (CodeGen target)
a -> CodeGen target a
Applicative (CodeGen target)
-> (forall a b.
    CodeGen target a -> (a -> CodeGen target b) -> CodeGen target b)
-> (forall a b.
    CodeGen target a -> CodeGen target b -> CodeGen target b)
-> (forall a. a -> CodeGen target a)
-> Monad (CodeGen target)
CodeGen target a -> (a -> CodeGen target b) -> CodeGen target b
CodeGen target a -> CodeGen target b -> CodeGen target b
forall target. Applicative (CodeGen target)
forall a. a -> CodeGen target a
forall target a. a -> CodeGen target a
forall a b.
CodeGen target a -> CodeGen target b -> CodeGen target b
forall a b.
CodeGen target a -> (a -> CodeGen target b) -> CodeGen target b
forall target a b.
CodeGen target a -> CodeGen target b -> CodeGen target b
forall target a b.
CodeGen target a -> (a -> CodeGen target b) -> CodeGen target b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> CodeGen target a
$creturn :: forall target a. a -> CodeGen target a
>> :: CodeGen target a -> CodeGen target b -> CodeGen target b
$c>> :: forall target a b.
CodeGen target a -> CodeGen target b -> CodeGen target b
>>= :: CodeGen target a -> (a -> CodeGen target b) -> CodeGen target b
$c>>= :: forall target a b.
CodeGen target a -> (a -> CodeGen target b) -> CodeGen target b
$cp1Monad :: forall target. Applicative (CodeGen target)
Monad, MonadState CodeGenState)

liftCodeGen :: LLVM arch a -> CodeGen arch a
liftCodeGen :: LLVM arch a -> CodeGen arch a
liftCodeGen = StateT CodeGenState (LLVM arch) a -> CodeGen arch a
forall target a.
StateT CodeGenState (LLVM target) a -> CodeGen target a
CodeGen (StateT CodeGenState (LLVM arch) a -> CodeGen arch a)
-> (LLVM arch a -> StateT CodeGenState (LLVM arch) a)
-> LLVM arch a
-> CodeGen arch a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LLVM arch a -> StateT CodeGenState (LLVM arch) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift


{-# INLINEABLE evalCodeGen #-}
evalCodeGen
    :: forall arch aenv a. (HasCallStack, Target arch, Intrinsic arch)
    => CodeGen arch (IROpenAcc arch aenv a)
    -> LLVM    arch (Module    arch aenv a)
evalCodeGen :: CodeGen arch (IROpenAcc arch aenv a)
-> LLVM arch (Module arch aenv a)
evalCodeGen CodeGen arch (IROpenAcc arch aenv a)
ll = do
  (IROpenAcc [Kernel arch aenv a]
ks, CodeGenState
st)   <- StateT CodeGenState (LLVM arch) (IROpenAcc arch aenv a)
-> CodeGenState -> LLVM arch (IROpenAcc arch aenv a, CodeGenState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (CodeGen arch (IROpenAcc arch aenv a)
-> StateT CodeGenState (LLVM arch) (IROpenAcc arch aenv a)
forall target a.
CodeGen target a -> StateT CodeGenState (LLVM target) a
runCodeGen CodeGen arch (IROpenAcc arch aenv a)
ll)
                        (CodeGenState -> LLVM arch (IROpenAcc arch aenv a, CodeGenState))
-> CodeGenState -> LLVM arch (IROpenAcc arch aenv a, CodeGenState)
forall a b. (a -> b) -> a -> b
$ CodeGenState :: Seq Block
-> Map Label Global
-> HashMap ShortByteString (Seq [Maybe Metadata])
-> HashMap ShortByteString Label
-> Word
-> CodeGenState
CodeGenState
                            { blockChain :: Seq Block
blockChain        = Seq Block
HasCallStack => Seq Block
initBlockChain
                            , symbolTable :: Map Label Global
symbolTable       = Map Label Global
forall k a. Map k a
Map.empty
                            , metadataTable :: HashMap ShortByteString (Seq [Maybe Metadata])
metadataTable     = HashMap ShortByteString (Seq [Maybe Metadata])
forall k v. HashMap k v
HashMap.empty
                            , intrinsicTable :: HashMap ShortByteString Label
intrinsicTable    = Intrinsic arch => HashMap ShortByteString Label
forall arch. Intrinsic arch => HashMap ShortByteString Label
intrinsicForTarget @arch
                            , next :: Word
next              = Word
0
                            }

  let ([Global]
kernels, Map Name (KernelMetadata arch)
md)     = let ([Global]
fs, [(Name, KernelMetadata arch)]
as) = [(Global, (Name, KernelMetadata arch))]
-> ([Global], [(Name, KernelMetadata arch)])
forall a b. [(a, b)] -> ([a], [b])
unzip [ (Global
f , (Global -> Name
LLVM.name Global
f, KernelMetadata arch
a)) | Kernel Global
f KernelMetadata arch
a <- [Kernel arch aenv a]
ks ]
                          in  ([Global]
fs, [(Name, KernelMetadata arch)] -> Map Name (KernelMetadata arch)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Name, KernelMetadata arch)]
as)

      definitions :: [Definition]
definitions       = (Global -> Definition) -> [Global] -> [Definition]
forall a b. (a -> b) -> [a] -> [b]
map Global -> Definition
LLVM.GlobalDefinition ([Global]
kernels [Global] -> [Global] -> [Global]
forall a. [a] -> [a] -> [a]
++ Map Label Global -> [Global]
forall k a. Map k a -> [a]
Map.elems (CodeGenState -> Map Label Global
symbolTable CodeGenState
st))
                       [Definition] -> [Definition] -> [Definition]
forall a. [a] -> [a] -> [a]
++ HashMap ShortByteString (Seq [Maybe Metadata]) -> [Definition]
createMetadata (CodeGenState -> HashMap ShortByteString (Seq [Maybe Metadata])
metadataTable CodeGenState
st)

      name :: ShortByteString
name | Global
x:[Global]
_               <- [Global]
kernels
           , f :: Global
f@LLVM.Function{} <- Global
x
           , LLVM.Name ShortByteString
s       <- Global -> Name
LLVM.name Global
f = ShortByteString
s
           | Bool
otherwise                        = ShortByteString
"<undefined>"

  Module arch aenv a -> LLVM arch (Module arch aenv a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Module arch aenv a -> LLVM arch (Module arch aenv a))
-> Module arch aenv a -> LLVM arch (Module arch aenv a)
forall a b. (a -> b) -> a -> b
$
    Module :: forall arch aenv a.
Module -> Map Name (KernelMetadata arch) -> Module arch aenv a
Module { moduleMetadata :: Map Name (KernelMetadata arch)
moduleMetadata = Map Name (KernelMetadata arch)
md
           , unModule :: Module
unModule       = Module :: ShortByteString
-> ShortByteString
-> Maybe DataLayout
-> Maybe ShortByteString
-> [Definition]
-> Module
LLVM.Module
                            { moduleName :: ShortByteString
LLVM.moduleName           = ShortByteString
name
                            , moduleSourceFileName :: ShortByteString
LLVM.moduleSourceFileName = ShortByteString
B.empty
                            , moduleDataLayout :: Maybe DataLayout
LLVM.moduleDataLayout     = Target arch => Maybe DataLayout
forall t. Target t => Maybe DataLayout
targetDataLayout @arch
                            , moduleTargetTriple :: Maybe ShortByteString
LLVM.moduleTargetTriple   = Target arch => Maybe ShortByteString
forall t. Target t => Maybe ShortByteString
targetTriple @arch
                            , moduleDefinitions :: [Definition]
LLVM.moduleDefinitions    = [Definition]
definitions
                            }
           }


-- Basic Blocks
-- ============

-- | An initial block chain
--
initBlockChain :: HasCallStack => Seq Block
initBlockChain :: Seq Block
initBlockChain
  = Block -> Seq Block
forall a. a -> Seq a
Seq.singleton
  (Block -> Seq Block) -> Block -> Seq Block
forall a b. (a -> b) -> a -> b
$ Label -> Seq (Named Instruction) -> Terminator -> Block
Block Label
"entry" Seq (Named Instruction)
forall a. Seq a
Seq.empty (String -> Terminator
forall a. HasCallStack => String -> a
internalError String
"block has no terminator")


-- | Create a new basic block, but don't yet add it to the block chain. You need
-- to call 'setBlock' to append it to the chain, so that subsequent instructions
-- are added to this block.
--
-- Note: [Basic blocks]
--
-- The names of basic blocks are generated based on the base name provided to
-- the 'newBlock' function, as well as the current state (length) of the block
-- stream. By not immediately adding new blocks to the stream, we have the
-- advantage that:
--
--   1. Instructions are generated "in order", and are always appended to the
--      stream. There is no need to search the stream for a block of the right
--      name.
--
--   2. Blocks are named in groups, which helps readability. For example, the
--      blocks for the then and else branches of a conditional, created at the
--      same time, will be named similarly: 'if4.then' and 'if4.else', etc.
--
-- However, this leads to a slight awkwardness when walking the AST. Since a new
-- naming group scheme is only applied *after* a call to 'setBlock',
-- encountering (say) nested conditionals in the walk will generate logically
-- distinct blocks that happen to have the same name. This means that
-- instructions might be added to the wrong blocks, or the first set of blocks
-- will be emitted empty and/or without a terminator.
--
newBlock :: HasCallStack => String -> CodeGen arch Block
newBlock :: String -> CodeGen arch Block
newBlock String
nm =
  (CodeGenState -> (Block, CodeGenState)) -> CodeGen arch Block
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state ((CodeGenState -> (Block, CodeGenState)) -> CodeGen arch Block)
-> (CodeGenState -> (Block, CodeGenState)) -> CodeGen arch Block
forall a b. (a -> b) -> a -> b
$ \CodeGenState
s ->
    let idx :: Int
idx     = Seq Block -> Int
forall a. Seq a -> Int
Seq.length (CodeGenState -> Seq Block
blockChain CodeGenState
s)
        label :: String
label   = let (String
h,String
t) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.') String
nm in (String
h String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String -> String
forall a. Show a => a -> String -> String
shows Int
idx String
t)
        next :: Block
next    = Label -> Seq (Named Instruction) -> Terminator -> Block
Block (String -> Label
forall a. IsString a => String -> a
fromString String
label) Seq (Named Instruction)
forall a. Seq a
Seq.empty Terminator
err
        err :: Terminator
err     = String -> Terminator
forall a. HasCallStack => String -> a
internalError (String -> String -> String
forall r. PrintfType r => String -> r
printf String
"block `%s' has no terminator" String
label)
    in
    ( Block
next, CodeGenState
s )


-- | Add this block to the block stream. Any instructions pushed onto the stream
-- by 'instr' and friends will now apply to this block.
--
setBlock :: Block -> CodeGen arch ()
setBlock :: Block -> CodeGen arch ()
setBlock Block
next =
  (CodeGenState -> CodeGenState) -> CodeGen arch ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((CodeGenState -> CodeGenState) -> CodeGen arch ())
-> (CodeGenState -> CodeGenState) -> CodeGen arch ()
forall a b. (a -> b) -> a -> b
$ \CodeGenState
s -> CodeGenState
s { blockChain :: Seq Block
blockChain = CodeGenState -> Seq Block
blockChain CodeGenState
s Seq Block -> Block -> Seq Block
forall a. Seq a -> a -> Seq a
Seq.|> Block
next }


-- | Generate a new block and branch unconditionally to it.
--
beginBlock :: HasCallStack => String -> CodeGen arch Block
beginBlock :: String -> CodeGen arch Block
beginBlock String
nm = do
  Block
next <- String -> CodeGen arch Block
forall arch. HasCallStack => String -> CodeGen arch Block
newBlock String
nm
  Block
_    <- Block -> CodeGen arch Block
forall arch. HasCallStack => Block -> CodeGen arch Block
br Block
next
  Block -> CodeGen arch ()
forall arch. Block -> CodeGen arch ()
setBlock Block
next
  Block -> CodeGen arch Block
forall (m :: * -> *) a. Monad m => a -> m a
return Block
next


-- | Extract the block state and construct the basic blocks that form a function
-- body. The block stream is re-initialised, but module-level state such as the
-- global symbol table is left intact.
--
createBlocks :: HasCallStack => CodeGen arch [LLVM.BasicBlock]
createBlocks :: CodeGen arch [BasicBlock]
createBlocks
  = (CodeGenState -> ([BasicBlock], CodeGenState))
-> CodeGen arch [BasicBlock]
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state
  ((CodeGenState -> ([BasicBlock], CodeGenState))
 -> CodeGen arch [BasicBlock])
-> (CodeGenState -> ([BasicBlock], CodeGenState))
-> CodeGen arch [BasicBlock]
forall a b. (a -> b) -> a -> b
$ \CodeGenState
s -> let s' :: CodeGenState
s'     = CodeGenState
s { blockChain :: Seq Block
blockChain = Seq Block
HasCallStack => Seq Block
initBlockChain, next :: Word
next = Word
0 }
              blocks :: Seq BasicBlock
blocks = Block -> BasicBlock
makeBlock (Block -> BasicBlock) -> Seq Block -> Seq BasicBlock
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` CodeGenState -> Seq Block
blockChain CodeGenState
s
              m :: Int
m      = Seq Block -> Int
forall a. Seq a -> Int
Seq.length (CodeGenState -> Seq Block
blockChain CodeGenState
s)
              n :: Int
n      = (Int -> Block -> Int) -> Int -> Seq Block -> Int
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl' (\Int
i Block
b -> Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Seq (Named Instruction) -> Int
forall a. Seq a -> Int
Seq.length (Block -> Seq (Named Instruction)
instructions Block
b)) Int
0 (CodeGenState -> Seq Block
blockChain CodeGenState
s)
          in
          String
-> ([BasicBlock], CodeGenState) -> ([BasicBlock], CodeGenState)
forall a. String -> a -> a
trace (String -> Int -> Int -> String
forall r. PrintfType r => String -> r
printf String
"generated %d instructions in %d blocks" (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
m) Int
m) ( Seq BasicBlock -> [BasicBlock]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList Seq BasicBlock
blocks , CodeGenState
s' )
  where
    makeBlock :: Block -> BasicBlock
makeBlock Block{Seq (Named Instruction)
Terminator
Label
terminator :: Terminator
instructions :: Seq (Named Instruction)
blockLabel :: Label
terminator :: Block -> Terminator
instructions :: Block -> Seq (Named Instruction)
blockLabel :: Block -> Label
..} =
      Name -> [Named Instruction] -> Named Terminator -> BasicBlock
LLVM.BasicBlock (Label -> Name
forall typed untyped.
(Downcast typed untyped, HasCallStack) =>
typed -> untyped
downcast Label
blockLabel) (Seq (Named Instruction) -> [Named Instruction]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList Seq (Named Instruction)
instructions) (Terminator -> Named Terminator
forall a. a -> Named a
LLVM.Do Terminator
terminator)


-- Instructions
-- ------------

-- | Generate a fresh local reference
--
fresh :: TypeR a -> CodeGen arch (Operands a)
fresh :: TypeR a -> CodeGen arch (Operands a)
fresh TypeR a
TupRunit         = Operands () -> CodeGen arch (Operands ())
forall (m :: * -> *) a. Monad m => a -> m a
return Operands ()
OP_Unit
fresh (TupRpair TupR ScalarType a1
t2 TupR ScalarType b
t1) = Operands a1 -> Operands b -> Operands (a1, b)
forall a b. Operands a -> Operands b -> Operands (a, b)
OP_Pair (Operands a1 -> Operands b -> Operands (a1, b))
-> CodeGen arch (Operands a1)
-> CodeGen arch (Operands b -> Operands (a1, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TupR ScalarType a1 -> CodeGen arch (Operands a1)
forall a arch. TypeR a -> CodeGen arch (Operands a)
fresh TupR ScalarType a1
t2 CodeGen arch (Operands b -> Operands (a1, b))
-> CodeGen arch (Operands b) -> CodeGen arch (Operands (a1, b))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TupR ScalarType b -> CodeGen arch (Operands b)
forall a arch. TypeR a -> CodeGen arch (Operands a)
fresh TupR ScalarType b
t1
fresh (TupRsingle ScalarType a
t)   = ScalarType a -> Operand a -> Operands a
forall (dict :: * -> *) a.
(IROP dict, HasCallStack) =>
dict a -> Operand a -> Operands a
ir ScalarType a
t (Operand a -> Operands a)
-> (Name a -> Operand a) -> Name a -> Operands a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type a -> Name a -> Operand a
forall a. Type a -> Name a -> Operand a
LocalReference (PrimType a -> Type a
forall a. PrimType a -> Type a
PrimType (ScalarType a -> PrimType a
forall a. ScalarType a -> PrimType a
ScalarPrimType ScalarType a
t)) (Name a -> Operands a)
-> CodeGen arch (Name a) -> CodeGen arch (Operands a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CodeGen arch (Name a)
forall arch a. CodeGen arch (Name a)
freshName

-- | Generate a fresh (un)name.
--
freshName :: CodeGen arch (Name a)
freshName :: CodeGen arch (Name a)
freshName = (CodeGenState -> (Name a, CodeGenState)) -> CodeGen arch (Name a)
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state ((CodeGenState -> (Name a, CodeGenState)) -> CodeGen arch (Name a))
-> (CodeGenState -> (Name a, CodeGenState))
-> CodeGen arch (Name a)
forall a b. (a -> b) -> a -> b
$ \s :: CodeGenState
s@CodeGenState{Word
Map Label Global
Seq Block
HashMap ShortByteString (Seq [Maybe Metadata])
HashMap ShortByteString Label
next :: Word
intrinsicTable :: HashMap ShortByteString Label
metadataTable :: HashMap ShortByteString (Seq [Maybe Metadata])
symbolTable :: Map Label Global
blockChain :: Seq Block
next :: CodeGenState -> Word
intrinsicTable :: CodeGenState -> HashMap ShortByteString Label
metadataTable :: CodeGenState -> HashMap ShortByteString (Seq [Maybe Metadata])
symbolTable :: CodeGenState -> Map Label Global
blockChain :: CodeGenState -> Seq Block
..} -> ( Word -> Name a
forall a. Word -> Name a
UnName Word
next, CodeGenState
s { next :: Word
next = Word
next Word -> Word -> Word
forall a. Num a => a -> a -> a
+ Word
1 } )


-- | Add an instruction to the state of the currently active block so that it is
-- computed, and return the operand (LocalReference) that can be used to later
-- refer to it.
--
instr :: HasCallStack => Instruction a -> CodeGen arch (Operands a)
instr :: Instruction a -> CodeGen arch (Operands a)
instr Instruction a
ins = Type a -> Operand a -> Operands a
forall (dict :: * -> *) a.
(IROP dict, HasCallStack) =>
dict a -> Operand a -> Operands a
ir (Instruction a -> Type a
forall (f :: * -> *) a. TypeOf f => f a -> Type a
typeOf Instruction a
ins) (Operand a -> Operands a)
-> CodeGen arch (Operand a) -> CodeGen arch (Operands a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Instruction a -> CodeGen arch (Operand a)
forall a arch.
HasCallStack =>
Instruction a -> CodeGen arch (Operand a)
instr' Instruction a
ins

instr' :: HasCallStack => Instruction a -> CodeGen arch (Operand a)
instr' :: Instruction a -> CodeGen arch (Operand a)
instr' Instruction a
ins =
  -- LLVM-5 does not allow instructions of type void to have a name.
  case Instruction a -> Type a
forall (f :: * -> *) a. TypeOf f => f a -> Type a
typeOf Instruction a
ins of
    Type a
VoidType -> do
      Instruction () -> CodeGen arch ()
forall arch. HasCallStack => Instruction () -> CodeGen arch ()
do_ Instruction a
Instruction ()
ins
      Operand () -> CodeGen arch (Operand ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Operand () -> CodeGen arch (Operand ()))
-> Operand () -> CodeGen arch (Operand ())
forall a b. (a -> b) -> a -> b
$ Type () -> Name () -> Operand ()
forall a. Type a -> Name a -> Operand a
LocalReference Type ()
VoidType (ShortByteString -> Name ()
forall a. ShortByteString -> Name a
Name ShortByteString
B.empty)
    --
    Type a
ty -> do
      Name a
name <- CodeGen arch (Name a)
forall arch a. CodeGen arch (Name a)
freshName
      Named Instruction -> CodeGen arch ()
forall arch. HasCallStack => Named Instruction -> CodeGen arch ()
instr_ (Named Instruction -> CodeGen arch ())
-> Named Instruction -> CodeGen arch ()
forall a b. (a -> b) -> a -> b
$ Named Instruction a -> Named Instruction
forall typed untyped.
(Downcast typed untyped, HasCallStack) =>
typed -> untyped
downcast (Name a
name Name a -> Instruction a -> Named Instruction a
forall a (ins :: * -> *). Name a -> ins a -> Named ins a
:= Instruction a
ins)
      Operand a -> CodeGen arch (Operand a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Operand a -> CodeGen arch (Operand a))
-> Operand a -> CodeGen arch (Operand a)
forall a b. (a -> b) -> a -> b
$ Type a -> Name a -> Operand a
forall a. Type a -> Name a -> Operand a
LocalReference Type a
ty Name a
name

-- | Execute an unnamed instruction
--
do_ :: HasCallStack => Instruction () -> CodeGen arch ()
do_ :: Instruction () -> CodeGen arch ()
do_ Instruction ()
ins = Named Instruction -> CodeGen arch ()
forall arch. HasCallStack => Named Instruction -> CodeGen arch ()
instr_ (Named Instruction -> CodeGen arch ())
-> Named Instruction -> CodeGen arch ()
forall a b. (a -> b) -> a -> b
$ Named Instruction () -> Named Instruction
forall typed untyped.
(Downcast typed untyped, HasCallStack) =>
typed -> untyped
downcast (Instruction () -> Named Instruction ()
forall (ins :: * -> *). ins () -> Named ins ()
Do Instruction ()
ins)

-- | Add raw assembly instructions to the execution stream
--
instr_ :: HasCallStack => LLVM.Named LLVM.Instruction -> CodeGen arch ()
instr_ :: Named Instruction -> CodeGen arch ()
instr_ Named Instruction
ins =
  (CodeGenState -> CodeGenState) -> CodeGen arch ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((CodeGenState -> CodeGenState) -> CodeGen arch ())
-> (CodeGenState -> CodeGenState) -> CodeGen arch ()
forall a b. (a -> b) -> a -> b
$ \CodeGenState
s ->
    case Seq Block -> ViewR Block
forall a. Seq a -> ViewR a
Seq.viewr (CodeGenState -> Seq Block
blockChain CodeGenState
s) of
      ViewR Block
Seq.EmptyR  -> String -> CodeGenState
forall a. HasCallStack => String -> a
internalError String
"empty block chain"
      Seq Block
bs Seq.:> Block
b -> CodeGenState
s { blockChain :: Seq Block
blockChain = Seq Block
bs Seq Block -> Block -> Seq Block
forall a. Seq a -> a -> Seq a
Seq.|> Block
b { instructions :: Seq (Named Instruction)
instructions = Block -> Seq (Named Instruction)
instructions Block
b Seq (Named Instruction)
-> Named Instruction -> Seq (Named Instruction)
forall a. Seq a -> a -> Seq a
Seq.|> Named Instruction
ins } }


-- | Return void from a basic block
--
return_ :: HasCallStack => CodeGen arch ()
return_ :: CodeGen arch ()
return_ = CodeGen arch Block -> CodeGen arch ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (CodeGen arch Block -> CodeGen arch ())
-> CodeGen arch Block -> CodeGen arch ()
forall a b. (a -> b) -> a -> b
$ Terminator () -> CodeGen arch Block
forall a arch. HasCallStack => Terminator a -> CodeGen arch Block
terminate Terminator ()
Ret

-- | Return a value from a basic block
--
retval_ :: HasCallStack => Operand a -> CodeGen arch ()
retval_ :: Operand a -> CodeGen arch ()
retval_ Operand a
x = CodeGen arch Block -> CodeGen arch ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (CodeGen arch Block -> CodeGen arch ())
-> CodeGen arch Block -> CodeGen arch ()
forall a b. (a -> b) -> a -> b
$ Terminator a -> CodeGen arch Block
forall a arch. HasCallStack => Terminator a -> CodeGen arch Block
terminate (Operand a -> Terminator a
forall a. Operand a -> Terminator a
RetVal Operand a
x)


-- | Unconditional branch. Return the name of the block that was branched from.
--
br :: HasCallStack => Block -> CodeGen arch Block
br :: Block -> CodeGen arch Block
br Block
target = Terminator () -> CodeGen arch Block
forall a arch. HasCallStack => Terminator a -> CodeGen arch Block
terminate (Terminator () -> CodeGen arch Block)
-> Terminator () -> CodeGen arch Block
forall a b. (a -> b) -> a -> b
$ Label -> Terminator ()
Br (Block -> Label
blockLabel Block
target)


-- | Conditional branch. Return the name of the block that was branched from.
--
cbr :: HasCallStack => Operands Bool -> Block -> Block -> CodeGen arch Block
cbr :: Operands Bool -> Block -> Block -> CodeGen arch Block
cbr (OP_Bool cond) Block
t Block
f = Terminator () -> CodeGen arch Block
forall a arch. HasCallStack => Terminator a -> CodeGen arch Block
terminate (Terminator () -> CodeGen arch Block)
-> Terminator () -> CodeGen arch Block
forall a b. (a -> b) -> a -> b
$ Operand Bool -> Label -> Label -> Terminator ()
CondBr Operand Bool
cond (Block -> Label
blockLabel Block
t) (Block -> Label
blockLabel Block
f)

-- | Switch statement. Return the name of the block that was branched from.
--
switch :: HasCallStack => Operands TAG -> Block -> [(TAG, Block)] -> CodeGen arch Block
switch :: Operands TAG -> Block -> [(TAG, Block)] -> CodeGen arch Block
switch Operands TAG
tag Block
def [(TAG, Block)]
eqs = Terminator () -> CodeGen arch Block
forall a arch. HasCallStack => Terminator a -> CodeGen arch Block
terminate (Terminator () -> CodeGen arch Block)
-> Terminator () -> CodeGen arch Block
forall a b. (a -> b) -> a -> b
$ Operand TAG -> Label -> [(Constant TAG, Label)] -> Terminator ()
forall a.
Operand a -> Label -> [(Constant a, Label)] -> Terminator ()
Switch (ScalarType TAG -> Operands TAG -> Operand TAG
forall (dict :: * -> *) a.
(IROP dict, HasCallStack) =>
dict a -> Operands a -> Operand a
op ScalarType TAG
forall a. IsScalar a => ScalarType a
scalarType Operands TAG
tag) (Block -> Label
blockLabel Block
def) [(ScalarType TAG -> TAG -> Constant TAG
forall a. ScalarType a -> a -> Constant a
ScalarConstant ScalarType TAG
forall a. IsScalar a => ScalarType a
scalarType TAG
t, Block -> Label
blockLabel Block
b) | (TAG
t,Block
b) <- [(TAG, Block)]
eqs]

-- | Add a phi node to the top of the current block
--
phi :: forall arch a. HasCallStack => TypeR a -> [(Operands a, Block)] -> CodeGen arch (Operands a)
phi :: TypeR a -> [(Operands a, Block)] -> CodeGen arch (Operands a)
phi TypeR a
tp [(Operands a, Block)]
incoming = do
  Operands a
crit  <- TypeR a -> CodeGen arch (Operands a)
forall a arch. TypeR a -> CodeGen arch (Operands a)
fresh TypeR a
tp
  Block
block <- (CodeGenState -> (Block, CodeGenState)) -> CodeGen arch Block
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state ((CodeGenState -> (Block, CodeGenState)) -> CodeGen arch Block)
-> (CodeGenState -> (Block, CodeGenState)) -> CodeGen arch Block
forall a b. (a -> b) -> a -> b
$ \CodeGenState
s -> case Seq Block -> ViewR Block
forall a. Seq a -> ViewR a
Seq.viewr (CodeGenState -> Seq Block
blockChain CodeGenState
s) of
                           ViewR Block
Seq.EmptyR -> String -> (Block, CodeGenState)
forall a. HasCallStack => String -> a
internalError String
"empty block chain"
                           Seq Block
_ Seq.:> Block
b -> ( Block
b, CodeGenState
s )
  TypeR a
-> Block
-> Operands a
-> [(Operands a, Block)]
-> CodeGen arch (Operands a)
forall a arch.
HasCallStack =>
TypeR a
-> Block
-> Operands a
-> [(Operands a, Block)]
-> CodeGen arch (Operands a)
phi' TypeR a
tp Block
block Operands a
crit [(Operands a, Block)]
incoming

phi' :: HasCallStack => TypeR a -> Block -> Operands a -> [(Operands a, Block)] -> CodeGen arch (Operands a)
phi' :: TypeR a
-> Block
-> Operands a
-> [(Operands a, Block)]
-> CodeGen arch (Operands a)
phi' TypeR a
tp Block
target = TypeR a
-> Operands a -> [(Operands a, Block)] -> CodeGen arch (Operands a)
forall t arch.
TypeR t
-> Operands t -> [(Operands t, Block)] -> CodeGen arch (Operands t)
go TypeR a
tp
  where
    go :: TypeR t -> Operands t -> [(Operands t, Block)] -> CodeGen arch (Operands t)
    go :: TypeR t
-> Operands t -> [(Operands t, Block)] -> CodeGen arch (Operands t)
go TypeR t
TupRunit Operands t
OP_Unit [(Operands t, Block)]
_
      = Operands () -> CodeGen arch (Operands ())
forall (m :: * -> *) a. Monad m => a -> m a
return Operands ()
OP_Unit
    go (TupRpair TupR ScalarType a1
t2 TupR ScalarType b
t1) (OP_Pair n2 n1) [(Operands t, Block)]
inc
      = Operands a1 -> Operands b -> Operands (a1, b)
forall a b. Operands a -> Operands b -> Operands (a, b)
OP_Pair (Operands a1 -> Operands b -> Operands (a1, b))
-> CodeGen arch (Operands a1)
-> CodeGen arch (Operands b -> Operands (a1, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TupR ScalarType a1
-> Operands a1
-> [(Operands a1, Block)]
-> CodeGen arch (Operands a1)
forall t arch.
TypeR t
-> Operands t -> [(Operands t, Block)] -> CodeGen arch (Operands t)
go TupR ScalarType a1
t2 Operands a1
n2 [ (Operands a1
x, Block
b) | (OP_Pair x _, Block
b) <- [(Operands t, Block)]
inc ]
                CodeGen arch (Operands b -> Operands (a1, b))
-> CodeGen arch (Operands b) -> CodeGen arch (Operands (a1, b))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TupR ScalarType b
-> Operands b -> [(Operands b, Block)] -> CodeGen arch (Operands b)
forall t arch.
TypeR t
-> Operands t -> [(Operands t, Block)] -> CodeGen arch (Operands t)
go TupR ScalarType b
t1 Operands b
n1 [ (Operands b
y, Block
b) | (OP_Pair _ y, Block
b) <- [(Operands t, Block)]
inc ]
    go (TupRsingle ScalarType t
t) Operands t
tup [(Operands t, Block)]
inc
      | LocalReference Type t
_ Name t
v <- ScalarType t -> Operands t -> Operand t
forall (dict :: * -> *) a.
(IROP dict, HasCallStack) =>
dict a -> Operands a -> Operand a
op ScalarType t
t Operands t
tup = ScalarType t -> Operand t -> Operands t
forall (dict :: * -> *) a.
(IROP dict, HasCallStack) =>
dict a -> Operand a -> Operands a
ir ScalarType t
t (Operand t -> Operands t)
-> CodeGen arch (Operand t) -> CodeGen arch (Operands t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Block -> Name t -> [(Operand t, Block)] -> CodeGen arch (Operand t)
forall a arch.
HasCallStack =>
Block -> Name a -> [(Operand a, Block)] -> CodeGen arch (Operand a)
phi1 Block
target Name t
v [ (ScalarType t -> Operands t -> Operand t
forall (dict :: * -> *) a.
(IROP dict, HasCallStack) =>
dict a -> Operands a -> Operand a
op ScalarType t
t Operands t
x, Block
b) | (Operands t
x, Block
b) <- [(Operands t, Block)]
inc ]
      | Bool
otherwise                      = String -> CodeGen arch (Operands t)
forall a. HasCallStack => String -> a
internalError String
"expected critical variable to be local reference"


phi1 :: HasCallStack => Block -> Name a -> [(Operand a, Block)] -> CodeGen arch (Operand a)
phi1 :: Block -> Name a -> [(Operand a, Block)] -> CodeGen arch (Operand a)
phi1 Block
target Name a
crit [(Operand a, Block)]
incoming =
  let cmp :: Block -> Block -> Bool
cmp       = Label -> Label -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Label -> Label -> Bool)
-> (Block -> Label) -> Block -> Block -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Block -> Label
blockLabel
      update :: Block -> Block
update Block
b  = Block
b { instructions :: Seq (Named Instruction)
instructions = Named Instruction a -> Named Instruction
forall typed untyped.
(Downcast typed untyped, HasCallStack) =>
typed -> untyped
downcast (Name a
crit Name a -> Instruction a -> Named Instruction a
forall a (ins :: * -> *). Name a -> ins a -> Named ins a
:= PrimType a -> [(Operand a, Label)] -> Instruction a
forall a. PrimType a -> [(Operand a, Label)] -> Instruction a
Phi PrimType a
t [ (Operand a
p,Label
blockLabel) | (Operand a
p,Block{Seq (Named Instruction)
Terminator
Label
terminator :: Terminator
instructions :: Seq (Named Instruction)
blockLabel :: Label
terminator :: Block -> Terminator
instructions :: Block -> Seq (Named Instruction)
blockLabel :: Block -> Label
..}) <- [(Operand a, Block)]
incoming ]) Named Instruction
-> Seq (Named Instruction) -> Seq (Named Instruction)
forall a. a -> Seq a -> Seq a
Seq.<| Block -> Seq (Named Instruction)
instructions Block
b }
      t :: PrimType a
t         = case [(Operand a, Block)]
incoming of
                    []        -> String -> PrimType a
forall a. HasCallStack => String -> a
internalError String
"no incoming values specified"
                    (Operand a
o,Block
_):[(Operand a, Block)]
_   -> case Operand a -> Type a
forall (f :: * -> *) a. TypeOf f => f a -> Type a
typeOf Operand a
o of
                                   Type a
VoidType    -> String -> PrimType a
forall a. HasCallStack => String -> a
internalError String
"operand has void type"
                                   PrimType PrimType a
x  -> PrimType a
x
  in
  (CodeGenState -> (Operand a, CodeGenState))
-> CodeGen arch (Operand a)
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state ((CodeGenState -> (Operand a, CodeGenState))
 -> CodeGen arch (Operand a))
-> (CodeGenState -> (Operand a, CodeGenState))
-> CodeGen arch (Operand a)
forall a b. (a -> b) -> a -> b
$ \CodeGenState
s ->
    case (Block -> Bool) -> Seq Block -> Maybe Int
forall a. (a -> Bool) -> Seq a -> Maybe Int
Seq.findIndexR (Block -> Block -> Bool
cmp Block
target) (CodeGenState -> Seq Block
blockChain CodeGenState
s) of
      Maybe Int
Nothing -> String -> (Operand a, CodeGenState)
forall a. HasCallStack => String -> a
internalError String
"unknown basic block"
      Just Int
i  -> ( Type a -> Name a -> Operand a
forall a. Type a -> Name a -> Operand a
LocalReference (PrimType a -> Type a
forall a. PrimType a -> Type a
PrimType PrimType a
t) Name a
crit
                 , CodeGenState
s { blockChain :: Seq Block
blockChain = (Block -> Block) -> Int -> Seq Block -> Seq Block
forall a. (a -> a) -> Int -> Seq a -> Seq a
Seq.adjust Block -> Block
update Int
i (CodeGenState -> Seq Block
blockChain CodeGenState
s) } )


-- | Add a termination condition to the current instruction stream. Also return
-- the block that was just terminated.
--
terminate :: HasCallStack => Terminator a -> CodeGen arch Block
terminate :: Terminator a -> CodeGen arch Block
terminate Terminator a
term =
  (CodeGenState -> (Block, CodeGenState)) -> CodeGen arch Block
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state ((CodeGenState -> (Block, CodeGenState)) -> CodeGen arch Block)
-> (CodeGenState -> (Block, CodeGenState)) -> CodeGen arch Block
forall a b. (a -> b) -> a -> b
$ \CodeGenState
s ->
    case Seq Block -> ViewR Block
forall a. Seq a -> ViewR a
Seq.viewr (CodeGenState -> Seq Block
blockChain CodeGenState
s) of
      ViewR Block
Seq.EmptyR  -> String -> (Block, CodeGenState)
forall a. HasCallStack => String -> a
internalError String
"empty block chain"
      Seq Block
bs Seq.:> Block
b -> ( Block
b, CodeGenState
s { blockChain :: Seq Block
blockChain = Seq Block
bs Seq Block -> Block -> Seq Block
forall a. Seq a -> a -> Seq a
Seq.|> Block
b { terminator :: Terminator
terminator = Terminator a -> Terminator
forall typed untyped.
(Downcast typed untyped, HasCallStack) =>
typed -> untyped
downcast Terminator a
term } } )


-- | Add a global declaration to the symbol table
--
declare :: HasCallStack => LLVM.Global -> CodeGen arch ()
declare :: Global -> CodeGen arch ()
declare Global
g =
  let unique :: Maybe Global -> Maybe Global
unique (Just Global
q) | Global
g Global -> Global -> Bool
forall a. Eq a => a -> a -> Bool
/= Global
q    = String -> Maybe Global
forall a. HasCallStack => String -> a
internalError String
"duplicate symbol"
                      | Bool
otherwise = Global -> Maybe Global
forall a. a -> Maybe a
Just Global
g
      unique Maybe Global
_                    = Global -> Maybe Global
forall a. a -> Maybe a
Just Global
g

      name :: Label
name = case Global -> Name
LLVM.name Global
g of
               LLVM.Name ShortByteString
n      -> ShortByteString -> Label
Label ShortByteString
n
               LLVM.UnName Word
n    -> ShortByteString -> Label
Label (String -> ShortByteString
forall a. IsString a => String -> a
fromString (Word -> String
forall a. Show a => a -> String
show Word
n))
  in
  (CodeGenState -> CodeGenState) -> CodeGen arch ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\CodeGenState
s -> CodeGenState
s { symbolTable :: Map Label Global
symbolTable = (Maybe Global -> Maybe Global)
-> Label -> Map Label Global -> Map Label Global
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter Maybe Global -> Maybe Global
unique Label
name (CodeGenState -> Map Label Global
symbolTable CodeGenState
s) })


-- | Get name of the corresponding intrinsic function implementing a given C
-- function. If there is no mapping, the C function name is used.
--
intrinsic :: ShortByteString -> CodeGen arch Label
intrinsic :: ShortByteString -> CodeGen arch Label
intrinsic ShortByteString
key =
  (CodeGenState -> (Label, CodeGenState)) -> CodeGen arch Label
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state ((CodeGenState -> (Label, CodeGenState)) -> CodeGen arch Label)
-> (CodeGenState -> (Label, CodeGenState)) -> CodeGen arch Label
forall a b. (a -> b) -> a -> b
$ \CodeGenState
s ->
    let name :: Label
name = Label -> ShortByteString -> HashMap ShortByteString Label -> Label
forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
HashMap.lookupDefault (ShortByteString -> Label
Label ShortByteString
key) ShortByteString
key (CodeGenState -> HashMap ShortByteString Label
intrinsicTable CodeGenState
s)
    in  (Label
name, CodeGenState
s)



-- Metadata
-- ========

-- | Insert a metadata key/value pair into the current module.
--
addMetadata :: ShortByteString -> [Maybe Metadata] -> CodeGen arch ()
addMetadata :: ShortByteString -> [Maybe Metadata] -> CodeGen arch ()
addMetadata ShortByteString
key [Maybe Metadata]
val =
  (CodeGenState -> CodeGenState) -> CodeGen arch ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((CodeGenState -> CodeGenState) -> CodeGen arch ())
-> (CodeGenState -> CodeGenState) -> CodeGen arch ()
forall a b. (a -> b) -> a -> b
$ \CodeGenState
s ->
    CodeGenState
s { metadataTable :: HashMap ShortByteString (Seq [Maybe Metadata])
metadataTable = (Seq [Maybe Metadata]
 -> Seq [Maybe Metadata] -> Seq [Maybe Metadata])
-> ShortByteString
-> Seq [Maybe Metadata]
-> HashMap ShortByteString (Seq [Maybe Metadata])
-> HashMap ShortByteString (Seq [Maybe Metadata])
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v
HashMap.insertWith ((Seq [Maybe Metadata]
 -> Seq [Maybe Metadata] -> Seq [Maybe Metadata])
-> Seq [Maybe Metadata]
-> Seq [Maybe Metadata]
-> Seq [Maybe Metadata]
forall a b c. (a -> b -> c) -> b -> a -> c
flip Seq [Maybe Metadata]
-> Seq [Maybe Metadata] -> Seq [Maybe Metadata]
forall a. Seq a -> Seq a -> Seq a
(Seq.><)) ShortByteString
key ([Maybe Metadata] -> Seq [Maybe Metadata]
forall a. a -> Seq a
Seq.singleton [Maybe Metadata]
val) (CodeGenState -> HashMap ShortByteString (Seq [Maybe Metadata])
metadataTable CodeGenState
s) }


-- | Generate the metadata definitions for the file. Every key in the map
-- represents a named metadata definition. The values associated with that key
-- represent the metadata node definitions that will be attached to that
-- definition.
--
createMetadata :: HashMap ShortByteString (Seq [Maybe Metadata]) -> [LLVM.Definition]
createMetadata :: HashMap ShortByteString (Seq [Maybe Metadata]) -> [Definition]
createMetadata HashMap ShortByteString (Seq [Maybe Metadata])
md = [(ShortByteString, Seq [Maybe Metadata])]
-> (Seq Definition, Seq Definition) -> [Definition]
build (HashMap ShortByteString (Seq [Maybe Metadata])
-> [(ShortByteString, Seq [Maybe Metadata])]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList HashMap ShortByteString (Seq [Maybe Metadata])
md) (Seq Definition
forall a. Seq a
Seq.empty, Seq Definition
forall a. Seq a
Seq.empty)
  where
    build :: [(ShortByteString, Seq [Maybe Metadata])]
          -> (Seq LLVM.Definition, Seq LLVM.Definition) -- accumulator of (names, metadata)
          -> [LLVM.Definition]
    build :: [(ShortByteString, Seq [Maybe Metadata])]
-> (Seq Definition, Seq Definition) -> [Definition]
build []     (Seq Definition
k,Seq Definition
d) = Seq Definition -> [Definition]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (Seq Definition
k Seq Definition -> Seq Definition -> Seq Definition
forall a. Seq a -> Seq a -> Seq a
Seq.>< Seq Definition
d)
    build ((ShortByteString, Seq [Maybe Metadata])
x:[(ShortByteString, Seq [Maybe Metadata])]
xs) (Seq Definition
k,Seq Definition
d) =
      let (Definition
k',Seq Definition
d') = Int
-> (ShortByteString, Seq [Maybe Metadata])
-> (Definition, Seq Definition)
meta (Seq Definition -> Int
forall a. Seq a -> Int
Seq.length Seq Definition
d) (ShortByteString, Seq [Maybe Metadata])
x
      in  [(ShortByteString, Seq [Maybe Metadata])]
-> (Seq Definition, Seq Definition) -> [Definition]
build [(ShortByteString, Seq [Maybe Metadata])]
xs (Seq Definition
k Seq Definition -> Definition -> Seq Definition
forall a. Seq a -> a -> Seq a
Seq.|> Definition
k', Seq Definition
d Seq Definition -> Seq Definition -> Seq Definition
forall a. Seq a -> Seq a -> Seq a
Seq.>< Seq Definition
d')

    meta :: Int                                         -- number of metadata node definitions so far
         -> (ShortByteString, Seq [Maybe Metadata])     -- current assoc of the metadata map
         -> (LLVM.Definition, Seq LLVM.Definition)
    meta :: Int
-> (ShortByteString, Seq [Maybe Metadata])
-> (Definition, Seq Definition)
meta Int
n (ShortByteString
key, Seq [Maybe Metadata]
vals)
      = let node :: Int -> MetadataNodeID
node Int
i      = Word -> MetadataNodeID
LLVM.MetadataNodeID (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
n))
            nodes :: Seq Definition
nodes       = (Int -> [Maybe Metadata] -> Definition)
-> Seq [Maybe Metadata] -> Seq Definition
forall a b. (Int -> a -> b) -> Seq a -> Seq b
Seq.mapWithIndex (\Int
i [Maybe Metadata]
x -> MetadataNodeID -> MDNode -> Definition
LLVM.MetadataNodeDefinition (Int -> MetadataNodeID
node Int
i) ([Maybe Metadata] -> MDNode
forall typed untyped.
(Downcast typed untyped, HasCallStack) =>
typed -> untyped
downcast ([Maybe Metadata] -> [Maybe Metadata]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList [Maybe Metadata]
x))) Seq [Maybe Metadata]
vals
            name :: Definition
name        = ShortByteString -> [MetadataNodeID] -> Definition
LLVM.NamedMetadataDefinition ShortByteString
key [ Int -> MetadataNodeID
node Int
i | Int
i <- [Int
0 .. Seq [Maybe Metadata] -> Int
forall a. Seq a -> Int
Seq.length Seq [Maybe Metadata]
vals Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ]
        in
        (Definition
name, Seq Definition
nodes)


-- Debug
-- =====

{-# INLINE trace #-}
trace :: String -> a -> a
trace :: String -> a -> a
trace String
msg = Flag -> String -> a -> a
forall a. Flag -> String -> a -> a
Debug.trace Flag
Debug.dump_cc (String
"llvm: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg)