packages feed

llvm-tf (empty) → 21.0

raw patch · 49 files changed

Files

+ Changes.md view
@@ -0,0 +1,72 @@+# Change log for the `llvm-tf` package++## 12.1++* make `IsFirstClass` superclass of `IsSized`.++## 9.2++* custom `Ptr` type:+  We leave the original `Ptr` type for data in `Storable` compatible format,+  and use `LLVM.Ptr` for data in LLVM layout.++* `instance Storable Vector`:+  Allows non-primitive elements and interleaves them.++* `instance Marshal Vector`:+  Should now be really compatible with LLVM.+  Formerly, it was wrong on big-endian systems+  and vectors of Bool, WordN, IntN.+  The correct implementation required a new class for storing vectors.++* `Ret` class: turned from multi-parameter type class+  to single parameter type class with type function `Result`.+  You may replace `Ret a r` by `Ret a, Result a ~ r` in your code,+  which may enable further simplifications.++* `CallArgs f g r` -> `CallArgs r f g`,+  `CallerFunction f r` -> `CallerFunction r f`++* `ArithFunction`, `ToArithFunction`:+  Replaced functional dependencies by type functions.++* `ArithFunction`: split off `Return`++## 9.0++* `Instructions.bitcastElements`:+  Use `Guided.bitcast Guided.vector` instead.++* `Core.Guided`: new module for instructions on both scalars and vectors++* fixed bug: `cmp` on `IntN` did an unsigned comparison++* `Vector`: instance `QuickCheck.Arbitrary`++## 3.1.2++* `Instructions`: setters for FastMath flags++## 3.1.0.1++* `addFunctionMapping` checks for functions+  that are eliminated by optimization passes.+  This fixes a crash when working with optimizations and call-back functions.++## 3.1++* `ExecutionEngine` is now managed by a `ForeignPtr` with a finalizer.+  That is, you must keep the `ExecutionEngine` alive+  as long as you call compiled functions.++  `FreePointers` and `getFreePointers` are gone.++## 3.0.3++* `constVector`, `constArray`, `vector` do no longer cycle the vector+  Instead they check for the appropriate static length.++* `FFI.constVector`, `FFI.constArray` must be in IO+  in order to proper sequence actions in `Core.Util.constVector`, `Core.Util.constArray`.+  Currently, in `Util.constVector` it is possible that `FFI.constArray`+  is called too late and thus operates on a released pointer.
+ LICENSE view
@@ -0,0 +1,69 @@+======================================================================+Haskell LLVM Bindings Release License+======================================================================+University of Illinois/NCSA+Open Source License++Copyright (c) 2007-2009 Bryan O'Sullivan+All rights reserved.++Developed by:++    Bryan O'Sullivan <bos@serpentine.com>+    http://www.serpentine.com/blog/++    Lennart Augustsson <lennart@augustsson.net>++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal with the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimers.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimers in the documentation and/or other materials provided+      with the distribution.++    * Neither the names of Bryan O'Sullivan, University of Illinois at+      Urbana-Champaign, nor the names of its contributors may be used+      to endorse or promote products derived from this Software+      without specific prior written permission.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE CONTRIBUTORS OR COPYRIGHT HOLDERS BE LIABLE FOR+ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF+CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS WITH THE SOFTWARE.++======================================================================+Copyrights and Licenses for Third Party Software Distributed with+Haskell LLVM Bindings:+======================================================================++The Haskell LLVM Bindings software may contain code written by third+parties.  Any such software will have its own individual license file+in the directory in which it appears.  This file will describe the+copyrights, license, and restrictions which apply to that code.++The disclaimer of warranty in the University of Illinois Open Source+License applies to all code in the Haskell LLVM Bindings Distribution,+and nothing in any of the other licenses gives permission to use the+name of Bryan O'Sullivan or the University of Illinois to endorse or+promote products derived from this Software.++The following pieces of software have additional or alternate+copyrights, licenses, and/or restrictions:++Program             Directory+-------             ---------+configure           .++
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ cbits/malloc.c view
@@ -0,0 +1,188 @@+#include <stdlib.h>+#include <stdint.h>++#ifdef DEBUG+#include <stdio.h>+#endif++#ifdef TEST+#include <stdio.h>+#endif+++size_t gcd(size_t x, size_t y) {+  while (x!=0) {+    size_t tmp = y%x;+    y = x;+    x = tmp;+  }+  return y;+};++size_t lcm(size_t x, size_t y) {+  return x*(y/gcd(x,y));+};++size_t round_down_multiple(size_t x, size_t y) {+  return x - (x%y);+};++/*+This is the alignment that malloc always warrants.+If smaller alignments are requested, then we do not need to pad.++FIXME:+This was only tested on ix86-linux.+How to get the right number for every platform?+*/+const size_t default_align = 8;++/*+We have to waste a lot of memory,+since we need an aligned address+and before that space for a pointer.+Less memory can be wasted if 'free' also gets size and align information.+In this case we could omit padding in some cases+and in the other cases we could put the pointer after the memory chunk,+which allows us to use less padding.+*/+void *aligned_malloc(size_t size, size_t requested_align) {+  const size_t ptrsize = sizeof(void *);+  /*+  Ensure that alignment always allows to store a pointer+  (to the whole allocated block).+  */+  const size_t align = lcm(requested_align, ptrsize);+  const size_t pad = align;+  void *ptr = malloc(pad+ptrsize+size);+  if (ptr) {+    void **alignedptr = (void **) round_down_multiple((size_t)(ptr+pad+ptrsize), align);+    *(alignedptr-1) = ptr;+#ifdef DEBUG+    printf("allocated size %x with alignment %x at %08x %08x \n",+       size, align, (size_t) ptr, (size_t) alignedptr);+#endif+    return alignedptr;+  } else {+    return NULL;+  }+};++/* align must be a power of two */+void *power2_aligned_malloc(size_t size, size_t align) {+  const size_t ptrsize = sizeof(void *);+  size_t pad = align>=default_align ? align-default_align : 0;+  void *ptr = malloc(pad+ptrsize+size);+  if (ptr) {+    void **alignedptr = (void **)((size_t)(ptr+pad+ptrsize) & (-align));+    *(alignedptr-1) = ptr;+#ifdef DEBUG+    printf("allocated size 0x%x with alignment 0x%x at %08x %08x \n",+       size, align, (size_t) ptr, (size_t) alignedptr);+#endif+    return alignedptr;+  } else {+    return NULL;+  }+};++void aligned_free(void *alignedptr) {+  if (alignedptr) {+    void **sptr = (void **) alignedptr;+    void *ptr = *(sptr - 1);+#ifdef DEBUG+    printf("freed %08x %08x \n", (size_t) ptr, (size_t) alignedptr);+#endif+    free(ptr);+  } else {+    /*+    What shall we do about NULL pointers?+    Crash immediately? Make an official crash by 'free'?+    */+    free(alignedptr);+  }+};+++/*+Abuse a pointer type as a size_t compatible type+and choose a name that will hopefully not clash+with names an llvm user already uses (such as 'malloc').+*/+void *aligned_malloc_sizeptr(void *size, void *align) {+  return aligned_malloc((size_t) size, (size_t) align);+}+++const int+  prepadsize = 1024,+  postpadsize = 1024;++void *padded_aligned_malloc(size_t size, size_t align) {+  void *ptr = aligned_malloc(prepadsize+size+postpadsize, align);+  return ptr ? ptr+prepadsize : NULL;+};++void padded_aligned_free(void *ptr) {+  aligned_free(ptr ? ptr-prepadsize : NULL);+};+++#ifdef TEST+void test_gcd (size_t x, size_t y) {+  printf("gcd(%d,%d) = %d\n", x, y, gcd (x,y));+}++void test_malloc (size_t size, size_t align) {+  uint8_t *ptr = aligned_malloc (size, align);+  if (ptr) {+    if (((size_t) ptr) % align) {+      printf ("ptr %08x not correctly aligned\n", (size_t) ptr);+    }+    size_t k;+    for (k = 0; k<size; k++) {+      ptr[k] = 0;+    }+    aligned_free (ptr);+  }+}++int main () {+  test_gcd (0,0);+  test_gcd (0,1);+  test_gcd (0,2);+  test_gcd (1,0);+  test_gcd (2,0);+  test_gcd (1,2);+  test_gcd (2,1);+  test_gcd (2,2);+  test_gcd (2,3);+  test_gcd (2,4);+  test_gcd (16,64);+  test_gcd (15,10);+  test_gcd (96,81);++  test_malloc (128, 1);+  test_malloc (128, 2);+  test_malloc (128, 3);+  test_malloc (128, 4);+  test_malloc (128, 5);+  test_malloc (128, 6);+  test_malloc (128, 8);+  test_malloc (128, 16);+  test_malloc (128, 32);+  test_malloc (128, 64);+  test_malloc (111, 1);+  test_malloc (111, 2);+  test_malloc (111, 3);+  test_malloc (111, 4);+  test_malloc (111, 5);+  test_malloc (111, 6);+  test_malloc (111, 8);+  test_malloc (111, 16);+  test_malloc (111, 32);+  test_malloc (111, 64);++  return 0;+}+#endif
+ example/Align.hs view
@@ -0,0 +1,27 @@+module Main (main) where++import qualified LLVM.ExecutionEngine as EE+import LLVM.Util.Proxy (Proxy(Proxy))+import LLVM.Core (Vector, unsafeTypeRef, initializeNativeTarget)++import Type.Data.Num.Decimal.Literal (D1, D4)++import Data.Word (Word32, Word64)+++main :: IO ()+main = do+    -- Initialize jitter+    initializeNativeTarget++    td <- EE.getTargetData+    print (+        EE.littleEndian td,+        EE.dataLayoutStr td,+        EE.abiAlignmentOfType td $ unsafeTypeRef (Proxy :: Proxy Word32),+        EE.abiAlignmentOfType td $ unsafeTypeRef (Proxy :: Proxy Word64),+        EE.abiAlignmentOfType td $ unsafeTypeRef (Proxy :: Proxy (Vector D4 Float)),+        EE.abiAlignmentOfType td $ unsafeTypeRef (Proxy :: Proxy (Vector D1 Double)),+        EE.storeSizeOfType td $ unsafeTypeRef (Proxy :: Proxy (Vector D4 Float)),+        EE.intPtrType td+        )
+ example/Arith.hs view
@@ -0,0 +1,89 @@+module Main (main) where++import qualified LLVM.Util.Arithmetic as A+import qualified LLVM.Util.Foreign as F+import LLVM.Util.Arithmetic (CallIntrinsic, arithFunction, (%<), (?))+import LLVM.Util.File (writeCodeGenModule)++import qualified LLVM.ExecutionEngine as EE+import LLVM.Core++import Type.Data.Num.Decimal.Literal (D4)++import Data.Int (Int32)++import qualified Prelude as P+import Prelude hiding ((^))+++(^) :: (Num a) => a -> Int -> a+(^) = (P.^)++mSomeFn ::+    (IsConst a, Floating a, IsFloating a, CallIntrinsic a, CmpRet a) =>+    CodeGenModule (Function (a -> IO a))+mSomeFn = do+    foo <-+        createFunction InternalLinkage $ arithFunction $ \ x y ->+            exp (sin x) + y+    createFunction ExternalLinkage $ arithFunction $ \ x -> do+        y <- A.set $ x^3+        sqrt (x^2 - 5 * x + 6) + A.toArithFunction foo x x + y + log y++mFib :: CodeGenModule (Function (Int32 -> IO Int32))+mFib = A.recursiveFunction $ \ rfib n -> n %< 2 ? (1, rfib (n-1) + rfib (n-2))++type V = Vector D4 Float++mVFun :: CodeGenModule (Function (Ptr V -> Ptr V -> IO ()))+mVFun = do+    fn <- createFunction ExternalLinkage $ arithFunction $ \ x ->+            log x * exp x * x - 16++    vectorToPtr fn+++main :: IO ()+main = do+    -- Initialize jitter+    initializeNativeTarget++    let mSomeFn' = mSomeFn+    ioSomeFn <- EE.simpleFunction mSomeFn'+    let someFn :: Double -> Double+        someFn = EE.unsafeRemoveIO ioSomeFn++    writeCodeGenModule "Arith.bc" mSomeFn'++    print (someFn 10)+    print (someFn 2)++    writeCodeGenModule "ArithFib.bc" mFib++    fib <- EE.simpleFunction mFib+    fib 22 >>= print++    writeCodeGenModule "VArith.bc" mVFun++    ioVFun <- EE.simpleFunction mVFun+    let v = consVector 1 2 3 4++    r <- vectorPtrWrap ioVFun v+    print r+++vectorToPtr ::+    Function (V -> IO V) -> CodeGenModule (Function (Ptr V -> Ptr V -> IO ()))+vectorToPtr f =+    createFunction ExternalLinkage $ \ px py -> do+        x <- load px+        y <- call f x+        store y py+        ret ()++vectorPtrWrap :: (Ptr V -> Ptr V -> IO ()) -> V -> IO V+vectorPtrWrap f v =+    F.with v $ \ aPtr ->+        F.alloca $ \ bPtr -> do+             f aPtr bPtr+             EE.peek bPtr
+ example/Array.hs view
@@ -0,0 +1,65 @@+{-# OPTIONS_GHC -fsimpl-tick-factor=500 #-}+{- ToDo: remove simplifier ticket option, cf. LLVM.Util.Memory -}+module Main (main) where++import LLVM.Util.Loop (forLoop)+import LLVM.Util.Optimize (optimizeModule)+import LLVM.Core++import Control.Monad (foldM, void)+import Data.Word (Word, Word32)+++cg :: CodeGenModule (Function (Double -> IO (Ptr Double)))+cg = do+    dotProd <- createFunction InternalLinkage $ \ size aPtr aStride bPtr bStride -> do+        r <- forLoop (valueOf 0) size (valueOf 0) $ \ i s -> do+            ai <- mul aStride i+            bi <- mul bStride i+            ap <- getElementPtr aPtr (ai, ())+            bp <- getElementPtr bPtr (bi, ())+            a <- load ap+            b <- load bp+            ab <- mul a b+            add (s :: Value Double) ab+        ret r+    let _ = dotProd :: Function (Word32 -> Ptr Double -> Word32 -> Ptr Double -> Word32 -> IO Double)++    -- multiply a:[n x m], b:[m x l]+    matMul <- createFunction InternalLinkage $ \ n m l aPtr bPtr cPtr -> do+        forLoop (valueOf 0) n () $ \ ni () -> do+           forLoop (valueOf 0) l () $ \ li () -> do+              ni' <- mul ni m+              row <- getElementPtr aPtr (ni', ())+              col <- getElementPtr bPtr (li, ())+              x <- call dotProd m row (valueOf 1) col m+              j <- add ni' li+              p <- getElementPtr cPtr (j, ())+              store x p+        ret ()+    let _ = matMul :: Function (Word32 -> Word32 -> Word32 -> Ptr Double -> Ptr Double -> Ptr Double -> IO ())++    let fillArray =+            (void .) .+            foldM (\ptr x -> store x ptr >> getElementPtr ptr (1::Word32,()))++    test <- createNamedFunction ExternalLinkage "test" $ \ x -> do+        a <- arrayMalloc (4 :: Word)+        fillArray a $ map valueOf [1,2,3,4]+        b <- arrayMalloc (4 :: Word)+        fillArray b [x,x,x,x]+        c <- arrayMalloc (4 :: Word)+        _ <- call matMul (valueOf 2) (valueOf 2) (valueOf 2) a b c+        ret c+    let _ = test :: Function (Double -> IO (Ptr Double))++    return test++main :: IO ()+main = do+    -- Initialize jitter+    initializeNativeTarget+    m <- createModule $ setTarget hostTriple >> cg >> getModule+    writeBitcodeToFile "Arr.bc" m+    _ <- optimizeModule 3 m+    writeBitcodeToFile "Arr-opt.bc" m
+ example/BrainF.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+module Main (main) where+-- BrainF compiler example+--+-- The BrainF language has 8 commands:+-- Command   Equivalent C    Action+-- -------   ------------    ------+-- ,         *h=getchar();   Read a character from stdin, 255 on EOF+-- .         putchar(*h);    Write a character to stdout+-- -         --*h;           Decrement tape+-- +         ++*h;           Increment tape+-- <         --h;            Move head left+-- >         ++h;            Move head right+-- [         while(*h) {     Start loop+-- ]         }               End loop+--++import qualified LLVM.ExecutionEngine as EE+import qualified LLVM.Util.Memory as Memory+import LLVM.Util.File (writeCodeGenModule)+import LLVM.Core++import qualified System.IO as IO+import System.Environment (getArgs)+import System.Exit (exitFailure)++import Control.Monad (when)+import Data.Word (Word8, Word32, Word)+import Data.Int (Int32)+++main :: IO ()+main = do+    -- Initialize jitter+    initializeNativeTarget++    aargs <- getArgs+    let (args, debug) =+           case aargs of+              "-":rargs -> (rargs, True)+              _ -> (aargs, False)+    let text = "+++++++++++++++++++++++++++++++++" ++  -- constant 33+               ">++++" ++                              -- next cell, loop counter, constant 4+               "[>++++++++++" ++                       -- loop, loop counter, constant 10+                 "[" ++                                -- loop+                   "<<.+>>-" ++                        -- back to 33, print, increment, forward, decrement loop counter+                 "]<-" ++                              -- back to 4, decrement loop counter+               "]" +++               "++++++++++."+    prog <-+       case args of+          [] -> return text+          fileName:[] -> readFile fileName+          _ ->+             IO.hPutStrLn IO.stderr "too many arguments" >>+             exitFailure++    when debug $+       writeCodeGenModule "BrainF.bc" $ brainCompile debug prog 65536++    bfprog <- EE.simpleFunction $ brainCompile debug prog 65536+    when (prog == text) $+        putStrLn "Should print '!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGH' on the next line:"+    bfprog++brainCompile :: Bool -> String -> Word -> CodeGenModule (Function (IO ()))+brainCompile _debug instrs wmemtotal = do+    -- LLVM functions+    memset    <- Memory.memset+    getchar   <- newNamedFunction ExternalLinkage "getchar"+              :: TFunction (IO Int32)+    putchar   <- newNamedFunction ExternalLinkage "putchar"+              :: TFunction (Int32 -> IO Int32)++    -- Generate code, first argument is the list of commands,+    -- second argument is a stack of loop contexts, and the+    -- third argument is the current register for the head and+    -- the current basic block.+    -- A loop context is a triple of the phi node, the loop top label,+    -- and the loop exit label.+    let generate [] [] _ = return ()+        generate [] (_:_) _ = error "Missing ]"+        generate (']':_) [] _ = error "Missing ["+        generate (']':is) ((cphi, loop, exit) : bs) (cur, bb) = do+            -- The loop has terminated, add the phi node at the top,+            -- branch to the top, and set up the exit label.+            addPhiInputs cphi [(cur, bb)]+            br loop+            defineBasicBlock exit+            generate is bs (cphi, exit)++        generate ('[':is) bs curbb = do+            -- Start a new loop.+            loop <- newBasicBlock    -- loop top+            body <- newBasicBlock    -- body of the loop+            exit <- newBasicBlock    -- loop exit label+            br loop++            defineBasicBlock loop+            cur <- phi [curbb]       -- will get one more input from the loop terminator.+            val <- load cur          -- load head byte.+            eqz <- cmp CmpEQ val (valueOf (0::Word8)) -- test if it is 0.+            condBr eqz exit body     -- and branch accordingly.++            defineBasicBlock body+            generate is ((cur, loop, exit) : bs) (cur, body)++        generate (i:is) bs (curhead, bb) = do+            -- A simple command, with no new basic blocks.+            -- Just update which register the head is in.+            curhead' <- gen curhead i+            generate is bs (curhead', bb)++        gen cur ',' = do+            -- Read a character.+            char32 <- call getchar+            char8  <- trunc char32+            store char8 cur+            return cur+        gen cur '.' = do+            -- Write a character.+            char8 <- load cur+            char32 <- zext char8+            _ <- call putchar char32+            return cur+        gen cur '-' = do+            -- Decrement byte at head.+            val <- load cur+            val' <- sub val (valueOf (1 :: Word8))+            store val' cur+            return cur+        gen cur '+' = do+            -- Increment byte at head.+            val <- load cur+            val' <- add val (valueOf (1 :: Word8))+            store val' cur+            return cur+        gen cur '<' =+            -- Decrement head.+            getElementPtr cur (-1 :: Int32, ())+        gen cur '>' =+            -- Increment head.+            getElementPtr cur (1 :: Word32, ())+        gen _ c = error $ "Bad character in program: " ++ show c+++    brainf <- createFunction ExternalLinkage $ do+        ptr_arr <- arrayMalloc wmemtotal+        _ <- memset ptr_arr (valueOf 0) (valueOf wmemtotal) (valueOf 0) (valueOf False)+--        _ptr_arrmax <- getElementPtr ptr_arr (wmemtotal, ())+        -- Start head in the middle.+        curhead <- getElementPtr ptr_arr (wmemtotal `div` 2, ())++        bb <- getCurrentBasicBlock+        generate instrs [] (curhead, bb)++        free ptr_arr+        ret ()++    return brainf
+ example/CallConv.hs view
@@ -0,0 +1,29 @@+module Main (main) where++import LLVM.Core+import LLVM.FFI.Core (CallingConvention(GHC))++import Data.Word (Word32)+++-- Our module will have these two functions.+data Mod = Mod {+    f1 :: Function (Word32 -> IO Word32),+    f2 :: Function (Word32 -> Word32 -> IO Word32)+    }++main :: IO ()+main = do+    m <- createModule $ setTarget hostTriple >> buildMod >> getModule+    --_ <- optimizeModule 3 m+    writeBitcodeToFile "CallConv.bc" m++buildMod :: CodeGenModule Mod+buildMod = do+    fun2 <- createNamedFunction InternalLinkage "plus" $ \ x y ->+      ret =<< add x y+    setFuncCallConv fun2 GHC+    fun1 <- newNamedFunction ExternalLinkage "test"+    defineFunction fun1 $ \ arg ->+      ret =<< callWithConv GHC fun2 arg (valueOf 1)+    return $ Mod {f1 = fun1, f2 = fun2}
+ example/Convert.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE FlexibleInstances #-}+module Convert(Convert(..)) where++import Foreign.Ptr (FunPtr)+import Data.Int (Int32)+import Data.Word (Word32)++type Importer f = FunPtr f -> f++class Convert f where+    convert :: Importer f++foreign import ccall safe "dynamic" c_IOFloat :: Importer (IO Float)+instance Convert (IO Float) where convert = c_IOFloat++foreign import ccall safe "dynamic" c_Float_IOFloat :: Importer (Float -> IO Float)+instance Convert (Float -> IO Float) where convert = c_Float_IOFloat++foreign import ccall safe "dynamic" c_Float_Float :: Importer (Float -> Float)+instance Convert (Float -> Float) where convert = c_Float_Float++foreign import ccall safe "dynamic" c_IODouble :: Importer (IO Double)+instance Convert (IO Double) where convert = c_IODouble++foreign import ccall safe "dynamic" c_Double_IODouble :: Importer (Double -> IO Double)+instance Convert (Double -> IO Double) where convert = c_Double_IODouble++foreign import ccall safe "dynamic" c_Double_Double :: Importer (Double -> Double)+instance Convert (Double -> Double) where convert = c_Double_Double++foreign import ccall safe "dynamic" c_Word32_IOWord32 :: Importer (Word32 -> IO Word32)+instance Convert (Word32 -> IO Word32) where convert = c_Word32_IOWord32++foreign import ccall safe "dynamic" c_Word32_Word32 :: Importer (Word32 -> Word32)+instance Convert (Word32 -> Word32) where convert = c_Word32_Word32++foreign import ccall safe "dynamic" c_Int32_IOInt32 :: Importer (Int32 -> IO Int32)+instance Convert (Int32 -> IO Int32) where convert = c_Int32_IOInt32++foreign import ccall safe "dynamic" c_Int32_Int32 :: Importer (Int32 -> Int32)+instance Convert (Int32 -> Int32) where convert = c_Int32_Int32+
+ example/DotProd.hs view
@@ -0,0 +1,86 @@+module Main (main) where++import qualified LLVM.ExecutionEngine as EE+import LLVM.Core++import LLVM.Util.Loop (forLoop)+import LLVM.Util.File (writeCodeGenModule)+import LLVM.Util.Foreign (withArrayLen)++import qualified Type.Data.Num.Decimal.Number as Dec+import qualified Type.Data.Num.Decimal.Literal as TypeNum+import Type.Base.Proxy (Proxy(Proxy))++import qualified Data.Traversable as Trav+import qualified Data.List.HT as ListHT+import qualified Data.List as List+import Data.Maybe.HT (toMaybe)+import Data.Maybe (fromMaybe)+import Data.Tuple.HT (swap)+import Data.Word (Word32)++import Control.Applicative (pure)+++mDotProd ::+    (Dec.Positive n,+     IsPrimitive a, IsArithmetic a, IsFirstClass a, IsConst a, Num a) =>+    CodeGenModule+        (Function (Word32 -> Ptr (Vector n a) -> Ptr (Vector n a) -> IO a))+mDotProd =+  createFunction ExternalLinkage $ \ size aPtr bPtr -> do+    s <- forLoop (valueOf 0) size (value zero) $ \ i s -> do++        ap <- getElementPtr aPtr (i, ()) -- index into aPtr+        bp <- getElementPtr bPtr (i, ()) -- index into bPtr+        a <- load ap                     -- load element from a vector+        b <- load bp                     -- load element from b vector+        ab <- mul a b                    -- multiply them+        add s ab                         -- accumulate sum++    r <-+        forLoop+            (valueOf (0::Word32))+            (valueOf (Dec.integralFromProxy (vectorSize aPtr)))+            (valueOf 0)+            (\ i r -> add r =<< extractelement s i)+    ret r++vectorSize :: Value (Ptr (Vector n a)) -> Proxy n+vectorSize _ = Proxy+++type R = Float+type T = Vector TypeNum.D4 R++main :: IO ()+main = do+    -- Initialize jitter+    initializeNativeTarget+    let mDotProd' = mDotProd+    writeCodeGenModule "DotProd.bc" mDotProd'++    ioDotProd <- EE.simpleFunction mDotProd'+    let dotProd :: [T] -> [T] -> R+        dotProd a b =+         EE.unsafeRemoveIO $+         withArrayLen a $ \ aLen aPtr ->+         withArrayLen b $ \ bLen bPtr ->+         ioDotProd (fromIntegral (aLen `min` bLen)) aPtr bPtr+++    let a = [1 .. 8]+        b = [4 .. 11]+    print $ dotProd (vectorize 0 a) (vectorize 0 b)+    print $ sum $ zipWith (*) a b++vectorize :: (Positive n) => a -> [a] -> [Vector n a]+vectorize deflt =+    List.unfoldr (\xs -> toMaybe (not $ null xs) (vectorizeHead deflt xs))++vectorizeHead :: (Positive n) => a -> [a] -> (Vector n a, [a])+vectorizeHead deflt ys =+    swap $+    Trav.mapAccumL+        (\xt () -> swap $ fromMaybe (deflt,[]) $ ListHT.viewL xt)+        ys (pure ())
+ example/Fibonacci.hs view
@@ -0,0 +1,112 @@+module Main (main) where++import qualified LLVM.ExecutionEngine as EE+import LLVM.Util.Optimize (optimizeModule)+import LLVM.Core++import System.Environment (getArgs)+import Control.Monad (forM_)+import Data.Word (Word32)++import Prelude hiding(and, or)+++-- Our module will have these two functions.+data Mod = Mod {+    mfib :: Function (Word32 -> IO Word32),+    _mplus :: Function (Word32 -> Word32 -> IO Word32)+    }++main :: IO ()+main = do+    args <- getArgs+    let args' = if null args then ["10"] else args++    -- Initialize jitter+    initializeNativeTarget+    -- Create a module,+    m <- newNamedModule "fib"+    -- and define its contents.+    td <- EE.getTargetData+    fns <-+        defineModule m $ do+            setTarget hostTriple+            setDataLayout (EE.dataLayoutStr td)+            buildMod++    -- Show the code for the two functions, just for fun.+    --dumpValue $ mfib fns+    --dumpValue $ mplus fns+    -- Write the code to a file for later perusal.+    -- Can be disassembled with llvm-dis.+    writeBitcodeToFile "Fibonacci.bc" m++    _ <- optimizeModule 3 m+    writeBitcodeToFile "Fibonacci-opt.bc" m++    -- Generate code for mfib, and then throw away the IO in the type.+    -- The result is an ordinary Haskell function.+    iofib <- EE.runEngineAccessWithModule m $+                 EE.generateFunction $ mfib fns+    let fib = EE.unsafeRemoveIO iofib++    -- Run fib for the arguments.+    forM_ args' $ \num -> do+        putStrLn $ "fib " ++ num ++ " = " ++ show (fib (read num))++buildMod :: CodeGenModule Mod+buildMod = do+    -- Add two numbers in a cumbersome way.+    plus <- createFunction InternalLinkage $ \ x y -> do+        -- Create three additional basic blocks, need to be created before being referred to.+        l1 <- newBasicBlock+        l2 <- newBasicBlock+        l3 <- newBasicBlock++        -- Test if x is even/odd.+        a <- and x (valueOf (1 :: Word32))+        c <- cmp CmpEQ a (valueOf (0 :: Word32))+        condBr c l1 l2++        -- Do x+y if even.+        defineBasicBlock l1+        r1 <- add x y+        br l3++        -- Do y+x if odd.+        defineBasicBlock l2+        r2 <- add y x+        br l3++        defineBasicBlock l3+        -- Join the two execution paths with a phi instruction.+        r <- phi [(r1, l1), (r2, l2)]+        ret r++    -- The usual doubly recursive Fibonacci.+    -- Use new&define so the name fib is defined in the body for recursive calls.+    fib <- newNamedFunction ExternalLinkage "fib"+    defineFunction fib $ \ arg -> do+        -- Create the two basic blocks.+        recurse <- newBasicBlock+        exit <- newBasicBlock++        -- Test if arg > 2+        test <- cmp CmpGT arg (valueOf (2::Word32))+        condBr test recurse exit++        -- Just return 1 if not > 2+        defineBasicBlock exit+        ret (valueOf (1::Word32))++        -- Recurse if > 2, using the cumbersome plus to add the results.+        defineBasicBlock recurse+        x1 <- sub arg (valueOf (1::Word32))+        fibx1 <- call fib x1+        x2 <- sub arg (valueOf (2::Word32))+        fibx2 <- call fib x2+        r <- call plus fibx1 fibx2+        ret r++    -- Return the two functions.+    return $ Mod fib plus
+ example/HelloJIT.hs view
@@ -0,0 +1,23 @@+module Main (main) where++import qualified LLVM.ExecutionEngine as EE+import LLVM.Core++import Data.Word (Word8, Word32)+++bldGreet :: CodeGenModule (Function (IO ()))+bldGreet = withStringNul "Hello, JIT!" (\greetz -> do+    puts <- newNamedFunction ExternalLinkage "puts" :: TFunction (Ptr Word8 -> IO Word32)+    func <- createFunction ExternalLinkage $ do+      _ <- call puts =<< getElementPtr0 greetz (0::Word32, ())+      ret ()+    return func)++main :: IO ()+main = do+    initializeNativeTarget+    greet <- EE.simpleFunction bldGreet+    greet+    greet+    greet
+ example/Intrinsic.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE ForeignFunctionInterface #-}+module Main where++import qualified LLVM.Core as LLVM+import qualified LLVM.ExecutionEngine as EE++import Foreign.Ptr (FunPtr)++import qualified Type.Data.Num.Decimal as TypeNum+import qualified Data.Word as W++import qualified Data.NonEmpty.Class as NonEmptyC+++type Vector4 = LLVM.Vector TypeNum.D4 Float+type Vector8 = LLVM.Vector TypeNum.D8 Float+type Vector = Vector4++vector :: Vector+vector = LLVM.vector $ NonEmptyC.iterate (1.2+) (-1.7 :: Float)++roundpsExtern4 ::+   LLVM.CodeGenFunction r+      (LLVM.Function (Vector4 -> W.Word32 -> IO Vector4))+roundpsExtern4 =+   LLVM.externFunction "llvm.x86.sse41.round.ps"++roundpsExtern8 ::+   LLVM.CodeGenFunction r+      (LLVM.Function (Vector8 -> W.Word32 -> IO Vector8))+roundpsExtern8 =+   LLVM.externFunction "llvm.x86.avx.round.ps.256"++roundps ::+   LLVM.Value Vector -> LLVM.Value W.Word32 ->+   LLVM.CodeGenFunction s (LLVM.Value Vector)+roundps xs mode = do+   f <- roundpsExtern4+   LLVM.call f xs mode++modul ::+   LLVM.CodeGenModule+      (LLVM.Function (LLVM.Ptr Vector -> LLVM.Ptr Vector -> IO ()))+modul =+   LLVM.createFunction LLVM.ExternalLinkage $ \ptr0 ptr1 -> do+      flip LLVM.store ptr1 =<< flip roundps (LLVM.valueOf 1) =<< LLVM.load ptr0+      LLVM.ret ()++type Importer func = FunPtr func -> func++foreign import ccall safe "dynamic" derefFloorPtr ::+   Importer (LLVM.Ptr Vector -> LLVM.Ptr Vector -> IO ())++run :: IO ()+run = do+   m <- LLVM.newModule+   floorFunc <- do+      func <- LLVM.defineModule m $ LLVM.setTarget LLVM.hostTriple >> modul+      EE.runEngineAccessWithModule m $+         EE.getExecutionFunction derefFloorPtr func+   LLVM.writeBitcodeToFile "floor.bc" m++   print vector+   EE.with vector $ \ptr0 ->+      EE.alloca $ \ptr1 -> do+         floorFunc ptr0 ptr1+         print =<< EE.peek ptr1+++main :: IO ()+main = do+   LLVM.initializeNativeTarget+   run
+ example/List.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ForeignFunctionInterface #-}+module Main (main) where++import qualified LLVM.ExecutionEngine as EE+import LLVM.Util.Loop (Phi, phis, addPhis, )+import LLVM.Core as LLVM+import qualified System.IO as IO++import Data.Word (Word32, )+import Data.Int (Int32, )+import Foreign.Marshal.Array (allocaArray, )+import qualified Foreign.Storable as St++import Foreign.StablePtr (StablePtr, newStablePtr, freeStablePtr, deRefStablePtr, )+import Foreign.Ptr (FunPtr)+import Data.IORef (IORef, newIORef, readIORef, writeIORef, )+++{-+I had to export Phi's methods in llvm-0.6.8+in order to be able to implement this function.+-}+arrayLoop ::+   (Phi a, IsType b,+    Num i, IsConst i, IsInteger i, IsFirstClass i, CmpRet i, CmpResult i ~ Bool) =>+   Value i -> Value (Ptr b) -> a ->+   (Value (Ptr b) -> a -> CodeGenFunction r a) ->+   CodeGenFunction r a+arrayLoop len ptr start loopBody = do+   top <- getCurrentBasicBlock+   loop <- newBasicBlock+   body <- newBasicBlock+   exit <- newBasicBlock++   br loop++   defineBasicBlock loop+   i <- phi [(len, top)]+   p <- phi [(ptr, top)]+   vars <- phis top start+   t <- cmp CmpNE i (valueOf 0 `asTypeOf` len)+   condBr t body exit++   defineBasicBlock body++   vars' <- loopBody p vars+   i' <- sub i (valueOf 1 `asTypeOf` len)+   p' <- getElementPtr p (valueOf 1 :: Value Word32, ())++   body' <- getCurrentBasicBlock+   addPhis body' vars vars'+   addPhiInputs i [(i', body')]+   addPhiInputs p [(p', body')]+   br loop++   defineBasicBlock exit+   return vars+++mList ::+   CodeGenModule (Function+      (StablePtr (IORef [Word32]) -> Word32 -> Ptr Word32 -> IO Int32))+mList =+   createFunction ExternalLinkage $ \ ref size ptr -> do+     next <- staticNamedFunction "next" nelem+     s <- arrayLoop size ptr (valueOf 0) $ \ ptri y -> do+       flip store ptri =<< call next ref+       return y+     ret (s :: Value Int32)++renderList :: IO ()+renderList = do+   m <- createModule $ setTarget hostTriple >> mList >> getModule+   writeBitcodeToFile "List.bc" m++   fill <- EE.simpleFunction mList+   stable <- newStablePtr =<< newIORef [3,5..]+   IO.withFile "listcontent.u32" IO.WriteMode $ \h ->+     let len = 100+     in  allocaArray len $ \ ptr ->+           fill stable (fromIntegral len) (LLVM.fromPtr ptr) >>+           IO.hPutBuf h ptr (len * St.sizeOf(undefined::Int32))+   freeStablePtr stable+++foreign import ccall "&nextListElement"+   nelem :: FunPtr (StablePtr (IORef [Word32]) -> IO Word32)++foreign export ccall+   nextListElement :: StablePtr (IORef [Word32]) -> IO Word32++nextListElement :: StablePtr (IORef [Word32]) -> IO Word32+nextListElement stable =+   do ioRef <- deRefStablePtr stable+      xt <- readIORef ioRef+      case xt of+         [] -> return 0+         (x:xs) -> writeIORef ioRef xs >> return x+++main :: IO ()+main = do+    -- Initialize jitter+    initializeNativeTarget+    renderList
+ example/Struct.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Main (main) where++import qualified LLVM.ExecutionEngine as EE+import LLVM.Util.File (writeCodeGenModule)+import LLVM.Core++import Type.Data.Num.Decimal.Literal (D10, d0, d1, d2)++import Data.Word (Word32)+++foreign import ccall structCheck :: Word32 -> Ptr S -> Int++-- Watch out for double!  Alignment differs between platforms.+-- struct S { uint32 x0; float x1; uint32 x2[10] };+type S = Struct (Word32 :& Float :& Array D10 Word32 :& ())++-- S *s = malloc(sizeof *s); s->x0 = a; s->x1 = 1.2; s->x2[5] = a+1; return s;+mStruct :: CodeGenModule (Function (Word32 -> IO (Ptr S)))+mStruct = do+    createFunction ExternalLinkage $ \ x -> do+      p  :: Value (Ptr S)+         <- malloc+      p0 <- getElementPtr0 p (d0 & ())+      store x (p0 :: Value (Ptr Word32))+      p1 <- getElementPtr0 p (d1 & ())+      store (valueOf 1.5) p1+      x' <- add x (valueOf (1 :: Word32))+      p2 <- getElementPtr0 p (d2 & (5::Word32) & ())+      store x' p2+      ret p++main :: IO ()+main = do+    initializeNativeTarget+    writeCodeGenModule "Struct.bc" mStruct+    struct <- EE.simpleFunction mStruct+    let a = 10+    p <- struct a+    putStrLn $ if structCheck a p /= 0 then "OK" else "failed"
+ example/Varargs.hs view
@@ -0,0 +1,39 @@+module Main (main) where++import qualified LLVM.ExecutionEngine as EE+import LLVM.Core++import Data.Word (Word8, Word32)+++firstChar ::+    (Natural n) =>+    Value (Ptr (Array n Word8)) -> CodeGenFunction r (Value (Ptr Word8))+firstChar str = getElementPtr0 str (0::Word32, ())++bldVarargs :: CodeGenModule (Function (Word32 -> IO ()))+bldVarargs =+   withStringNul "Hello\n" (\fmt1 ->+   withStringNul "A number %d\n" (\fmt2 ->+   withStringNul "Two numbers %d %d\n" (\fmt3 -> do+      printf <- newNamedFunction ExternalLinkage "printf" :: TFunction (Ptr Word8 -> VarArgs Word32)+      func <- createFunction ExternalLinkage $ \ x -> do++        tmp1 <- firstChar fmt1+        _ <- call (castVarArgs printf) tmp1++        tmp2 <- firstChar fmt2+        _ <- call (castVarArgs printf) tmp2 x++        tmp3 <- firstChar fmt3+        _ <- call (castVarArgs printf) tmp3 x x++        ret ()+      return func+   )))++main :: IO ()+main = do+    initializeNativeTarget+    varargs <- EE.simpleFunction bldVarargs+    varargs 42
+ example/Vector.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE TypeOperators #-}+module Main (main) where++import Convert++import LLVM.ExecutionEngine+          (runEngineAccessWithModule, generateFunction, getExecutionFunction)+import LLVM.Util.Optimize (optimizeModule, )+import LLVM.Util.Loop (forLoop, )+import LLVM.Core++import qualified Type.Data.Num.Decimal.Number as Dec+import Type.Data.Num.Decimal.Literal (D16, )++import Control.Monad.IO.Class (liftIO, )+import Control.Monad (liftM2, when, )+import Data.Word (Word32)+import Data.Int (Int32)++-- Type of vector elements.+type T = Int32++-- Number of vector elements.+type N = D16++retAccName, fName :: String+retAccName = "retacc"+fName = "vectest"++cgvec :: CodeGenModule (Function (T -> IO T))+cgvec = do+    -- A global variable that vectest messes with.+    acc <- createNamedGlobal False ExternalLinkage "acc" (constOf (0 :: T))++    -- Return the global variable.+    retAcc <- createNamedFunction ExternalLinkage retAccName $ do+        vacc <- load acc+        ret vacc+    let _ = retAcc :: Function (IO T)  -- Force the type of retAcc.++    -- A function that tests vector operations.+    f <- createNamedFunction ExternalLinkage fName $ \ x -> do++        let v = value (zero :: ConstValue (Vector N T))+            n = Dec.integralFromSingleton (Dec.singleton :: Dec.Singleton N) :: Word32++        -- Fill the vector with x, x+1, x+2, ...+        (_, v1) <- forLoop (valueOf 0) (valueOf n) (x, v) $ \ i (x1, v1) -> do+            x1' <- add x1 (valueOf (1::T))+            v1' <- insertelement v1 x1 i+            return (x1', v1')++        -- Elementwise cubing of the vector.+        vcb <- mul v1 =<< mul v1 v1++        -- Sum the elements of the vector.+        s <- forLoop (valueOf 0) (valueOf n) (valueOf 0) $ \ i s -> do+            y <- extractelement vcb i+            add s (y :: Value T)++        -- Update the global variable.+        vacc <- load acc+        vacc' <- add vacc s+        store vacc' acc++        ret (s :: Value T)++    when False $ liftIO $ dumpValue f+    return f++createFuncModule :: IO (Module, Function (T -> IO T))+createFuncModule =+    createModule $ setTarget hostTriple >> liftM2 (,) getModule cgvec++main :: IO ()+main = do+    -- Initialize jitter+    initializeNativeTarget++    -- First run standard code.+    do  (m, iovec) <- createFuncModule+        fvec <- runEngineAccessWithModule m $ getExecutionFunction convert iovec+        fvec 10 >>= print++    do  (m, iovec) <- createFuncModule+        vec <- runEngineAccessWithModule m $ generateFunction iovec+        vec 10 >>= print++    -- And then optimize and run.+    do  m <- fmap fst createFuncModule+        _ <- optimizeModule 1 m++        funcs <- getModuleValues m+        print $ map fst funcs++        let iovec' :: Function (T -> IO T)+            Just iovec' = castModuleValue =<< lookup fName funcs+            ioretacc' :: Function (IO T)+            Just ioretacc' = castModuleValue =<< lookup retAccName funcs++        (vec', retacc') <-+            runEngineAccessWithModule m $+            liftM2 (,) (generateFunction iovec') (generateFunction ioretacc')++        when False $ dumpValue iovec'++        vec' 10 >>= print+        vec' 0 >>= print+        retacc' >>= print
+ example/structCheck.c view
@@ -0,0 +1,9 @@+#include <stdint.h>++struct S { uint32_t x0; float x1; uint32_t x2[10]; };++int+structCheck(uint32_t a, struct S *s)+{+  return s->x0 == a && s->x1 == 1.5 && s->x2[5] == a+1;+}
+ llvm-tf.cabal view
@@ -0,0 +1,317 @@+Name:          llvm-tf+Version:       21.0+License:       BSD3+License-File:  LICENSE+Synopsis:      Bindings to the LLVM compiler toolkit using type families.+Description:+  High-level bindings to the LLVM compiler toolkit using type families.+  .+  A note on versioning:+  The versions of this package are loosely based on the LLVM version.+  However, we depend on a relatively stable part of LLVM+  and provide a relatively stable API for it.+  We conform to the Package Versioning Policy PVP,+  i.e. we increase the version of this package when its API changes,+  but not necessarily when we add support for a new LLVM version.+  We support all those LLVM versions+  that are supported by our @llvm-ffi@ dependency.+  .+  This package is a descendant of the @llvm@ package+  which used functional dependencies.+  The original @llvm@ package will no longer work+  with current versions of LLVM nor GHC.+Author:        Henning Thielemann, Bryan O'Sullivan, Lennart Augustsson+Maintainer:    Henning Thielemann <llvm@henning-thielemann.de>+Homepage:      https://wiki.haskell.org/LLVM+Stability:     experimental+Category:      Compilers/Interpreters, Code Generation+Tested-With:   GHC == 7.4.2, GHC == 8.6.5+Cabal-Version: 2.0+Build-Type:    Simple++Extra-Source-Files:+  Changes.md++Source-Repository head+  Type:     darcs+  Location: http://code.haskell.org/~thielema/llvm-tf/++Source-Repository this+  Tag:      21.0+  Type:     darcs+  Location: http://code.haskell.org/~thielema/llvm-tf/++Flag developer+  Description: developer mode - warnings let compilation fail+  Manual: True+  Default: False++Flag buildExamples+  Description: Build example executables+  Default:     False++Library private+  Default-Language: Haskell98+  Build-Depends:+    llvm-ffi >=17.0 && <22.0,+    tfp >=1.0 && <1.1,+    transformers >=0.3 && <0.7,+    storable-record >=0.0.2 && <0.1,+    enumset >=0.0.5 && <0.2,+    fixed-length >=0.2 && <0.3,+    non-empty >=0.2 && <0.4,+    semigroups >=0.1 && <1.0,+    utility-ht >=0.0.10 && <0.1,+    QuickCheck >=2.0 && <3.0,+    containers >=0.4 && <0.8,+    base >=3 && <5++  Hs-Source-Dirs: private+  GHC-Options: -Wall++  If flag(developer)+    GHC-Options: -Werror++  If os(darwin)+    Ld-Options: -w+    Frameworks: vecLib+    CPP-Options: -D__MACOS__++  C-Sources:+--    cbits/free.c+    cbits/malloc.c++  Exposed-Modules:+    LLVM.Core.CodeGen+    LLVM.Core.CodeGenMonad+    LLVM.Core.Data+    LLVM.Core.Instructions+    LLVM.Core.Instructions.Guided+    LLVM.Core.Instructions.Private+    LLVM.Core.Proxy+    LLVM.Core.Type+    LLVM.Core.Util+    LLVM.Core.Vector+    LLVM.Core.UnaryVector+    LLVM.ExecutionEngine.Engine+    LLVM.ExecutionEngine.Target+    LLVM.ExecutionEngine.Marshal++Library+  Default-Language: Haskell98+  Build-Depends:+    private,+    llvm-ffi,+    tfp,+    utility-ht,+    base++  Hs-Source-Dirs: src+  GHC-Options: -Wall++  Exposed-Modules:+    LLVM.Core+    LLVM.Core.Attribute+    LLVM.Core.Guided+    LLVM.ExecutionEngine+    LLVM.Util.Arithmetic+    LLVM.Util.File+    LLVM.Util.Foreign+    LLVM.Util.Intrinsic+    LLVM.Util.Loop+    LLVM.Util.Memory+    LLVM.Util.Optimize+    LLVM.Util.Proxy++Test-Suite llvm-test+  Type: exitcode-stdio-1.0+  Build-Depends:+    QuickCheck >=2.11 && <3,+    private,+    llvm-tf,+    tfp,+    utility-ht,+    base+  Default-Language: Haskell98+  GHC-Options: -Wall+  Hs-Source-Dirs: test+  Main-Is: Main.hs+  Other-Modules:+    Test.Chop+    Test.Marshal++Executable llvm-align+  If flag(buildExamples)+    Build-Depends:+      llvm-tf,+      tfp,+      base+  Else+    Buildable: False++  Main-Is: example/Align.hs+  Default-Language: Haskell98+  GHC-Options: -Wall++Executable llvm-arith+  If flag(buildExamples)+    Build-Depends:+      llvm-tf,+      tfp,+      base+  Else+    Buildable: False++  Main-Is: example/Arith.hs+  Default-Language: Haskell98+  GHC-Options: -Wall++Executable llvm-array+  If flag(buildExamples)+    Build-Depends:+      llvm-tf,+      tfp,+      base+  Else+    Buildable: False++  Main-Is: example/Array.hs+  Default-Language: Haskell98+  GHC-Options: -Wall++Executable llvm-brainf+  If flag(buildExamples)+    Build-Depends:+      llvm-tf,+      tfp,+      base+  Else+    Buildable: False++  Main-Is: example/BrainF.hs+  Default-Language: Haskell98+  GHC-Options: -Wall++Executable llvm-call-conv+  If flag(buildExamples)+    Build-Depends:+      llvm-tf,+      llvm-ffi,+      tfp,+      base+  Else+    Buildable: False++  Main-Is: example/CallConv.hs+  Default-Language: Haskell98+  GHC-Options: -Wall++Executable llvm-dot-prod+  If flag(buildExamples)+    Build-Depends:+      llvm-tf,+      tfp,+      utility-ht,+      base+  Else+    Buildable: False++  Main-Is: example/DotProd.hs+  Default-Language: Haskell98+  GHC-Options: -Wall++Executable llvm-fibonacci+  If flag(buildExamples)+    Build-Depends:+      llvm-tf,+      tfp,+      base+  Else+    Buildable: False++  Main-Is: example/Fibonacci.hs+  Default-Language: Haskell98+  GHC-Options: -Wall++Executable llvm-hello-jit+  If flag(buildExamples)+    Build-Depends:+      llvm-tf,+      tfp,+      base+  Else+    Buildable: False++  Main-Is: example/HelloJIT.hs+  Default-Language: Haskell98+  GHC-Options: -Wall++Executable llvm-intrinsic+  If flag(buildExamples)+    Build-Depends:+      llvm-tf,+      tfp,+      non-empty,+      base+  Else+    Buildable: False++  Main-Is: example/Intrinsic.hs+  Default-Language: Haskell98+  GHC-Options: -Wall++Executable llvm-list+  If flag(buildExamples)+    Build-Depends:+      llvm-tf,+      tfp,+      base+  Else+    Buildable: False++  Main-Is: example/List.hs+  Default-Language: Haskell98+  GHC-Options: -Wall++Executable llvm-struct+  If flag(buildExamples)+    Build-Depends:+      llvm-tf,+      tfp,+      base+  Else+    Buildable: False++  Main-Is: example/Struct.hs+  C-Sources: example/structCheck.c+  Default-Language: Haskell98+  GHC-Options: -Wall++Executable llvm-varargs+  If flag(buildExamples)+    Build-Depends:+      llvm-tf,+      tfp,+      base+  Else+    Buildable: False++  Main-Is: example/Varargs.hs+  Default-Language: Haskell98+  GHC-Options: -Wall++Executable llvm-vector+  If flag(buildExamples)+    Build-Depends:+      llvm-tf,+      tfp,+      transformers,+      base+  Else+    Buildable: False++  Hs-Source-Dirs: example+  Main-Is: Vector.hs+  Other-Modules: Convert+  Default-Language: Haskell98+  GHC-Options: -Wall
+ private/LLVM/Core/CodeGen.hs view
@@ -0,0 +1,723 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+module LLVM.Core.CodeGen(+    -- * Module creation+    newModule, newNamedModule, defineModule, createModule, createNamedModule,+    getModuleValues, ModuleValue, castModuleValue, setTarget, setDataLayout,+    -- * Globals+    Linkage(..),+    Visibility(..),+    -- * Function creation+    Function, newFunction, newNamedFunction, defineFunction,+    createFunction, createNamedFunction, setFuncCallConv, functionParameter,+    addAttributes,+    FFI.AttributeIndex(..), Attribute(..),+    externFunction, staticFunction, staticNamedFunction,+    FunctionArgs, FunctionCodeGen, FunctionResult,+    TFunction,+    CodeValue, CodeResult,+    proxyFromFunction,+    -- * Global variable creation+    Global, newGlobal, newNamedGlobal,+    defineGlobal, createGlobal, createNamedGlobal, TGlobal,+    externGlobal, staticGlobal,+    -- * Values+    Value(..), ConstValue(..), UnValue,+    IsConst(..), valueOf, value,+    IsConstFields,+    zero, allOnes, undef,+    createString, createStringNul,+    withString, withStringNul,+    constVector, constArray, constStruct, constPackedStruct,+    constCyclicVector, constCyclicArray,+    -- * Basic blocks+    BasicBlock(..), newBasicBlock, newNamedBasicBlock,+    defineBasicBlock, createBasicBlock, getCurrentBasicBlock,+    fromLabel, toLabel,+    -- * Misc+    withCurrentBuilder+    ) where++import qualified LLVM.Core.UnaryVector as UnaryVector+import qualified LLVM.Core.Util as U+import qualified LLVM.Core.Data as Data+import qualified LLVM.Core.Proxy as LP+import LLVM.Core.CodeGenMonad+import LLVM.Core.Type+import LLVM.Core.Data hiding (Ptr)++import qualified LLVM.FFI.Core.Attribute as Attr+import qualified LLVM.FFI.Core as FFI+import LLVM.FFI.Core(Linkage(..), Visibility(..))++import qualified Type.Data.Num.Decimal.Proof as DecProof+import qualified Type.Data.Num.Decimal.Number as Dec+import qualified Type.Data.Num.Unary as Un+import Type.Base.Proxy (Proxy)++import qualified Foreign+import Foreign.C.String (withCString, withCStringLen)+import Foreign.StablePtr (StablePtr, castStablePtrToPtr)+import Foreign.Ptr (FunPtr, castFunPtrToPtr)+import System.IO.Unsafe (unsafePerformIO)++import Control.Monad.IO.Class (liftIO)+import Control.Monad (liftM, when)+import Control.Applicative ((<*>))++import qualified Data.NonEmpty as NonEmpty+import qualified Data.Foldable as Fold+import Data.Typeable (Typeable)+import Data.Int (Int8, Int16, Int32, Int64)+import Data.Word (Word8, Word16, Word32, Word64, Word)+import Data.Tuple.HT (mapSnd)+import Data.Maybe.HT (toMaybe)+import Data.Maybe (fromMaybe)++import Text.Printf (printf)++--------------------------------------++-- | Create a new module.+newModule :: IO U.Module+newModule = newNamedModule "_module"  -- XXX should generate a name++-- | Create a new explicitely named module.+newNamedModule :: String              -- ^ module name+               -> IO U.Module+newNamedModule = U.createModule++-- | Give the body for a module.+defineModule :: U.Module              -- ^ module that is defined+             -> CodeGenModule a       -- ^ module body+             -> IO a+defineModule = runCodeGenModule++-- | Create a new module with the given body.+createModule :: CodeGenModule a       -- ^ module body+             -> IO a+createModule cgm = newModule >>= \ m -> defineModule m cgm++-- | Create a new explicitly named module with the given body.+createNamedModule :: String              -- ^ module name+                  -> CodeGenModule a     -- ^ module body+                  -> IO a+createNamedModule name cgm = newNamedModule name >>= \ m -> defineModule m cgm++setTarget :: String -> CodeGenModule ()+setTarget triple = do+    modul <- getModule+    liftIO $ U.withModule modul $ \m -> withCString triple $ FFI.setTarget m++setDataLayout :: String -> CodeGenModule ()+setDataLayout layout = do+    modul <- getModule+    liftIO $ U.withModule modul $ \m -> withCString layout $ FFI.setDataLayout m+++--------------------------------------++newtype ModuleValue = ModuleValue FFI.ValueRef+    deriving (Show, Typeable)++getModuleValues :: U.Module -> IO [(String, ModuleValue)]+getModuleValues =+    liftM (map (\ (s,p) -> (s, ModuleValue p))) . U.getModuleValues++castModuleValue :: forall a . (IsType a) => ModuleValue -> Maybe (Value a)+castModuleValue (ModuleValue f) =+    toMaybe (U.valueHasType f (unsafeTypeRef (LP.Proxy :: LP.Proxy a))) (Value f)++--------------------------------------++newtype Value a = Value { unValue :: FFI.ValueRef }+    deriving (Show, Typeable)++newtype ConstValue a = ConstValue { unConstValue :: FFI.ValueRef }+    deriving (Show, Typeable)++-- XXX merge with IsArithmetic?+class IsConst a where+    constOf :: a -> ConstValue a++instance IsConst Bool   where constOf = constEnum (typeRef (LP.Proxy :: LP.Proxy Bool))+--instance IsConst Char   where constOf = constEnum (typeRef (0::Word8)) -- XXX Unicode+instance IsConst Word   where constOf = constI+instance IsConst Word8  where constOf = constI+instance IsConst Word16 where constOf = constI+instance IsConst Word32 where constOf = constI+instance IsConst Word64 where constOf = constI+instance IsConst Int    where constOf = constI+instance IsConst Int8   where constOf = constI+instance IsConst Int16  where constOf = constI+instance IsConst Int32  where constOf = constI+instance IsConst Int64  where constOf = constI+instance IsConst Float  where constOf = constF+instance IsConst Double where constOf = constF+--instance IsConst FP128  where constOf = constF++instance (Dec.Positive n) => IsConst (WordN n) where+    constOf (WordN i) = constInteger i+instance (Dec.Positive n) => IsConst (IntN n) where+    constOf (IntN i) = constInteger i++constOfPtr :: (IsType ptr) => ptr -> Foreign.Ptr b -> ConstValue ptr+constOfPtr proto p =+    let ip = p `Foreign.minusPtr` Foreign.nullPtr+        inttoptrC :: ConstValue int -> ConstValue ptr+        inttoptrC (ConstValue v) =+           unsafeConstValue $+           FFI.constIntToPtr v $ unsafeTypeRef $ LP.fromValue proto+    in  inttoptrC $ constOf ip++-- This instance doesn't belong here, but mutually recursive modules are painful.+instance IsConst (Foreign.Ptr a) where+    constOf p = constOfPtr p p++instance (IsType a) => IsConst (Data.Ptr a) where+    constOf p = constOfPtr p (Data.uncheckedToPtr p)++instance (IsFunction a) => IsConst (FunPtr a) where+    constOf p = constOfPtr p (castFunPtrToPtr p)++instance IsConst (StablePtr a) where+    constOf p = constOfPtr p (castStablePtrToPtr p)++instance (IsPrimitive a, IsConst a, Dec.Positive n) => IsConst (Vector n a) where+    constOf (Vector x) = constVectorGen constOf x++instance (IsConst a, IsSized a, Dec.Natural n) => IsConst (Array n a) where+    constOf (Array xs) = constArray (map constOf xs)++instance (IsConstFields a) => IsConst (Struct a) where+    constOf (Struct a) =+        unsafeConstValue $ U.constStruct (constFieldsOf a) False+instance (IsConstFields a) => IsConst (PackedStruct a) where+    constOf (PackedStruct a) =+        unsafeConstValue $ U.constStruct (constFieldsOf a) True++class IsConstFields a where+    constFieldsOf :: a -> [FFI.ValueRef]++instance (IsConst a, IsConstFields as) => IsConstFields (a, as) where+    constFieldsOf (a, as) = unConstValue (constOf a) : constFieldsOf as+instance IsConstFields () where+    constFieldsOf _ = []+++unsafeConstValue :: IO FFI.ValueRef -> ConstValue a+unsafeConstValue =+    ConstValue . unsafePerformIO++unsafeWithConstValue ::+    forall a.+    (IsType a) =>+    (FFI.TypeRef -> IO FFI.ValueRef) ->+    ConstValue a+unsafeWithConstValue f =+    unsafePerformIO $ fmap ConstValue $+        f =<< typeRef (LP.Proxy :: LP.Proxy a)++constEnum :: (Enum a) => IO FFI.TypeRef -> a -> ConstValue a+constEnum mt i =+    unsafeConstValue $ mt >>= \t ->+        FFI.constInt t (fromIntegral $ fromEnum i) FFI.false++{-+ToDo:+Passes a BigInt as decimal number string.+Not very efficient but quite generic.+Maybe Hex is better?+-}+constInteger :: (IsType (intN n)) => Integer -> ConstValue (intN n)+constInteger i =+    unsafeWithConstValue $ \typ ->+    withCString (show i) $ \cstr ->+    FFI.constIntOfString typ cstr 10++constI :: (IsInteger a, Integral a) => a -> ConstValue a+constI i =+    unsafeWithConstValue $ \typ ->+    FFI.constInt typ (fromIntegral i) (FFI.consBool $ isSigned $ LP.fromValue i)++constF :: (IsFloating a, Real a) => a -> ConstValue a+constF i =+    unsafeWithConstValue $ \typ -> FFI.constReal typ (realToFrac i)++valueOf :: (IsConst a) => a -> Value a+valueOf = value . constOf++value :: ConstValue a -> Value a+value (ConstValue a) = Value a++zero :: forall a . (IsType a) => ConstValue a+zero = unsafeWithConstValue FFI.constNull++allOnes :: forall a . (IsInteger a) => ConstValue a+allOnes = unsafeWithConstValue FFI.constAllOnes++undef :: forall a . (IsType a) => ConstValue a+undef = unsafeWithConstValue FFI.getUndef++{-+createString :: String -> ConstValue (DynamicArray Word8)+createString = ConstValue . U.constString++constStringNul :: String -> ConstValue (DynamicArray Word8)+constStringNul = ConstValue . U.constStringNul+-}++--------------------------------------+++-- |A function is simply a pointer to the function.+type Function a = Value (FunPtr a)++-- | Create a new named function.+newNamedFunction :: forall a . (IsFunction a)+                 => Linkage+                 -> String   -- ^ Function name+                 -> CodeGenModule (Function a)+newNamedFunction linkage name = do+    modul <- getModule+    typ <- liftIO $ typeRef (LP.Proxy :: LP.Proxy a)+    liftIO $ liftM Value $ U.addFunction modul linkage name typ++-- | Create a new function.  Use 'newNamedFunction' to create a function with external linkage, since+-- it needs a known name.+newFunction :: forall a . (IsFunction a)+            => Linkage+            -> CodeGenModule (Function a)+newFunction linkage = genMSym "fun" >>= newNamedFunction linkage++-- | Define a function body.  The basic block returned by the function is the function entry point.+defineFunction :: forall f . (FunctionArgs f)+               => Function f        -- ^ Function to define (created by 'newFunction').+               -> FunctionCodeGen f -- ^ Function body.+               -> CodeGenModule ()+defineFunction fn body = do+    bld <- liftIO $ U.createBuilder+    let body' = do+            newBasicBlock >>= defineBasicBlock+            paramFunc (unValue fn) (proxyFromFunction fn) body 0+    runCodeGenFunction bld (unValue fn) body'++proxyFromFunction :: Function f -> LP.Proxy f+proxyFromFunction _ = LP.Proxy++-- | Create a new function with the given body.+createFunction :: (FunctionArgs f)+               => Linkage+               -> FunctionCodeGen f  -- ^ Function body.+               -> CodeGenModule (Function f)+createFunction linkage body = do+    f <- newFunction linkage+    defineFunction f body+    return f++-- | Create a new function with the given body.+createNamedFunction :: (FunctionArgs f)+               => Linkage+               -> String+               -> FunctionCodeGen f  -- ^ Function body.+               -> CodeGenModule (Function f)+createNamedFunction linkage name body = do+    f <- newNamedFunction linkage name+    defineFunction f body+    return f++-- | Set the calling convention of a function. By default it is the+-- C calling convention.+setFuncCallConv :: Function a+                -> FFI.CallingConvention+                -> CodeGenModule ()+setFuncCallConv (Value f) cc = do+  liftIO $ FFI.setFunctionCallConv f (FFI.fromCallingConvention cc)++data Attribute = Attribute Attr.Name Word64++-- | Add attributes to a value.  Beware, what attributes are allowed depends on+-- what kind of value it is.+addAttributes ::+    Value a -> FFI.AttributeIndex -> [Attribute] -> CodeGenFunction r ()+addAttributes (Value f) i as =+    liftIO $ do+        context <- FFI.getGlobalContext+        Fold.forM_ as $ \(Attribute (Attr.Name name) val) -> do+            attrKind <-+                withCStringLen name $+                    uncurry FFI.getEnumAttributeKindForName .+                    mapSnd fromIntegral+            FFI.addCallSiteAttribute f i =<<+                FFI.createEnumAttribute context attrKind val++{- |+Convert a function @f@ of type @t1->t2->...-> IO r@ to+@Value t1 -> Value t2 -> ... CodeGenFunction r ()@.+-}+class IsFunction f => FunctionArgs f where+    type FunctionCodeGen f+    type FunctionResult  f+    paramFunc ::+        FFI.ValueRef -> LP.Proxy f -> FunctionCodeGen f ->+        Int -> CodeGenFunction (FunctionResult f) ()++instance (FunctionArgs b, IsFirstClass a) => FunctionArgs (a -> b) where+    type FunctionCodeGen (a -> b) = Value a -> FunctionCodeGen b+    type FunctionResult  (a -> b) = FunctionResult b+    paramFunc f proxy g n =+        paramFunc f (proxy<*>LP.Proxy) (g $ Value $ U.getParam f n) (n+1)++instance IsFirstClass a => FunctionArgs (IO a) where+    type FunctionCodeGen (IO a) = CodeGenFunction a ()+    type FunctionResult (IO a) = a+    paramFunc _ LP.Proxy code = const code+++type family UnaryParameter f i+type instance UnaryParameter (a -> b) Un.Zero = a+type instance UnaryParameter (a -> b) (Un.Succ i) = UnaryParameter b i++type FunctionParameter f i = UnaryParameter f (Dec.ToUnary i)++{- |+Preferably you use the parameter values provided by+'createFunction' or 'defineFunction',+but sometimes you need to access a parameter+after 'newFunction' and before 'defineFunction'.+In this case you can obtain a function parameter using this accessor.+-}+functionParameter ::+    (Dec.Natural i) => Function f -> Proxy i -> Value (FunctionParameter f i)+functionParameter (Value f) n =+    Value $ U.getParam f $ Dec.integralFromProxy n+++type family UnValue a+type instance UnValue (Value a) = a++type family CodeValue code+type instance CodeValue (CodeGenFunction r a) = a+type instance CodeValue (a -> b) = CodeValue b++type family CodeResult code+type instance CodeResult (CodeGenFunction r a) = r+type instance CodeResult (a -> b) = CodeResult b+++--------------------------------------++-- |A basic block is a sequence of non-branching instructions, terminated by a control flow instruction.+newtype BasicBlock = BasicBlock FFI.BasicBlockRef+    deriving (Show, Typeable)++createBasicBlock :: CodeGenFunction r BasicBlock+createBasicBlock = do+    b <- newBasicBlock+    defineBasicBlock b+    return b++newBasicBlock :: CodeGenFunction r BasicBlock+newBasicBlock = genFSym >>= newNamedBasicBlock++newNamedBasicBlock :: String -> CodeGenFunction r BasicBlock+newNamedBasicBlock name = do+    fn <- getFunction+    liftIO $ liftM BasicBlock $ U.appendBasicBlock fn name++defineBasicBlock :: BasicBlock -> CodeGenFunction r ()+defineBasicBlock (BasicBlock l) = do+    bld <- getBuilder+    liftIO $ U.positionAtEnd bld l++getCurrentBasicBlock :: CodeGenFunction r BasicBlock+getCurrentBasicBlock = do+    bld <- getBuilder+    liftIO $ liftM BasicBlock $ U.getInsertBlock bld++toLabel :: BasicBlock -> Value Label+toLabel (BasicBlock ptr) =+    Value (unsafePerformIO $ FFI.basicBlockAsValue ptr)++fromLabel :: Value Label -> BasicBlock+fromLabel (Value ptr) =+    BasicBlock (unsafePerformIO $ FFI.valueAsBasicBlock ptr)++--------------------------------------++--- XXX: the functions in this section (and addGlobalMapping) don't actually use any+-- Function state so should really be in the CodeGenModule monad++{- |+Create a reference to an external function while code generating for a function.+Functions are not redefined, that is,+all functions with the same name must have the same type.+If LLVM cannot resolve the function name, then you may try 'staticFunction'.+-}+externFunction :: forall a r.+    (IsFunction a) => String -> CodeGenFunction r (Function a)+externFunction name =+    externCore name $+        fmap (unValue :: Function a -> FFI.ValueRef) .+        newNamedFunction ExternalLinkage++-- | As 'externFunction', but for 'Global's rather than 'Function's+externGlobal :: forall a r . (IsType a) => Bool -> String -> CodeGenFunction r (Global a)+externGlobal isConst name =+    externCore name $+        fmap (unValue :: Global a -> FFI.ValueRef) .+        newNamedGlobal isConst ExternalLinkage++externCore ::+    String -> (String -> CodeGenModule FFI.ValueRef) ->+    CodeGenFunction r (Value ptr)+externCore name act = do+    mf <- lookupExtern name+    case mf of+        Just f -> return $ Value f+        Nothing -> do+            f <- liftCodeGenModule $ act name+            addExtern name f+            return $ Value f++{- |+Make an external C function with a fixed address callable from LLVM code.+This callback function can also be a Haskell function,+that was imported like++> foreign import ccall "&nextElement"+>    nextElementFunPtr :: FunPtr (StablePtr (IORef [Word32]) -> IO Word32)++See @examples\/List.hs@.++When you only use 'externFunction', then LLVM cannot resolve the name.+(However, I do not know why.)+Thus 'staticFunction' manages a list of static functions.+This list is automatically installed by 'ExecutionEngine.simpleFunction'+and can be manually obtained by 'getGlobalMappings'+and installed by 'ExecutionEngine.addGlobalMappings'.+\"Installing\" means calling LLVM's @addGlobalMapping@ according to+<http://old.nabble.com/jit-with-external-functions-td7769793.html>.+-}+staticFunction :: forall f r.+    (IsFunction f) => FunPtr f -> CodeGenFunction r (Function f)+staticFunction = staticNamedFunction ""++{- |+Due to <https://llvm.org/bugs/show_bug.cgi?id=20656>+this will fail with MCJIT of LLVM-3.6.+-}+staticNamedFunction :: forall f r.+    (IsFunction f) => String -> FunPtr f -> CodeGenFunction r (Function f)+staticNamedFunction name func = liftCodeGenModule $ do+    val <- newNamedFunction ExternalLinkage name+    addFunctionMapping (unValue (val :: Function f)) func+    return val++-- | As 'staticFunction', but for 'Global's rather than 'Function's+staticGlobal :: forall a r.+    (IsType a) => Bool -> Data.Ptr a -> CodeGenFunction r (Global a)+staticGlobal isConst gbl = liftCodeGenModule $ do+    val <- newNamedGlobal isConst ExternalLinkage ""+    addGlobalMapping (unValue (val :: Global a)) gbl+    return val++--------------------------------------++withCurrentBuilder :: (FFI.BuilderRef -> IO a) -> CodeGenFunction r a+withCurrentBuilder body = do+    bld <- getBuilder+    liftIO $ U.withBuilder bld body++--------------------------------------++-- Mark all block terminating instructions.  Not used yet.+--data Terminate = Terminate++--------------------------------------++type Global a = Value (Data.Ptr a)++-- | Create a new named global variable.+newNamedGlobal :: forall a . (IsType a)+               => Bool         -- ^Constant?+               -> Linkage      -- ^Visibility+               -> String       -- ^Name+               -> TGlobal a+newNamedGlobal isConst linkage name = do+    modul <- getModule+    typ <- liftIO $ typeRef (LP.Proxy :: LP.Proxy a)+    liftIO $ liftM Value $ do+        g <- U.addGlobal modul linkage name typ+        when isConst $ FFI.setGlobalConstant g FFI.true+        return g++-- | Create a new global variable.+newGlobal :: forall a . (IsType a) => Bool -> Linkage -> TGlobal a+newGlobal isConst linkage = genMSym "glb" >>= newNamedGlobal isConst linkage++-- | Give a global variable a (constant) value.+defineGlobal :: Global a -> ConstValue a -> CodeGenModule ()+defineGlobal (Value g) (ConstValue v) =+    liftIO $ FFI.setInitializer g v++-- | Create and define a global variable.+createGlobal :: (IsType a) => Bool -> Linkage -> ConstValue a -> TGlobal a+createGlobal isConst linkage con = do+    g <- newGlobal isConst linkage+    defineGlobal g con+    return g++-- | Create and define a named global variable.+createNamedGlobal :: (IsType a) => Bool -> Linkage -> String -> ConstValue a -> TGlobal a+createNamedGlobal isConst linkage name con = do+    g <- newNamedGlobal isConst linkage name+    defineGlobal g con+    return g++type TFunction a = CodeGenModule (Function a)+type TGlobal a = CodeGenModule (Global a)++-- Special string creators+{-# DEPRECATED createString "use withString instead" #-}+createString :: String -> TGlobal (Array n Word8)+createString s = string (length s) (U.constString s)++{-# DEPRECATED createStringNul "use withStringNul instead" #-}+createStringNul :: String -> TGlobal (Array n Word8)+createStringNul s = string (length s + 1) (U.constStringNul s)++withString ::+    String ->+    (forall n. (Dec.Natural n) => Global (Array n Word8) -> CodeGenModule a) ->+    CodeGenModule a+withString s act =+    let n = length s+    in  fromMaybe (error "withString: length must always be non-negative") $+        Dec.reifyNatural (fromIntegral n) (\tn -> do+            arr <- string n (U.constString s)+            act (fixArraySize tn arr))++withStringNul ::+    String ->+    (forall n. (Dec.Natural n) => Global (Array n Word8) -> CodeGenModule a) ->+    CodeGenModule a+withStringNul s act =+    let n = length s + 1+    in  fromMaybe (error "withStringNul: length must always be non-negative") $+        Dec.reifyNatural (fromIntegral n) (\tn -> do+            arr <- string n (U.constStringNul s)+            act (fixArraySize tn arr))++fixArraySize :: Proxy n -> Global (Array n a) -> Global (Array n a)+fixArraySize _ = id++string :: Int -> FFI.ValueRef -> TGlobal (Array n Word8)+string n s = do+    modul <- getModule+    name <- genMSym "str"+    elemTyp <- liftIO $ typeRef (LP.Proxy :: LP.Proxy Word8)+    typ <- liftIO $ FFI.arrayType elemTyp (fromIntegral n)+    liftIO $ liftM Value $ do g <- U.addGlobal modul InternalLinkage name typ+                              FFI.setGlobalConstant g FFI.true+                              FFI.setInitializer g s+                              return g++--------------------------------------++-- |Make a constant vector.+constVector ::+    forall a n u.+    (Dec.Positive n, Dec.ToUnary n ~ u,+     UnaryVector.Length (FixedList u) ~ u) =>+    UnaryVector.FixedList u (ConstValue a) ->+    ConstValue (Vector n a)+constVector =+    constVectorGen id++constVectorGen ::+    forall a b n u.+    (Dec.Positive n, Dec.ToUnary n ~ u) =>+    (b -> ConstValue a) ->+    UnaryVector.FixedList u b ->+    ConstValue (Vector n a)+constVectorGen f xs =+    unsafeConstValue $+    U.constVector+        (case DecProof.unaryNat :: DecProof.UnaryNat n of+             DecProof.UnaryNat ->+                 map (unConstValue . f) $+                 Fold.toList+                     (UnaryVector.fromFixedList xs :: UnaryVector.T u b))++{- |+Make a constant vector.+Replicates or truncates the list to get length @n@.+-}+constCyclicVector ::+    forall a n.+    (Dec.Positive n) =>+    NonEmpty.T [] (ConstValue a) ->+    ConstValue (Vector n a)+constCyclicVector xs =+    unsafeConstValue $+    U.constVector+        (take (Dec.integralFromSingleton (Dec.singleton :: Dec.Singleton n)) $+         map unConstValue $ NonEmpty.flatten $ NonEmpty.cycle xs)+++constArray ::+    forall a n . (IsSized a, Dec.Natural n) =>+    [ConstValue a] -> ConstValue (Array n a)+constArray xs = unsafeConstValue $ do+    let m = length xs+        n = Dec.integralFromSingleton (Dec.singleton :: Dec.Singleton n)+    when (m /= n) $+        error $+            printf "LLVM.constArray: number of array elements (%d) mismatches typed array length (%d)"+                m n+    typ <- typeRef (LP.Proxy :: LP.Proxy a)+    U.constArray typ $ map unConstValue xs++{- |+Make a constant array.+Replicates or truncates the list to get length @n@.+-}+constCyclicArray ::+    forall a n.+    (IsSized a, Dec.Natural n) =>+    NonEmpty.T [] (ConstValue a) ->+    ConstValue (Vector n a)+constCyclicArray xs = unsafeConstValue $ do+    typ <- typeRef (LP.Proxy :: LP.Proxy a)+    U.constArray typ+        (take (Dec.integralFromSingleton (Dec.singleton :: Dec.Singleton n)) $+         map unConstValue $ NonEmpty.flatten $ NonEmpty.cycle xs)++-- |Make a constant struct.+constStruct ::+    (IsConstStruct c) => c -> ConstValue (Struct (ConstStructOf c))+constStruct struct =+    unsafeConstValue $ U.constStruct (constValueFieldsOf struct) False++-- |Make a constant packed struct.+constPackedStruct ::+    (IsConstStruct c) => c -> ConstValue (PackedStruct (ConstStructOf c))+constPackedStruct struct =+    unsafeConstValue $ U.constStruct (constValueFieldsOf struct) True++class IsConstStruct c where+    type ConstStructOf c+    constValueFieldsOf :: c -> [FFI.ValueRef]++instance (IsConst a, IsConstStruct cs) => IsConstStruct (ConstValue a, cs) where+    type ConstStructOf (ConstValue a, cs) = (a, ConstStructOf cs)+    constValueFieldsOf (a, as) = unConstValue a : constValueFieldsOf as+instance IsConstStruct () where+    type ConstStructOf () = ()+    constValueFieldsOf _ = []
+ private/LLVM/Core/CodeGenMonad.hs view
@@ -0,0 +1,185 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveDataTypeable #-}+module LLVM.Core.CodeGenMonad(+    -- * Module code generation+    CodeGenModule, runCodeGenModule, genMSym, getModule,+    GlobalMappings(..), addGlobalMapping, getGlobalMappings,+    addFunctionMapping,+    -- * Function code generation+    CodeGenFunction, runCodeGenFunction, liftCodeGenModule, genFSym,+    getFunction, getBuilder, getFunctionModule, lookupExtern, addExtern,+    ) where++import qualified LLVM.Core.Data as Data+import qualified LLVM.Core.Type as Type+import LLVM.Core.Util (Module, Builder, Function, getValueNameU, withModule, )++import qualified LLVM.FFI.Core as FFI+import qualified LLVM.FFI.ExecutionEngine as EE++import Foreign.C.String (withCString, )+import Foreign.Ptr (FunPtr, nullPtr, )++import Control.Monad.Trans.State (StateT, runStateT, evalStateT, get, gets, put, modify, )+import Control.Monad.IO.Class (MonadIO, liftIO, )+import Control.Monad (when, )+import Control.Applicative (Applicative, )++import qualified Data.Map as Map+import Data.Map (Map)+import Data.Monoid (Monoid, mempty, mappend, )+import Data.Semigroup (Semigroup, (<>), )++import Data.Typeable (Typeable)++--------------------------------------++data CGMState = CGMState {+    cgm_module :: Module,+    cgm_externs :: Map String Function,+    cgm_global_mappings :: GlobalMappings,+    cgm_next :: !Int+    }+    deriving (Show, Typeable)+newtype CodeGenModule a = CGM (StateT CGMState IO a)+    deriving (Functor, Applicative, Monad, MonadIO, Typeable)++genMSym :: String -> CodeGenModule String+genMSym prefix = do+    s <- CGM get+    let n = cgm_next s+    CGM $ put (s { cgm_next = n + 1 })+    return $ "_" ++ prefix ++ show n++getModule :: CodeGenModule Module+getModule = CGM $ gets cgm_module++runCodeGenModule :: Module -> CodeGenModule a -> IO a+runCodeGenModule m (CGM body) =+    evalStateT body $+    CGMState {+        cgm_module = m, cgm_next = 1,+        cgm_externs = Map.empty, cgm_global_mappings = mempty+    }++--------------------------------------++data CGFState r = CGFState {+    cgf_module :: CGMState,+    cgf_builder :: Builder,+    cgf_function :: Function,+    cgf_next :: !Int+    }+    deriving (Show, Typeable)+newtype CodeGenFunction r a = CGF (StateT (CGFState r) IO a)+    deriving (Functor, Applicative, Monad, MonadIO, Typeable)++genFSym :: CodeGenFunction a String+genFSym = do+    s <- CGF get+    let n = cgf_next s+    CGF $ put (s { cgf_next = n + 1 })+    return $ "_L" ++ show n++getFunction :: CodeGenFunction a Function+getFunction = CGF $ gets cgf_function++getBuilder :: CodeGenFunction a Builder+getBuilder = CGF $ gets cgf_builder++getFunctionModule :: CodeGenFunction a Module+getFunctionModule = CGF $ gets (cgm_module . cgf_module)++lookupExtern :: String -> CodeGenFunction a (Maybe Function)+lookupExtern name = CGF $ gets (Map.lookup name . cgm_externs . cgf_module)++addExtern :: String -> Function -> CodeGenFunction a ()+addExtern name func = CGF $ modify $ \cgf ->+    cgf {cgf_module = (cgf_module cgf)+            {cgm_externs =+                Map.insert name func (cgm_externs $ cgf_module cgf) } }+++type Value = FFI.ValueRef++addGlobalMapping :: (Type.IsType a) => Value -> Data.Ptr a -> CodeGenModule ()+addGlobalMapping value ptr = CGM $+    addMappingToState $+        GlobalMappings (\ee ->+            EE.addGlobalMapping ee value $ Data.uncheckedToPtr ptr)++addFunctionMapping :: Function -> FunPtr f -> CodeGenModule ()+addFunctionMapping value func = CGM $ do+    {-+    We need to fetch the name from the value+    since it might have been disambiguized after adding.+    -}+    name <- liftIO $ getValueNameU value+    modul <- gets cgm_module+    addMappingToState $+        GlobalMappings $ \ee -> do+            {-+            Between adding and application+            the program may have been restructured by optimization passes.+            I have not seen that the optimizer alters a Function Value pointer,+            but the optimizer can remove an unused function.+            That would render the original value invalid.+            -}+            currentValue <-+                liftIO $+                    withCString name $ \cname ->+                    withModule modul $ \cmodule ->+                        FFI.getNamedFunction cmodule cname+            -- the optimizer could have removed the function+            when (currentValue/=nullPtr) $+                EE.addFunctionMapping ee currentValue func++addMappingToState :: GlobalMappings -> StateT CGMState IO ()+addMappingToState gm =+    modify $ \cgm ->+        cgm { cgm_global_mappings = cgm_global_mappings cgm <> gm }++newtype GlobalMappings =+    GlobalMappings (EE.ExecutionEngineRef -> IO ())++instance Show GlobalMappings where+    show _ = "GlobalMappings"++instance Semigroup GlobalMappings where+    GlobalMappings x <> GlobalMappings y =+        GlobalMappings (\ee -> x ee >> y ee)++instance Monoid GlobalMappings where+    mempty = GlobalMappings $ const $ return ()+    mappend = (<>)+++{- |+Get a list created by calls to 'staticFunction'+that must be passed to the execution engine+via 'LLVM.ExecutionEngine.addGlobalMappings'.+-}+getGlobalMappings :: CodeGenModule GlobalMappings+getGlobalMappings = CGM $ gets cgm_global_mappings++runCodeGenFunction ::+    Builder -> Function -> CodeGenFunction r a -> CodeGenModule a+runCodeGenFunction bld fn (CGF body) = do+    cgm <- CGM get+    let cgf = CGFState { cgf_module = cgm,+                         cgf_builder = bld,+                         cgf_function = fn,+                         cgf_next = 1 }+    (a, cgf') <- liftIO $ runStateT body cgf+    CGM $ put (cgf_module cgf')+    return a++--------------------------------------++-- | Allows you to define part of a module while in the middle of defining a function.+liftCodeGenModule :: CodeGenModule a -> CodeGenFunction r a+liftCodeGenModule (CGM act) = do+    cgf <- CGF get+    (a, cgm') <- liftIO $ runStateT act (cgf_module cgf)+    CGF $ put (cgf { cgf_module = cgm' })+    return a
+ private/LLVM/Core/Data.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables #-}+module LLVM.Core.Data (+    Ptr(..), uncheckedFromPtr, uncheckedToPtr,+    IntN(..), WordN(..), FP128(..),+    Array(..), Vector(..), Label, Struct(..), PackedStruct(..),+    FixedList,+    ) where++import qualified LLVM.Core.UnaryVector as UnaryVector+import LLVM.Core.UnaryVector (FixedList)++import qualified Type.Data.Num.Decimal.Proof as DecProof+import qualified Type.Data.Num.Decimal.Number as Dec+import Type.Base.Proxy (Proxy(Proxy))++import qualified Foreign++import qualified Data.Foldable as Fold+import qualified Data.Bits as Bits++import Data.Typeable (Typeable)++import qualified Test.QuickCheck as QC+++{- |+We export the constructor such that you can use 'Ptr' in foreign imports.+However, we recommend that you call 'uncheckedFromPtr' instead.+-}+newtype Ptr a = Ptr (Foreign.Ptr a)+    deriving (Show, Eq, Ord, Typeable)++uncheckedFromPtr :: Foreign.Ptr a -> Ptr a+uncheckedFromPtr = Ptr++uncheckedToPtr :: Ptr a -> Foreign.Ptr a+uncheckedToPtr (Ptr ptr) = ptr++instance Foreign.Storable (Ptr a) where+    sizeOf = Foreign.sizeOf . uncheckedToPtr+    alignment = Foreign.alignment . uncheckedToPtr+    poke p = Foreign.pokeByteOff p 0 . uncheckedToPtr+    peek p = fmap uncheckedFromPtr $ Foreign.peekByteOff p 0+++-- TODO:+-- Make instances IntN, WordN to actually do the right thing.+-- Make FP128 do the right thing+-- Make Array functions.++-- |Variable sized signed integer.+-- The /n/ parameter should belong to @PosI@.+newtype IntN n = IntN Integer+    deriving (Show, Eq, Ord, Typeable)++instance (Dec.Positive n) => QC.Arbitrary (IntN n) where+    arbitrary = arbitraryInt IntN (\(IntN a) -> a)++instance (Dec.Positive n) => Bounded (IntN n) where+    minBound =+        withBitSize $+        IntN . negate . Bits.shiftL 1 . subtract 1 . Dec.integralFromProxy+    maxBound =+        withBitSize $+        IntN . subtract 1 . Bits.shiftL 1 . subtract 1 . Dec.integralFromProxy++-- |Variable sized unsigned integer.+-- The /n/ parameter should belong to @PosI@.+newtype WordN n = WordN Integer+    deriving (Show, Eq, Ord, Typeable)++instance (Dec.Positive n) => QC.Arbitrary (WordN n) where+    arbitrary = arbitraryInt WordN (\(WordN a) -> a)++instance (Dec.Positive n) => Bounded (WordN n) where+    minBound = WordN 0+    maxBound =+        withBitSize $ WordN . subtract 1 . Bits.shiftL 1 . Dec.integralFromProxy++arbitraryInt :: (Bounded a) => (Integer -> a) -> (a -> Integer) -> QC.Gen a+arbitraryInt wrap unwrap =+    case (minBound, maxBound) of+        (a,b) -> do+            x <- QC.choose (unwrap a, unwrap b)+            return $ wrap x `asTypeOf` a `asTypeOf` b++withBitSize :: (Proxy n -> f n) -> f n+withBitSize f = f Proxy++-- |128 bit floating point.+newtype FP128 = FP128 Rational+    deriving (Show, Typeable)+++-- |Fixed sized arrays, the array size is encoded in the /n/ parameter.+newtype Array n a = Array [a]+    deriving (Eq, Show, Typeable)++instance (Dec.Integer n) => Fold.Foldable (Array n) where+    foldMap f (Array xs) = Fold.foldMap f xs++instance (Dec.Integer n, QC.Arbitrary a) => QC.Arbitrary (Array n a) where+    arbitrary = withArraySize $ fmap Array . QC.vector . Dec.integralFromProxy++withArraySize :: (Proxy n -> gen (Array n a)) -> gen (Array n a)+withArraySize f = f Proxy++-- |Fixed sized vector, the array size is encoded in the /n/ parameter.+newtype Vector n a = Vector (FixedList (Dec.ToUnary n) a)++instance (Dec.Natural n, Show a) => Show (Vector n a) where+    showsPrec p (Vector xs) =+        case DecProof.unaryNat :: DecProof.UnaryNat n of+            DecProof.UnaryNat ->+                showParen (p>10) $+                    showString "Vector " .+                    showList (Fold.toList+                        (UnaryVector.fromFixedList xs+                            :: UnaryVector.T (Dec.ToUnary n) a))++-- |Label type, produced by a basic block.+data Label+    deriving (Typeable)++-- |Struct types; a list (nested tuple) of component types.+newtype Struct a = Struct a+    deriving (Eq, Show, Typeable)+newtype PackedStruct a = PackedStruct a+    deriving (Eq, Show, Typeable)++instance (QC.Arbitrary a) => QC.Arbitrary (Struct a) where+    arbitrary = fmap Struct QC.arbitrary
+ private/LLVM/Core/Instructions.hs view
@@ -0,0 +1,1282 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ForeignFunctionInterface #-}+module LLVM.Core.Instructions(+    -- * ADT representation of IR+    BinOpDesc(..), InstrDesc(..), ArgDesc(..), getInstrDesc,+    -- * Terminator instructions+    ret,+    condBr,+    br,+    switch,+    invoke, invokeWithConv,+    invokeFromFunction, invokeWithConvFromFunction,+    unreachable,+    -- * Arithmetic binary operations+    -- | Arithmetic operations with the normal semantics.+    -- The u instructions are unsigned, the s instructions are signed.+    add, sub, mul, neg,+    iadd, isub, imul, ineg,+    iaddNoWrap, isubNoWrap, imulNoWrap, inegNoWrap,+    fadd, fsub, fmul, fneg,+    idiv, irem,+    udiv, sdiv, fdiv, urem, srem, frem,+    -- * Logical binary operations+    -- |Logical instructions with the normal semantics.+    shl, shr, lshr, ashr, and, or, xor, inv,+    -- * Vector operations+    extractelement,+    insertelement,+    shufflevector,+    -- * Aggregate operation+    extractvalue,+    insertvalue,+    -- * Memory access+    malloc, arrayMalloc,+    alloca, arrayAlloca,+    free,+    load,+    store,+    getElementPtr, getElementPtr0,+    -- * Conversions+    ValueCons,+    trunc, zext, sext, ext, zadapt, sadapt, adapt,+    fptrunc, fpext,+    fptoui, fptosi, fptoint,+    uitofp, sitofp, inttofp,+    ptrtoint, inttoptr,+    bitcast,+    -- * Comparison+    CmpPredicate(..), IntPredicate(..), FPPredicate(..),+    CmpRet, CmpResult,+    cmp, pcmp, icmp, fcmp,+    select,+    -- * Fast math+    setHasNoNaNs,+    setHasNoInfs,+    setHasNoSignedZeros,+    setHasAllowReciprocal,+    setFastMath,+    -- * Other+    phi, addPhiInputs,+    call, callWithConv,+    callFromFunction, callWithConvFromFunction,+    Call, applyCall, runCall,++    -- * Classes and types+    ValueCons2, BinOpValue,+    Terminate, Ret, Result, CallArgs,+    CodeGen.FunctionArgs, CodeGen.FunctionCodeGen, CodeGen.FunctionResult,+    AllocArg,+    GetElementPtr, ElementPtrType, IsIndexArg, IsIndexType,+    GetValue, ValueType, ArrayIndex,+    GetField, FieldType,+    ) where++import qualified LLVM.Core.Util as U+import qualified LLVM.Core.Proxy as LP+import qualified LLVM.Core.CodeGen as CodeGen+import LLVM.Core.Instructions.Private+            (ValueCons, unValue, convert, convertValue,+             unop, unopValue, binopValue, proxyFromValuePtr,+             FFIBinOp, FFIConstBinOp,+             GetField, FieldType, GetElementPtr, ElementPtrType,+             IsIndexArg, IsIndexType, getIxList, getArg,+             CmpPredicate(..),+             uintFromCmpPredicate, sintFromCmpPredicate, fpFromCmpPredicate)+import LLVM.Core.Data+import LLVM.Core.Type+import LLVM.Core.CodeGenMonad+import LLVM.Core.CodeGen+            (BasicBlock(BasicBlock), Function, withCurrentBuilder,+             proxyFromFunction,+             ConstValue(ConstValue), zero,+             Value(Value), value, valueOf, UnValue, CodeResult)++import qualified LLVM.FFI.Core as FFI+import LLVM.FFI.Core (IntPredicate(..), FPPredicate(..))++import qualified Type.Data.Num.Decimal.Number as Dec+import Type.Data.Num.Decimal.Literal (d1)+import Type.Data.Num.Decimal.Number ((:<:), (:>:))+import Type.Data.Bool (False)+import Type.Base.Proxy (Proxy)++import qualified Foreign+import Foreign.Ptr (FunPtr)+import Foreign.C (CUInt, CInt)++import Control.Monad.IO.Class (liftIO)+import Control.Monad (liftM)++import qualified Data.Map as Map+import Data.Map (Map)+import Data.Int (Int8, Int16, Int32, Int64)+import Data.Word (Word8, Word16, Word32, Word64, Word)++import Prelude hiding (and, or)+++-- TODO:+-- Add vector version of arithmetic+-- Add rest of instructions+-- Use Terminate to ensure bb termination (how?)+-- more intrinsics are needed to, e.g., create an empty vector++data ArgDesc = AV String | AI Int | AL String | AE++instance Show ArgDesc where+    -- show (AV s) = "V_" ++ s+    -- show (AI i) = "I_" ++ show i+    -- show (AL l) = "L_" ++ l+    show (AV s) = s+    show (AI i) = show i+    show (AL l) = l+    show AE = "voidarg?"++data BinOpDesc = BOAdd | BOAddNuw | BOAddNsw | BOAddNuwNsw | BOFAdd+               | BOSub | BOSubNuw | BOSubNsw | BOSubNuwNsw | BOFSub+               | BOMul | BOMulNuw | BOMulNsw | BOMulNuwNsw | BOFMul+               | BOUDiv | BOSDiv | BOSDivExact | BOFDiv | BOURem | BOSRem | BOFRem+               | BOShL | BOLShR | BOAShR | BOAnd | BOOr | BOXor+    deriving Show++-- FIXME: complete definitions for unimplemented instructions+data InstrDesc =+    -- terminators+    IDRet TypeDesc ArgDesc | IDRetVoid+  | IDBrCond ArgDesc ArgDesc ArgDesc | IDBrUncond ArgDesc+  | IDSwitch [(ArgDesc, ArgDesc)]+  | IDIndirectBr+  | IDInvoke+  | IDUnwind+  | IDUnreachable+    -- binary operators (including bitwise)+  | IDBinOp BinOpDesc TypeDesc ArgDesc ArgDesc+    -- memory access and addressing+  | IDAlloca TypeDesc Int Int | IDLoad TypeDesc ArgDesc | IDStore TypeDesc ArgDesc ArgDesc+  | IDGetElementPtr TypeDesc [ArgDesc]+    -- conversion+  | IDTrunc TypeDesc TypeDesc ArgDesc | IDZExt TypeDesc TypeDesc ArgDesc+  | IDSExt TypeDesc TypeDesc ArgDesc | IDFPtoUI TypeDesc TypeDesc ArgDesc+  | IDFPtoSI TypeDesc TypeDesc ArgDesc | IDUItoFP TypeDesc TypeDesc ArgDesc+  | IDSItoFP TypeDesc TypeDesc ArgDesc+  | IDFPTrunc TypeDesc TypeDesc ArgDesc | IDFPExt TypeDesc TypeDesc ArgDesc+  | IDPtrToInt TypeDesc TypeDesc ArgDesc | IDIntToPtr TypeDesc TypeDesc ArgDesc+  | IDBitcast TypeDesc TypeDesc ArgDesc+    -- other+  | IDICmp IntPredicate ArgDesc ArgDesc | IDFCmp FPPredicate ArgDesc ArgDesc+  | IDPhi TypeDesc [(ArgDesc, ArgDesc)] | IDCall TypeDesc ArgDesc [ArgDesc]+  | IDSelect TypeDesc ArgDesc ArgDesc | IDUserOp1 | IDUserOp2 | IDVAArg+    -- vector operators+  | IDExtractElement | IDInsertElement | IDShuffleVector+    -- aggregate operators+  | IDExtractValue | IDInsertValue+    -- invalid+  | IDInvalidOp+    deriving Show++-- TODO: overflow support for binary operations (add/sub/mul)+getInstrDesc :: FFI.ValueRef -> IO (String, InstrDesc)+getInstrDesc v = do+    valueName <- U.getValueNameU v+    opcode <- FFI.instGetOpcode v+    t <- FFI.typeOf v >>= typeDesc2+    -- FIXME: sizeof() does not work for types!+    --tsize <- FFI.typeOf v -- >>= FFI.sizeOf -- >>= FFI.constIntGetZExtValue >>= return . fromIntegral+    tsize <- return 1+    ovs <- U.getOperands v+    os <- mapM getArgDesc ovs+    os0 <- return $ case os of {o:_   -> o; _ -> AE}+    os1 <- return $ case os of {_:o:_ -> o; _ -> AE}+    instr <-+        case Map.lookup opcode binOpMap of -- binary arithmetic+          Just op -> return $ IDBinOp op t os0 os1+          Nothing ->+            case Map.lookup opcode convOpMap of+              Just op -> do+                t2 <-+                    case ovs of+                        (_name,ov):_ -> FFI.typeOf ov >>= typeDesc2+                        _ -> return TDVoid+                return $ op t2 t os0+              Nothing ->+                case opcode of+                  1 -> return $ if null os then IDRetVoid else IDRet t os0+                  2 -> return $ if length os == 1 then IDBrUncond os0 else IDBrCond os0 (os !! 2) os1+                  3 -> return $ IDSwitch $ toPairs os+                  -- TODO (can skip for now)+                  -- 4 -> return IndirectBr ; 5 -> return Invoke+                  6 -> return IDUnwind; 7 -> return IDUnreachable+                  26 -> return $ IDAlloca (getPtrType t) tsize (getImmInt os0)+                  27 -> return $ IDLoad t os0; 28 -> return $ IDStore t os0 os1+                  29 -> return $ IDGetElementPtr t os+                  42 -> do+                      pInt <- FFI.cmpInstGetIntPredicate v+                      return $ IDICmp (FFI.toIntPredicate pInt) os0 os1+                  43 -> do+                      pFloat <- FFI.cmpInstGetRealPredicate v+                      return $ IDFCmp (FFI.toRealPredicate pFloat) os0 os1+                  44 -> return $ IDPhi t $ toPairs os+                  -- FIXME: getelementptr arguments are not handled+                  45 -> return $ IDCall t (last os) (init os)+                  46 -> return $ IDSelect t os0 os1+                  -- TODO (can skip for now)+                  -- 47 -> return UserOp1 ; 48 -> return UserOp2 ; 49 -> return VAArg+                  -- 50 -> return ExtractElement ; 51 -> return InsertElement ; 52 -> return ShuffleVector+                  -- 53 -> return ExtractValue ; 54 -> return InsertValue+                  _ -> return IDInvalidOp+    return (valueName, instr)+    --if instr /= InvalidOp then return instr else fail $ "Invalid opcode: " ++ show opcode+        where toPairs xs = zip (stride 2 xs) (stride 2 (drop 1 xs))+              stride _ [] = []+              stride n (x:xs) = x : stride n (drop (n-1) xs)+              getPtrType (TDPtr t) = t+              getPtrType _ = TDVoid+              getImmInt (AI i) = i+              getImmInt _ = 0++binOpMap :: Map CInt BinOpDesc+binOpMap =+    Map.fromList+        [(8, BOAdd), (9, BOFAdd), (10, BOSub), (11, BOFSub),+         (12, BOMul), (13, BOFMul), (14, BOUDiv), (15, BOSDiv),+         (16, BOFDiv), (17, BOURem), (18, BOSRem), (19, BOFRem),+         (20, BOShL), (21, BOLShR), (22, BOAShR), (23, BOAnd),+         (24, BOOr), (25, BOXor)]++convOpMap :: Map CInt (TypeDesc -> TypeDesc -> ArgDesc -> InstrDesc)+convOpMap =+    Map.fromList+        [(30, IDTrunc), (31, IDZExt), (32, IDSExt), (33, IDFPtoUI),+         (34, IDFPtoSI), (35, IDUItoFP), (36, IDSItoFP), (37, IDFPTrunc),+         (38, IDFPExt), (39, IDPtrToInt), (40, IDIntToPtr), (41, IDBitcast)]++-- TODO: fix for non-int constants+getArgDesc :: (String, FFI.ValueRef) -> IO ArgDesc+getArgDesc (vname, v) = do+    isC <- U.isConstant v+    t <- FFI.typeOf v >>= typeDesc2+    if isC+      then case t of+             TDInt _ _ -> do+                          cV <- FFI.constIntGetSExtValue v+                          return $ AI $ fromIntegral cV+             _ -> return AE+      else case t of+             TDLabel -> return $ AL vname+             _ -> return $ AV vname++--------------------------------------++type Terminate = ()+terminate :: Terminate+terminate = ()++--------------------------------------++-- |Acceptable arguments to the 'ret' instruction.+class Ret a where+    type Result a+    ret' :: a -> CodeGenFunction (Result a) Terminate++-- | Return from the current function with the given value.  Use () as the return value for what would be a void function in C.+ret :: (Ret a) => a -> CodeGenFunction (Result a) Terminate+ret = ret'++-- overlaps with Ret () ()!+{-+instance (IsFirstClass a, IsConst a) => Ret a a where+    ret' = ret . valueOf+-}++instance Ret (Value a) where+    type Result (Value a) = a+    ret' (Value a) = do+        withCurrentBuilder_ $ \ bldPtr -> FFI.buildRet bldPtr a+        return terminate++instance Ret () where+    type Result () = ()+    ret' _ = do+        withCurrentBuilder_ $ FFI.buildRetVoid+        return terminate++withCurrentBuilder_ :: (FFI.BuilderRef -> IO a) -> CodeGenFunction r ()+withCurrentBuilder_ p = withCurrentBuilder p >> return ()++--------------------------------------++-- | Branch to the first basic block if the boolean is true, otherwise to the second basic block.+condBr :: Value Bool -- ^ Boolean to branch upon.+       -> BasicBlock -- ^ Target for true.+       -> BasicBlock -- ^ Target for false.+       -> CodeGenFunction r Terminate+condBr (Value b) (BasicBlock t1) (BasicBlock t2) = do+    withCurrentBuilder_ $ \ bldPtr -> FFI.buildCondBr bldPtr b t1 t2+    return terminate++--------------------------------------++-- | Unconditionally branch to the given basic block.+br :: BasicBlock  -- ^ Branch target.+   -> CodeGenFunction r Terminate+br (BasicBlock t) = do+    withCurrentBuilder_ $ \ bldPtr -> FFI.buildBr bldPtr t+    return terminate++--------------------------------------++-- | Branch table instruction.+switch :: (IsInteger a)+       => Value a                        -- ^ Value to branch upon.+       -> BasicBlock                     -- ^ Default branch target.+       -> [(ConstValue a, BasicBlock)]   -- ^ Labels and corresponding branch targets.+       -> CodeGenFunction r Terminate+switch (Value val) (BasicBlock dflt) arms = do+    withCurrentBuilder_ $ \ bldPtr -> do+        inst <- FFI.buildSwitch bldPtr val dflt (fromIntegral $ length arms)+        sequence_ [ FFI.addCase inst c b | (ConstValue c, BasicBlock b) <- arms ]+    return terminate++--------------------------------------++-- |Inform the code generator that this code can never be reached.+unreachable :: CodeGenFunction r Terminate+unreachable = do+    withCurrentBuilder_ FFI.buildUnreachable+    return terminate++--------------------------------------+++withArithmeticType ::+    (IsArithmetic c) =>+    (ArithmeticType c -> a -> CodeGenFunction r (v c)) ->+    (a -> CodeGenFunction r (v c))+withArithmeticType f = f arithmeticType+++class (ValueCons value0, ValueCons value1) => ValueCons2 value0 value1 where+    type BinOpValue (value0 :: * -> *) (value1 :: * -> *) :: * -> *+    binop ::+        FFIConstBinOp -> FFIBinOp ->+        value0 a -> value1 a -> CodeGenFunction r (BinOpValue value0 value1 b)++instance ValueCons2 Value Value where+    type BinOpValue Value Value = Value+    binop _ op (Value a1) (Value a2) = buildBinOp op a1 a2++instance ValueCons2 Value ConstValue where+    type BinOpValue Value ConstValue = Value+    binop _ op (Value a1) (ConstValue a2) = buildBinOp op a1 a2++instance ValueCons2 ConstValue Value where+    type BinOpValue ConstValue Value = Value+    binop _ op (ConstValue a1) (Value a2) = buildBinOp op a1 a2++instance ValueCons2 ConstValue ConstValue where+    type BinOpValue ConstValue ConstValue = ConstValue+    binop cop _ (ConstValue a1) (ConstValue a2) =+        liftIO $ fmap ConstValue $ cop a1 a2+++add, sub, mul ::+    (IsArithmetic a) => Value a -> Value a -> CodeGenFunction r (Value a)+add =+    curry $ withArithmeticType $ \typ -> uncurry $ case typ of+      IntegerType  -> binopValue FFI.buildAdd+      FloatingType -> binopValue FFI.buildFAdd++sub =+    curry $ withArithmeticType $ \typ -> uncurry $ case typ of+      IntegerType  -> binopValue FFI.buildSub+      FloatingType -> binopValue FFI.buildFSub++mul =+    curry $ withArithmeticType $ \typ -> uncurry $ case typ of+      IntegerType  -> binopValue FFI.buildMul+      FloatingType -> binopValue FFI.buildFMul++iadd, isub ::+    (ValueCons2 value0 value1, IsInteger a) =>+    value0 a -> value1 a -> CodeGenFunction r (BinOpValue value0 value1 a)+iadd = binop FFI.constAdd FFI.buildAdd+isub = binop FFI.constSub FFI.buildSub++imul :: (IsInteger a) => Value a -> Value a -> CodeGenFunction r (Value a)+imul = binopValue FFI.buildMul++iaddNoWrap, isubNoWrap ::+    (ValueCons2 value0 value1, IsInteger a) =>+    value0 a -> value1 a -> CodeGenFunction r (BinOpValue value0 value1 a)+iaddNoWrap =+    sbinop FFI.constNSWAdd FFI.buildNSWAdd FFI.constNUWAdd FFI.buildNUWAdd+isubNoWrap =+    sbinop FFI.constNSWSub FFI.buildNSWSub FFI.constNUWSub FFI.buildNUWSub++imulNoWrap :: (IsInteger a) => Value a -> Value a -> CodeGenFunction r (Value a)+imulNoWrap =+    sbinopValue FFI.buildNSWMul FFI.buildNUWMul++-- | signed or unsigned integer division depending on the type+idiv :: (IsInteger a) => Value a -> Value a -> CodeGenFunction r (Value a)+idiv = sbinopValue FFI.buildSDiv FFI.buildUDiv+-- | signed or unsigned remainder depending on the type+irem :: (IsInteger a) => Value a -> Value a -> CodeGenFunction r (Value a)+irem = sbinopValue FFI.buildSRem FFI.buildURem++{-# DEPRECATED udiv "use idiv instead" #-}+{-# DEPRECATED sdiv "use idiv instead" #-}+{-# DEPRECATED urem "use irem instead" #-}+{-# DEPRECATED srem "use irem instead" #-}+udiv, sdiv, urem, srem ::+    (IsInteger a) => Value a -> Value a -> CodeGenFunction r (Value a)+udiv = binopValue FFI.buildUDiv+sdiv = binopValue FFI.buildSDiv+urem = binopValue FFI.buildURem+srem = binopValue FFI.buildSRem++fadd, fsub, fmul ::+    (IsFloating a) => Value a -> Value a -> CodeGenFunction r (Value a)+fadd = binopValue FFI.buildFAdd+fsub = binopValue FFI.buildFSub+fmul = binopValue FFI.buildFMul++-- | Floating point division.+fdiv :: (IsFloating a) => Value a -> Value a -> CodeGenFunction r (Value a)+fdiv = binopValue FFI.buildFDiv+-- | Floating point remainder.+frem :: (IsFloating a) => Value a -> Value a -> CodeGenFunction r (Value a)+frem = binopValue FFI.buildFRem++xor ::+    (ValueCons2 value0 value1, IsInteger a) =>+    value0 a -> value1 a -> CodeGenFunction r (BinOpValue value0 value1 a)+xor  = binop FFI.constXor  FFI.buildXor++shl, lshr, ashr, and, or :: Value a -> Value a -> CodeGenFunction r (Value a)+shl  = binopValue FFI.buildShl+lshr = binopValue FFI.buildLShr+ashr = binopValue FFI.buildAShr+and  = binopValue FFI.buildAnd+or   = binopValue FFI.buildOr++shr ::+    (IsInteger a) => Value a -> Value a -> CodeGenFunction r (Value a)+shr = sbinopValue FFI.buildAShr FFI.buildLShr++sbinopValue ::+    forall a b r.+    (IsInteger a) =>+    FFIBinOp -> FFIBinOp ->+    Value a -> Value a -> CodeGenFunction r (Value b)+sbinopValue sop uop =+    if isSigned (LP.Proxy :: LP.Proxy a)+        then binopValue sop+        else binopValue uop++sbinop ::+    forall value0 value1 a b r.+    (ValueCons2 value0 value1, IsInteger a) =>+    FFIConstBinOp -> FFIBinOp ->+    FFIConstBinOp -> FFIBinOp ->+    value0 a -> value1 a -> CodeGenFunction r (BinOpValue value0 value1 b)+sbinop scop sop ucop uop =+    if isSigned (LP.Proxy :: LP.Proxy a)+        then binop scop sop+        else binop ucop uop+++buildBinOp ::+    FFIBinOp -> FFI.ValueRef -> FFI.ValueRef -> CodeGenFunction r (Value a)+buildBinOp op a1 a2 =+    liftM Value $+    withCurrentBuilder $ \ bld ->+      U.withEmptyCString $ op bld a1 a2++neg ::+    (IsArithmetic a) =>+    Value a -> CodeGenFunction r (Value a)+neg =+    withArithmeticType $ \typ -> case typ of+      IntegerType  -> unopValue FFI.buildNeg+      FloatingType -> unopValue FFI.buildFNeg++ineg ::+    (ValueCons value, IsInteger a) =>+    value a -> CodeGenFunction r (value a)+ineg = unop FFI.constNeg FFI.buildNeg++inegNoWrap ::+    forall value a r.+    (ValueCons value, IsInteger a, Signed a ~ False) =>+    value a -> CodeGenFunction r (value a)+inegNoWrap =+   unop FFI.constNSWNeg FFI.buildNSWNeg++fneg ::+    (IsFloating a) =>+    Value a -> CodeGenFunction r (Value a)+fneg = unopValue FFI.buildFNeg++inv ::+    (ValueCons value, IsInteger a) =>+    value a -> CodeGenFunction r (value a)+inv = unop FFI.constNot FFI.buildNot++--------------------------------------++-- | Get a value from a vector.+extractelement :: (Dec.Positive n, IsPrimitive a)+               => Value (Vector n a)               -- ^ Vector+               -> Value Word32                     -- ^ Index into the vector+               -> CodeGenFunction r (Value a)+extractelement (Value vec) (Value i) =+    liftM Value $+    withCurrentBuilder $ \ bldPtr ->+      U.withEmptyCString $ FFI.buildExtractElement bldPtr vec i++-- | Insert a value into a vector, nondestructive.+insertelement :: (Dec.Positive n, IsPrimitive a)+              => Value (Vector n a)                -- ^ Vector+              -> Value a                           -- ^ Value to insert+              -> Value Word32                      -- ^ Index into the vector+              -> CodeGenFunction r (Value (Vector n a))+insertelement (Value vec) (Value e) (Value i) =+    liftM Value $+    withCurrentBuilder $ \ bldPtr ->+      U.withEmptyCString $ FFI.buildInsertElement bldPtr vec e i++-- | Permute vector.+shufflevector :: (Dec.Positive n, Dec.Positive m, IsPrimitive a)+              => Value (Vector n a)+              -> Value (Vector n a)+              -> ConstValue (Vector m Word32)+              -> CodeGenFunction r (Value (Vector m a))+shufflevector (Value a) (Value b) (ConstValue mask) =+    liftM Value $+    withCurrentBuilder $ \ bldPtr ->+      U.withEmptyCString $ FFI.buildShuffleVector bldPtr a b mask+++-- |Acceptable arguments to 'extractvalue' and 'insertvalue'.+class GetValue agg ix where+    type ValueType agg ix+    getIx :: proxy agg -> ix -> CUInt++instance (GetField as i, Dec.Natural i) => GetValue (Struct as) (Proxy i) where+    type ValueType (Struct as) (Proxy i) = FieldType as i+    getIx _ = Dec.integralFromProxy++class (Dec.Natural n) => ArrayIndex n ix where+    cuIntFromArrayIndex :: proxy (Array n a) -> ix -> CUInt++instance (Dec.Natural n) => ArrayIndex n Word where+    cuIntFromArrayIndex _ = fromIntegral+instance (Dec.Natural n) => ArrayIndex n Word32 where+    cuIntFromArrayIndex _ = fromIntegral+instance (Dec.Natural n) => ArrayIndex n Word64 where+    cuIntFromArrayIndex _ = fromIntegral+instance (Dec.Natural n, Dec.Natural i, i :<: n) => ArrayIndex n (Proxy i) where+    cuIntFromArrayIndex _ = Dec.integralFromProxy++instance (IsFirstClass a, ArrayIndex n ix) => GetValue (Array n a) ix where+    type ValueType (Array n a) ix = a+    getIx = cuIntFromArrayIndex+++-- | Get a value from an aggregate.+extractvalue :: forall r agg i.+                GetValue agg i+             => Value agg                   -- ^ Aggregate+             -> i                           -- ^ Index into the aggregate+             -> CodeGenFunction r (Value (ValueType agg i))+extractvalue v@(Value agg) i =+    liftM Value $+    withCurrentBuilder $ \ bldPtr ->+      U.withEmptyCString $+        FFI.buildExtractValue bldPtr agg (getIx v i)++-- | Insert a value into an aggregate, nondestructive.+insertvalue :: forall r agg i.+               GetValue agg i+            => Value agg                   -- ^ Aggregate+            -> Value (ValueType agg i)     -- ^ Value to insert+            -> i                           -- ^ Index into the aggregate+            -> CodeGenFunction r (Value agg)+insertvalue v@(Value agg) (Value e) i =+    liftM Value $+    withCurrentBuilder $ \ bldPtr ->+      U.withEmptyCString $+        FFI.buildInsertValue bldPtr agg e (getIx v i)+++--------------------------------------++-- | Truncate a value to a shorter bit width.+trunc :: (ValueCons value, IsInteger a, IsInteger b, ShapeOf a ~ ShapeOf b, IsSized a, IsSized b, SizeOf a :>: SizeOf b)+      => value a -> CodeGenFunction r (value b)+trunc = convert FFI.constTrunc FFI.buildTrunc++-- | Zero extend a value to a wider width.+-- If possible, use 'ext' that chooses the right padding according to the types+zext ::+    (IsInteger a, IsInteger b, ShapeOf a ~ ShapeOf b,+     IsSized a, IsSized b, SizeOf a :<: SizeOf b) =>+    Value a -> CodeGenFunction r (Value b)+zext = convertValue LP.Proxy FFI.buildZExt++-- | Sign extend a value to wider width.+-- If possible, use 'ext' that chooses the right padding according to the types+sext ::+    (IsInteger a, IsInteger b, ShapeOf a ~ ShapeOf b,+     IsSized a, IsSized b, SizeOf a :<: SizeOf b) =>+    Value a -> CodeGenFunction r (Value b)+sext = convertValue LP.Proxy FFI.buildSExt++-- | Extend a value to wider width.+-- If the target type is signed, then preserve the sign,+-- If the target type is unsigned, then extended by zeros.+ext ::+    forall a b r.+    (IsInteger a, IsInteger b, ShapeOf a ~ ShapeOf b, Signed a ~ Signed b,+     IsSized a, IsSized b, SizeOf a :<: SizeOf b) =>+    Value a -> CodeGenFunction r (Value b)+ext =+   if isSigned (LP.Proxy :: LP.Proxy b)+     then convertValue LP.Proxy FFI.buildSExt+     else convertValue LP.Proxy FFI.buildZExt++-- | It is 'zext', 'trunc' or nop depending on the relation of the sizes.+zadapt ::+    forall a b r.+    (IsInteger a, IsInteger b, ShapeOf a ~ ShapeOf b) =>+    Value a -> CodeGenFunction r (Value b)+zadapt =+   case compare (sizeOf (typeDesc (LP.Proxy :: LP.Proxy a)))+                (sizeOf (typeDesc (LP.Proxy :: LP.Proxy b))) of+      LT -> convertValue LP.Proxy FFI.buildZExt+      EQ -> convertValue LP.Proxy FFI.buildBitCast+      GT -> convertValue LP.Proxy FFI.buildTrunc++-- | It is 'sext', 'trunc' or nop depending on the relation of the sizes.+sadapt ::+    forall a b r.+    (IsInteger a, IsInteger b, ShapeOf a ~ ShapeOf b) =>+    Value a -> CodeGenFunction r (Value b)+sadapt =+   case compare (sizeOf (typeDesc (LP.Proxy :: LP.Proxy a)))+                (sizeOf (typeDesc (LP.Proxy :: LP.Proxy b))) of+      LT -> convertValue LP.Proxy FFI.buildSExt+      EQ -> convertValue LP.Proxy FFI.buildBitCast+      GT -> convertValue LP.Proxy FFI.buildTrunc++-- | It is 'sadapt' or 'zadapt' depending on the sign mode.+adapt ::+    forall a b r.+    (IsInteger a, IsInteger b, ShapeOf a ~ ShapeOf b, Signed a ~ Signed b) =>+    Value a -> CodeGenFunction r (Value b)+adapt =+   case compare (sizeOf (typeDesc (LP.Proxy :: LP.Proxy a)))+                (sizeOf (typeDesc (LP.Proxy :: LP.Proxy b))) of+      LT ->+         if isSigned (LP.Proxy :: LP.Proxy b)+           then convertValue LP.Proxy FFI.buildSExt+           else convertValue LP.Proxy FFI.buildZExt+      EQ -> convertValue LP.Proxy FFI.buildBitCast+      GT -> convertValue LP.Proxy FFI.buildTrunc++-- | Truncate a floating point value.+fptrunc ::+    (IsFloating a, IsFloating b, ShapeOf a ~ ShapeOf b,+     IsSized a, IsSized b, SizeOf a :>: SizeOf b) =>+    Value a -> CodeGenFunction r (Value b)+fptrunc = convertValue LP.Proxy FFI.buildFPTrunc++-- | Extend a floating point value.+fpext ::+    (IsFloating a, IsFloating b, ShapeOf a ~ ShapeOf b,+     IsSized a, IsSized b, SizeOf a :<: SizeOf b) =>+    Value a -> CodeGenFunction r (Value b)+fpext = convertValue LP.Proxy FFI.buildFPExt++{-# DEPRECATED fptoui "use fptoint since it is type-safe with respect to signs" #-}+-- | Convert a floating point value to an unsigned integer.+fptoui ::+    (IsFloating a, IsInteger b, ShapeOf a ~ ShapeOf b) =>+    Value a -> CodeGenFunction r (Value b)+fptoui = convertValue LP.Proxy FFI.buildFPToUI++{-# DEPRECATED fptosi "use fptoint since it is type-safe with respect to signs" #-}+-- | Convert a floating point value to a signed integer.+fptosi ::+    (IsFloating a, IsInteger b, ShapeOf a ~ ShapeOf b) =>+    Value a -> CodeGenFunction r (Value b)+fptosi = convertValue LP.Proxy FFI.buildFPToSI++-- | Convert a floating point value to an integer.+-- It is mapped to @fptosi@ or @fptoui@ depending on the type @a@.+fptoint ::+    forall a b r.+    (IsFloating a, IsInteger b, ShapeOf a ~ ShapeOf b) =>+    Value a -> CodeGenFunction r (Value b)+fptoint =+   if isSigned (LP.Proxy :: LP.Proxy b)+     then convertValue LP.Proxy FFI.buildFPToSI+     else convertValue LP.Proxy FFI.buildFPToUI+++{- DEPRECATED uitofp "use inttofp since it is type-safe with respect to signs" -}+-- | Convert an unsigned integer to a floating point value.+-- Although 'inttofp' should be prefered, this function may be useful for conversion from Bool.+uitofp ::+    (IsInteger a, IsFloating b, ShapeOf a ~ ShapeOf b) =>+    Value a -> CodeGenFunction r (Value b)+uitofp = convertValue LP.Proxy FFI.buildUIToFP++{- DEPRECATED sitofp "use inttofp since it is type-safe with respect to signs" -}+-- | Convert a signed integer to a floating point value.+-- Although 'inttofp' should be prefered, this function may be useful for conversion from Bool.+sitofp ::+    (IsInteger a, IsFloating b, ShapeOf a ~ ShapeOf b) =>+    Value a -> CodeGenFunction r (Value b)+sitofp = convertValue LP.Proxy FFI.buildSIToFP++-- | Convert an integer to a floating point value.+-- It is mapped to @sitofp@ or @uitofp@ depending on the type @a@.+inttofp ::+    forall a b r.+    (IsInteger a, IsFloating b, ShapeOf a ~ ShapeOf b) =>+    Value a -> CodeGenFunction r (Value b)+inttofp =+   if isSigned (LP.Proxy :: LP.Proxy a)+     then convertValue LP.Proxy FFI.buildSIToFP+     else convertValue LP.Proxy FFI.buildUIToFP+++-- | Convert a pointer to an integer.+ptrtoint :: (ValueCons value, IsInteger b, IsPrimitive b) => value (Ptr a) -> CodeGenFunction r (value b)+ptrtoint = convert FFI.constPtrToInt FFI.buildPtrToInt++-- | Convert an integer to a pointer.+inttoptr :: (ValueCons value, IsInteger a, IsType b) => value a -> CodeGenFunction r (value (Ptr b))+inttoptr = convert FFI.constIntToPtr FFI.buildIntToPtr++-- | Convert between to values of the same size by just copying the bit pattern.+bitcast :: (ValueCons value, IsSized a, IsSized b, SizeOf a ~ SizeOf b)+        => value a -> CodeGenFunction r (value b)+bitcast = convert FFI.constBitCast FFI.buildBitCast+++--------------------------------------++type CmpResult c = ShapedType (ShapeOf c) Bool++class (IsFirstClass c) => CmpRet c where+    cmpBld :: LP.Proxy c -> CmpPredicate -> FFIBinOp++instance CmpRet Float   where cmpBld _ = fcmpBld+instance CmpRet Double  where cmpBld _ = fcmpBld+instance CmpRet FP128   where cmpBld _ = fcmpBld+instance CmpRet Bool    where cmpBld _ = ucmpBld+instance CmpRet Word    where cmpBld _ = ucmpBld+instance CmpRet Word8   where cmpBld _ = ucmpBld+instance CmpRet Word16  where cmpBld _ = ucmpBld+instance CmpRet Word32  where cmpBld _ = ucmpBld+instance CmpRet Word64  where cmpBld _ = ucmpBld+instance CmpRet Int     where cmpBld _ = scmpBld+instance CmpRet Int8    where cmpBld _ = scmpBld+instance CmpRet Int16   where cmpBld _ = scmpBld+instance CmpRet Int32   where cmpBld _ = scmpBld+instance CmpRet Int64   where cmpBld _ = scmpBld+instance CmpRet (Foreign.Ptr a)+                        where cmpBld _ = ucmpBld+instance (IsType a) =>+         CmpRet (Ptr a) where cmpBld _ = ucmpBld++instance (Dec.Positive n) => CmpRet (WordN n) where+    cmpBld _ = ucmpBld+instance (Dec.Positive n) => CmpRet (IntN n) where+    cmpBld _ = scmpBld++instance (CmpRet a, IsPrimitive a, Dec.Positive n) => CmpRet (Vector n a) where+    cmpBld _ = cmpBld (LP.Proxy :: LP.Proxy a)+++{- |+Compare values of ordered types+and choose predicates according to the compared types.+Floating point numbers are compared in \"ordered\" mode,+that is @NaN@ operands yields 'False' as result.+Pointers are compared unsigned.+These choices are consistent with comparison in plain Haskell.+-}+cmp :: forall a r.+   (CmpRet a) =>+   CmpPredicate -> Value a -> Value a ->+   CodeGenFunction r (Value (CmpResult a))+cmp p = binopValue (cmpBld (LP.Proxy :: LP.Proxy a) p)++ucmpBld :: CmpPredicate -> FFIBinOp+ucmpBld p = flip FFI.buildICmp (FFI.fromIntPredicate (uintFromCmpPredicate p))++scmpBld :: CmpPredicate -> FFIBinOp+scmpBld p = flip FFI.buildICmp (FFI.fromIntPredicate (sintFromCmpPredicate p))++fcmpBld :: CmpPredicate -> FFIBinOp+fcmpBld p = flip FFI.buildFCmp (FFI.fromRealPredicate (fpFromCmpPredicate p))+++pcmp ::+    (IsType a) =>+    IntPredicate -> Value (Ptr a) -> Value (Ptr a) ->+    CodeGenFunction r (Value Bool)+pcmp p = binopValue (flip FFI.buildICmp (FFI.fromIntPredicate p))+++{-# DEPRECATED icmp "use cmp or pcmp instead" #-}+-- | Compare integers.+icmp ::+    (CmpRet a, IsIntegerOrPointer a) =>+    IntPredicate -> Value a -> Value a ->+    CodeGenFunction r (Value (CmpResult a))+icmp p = binopValue (flip FFI.buildICmp (FFI.fromIntPredicate p))++-- | Compare floating point values.+fcmp ::+    (CmpRet a, IsFloating a) =>+    FPPredicate -> Value a -> Value a ->+    CodeGenFunction r (Value (CmpResult a))+fcmp p = binopValue (flip FFI.buildFCmp (FFI.fromRealPredicate p))++--------------------------------------++setHasNoNaNs, setHasNoInfs, setHasNoSignedZeros, setHasAllowReciprocal,+    setFastMath :: (IsFloating a) => Bool -> Value a -> CodeGenFunction r ()+setHasNoNaNs          = fastMath FFI.setHasNoNaNs+setHasNoInfs          = fastMath FFI.setHasNoInfs+setHasNoSignedZeros   = fastMath FFI.setHasNoSignedZeros+setHasAllowReciprocal = fastMath FFI.setHasAllowReciprocal+setFastMath           = fastMath FFI.setHasUnsafeAlgebra++fastMath ::+    (IsFloating a) =>+    (FFI.ValueRef -> FFI.Bool -> IO ()) ->+    Bool -> Value a -> CodeGenFunction r ()+fastMath setter b (Value v) = liftIO $ setter v $ FFI.consBool b+++--------------------------------------++-- XXX could do const song and dance+-- | Select between two values depending on a boolean.+select :: (CmpRet a) => Value (CmpResult a) -> Value a -> Value a -> CodeGenFunction r (Value a)+select (Value cnd) (Value thn) (Value els) =+    liftM Value $+      withCurrentBuilder $ \ bldPtr ->+        U.withEmptyCString $+          FFI.buildSelect bldPtr cnd thn els++--------------------------------------++type Caller = FFI.BuilderRef -> [FFI.ValueRef] -> IO FFI.ValueRef++{-+Function (a -> b -> IO c)+Value a -> Value b -> CodeGenFunction r c+-}++-- |Acceptable arguments to 'call'.+class+    (r ~ CodeResult g, f ~ CalledFunction g, g ~ CallerFunction r f,+     IsFunction f) =>+        CallArgs r f g where+    type CalledFunction g+    type CallerFunction r f+    doCall :: Call f -> g++instance+    (IsFirstClass a, Value a ~ a', CallArgs r b b') =>+        CallArgs r (a -> b) (a' -> b') where+    type CalledFunction (a' -> b') = UnValue a' -> CalledFunction b'+    type CallerFunction r (a -> b) = Value a -> CallerFunction r b+    doCall f a = doCall (applyCall f a)++instance+    (IsFirstClass a, Value a ~ a', r ~ r') =>+        CallArgs r (IO a) (CodeGenFunction r' a') where+    type CalledFunction (CodeGenFunction r' a') = IO (UnValue a')+    type CallerFunction r (IO a) = CodeGenFunction r (Value a)+    doCall = runCall++doCallDef :: Caller -> [FFI.ValueRef] -> CodeGenFunction r (Value a)+doCallDef mkCall args =+    withCurrentBuilder $ \ bld ->+      liftM Value $ mkCall bld (reverse args)++-- | Call a function with the given arguments.  The 'call' instruction is variadic, i.e., the number of arguments+-- it takes depends on the type of /f/.+call :: (CallArgs r f g) => Function f -> g+call = doCall . callFromFunction++data Call a = Call Caller [FFI.ValueRef]++typedCall ::+    (IsFunction f) =>+    Function f ->+    (U.FunctionWithType -> FFI.BuilderRef ->+        [FFI.ValueRef] -> IO FFI.ValueRef) ->+    Call a+typedCall func@(Value f) makeCall =+    Call+        (\bld args -> do+            typ <- typeRef $ proxyFromFunction func+            makeCall (typ, f) bld args)+        []++callFromFunction :: (IsFunction f) => Function f -> Call f+callFromFunction func = typedCall func U.makeCall++-- like Applicative.<*>+infixl 4 `applyCall`++applyCall :: Call (a -> b) -> Value a -> Call b+applyCall (Call mkCall args) (Value arg) = Call mkCall (arg:args)++runCall :: Call (IO a) -> CodeGenFunction r (Value a)+runCall (Call mkCall args) = doCallDef mkCall args+++invokeFromFunction ::+          (IsFunction f)+       => BasicBlock         -- ^Normal return point.+       -> BasicBlock         -- ^Exception return point.+       -> Function f         -- ^Function to call.+       -> Call f+invokeFromFunction (BasicBlock norm) (BasicBlock expt) func =+    typedCall func $ U.makeInvoke norm expt++-- | Call a function with exception handling.+invoke :: (CallArgs r f g)+       => BasicBlock         -- ^Normal return point.+       -> BasicBlock         -- ^Exception return point.+       -> Function f         -- ^Function to call.+       -> g+invoke norm expt f = doCall $ invokeFromFunction norm expt f++callWithConvFromFunction ::+    (IsFunction f) => FFI.CallingConvention -> Function f -> Call f+callWithConvFromFunction cc func = typedCall func $ U.makeCallWithCc cc++-- | Call a function with the given arguments.  The 'call' instruction+-- is variadic, i.e., the number of arguments it takes depends on the+-- type of /f/.+-- This also sets the calling convention of the call to the function.+-- As LLVM itself defines, if the calling conventions of the calling+-- /instruction/ and the function being /called/ are different, undefined+-- behavior results.+callWithConv :: (CallArgs r f g) => FFI.CallingConvention -> Function f -> g+callWithConv cc f = doCall $ callWithConvFromFunction cc f++invokeWithConvFromFunction ::+          (IsFunction f)+       => FFI.CallingConvention -- ^Calling convention+       -> BasicBlock         -- ^Normal return point.+       -> BasicBlock         -- ^Exception return point.+       -> Function f         -- ^Function to call.+       -> Call f+invokeWithConvFromFunction cc (BasicBlock norm) (BasicBlock expt) func =+    typedCall func $ U.makeInvokeWithCc cc norm expt++-- | Call a function with exception handling.+-- This also sets the calling convention of the call to the function.+-- As LLVM itself defines, if the calling conventions of the calling+-- /instruction/ and the function being /called/ are different, undefined+-- behavior results.+invokeWithConv :: (CallArgs r f g)+               => FFI.CallingConvention -- ^Calling convention+               -> BasicBlock         -- ^Normal return point.+               -> BasicBlock         -- ^Exception return point.+               -> Function f         -- ^Function to call.+               -> g+invokeWithConv cc norm expt f =+    doCall $ invokeWithConvFromFunction cc norm expt f++--------------------------------------++-- XXX could do const song and dance+-- |Join several variables (virtual registers) from different basic blocks into one.+-- All of the variables in the list are joined.  See also 'addPhiInputs'.+phi :: forall a r . (IsFirstClass a) => [(Value a, BasicBlock)] -> CodeGenFunction r (Value a)+phi incoming =+    liftM Value $+      withCurrentBuilder $ \ bldPtr -> do+        inst <- U.buildEmptyPhi bldPtr =<< typeRef (LP.Proxy :: LP.Proxy a)+        U.addPhiIns inst [ (v, b) | (Value v, BasicBlock b) <- incoming ]+        return inst++-- |Add additional inputs to an existing phi node.+-- The reason for this instruction is that sometimes the structure of the code+-- makes it impossible to have all variables in scope at the point where you need the phi node.+addPhiInputs :: forall a r . (IsFirstClass a)+             => Value a                      -- ^Must be a variable from a call to 'phi'.+             -> [(Value a, BasicBlock)]      -- ^Variables to add.+             -> CodeGenFunction r ()+addPhiInputs (Value inst) incoming =+    liftIO $ U.addPhiIns inst [ (v, b) | (Value v, BasicBlock b) <- incoming ]+++--------------------------------------++-- | Acceptable argument to array memory allocation.+class AllocArg a where+    getAllocArg :: a -> Value Word+instance (i ~ Word) => AllocArg (Value i) where+    getAllocArg = id+instance (i ~ Word) => AllocArg (ConstValue i) where+    getAllocArg = value+instance AllocArg Word where+    getAllocArg = valueOf++-- could be moved to Util.Memory+-- FFI.buildMalloc deprecated since LLVM-2.7+-- XXX What's the type returned by malloc+-- | Allocate heap memory.+malloc :: forall a r . (IsSized a) => CodeGenFunction r (Value (Ptr a))+malloc = arrayMalloc (1::Word)++type BytePtr = Ptr Word8++{-+I use a pointer type as size parameter of 'malloc'.+This way I hope that the parameter has always the correct size (32 or 64 bit).+A side effect is that we can convert the result of 'getelementptr' using 'bitcast',+that does not suffer from the slow assembly problem. (bug #8281)+-}+foreign import ccall "&aligned_malloc_sizeptr"+   alignedMalloc :: FunPtr (BytePtr -> BytePtr -> IO BytePtr)++foreign import ccall "&aligned_free"+   alignedFree :: FunPtr (BytePtr -> IO ())+++{-+There is a bug in LLVM-2.7 and LLVM-2.8+(http://llvm.org/bugs/show_bug.cgi?id=8281)+that causes huge assembly times for expressions like+ptrtoint(getelementptr(zero,..)).+If you break those expressions into two statements+at separate lines, everything is fine.+But the C interface is too clever,+and rewrites two separate statements into a functional expression on a single line.+Such code is generated whenever you call+buildMalloc, buildArrayMalloc, sizeOf (called by buildMalloc), or alignOf.+One possible way is to write a getelementptr expression+containing a nullptr in a way+that hides the constant nature of nullptr.++    ptr <- alloca+    store (value zero) ptr+    z <- load ptr+    size <- bitcast =<<+       getElementPtr (z :: Value (Ptr a)) (getAllocArg s, ())++However, I found that bitcast on pointers causes no problems.+Thus I switched to using pointers for size quantities.+This still allows for optimizations involving pointers.+-}++-- XXX What's the type returned by arrayMalloc?+-- | Allocate heap (array) memory.+arrayMalloc :: forall a r s . (IsSized a, AllocArg s) =>+               s -> CodeGenFunction r (Value (Ptr a)) -- XXX+arrayMalloc s = do+    func <- CodeGen.staticNamedFunction "alignedMalloc" alignedMalloc+--    func <- externFunction "malloc"++    size <- sizeOfArray (LP.Proxy :: LP.Proxy a) (getAllocArg s)+    alignment <- alignOf (LP.Proxy :: LP.Proxy a)+    bitcast =<< call func size alignment++-- XXX What's the type returned by malloc+-- | Allocate stack memory.+alloca :: forall a r . (IsSized a) => CodeGenFunction r (Value (Ptr a))+alloca =+    liftM Value $+    withCurrentBuilder $ \ bldPtr -> do+      typ <- typeRef (LP.Proxy :: LP.Proxy a)+      U.withEmptyCString $ FFI.buildAlloca bldPtr typ++-- XXX What's the type returned by arrayAlloca?+-- | Allocate stack (array) memory.+arrayAlloca :: forall a r s . (IsSized a, AllocArg s) =>+               s -> CodeGenFunction r (Value (Ptr a))+arrayAlloca s =+    liftM Value $+    withCurrentBuilder $ \ bldPtr -> do+      typ <- typeRef (LP.Proxy :: LP.Proxy a)+      U.withEmptyCString $+        FFI.buildArrayAlloca bldPtr typ (case getAllocArg s of Value v -> v)++-- FFI.buildFree deprecated since LLVM-2.7+-- XXX What's the type of free?+-- | Free heap memory.+free :: (IsType a) => Value (Ptr a) -> CodeGenFunction r ()+free ptr = do+    func <- CodeGen.staticNamedFunction "alignedFree" alignedFree+--    func <- externFunction "free"+    _ <- call func =<< bitcast ptr+    return ()+++-- | If we want to export that, then we should have a Size type+-- This is the official implementation,+-- but it suffers from the ptrtoint(gep) bug.+_sizeOf ::+    forall a r.+    (IsSized a) => LP.Proxy a -> CodeGenFunction r (Value Word)+_sizeOf a =+    liftIO $ liftM Value $+    FFI.sizeOf =<< typeRef a++_alignOf ::+    forall a r.+    (IsSized a) => LP.Proxy a -> CodeGenFunction r (Value Word)+_alignOf a =+    liftIO $ liftM Value $+    FFI.alignOf =<< typeRef a+++-- Here are reimplementation from Constants.cpp that avoid the ptrtoint(gep) bug #8281.+-- see ConstantExpr::getSizeOf+sizeOfArray ::+    forall a r . (IsSized a) =>+    LP.Proxy a -> Value Word -> CodeGenFunction r (Value BytePtr)+sizeOfArray _ len =+    bitcast =<<+       getElementPtr (value zero :: Value (Ptr a)) (len, ())++-- see ConstantExpr::getAlignOf+alignOf ::+    forall a r . (IsSized a) =>+    LP.Proxy a -> CodeGenFunction r (Value BytePtr)+alignOf _ =+    bitcast =<<+       getElementPtr0 (value zero :: Value (Ptr (Struct (Bool, (a, ()))))) (d1, ())+++-- | Load a value from memory.+load ::+       (IsType a)+    => Value (Ptr a)                   -- ^ Address to load from.+    -> CodeGenFunction r (Value a)+load ptr@(Value p) =+    liftM Value $+    withCurrentBuilder $ \ bldPtr -> do+        typ <- typeRef $ proxyFromValuePtr ptr+        U.withEmptyCString $ FFI.buildLoad2 bldPtr typ p++-- | Store a value in memory+store ::+       (IsType a)+    => Value a                        -- ^ Value to store.+    -> Value (Ptr a)                  -- ^ Address to store to.+    -> CodeGenFunction r ()+store (Value v) (Value p) = do+    withCurrentBuilder_ $ \ bldPtr -> FFI.buildStore bldPtr v p+    return ()++-- | Address arithmetic.  See LLVM description.+-- (The type isn't as accurate as it should be.)+_getElementPtrDynamic :: (IsType a, IsInteger i) =>+    Value (Ptr a) -> [Value i] -> CodeGenFunction r (Value (Ptr b))+_getElementPtrDynamic ptr@(Value p) ixs =+    liftM Value $+    withCurrentBuilder $ \ bldPtr -> do+      typ <- typeRef $ proxyFromValuePtr ptr+      U.withArrayLen [ v | Value v <- ixs ] $ \ idxLen idxPtr ->+        U.withEmptyCString $+          FFI.buildGEP2 bldPtr typ p idxPtr (fromIntegral idxLen)++-- | Address arithmetic.  See LLVM description.+-- The index is a nested tuple of the form @(i1,(i2,( ... ())))@.+-- (This is without a doubt the most confusing LLVM instruction, but the types help.)+getElementPtr :: forall a o i r . (GetElementPtr o i, IsType o, IsIndexArg a) =>+                 Value (Ptr o) -> (a, i) -> CodeGenFunction r (Value (Ptr (ElementPtrType o i)))+getElementPtr ptr@(Value p) (a, ixs) =+    let ixl = getArg a : getIxList (LP.Proxy :: LP.Proxy o) ixs in+    liftM Value $+    withCurrentBuilder $ \ bldPtr -> do+      typ <- typeRef $ proxyFromValuePtr ptr+      U.withArrayLen ixl $ \ idxLen idxPtr ->+        U.withEmptyCString $+          FFI.buildGEP2 bldPtr typ p idxPtr (fromIntegral idxLen)++-- | Like getElementPtr, but with an initial index that is 0.+-- This is useful since any pointer first need to be indexed off the pointer, and then into+-- its actual value.  This first indexing is often with 0.+getElementPtr0 :: (GetElementPtr o i, IsType o) =>+                  Value (Ptr o) -> i -> CodeGenFunction r (Value (Ptr (ElementPtrType o i)))+getElementPtr0 p i = getElementPtr p (0::Word32, i)++_getElementPtr :: forall value o i i0 r.+    (ValueCons value, IsType o, GetElementPtr o i, IsIndexType i0) =>+    value (Ptr o) -> (value i0, i) ->+    CodeGenFunction r (value (Ptr (ElementPtrType o i)))+_getElementPtr vptr (a, ixs) =+    let withArgs act =+            U.withArrayLen+                (unValue a : getIxList (LP.Proxy :: LP.Proxy o) ixs) $+            \ idxLen idxPtr ->+                act idxPtr (fromIntegral idxLen)+    in  unop+            (\ptr -> do+                typ <- typeRef $ proxyFromValuePtr vptr+                withArgs $ FFI.constGEP2 typ ptr)+            (\bldPtr ptr cstr -> do+                typ <- typeRef $ proxyFromValuePtr vptr+                withArgs $ \idxPtr idxLen ->+                    FFI.buildGEP2 bldPtr typ ptr idxPtr idxLen cstr)+            vptr++--------------------------------------+{-+instance (IsConst a) => Show (ConstValue a) -- XXX+instance (IsConst a) => Eq (ConstValue a)++{-+instance (IsConst a) => Eq (ConstValue a) where+    ConstValue x == ConstValue y  =+        if isFloating x then ConstValue (FFI.constFCmp (FFI.fromRealPredicate  FPOEQ) x y)+                        else ConstValue (FFI.constICmp (FFI.fromIntPredicate IntEQ) x y)+    ConstValue x /= ConstValue y  =+        if isFloating x then ConstValue (FFI.constFCmp (FFI.fromRealPredicate  FPONE) x y)+                        else ConstValue (FFI.constICmp (FFI.fromIntPredicate IntNE) x y)++instance (IsConst a) => Ord (ConstValue a) where+    ConstValue x <  ConstValue y  =+        if isFloating x then ConstValue (FFI.constFCmp (FFI.fromRealPredicate  FPOLT) x y)+                        else ConstValue (FFI.constICmp (FFI.fromIntPredicate IntLT) x y)+    ConstValue x <= ConstValue y  =+        if isFloating x then ConstValue (FFI.constFCmp (FFI.fromRealPredicate  FPOLE) x y)+                        else ConstValue (FFI.constICmp (FFI.fromIntPredicate IntLE) x y)+    ConstValue x >  ConstValue y  =+        if isFloating x then ConstValue (FFI.constFCmp (FFI.fromRealPredicate  FPOGT) x y)+                        else ConstValue (FFI.constICmp (FFI.fromIntPredicate IntGT) x y)+    ConstValue x >= ConstValue y  =+        if isFloating x then ConstValue (FFI.constFCmp (FFI.fromRealPredicate  FPOGE) x y)+                        else ConstValue (FFI.constICmp (FFI.fromIntPredicate IntGE) x y)+-}++instance (Num a, IsConst a) => Num (ConstValue a) where+    ConstValue x + ConstValue y  =  ConstValue (FFI.constAdd x y)+    ConstValue x - ConstValue y  =  ConstValue (FFI.constSub x y)+    ConstValue x * ConstValue y  =  ConstValue (FFI.constMul x y)+    negate (ConstValue x)        =  ConstValue (FFI.constNeg x)+    fromInteger x                =  constOf (fromInteger x :: a)+-}
+ private/LLVM/Core/Instructions/Guided.hs view
@@ -0,0 +1,352 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE EmptyDataDecls #-}+{- |+This module provides some functions from the "LLVM.Core.Instructions" module+in a way that enables easier type handling.+E.g. 'trunc' on vectors requires you to prove+that reducing the bitsize of the elements+reduces the bitsize of the whole vector.+We solve the problem by adding a 'Guide' parameter.+It can be either 'scalar' or 'vector'.+We impose the bitsize constraint only on the element type,+but not on the size of the whole value (scalar or vector).++Another example:+If you call 'trunc' on a Vector input,+GHC cannot infer that the result must be a 'Data.Vector' of the same size.+Using the guide, it can.+However, in practice this is not as useful as I thought initially.+-}+module LLVM.Core.Instructions.Guided (+    Guide,+    scalar,+    vector,+    getElementPtr,+    getElementPtr0,+    trunc,+    ext,+    extBool,+    zadapt,+    sadapt,+    adapt,+    fptrunc,+    fpext,+    fptoint,+    inttofp,+    ptrtoint,+    inttoptr,+    bitcast,+    select,+    cmp,+    icmp,+    pcmp,+    fcmp,+    ) where++import qualified LLVM.Core.Instructions.Private as Priv+import qualified LLVM.Core.Type as Type+import qualified LLVM.Core.Util as U+import qualified LLVM.Core.Proxy as LP+import LLVM.Core.Instructions.Private (ValueCons, proxyFromValuePtr)+import LLVM.Core.CodeGenMonad (CodeGenFunction)+import LLVM.Core.CodeGen (ConstValue, Value, zero)+import LLVM.Core.Data (Ptr)+import LLVM.Core.Type+         (IsArithmetic, IsInteger, IsIntegerOrPointer, IsFloating,+          IsFirstClass, IsPrimitive,+          Signed, Positive, IsType, IsSized, SizeOf,+          isFloating, sizeOf, typeDesc, typeRef)++import qualified LLVM.FFI.Core as FFI++import Type.Data.Num.Decimal.Number ((:<:), (:>:))++import qualified Control.Functor.HT as FuncHT++import Data.Word (Word32)+++data Guide shape elem = Guide++instance Functor (Guide shape) where+    fmap _ Guide = Guide++scalar :: Guide Type.ScalarShape a+scalar = Guide++vector :: (Positive n) => Guide (Type.VectorShape n) a+vector = Guide++proxyFromGuide :: Guide shape elem -> LP.Proxy elem+proxyFromGuide Guide = LP.Proxy+++type Type shape a = Type.ShapedType shape a+type VT value shape a = value (Type shape a)++getElementPtr ::+    (ValueCons value, IsType o, Priv.GetElementPtr o i, Priv.IsIndexType i0) =>+    Guide shape (Ptr o, i0) ->+    VT value shape (Ptr o) ->+    (VT value shape i0, i) ->+    CodeGenFunction r (VT value shape (Ptr (Priv.ElementPtrType o i)))+getElementPtr guide vptr (a, ixs) =+    getElementPtrGen (fmap fst guide) vptr (Priv.unValue a, ixs)++getElementPtr0 ::+    (ValueCons value, IsType o, Priv.GetElementPtr o i) =>+    Guide shape (Ptr o) ->+    VT value shape (Ptr o) -> i ->+    CodeGenFunction r (VT value shape (Ptr (Priv.ElementPtrType o i)))+getElementPtr0 guide vptr ixs =+    getElementPtrGen guide vptr+        (Priv.unConst (zero :: ConstValue Word32), ixs)++getElementPtrGen ::+    (ValueCons value, IsType o, Priv.GetElementPtr o i) =>+    Guide shape (Ptr o) ->+    VT value shape (Ptr o) -> (FFI.ValueRef, i) ->+    CodeGenFunction r (VT value shape (Ptr (Priv.ElementPtrType o i)))+getElementPtrGen guide vptr (i0val,ixs) =+    let withArgs act =+            U.withArrayLen+                (i0val : Priv.getIxList (LP.element (proxyFromGuide guide)) ixs) $+            \ idxLen idxPtr ->+                act idxPtr (fromIntegral idxLen)+    in  Priv.unop+            (\ptr -> do+                typ <- typeRef $ proxyFromValuePtr guide+                withArgs $ FFI.constGEP2 typ ptr)+            (\bldPtr ptr cstr -> do+                typ <- typeRef $ proxyFromValuePtr guide+                withArgs $ \idxPtr idxLen ->+                    FFI.buildGEP2 bldPtr typ ptr idxPtr idxLen cstr)+            vptr+++-- | Truncate a value to a shorter bit width.+trunc ::+    (ValueCons value, IsInteger av, IsInteger bv,+     IsPrimitive a, IsPrimitive b, Type shape a ~ av, Type shape b ~ bv,+     IsSized a, IsSized b, SizeOf a :>: SizeOf b) =>+    Guide shape (a,b) -> value av -> CodeGenFunction r (value bv)+trunc = convert FFI.constTrunc FFI.buildTrunc++isSigned :: (IsArithmetic a) => Guide shape a -> Bool+isSigned = Type.isSigned . proxyFromGuide++-- | Extend a value to wider width.+-- If the target type is signed, then preserve the sign,+-- If the target type is unsigned, then extended by zeros.+ext ::+    (IsInteger a, IsInteger b, IsType bv, Signed a ~ Signed b,+     IsPrimitive a, IsPrimitive b, Type shape a ~ av, Type shape b ~ bv,+     IsSized a, IsSized b, SizeOf a :<: SizeOf b) =>+    Guide shape (a,b) -> Value av -> CodeGenFunction r (Value bv)+ext guide =+   if isSigned (fmap snd guide)+     then convertValue FFI.buildSExt guide+     else convertValue FFI.buildZExt guide++extBool ::+    (IsInteger b, IsType bv,+     IsPrimitive b, Type shape Bool ~ av, Type shape b ~ bv) =>+    Guide shape (Bool,b) -> Value av -> CodeGenFunction r (Value bv)+extBool guide =+   if isSigned (fmap snd guide)+     then convertValue FFI.buildSExt guide+     else convertValue FFI.buildZExt guide+++compareGuideSizes :: (IsType a, IsType b) => Guide shape (a,b) -> Ordering+compareGuideSizes guide =+   case FuncHT.unzip $ proxyFromGuide guide of+      (a,b) -> compare (sizeOf (typeDesc a)) (sizeOf (typeDesc b))++-- | It is 'zext', 'trunc' or nop depending on the relation of the sizes.+zadapt ::+    (IsInteger a, IsInteger b, IsType bv,+     IsPrimitive a, IsPrimitive b, Type shape a ~ av, Type shape b ~ bv) =>+    Guide shape (a,b) -> Value av -> CodeGenFunction r (Value bv)+zadapt guide =+   case compareGuideSizes guide of+      LT -> convertValue FFI.buildZExt guide+      EQ -> convertValue FFI.buildBitCast guide+      GT -> convertValue FFI.buildTrunc guide++-- | It is 'sext', 'trunc' or nop depending on the relation of the sizes.+sadapt ::+    (IsInteger a, IsInteger b, IsType bv,+     IsPrimitive a, IsPrimitive b, Type shape a ~ av, Type shape b ~ bv) =>+    Guide shape (a,b) -> Value av -> CodeGenFunction r (Value bv)+sadapt guide =+   case compareGuideSizes guide of+      LT -> convertValue FFI.buildSExt guide+      EQ -> convertValue FFI.buildBitCast guide+      GT -> convertValue FFI.buildTrunc guide++-- | It is 'sadapt' or 'zadapt' depending on the sign mode.+adapt ::+    (IsInteger a, IsInteger b, IsType bv,+     IsPrimitive a, IsPrimitive b, Type shape a ~ av, Type shape b ~ bv,+     Signed a ~ Signed b) =>+    Guide shape (a,b) -> Value av -> CodeGenFunction r (Value bv)+adapt guide =+   case compareGuideSizes guide of+      LT ->+         if isSigned (fmap snd guide)+           then convertValue FFI.buildSExt guide+           else convertValue FFI.buildZExt guide+      EQ -> convertValue FFI.buildBitCast guide+      GT -> convertValue FFI.buildTrunc guide++-- | Truncate a floating point value.+fptrunc ::+    (IsFloating av, IsFloating bv,+     IsPrimitive a, IsPrimitive b, Type shape a ~ av, Type shape b ~ bv,+     IsSized a, IsSized b, SizeOf a :>: SizeOf b) =>+    Guide shape (a,b) -> Value av -> CodeGenFunction r (Value bv)+fptrunc = convertValue FFI.buildFPTrunc++-- | Extend a floating point value.+fpext ::+    (IsFloating av, IsFloating bv,+     IsPrimitive a, IsPrimitive b, Type shape a ~ av, Type shape b ~ bv,+     IsSized a, IsSized b, SizeOf a :<: SizeOf b) =>+    Guide shape (a,b) -> Value av -> CodeGenFunction r (Value bv)+fpext = convertValue FFI.buildFPExt++-- | Convert a floating point value to an integer.+-- It is mapped to @fptosi@ or @fptoui@ depending on the type @a@.+fptoint ::+    (IsFloating a, IsInteger b, IsType bv,+     IsPrimitive a, IsPrimitive b, Type shape a ~ av, Type shape b ~ bv) =>+    Guide shape (a,b) -> Value av -> CodeGenFunction r (Value bv)+fptoint guide =+   if isSigned (fmap snd guide)+     then convertValue FFI.buildFPToSI guide+     else convertValue FFI.buildFPToUI guide+++-- | Convert an integer to a floating point value.+-- It is mapped to @sitofp@ or @uitofp@ depending on the type @a@.+inttofp ::+    (IsInteger a, IsFloating b, IsType bv,+     IsPrimitive a, IsPrimitive b, Type shape a ~ av, Type shape b ~ bv) =>+    Guide shape (a,b) -> Value av -> CodeGenFunction r (Value bv)+inttofp guide =+   if isSigned (fmap fst guide)+     then convertValue FFI.buildSIToFP guide+     else convertValue FFI.buildUIToFP guide+++-- | Convert a pointer to an integer.+ptrtoint ::+    (ValueCons value, IsType a, IsInteger b, IsType bv,+     IsPrimitive b, Type shape (Ptr a) ~ av, Type shape b ~ bv) =>+    Guide shape (Ptr a, b) -> value av -> CodeGenFunction r (value bv)+ptrtoint = convert FFI.constPtrToInt FFI.buildPtrToInt++-- | Convert an integer to a pointer.+inttoptr ::+    (ValueCons value, IsInteger a, IsType b, IsType bv,+     IsPrimitive a, Type shape a ~ av, Type shape (Ptr b) ~ bv) =>+    Guide shape (a, Ptr b) -> value av -> CodeGenFunction r (value bv)+inttoptr = convert FFI.constIntToPtr FFI.buildIntToPtr++-- | Convert between to values of the same size by just copying the bit pattern.+bitcast ::+    (ValueCons value, IsFirstClass bv,+     IsPrimitive a, IsPrimitive b, Type shape a ~ av, Type shape b ~ bv,+     IsSized a, IsSized b, SizeOf a ~ SizeOf b) =>+    Guide shape (a,b) -> value av -> CodeGenFunction r (value bv)+bitcast = convert FFI.constBitCast FFI.buildBitCast+++convert ::+    (ValueCons value, IsType bv,+     IsPrimitive a, IsPrimitive b, Type shape a ~ av, Type shape b ~ bv) =>+    Priv.FFIConstConvert -> Priv.FFIConvert -> Guide shape (a,b) ->+    value av -> CodeGenFunction r (value bv)+convert cnvConst cnv Guide = Priv.convert cnvConst cnv++convertValue ::+    (IsType bv,+     IsPrimitive a, IsPrimitive b, Type shape a ~ av, Type shape b ~ bv) =>+    Priv.FFIConvert -> Guide shape (a,b) ->+    Value av -> CodeGenFunction r (Value bv)+convertValue cnv Guide = Priv.convertValue LP.Proxy cnv++++select ::+    (IsPrimitive a, Type shape a ~ av, Type shape Bool ~ bv) =>+    Guide shape a ->+    Value bv -> Value av -> Value av -> CodeGenFunction r (Value av)+select Guide = Priv.trinopValue FFI.buildSelect+++cmp ::+    (IsArithmetic a, IsPrimitive a,+     Type shape a ~ av, Type shape Bool ~ bv) =>+    Guide shape a ->+    Priv.CmpPredicate -> Value av -> Value av -> CodeGenFunction r (Value bv)+cmp guide@Guide p =+    let cmpop buildCmp predi = Priv.binopValue (flip buildCmp predi)+    in  if isFloating (proxyFromGuide guide)+          then+            cmpop FFI.buildFCmp $+            FFI.fromRealPredicate $ Priv.fpFromCmpPredicate p+          else+            cmpop FFI.buildICmp $+            FFI.fromIntPredicate $+            if isSigned guide+              then Priv.sintFromCmpPredicate p+              else Priv.uintFromCmpPredicate p++_cmp ::+    (IsArithmetic a, IsPrimitive a,+     Type shape a ~ av, Type shape Bool ~ bv) =>+    Guide shape a ->+    Priv.CmpPredicate -> Value av -> Value av -> CodeGenFunction r (Value bv)+_cmp guide@Guide p =+    if isFloating (proxyFromGuide guide)+      then+        let predi = FFI.fromRealPredicate $ Priv.fpFromCmpPredicate p+        in  Priv.binopValue (flip FFI.buildFCmp predi)+      else+        let predi =+              FFI.fromIntPredicate $+              if isSigned guide+                then Priv.sintFromCmpPredicate p+                else Priv.uintFromCmpPredicate p+        in  Priv.binopValue (flip FFI.buildICmp predi)++{-# DEPRECATED icmp "use cmp or pcmp instead" #-}+-- | Compare integers.+icmp ::+    (IsIntegerOrPointer a, IsPrimitive a,+     Type shape a ~ av, Type shape Bool ~ bv) =>+    Guide shape a ->+    FFI.IntPredicate -> Value av -> Value av -> CodeGenFunction r (Value bv)+icmp Guide p =+    Priv.binopValue $ flip FFI.buildICmp (FFI.fromIntPredicate p)++-- | Compare pointers.+pcmp :: (Type shape (Ptr a) ~ av, Type shape Bool ~ bv) =>+    Guide shape (Ptr a) ->+    FFI.IntPredicate -> Value av -> Value av -> CodeGenFunction r (Value bv)+pcmp Guide p =+    Priv.binopValue $ flip FFI.buildICmp (FFI.fromIntPredicate p)++-- | Compare floating point values.+fcmp ::+    (IsFloating a, IsPrimitive a,+     Type shape a ~ av, Type shape Bool ~ bv) =>+    Guide shape a ->+    FFI.FPPredicate -> Value av -> Value av -> CodeGenFunction r (Value bv)+fcmp Guide p =+    Priv.binopValue $ flip FFI.buildFCmp (FFI.fromRealPredicate p)
+ private/LLVM/Core/Instructions/Private.hs view
@@ -0,0 +1,320 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+module LLVM.Core.Instructions.Private where++import qualified LLVM.Core.Util as U+import qualified LLVM.Core.Proxy as LP+import LLVM.Core.Type (IsType, IsPrimitive, typeRef)+import LLVM.Core.Data (Vector, Array, Struct, PackedStruct, Ptr)+import LLVM.Core.CodeGenMonad (CodeGenFunction)+import LLVM.Core.CodeGen+            (ConstValue(ConstValue), constOf, Value(Value), withCurrentBuilder)++import qualified LLVM.FFI.Core as FFI+import LLVM.FFI.Core (IntPredicate(..), FPPredicate(..))++import qualified Type.Data.Num.Decimal.Number as Dec+import Type.Data.Num.Decimal.Number (Pred)+import Type.Base.Proxy (Proxy)++import Control.Monad.IO.Class (liftIO)+import Control.Monad (liftM)++import Data.Typeable (Typeable)+import Data.Int (Int32, Int64)+import Data.Word (Word32, Word64, Word)++++type FFIConstConvert = FFI.ValueRef -> FFI.TypeRef -> IO FFI.ValueRef+type FFIConvert =+        FFI.BuilderRef -> FFI.ValueRef -> FFI.TypeRef ->+        U.CString -> IO FFI.ValueRef++type FFIConstUnOp = FFI.ValueRef -> IO FFI.ValueRef+type FFIUnOp = FFI.BuilderRef -> FFI.ValueRef -> U.CString -> IO FFI.ValueRef++type FFIConstBinOp = FFI.ValueRef -> FFI.ValueRef -> IO FFI.ValueRef+type FFIBinOp =+        FFI.BuilderRef -> FFI.ValueRef -> FFI.ValueRef ->+        U.CString -> IO FFI.ValueRef++type FFIConstTrinOp =+        FFI.ValueRef -> FFI.ValueRef -> FFI.ValueRef -> IO FFI.ValueRef+type FFITrinOp =+        FFI.BuilderRef -> FFI.ValueRef -> FFI.ValueRef -> FFI.ValueRef ->+        U.CString -> IO FFI.ValueRef+++proxyFromValuePtr :: value (Ptr a) -> LP.Proxy a+proxyFromValuePtr _ = LP.Proxy+++class ValueCons value where+    switchValueCons :: f ConstValue -> f Value -> f value++instance ValueCons ConstValue where+    switchValueCons f _ = f++instance ValueCons Value where+    switchValueCons _ f = f+++convert :: (ValueCons value, IsType b) =>+    FFIConstConvert -> FFIConvert -> value a -> CodeGenFunction r (value b)+convert cop op =+    getUnOp $+    switchValueCons+        (UnOp $ convertConstValue LP.Proxy cop)+        (UnOp $ convertValue LP.Proxy op)++convertConstValue ::+    (IsType b) =>+    LP.Proxy b -> FFIConstConvert ->+    ConstValue a -> CodeGenFunction r (ConstValue b)+convertConstValue proxy conv (ConstValue a) =+    liftM ConstValue $ liftIO $ conv a =<< typeRef proxy++convertValue ::+    (IsType b) =>+    LP.Proxy b -> FFIConvert -> Value a -> CodeGenFunction r (Value b)+convertValue proxy conv (Value a) =+    liftM Value $+    withCurrentBuilder $ \ bldPtr -> do+      typ <- typeRef proxy+      U.withEmptyCString $ conv bldPtr a typ+++newtype UnValue a value = UnValue {getUnValue :: value a -> FFI.ValueRef}++unValue :: (ValueCons value) => value a -> FFI.ValueRef+unValue =+    getUnValue $+    switchValueCons+        (UnValue $ \(ConstValue a) -> a)+        (UnValue $ \(Value a) -> a)++newtype UnOp a b r value =+    UnOp {getUnOp :: value a -> CodeGenFunction r (value b)}++unop ::+    (ValueCons value) =>+    FFIConstUnOp -> FFIUnOp -> value a -> CodeGenFunction r (value b)+unop cop op =+    getUnOp $+    switchValueCons+        (UnOp $ \(ConstValue a) -> liftIO $ fmap ConstValue $ cop a)+        (UnOp $ unopValue op)++unopValue :: FFIUnOp -> Value a -> CodeGenFunction r (Value b)+unopValue op (Value a) =+    liftM Value $+    withCurrentBuilder $ \ bld ->+        U.withEmptyCString $ op bld a++newtype BinOp a b c r value =+    BinOp {getBinOp :: value a -> value b -> CodeGenFunction r (value c)}++binop ::+    (ValueCons value) =>+    FFIConstBinOp -> FFIBinOp ->+    value a -> value b -> CodeGenFunction r (value c)+binop cop op =+    getBinOp $+    switchValueCons+        (BinOp $ \(ConstValue a) (ConstValue b) ->+            liftIO $ fmap ConstValue $ cop a b)+        (BinOp $ binopValue op)++binopValue ::+    FFIBinOp ->+    Value a -> Value b -> CodeGenFunction r (Value c)+binopValue op (Value a) (Value b) =+    liftM Value $+    withCurrentBuilder $ \ bld ->+        U.withEmptyCString $ op bld a b++newtype TrinOp a b c d r value =+    TrinOp {+        getTrinOp ::+            value a -> value b -> value c -> CodeGenFunction r (value d)+    }++trinop ::+    (ValueCons value) =>+    FFIConstTrinOp -> FFITrinOp ->+    value a -> value b -> value c -> CodeGenFunction r (value d)+trinop cop op =+    getTrinOp $+    switchValueCons+        (TrinOp $ \(ConstValue a) (ConstValue b) (ConstValue c) ->+            liftIO $ fmap ConstValue $ cop a b c)+        (TrinOp $ trinopValue op)++trinopValue ::+    FFITrinOp ->+    Value a -> Value b -> Value c -> CodeGenFunction r (Value d)+trinopValue op (Value a) (Value b) (Value c) =+    liftM Value $+    withCurrentBuilder $ \ bld ->+        U.withEmptyCString $ op bld a b c++++-- | Acceptable arguments to 'getElementPointer'.+class GetElementPtr optr ixs where+    type ElementPtrType optr ixs+    getIxList :: LP.Proxy optr -> ixs -> [FFI.ValueRef]++-- | Acceptable single index to 'getElementPointer'.+class IsIndexArg a where+    getArg :: a -> FFI.ValueRef++{- |+In principle we do not need the getValueArg method,+because we could just use 'unValue'.+However, we want to prevent users+from defining their own (disfunctional) IsIndexType instances.+-}+class (IsPrimitive i) => IsIndexType i where+    getValueArg :: (ValueCons value) => value i -> FFI.ValueRef++instance IsIndexType Word where+    getValueArg = unValue++instance IsIndexType Word32 where+    getValueArg = unValue++instance IsIndexType Word64 where+    getValueArg = unValue++instance IsIndexType Int where+    getValueArg = unValue++instance IsIndexType Int32 where+    getValueArg = unValue++instance IsIndexType Int64 where+    getValueArg = unValue++instance IsIndexType i => IsIndexArg (ConstValue i) where+    getArg = getValueArg++instance IsIndexType i => IsIndexArg (Value i) where+    getArg = getValueArg++instance IsIndexArg Word where+    getArg = unConst . constOf++instance IsIndexArg Word32 where+    getArg = unConst . constOf++instance IsIndexArg Word64 where+    getArg = unConst . constOf++instance IsIndexArg Int where+    getArg = unConst . constOf++instance IsIndexArg Int32 where+    getArg = unConst . constOf++instance IsIndexArg Int64 where+    getArg = unConst . constOf++unConst :: ConstValue a -> FFI.ValueRef+unConst (ConstValue v) = v++-- End of indexing+instance GetElementPtr a () where+    type ElementPtrType a () = a+    getIxList LP.Proxy () = []++-- Index in Array+instance+    (GetElementPtr o i, IsIndexArg a, Dec.Natural k) =>+        GetElementPtr (Array k o) (a, i) where+    type ElementPtrType (Array k o) (a, i) = ElementPtrType o i+    getIxList proxy (v, i) = getArg v : getIxList (LP.element proxy) i++-- Index in Vector+instance+    (GetElementPtr o i, IsIndexArg a, Dec.Positive k) =>+        GetElementPtr (Vector k o) (a, i) where+    type ElementPtrType (Vector k o) (a, i) = ElementPtrType o i+    getIxList proxy (v, i) = getArg v : getIxList (LP.element proxy) i++fieldProxy :: LP.Proxy (struct fs) -> Proxy a -> LP.Proxy (FieldType fs a)+fieldProxy LP.Proxy _proxy = LP.Proxy++-- Index in Struct and PackedStruct.+-- The index has to be a type level integer to statically determine the record field type+instance+    (GetElementPtr (FieldType fs a) i, Dec.Natural a) =>+        GetElementPtr (Struct fs) (Proxy a, i) where+    type ElementPtrType (Struct fs) (Proxy a, i) =+            ElementPtrType (FieldType fs a) i+    getIxList proxy (a, i) =+        unConst (constOf (Dec.integralFromProxy a :: Word32)) :+        getIxList (fieldProxy proxy a) i+instance+    (GetElementPtr (FieldType fs a) i, Dec.Natural a) =>+        GetElementPtr (PackedStruct fs) (Proxy a, i) where+    type ElementPtrType (PackedStruct fs) (Proxy a, i) =+            ElementPtrType (FieldType fs a) i+    getIxList proxy (a, i) =+        unConst (constOf (Dec.integralFromProxy a :: Word32)) :+        getIxList (fieldProxy proxy a) i++class GetField as i where type FieldType as i+instance GetField (a, as) Dec.Zero where+    type FieldType (a, as) Dec.Zero = a+instance+    (GetField as (Pred (Dec.Pos i0 i1))) =>+        GetField (a, as) (Dec.Pos i0 i1) where+    type FieldType (a,as) (Dec.Pos i0 i1) = FieldType as (Pred (Dec.Pos i0 i1))++++data CmpPredicate =+    CmpEQ                       -- ^ equal+  | CmpNE                       -- ^ not equal+  | CmpGT                       -- ^ greater than+  | CmpGE                       -- ^ greater or equal+  | CmpLT                       -- ^ less than+  | CmpLE                       -- ^ less or equal+    deriving (Eq, Ord, Enum, Show, Typeable)++uintFromCmpPredicate :: CmpPredicate -> IntPredicate+uintFromCmpPredicate p =+   case p of+      CmpEQ -> IntEQ+      CmpNE -> IntNE+      CmpGT -> IntUGT+      CmpGE -> IntUGE+      CmpLT -> IntULT+      CmpLE -> IntULE++sintFromCmpPredicate :: CmpPredicate -> IntPredicate+sintFromCmpPredicate p =+   case p of+      CmpEQ -> IntEQ+      CmpNE -> IntNE+      CmpGT -> IntSGT+      CmpGE -> IntSGE+      CmpLT -> IntSLT+      CmpLE -> IntSLE++fpFromCmpPredicate :: CmpPredicate -> FPPredicate+fpFromCmpPredicate p =+   case p of+      CmpEQ -> FPOEQ+      CmpNE -> FPONE+      CmpGT -> FPOGT+      CmpGE -> FPOGE+      CmpLT -> FPOLT+      CmpLE -> FPOLE
+ private/LLVM/Core/Proxy.hs view
@@ -0,0 +1,19 @@+module LLVM.Core.Proxy where++import Control.Applicative (Applicative, pure, (<*>), )++data Proxy a = Proxy++instance Functor Proxy where+   fmap _f Proxy = Proxy++instance Applicative Proxy where+   pure _ = Proxy+   Proxy <*> Proxy = Proxy+++fromValue :: a -> Proxy a+fromValue _ = Proxy++element :: Proxy (f a) -> Proxy a+element Proxy = Proxy
+ private/LLVM/Core/Type.hs view
@@ -0,0 +1,698 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeFamilies #-}+-- |The LLVM type system is captured with a number of Haskell type classes.+-- In general, an LLVM type @T@ is represented as @Value T@, where @T@ is some Haskell type.+-- The various types @T@ are classified by various type classes, e.g., 'IsFirstClass' for+-- those types that are LLVM first class types (passable as arguments etc).+-- All valid LLVM types belong to the 'IsType' class.+module LLVM.Core.Type(+    -- * Type classifier+    IsType(..),+    -- ** Special type classifiers+    Dec.Natural,+    Dec.Positive,+    IsArithmetic(arithmeticType),+    ArithmeticType(IntegerType,FloatingType),+    IsInteger, Signed,+    IsIntegerOrPointer,+    IsFloating,+    IsPrimitive,+    IsFirstClass,+    IsSized, SizeOf, sizeOf,+    IsFunction,+    Storable, fromPtr, toPtr,+    -- ** Others+    IsScalarOrVector,+    ShapeOf, ScalarShape, VectorShape,+    Shape, ShapedType,+    StructFields,+    PtrSize, IntSize,+    UnknownSize, -- needed for arrays of structs+    -- ** Structs+    ConsStruct(..), consStruct,+    CurryStruct, Curried, curryStruct, uncurryStruct,+    (:&), (&),+    -- ** Type tests+    TypeDesc(..),+    isFloating,+    isSigned,+    typeRef,+    unsafeTypeRef,+    typeName,+    intrinsicTypeName,+    typeDesc2,+    VarArgs, CastVarArgs,+    ) where++import qualified LLVM.FFI.Core as FFI++import qualified LLVM.Core.Data as Data+import LLVM.Core.Util (functionType, structType)+import LLVM.Core.Data+        (IntN, WordN, Vector, Array, FP128,+         Struct(Struct), PackedStruct(PackedStruct), Label)+import LLVM.Core.Proxy (Proxy(Proxy))++import qualified Type.Data.Num.Decimal.Number as Dec+import Type.Data.Num.Decimal.Number ((:*:))+import Type.Data.Num.Decimal.Literal (D1, D8, D16, D32, D64, D128, D99)+import Type.Data.Bool (True, False)++import qualified Foreign+import Foreign.StablePtr (StablePtr, )+import Foreign.Ptr (FunPtr)+import System.IO.Unsafe (unsafePerformIO)++import Data.Typeable (Typeable)+import Data.List (intercalate)+import Data.Bits (bitSize)+import Data.Int (Int8, Int16, Int32, Int64)+import Data.Word (Word8, Word16, Word32, Word64, Word)+++#include "MachDeps.h"++-- TODO:+-- Move IntN, WordN to a special module that implements those types+--   properly in Haskell.+-- Also move Array and Vector to a Haskell module to implement them.+-- Add Label?+-- Add structures (using tuples, maybe nested).++-- |The 'IsType' class classifies all types that have an LLVM representation.+class IsType a where+    typeDesc :: Proxy a -> TypeDesc++typeRef :: (IsType a) => Proxy a -> IO FFI.TypeRef+typeRef = code . typeDesc+  where code TDFloat  = FFI.floatType+        code TDDouble = FFI.doubleType+        code TDFP128  = FFI.fp128Type+        code TDVoid   = FFI.voidType+        code (TDInt _ n)  = FFI.integerType (fromInteger n)+        code (TDArray n a) = withCode FFI.arrayType (code a) (fromInteger n)+        code (TDVector n a) = withCode FFI.vectorType (code a) (fromInteger n)+        code (TDPtr a) = withCode FFI.pointerType (code a) 0+        code (TDFunction va as b) = do+            bt <- code b+            ast <- mapM code as+            functionType va bt ast+        code TDLabel = FFI.labelType+        code (TDStruct ts packed) = withCode structType (mapM code ts) packed+        code TDInvalidType = error "typeRef TDInvalidType"++unsafeTypeRef :: (IsType a) => Proxy a -> FFI.TypeRef+unsafeTypeRef = unsafePerformIO . typeRef+++withCode ::+    Monad m =>+    (a -> b -> m c) ->+    m a -> b -> m c+withCode f mx y =+    mx >>= \x -> f x y+++typeName :: (IsType a) => Proxy a -> String+typeName = code . typeDesc+  where code TDFloat  = "f32"+        code TDDouble = "f64"+        code TDFP128  = "f128"+        code TDVoid   = "void"+        code (TDInt _ n)  = "i" ++ show n+        code (TDArray n a) = "[" ++ show n ++ " x " ++ code a ++ "]"+        code (TDVector n a) = "<" ++ show n ++ " x " ++ code a ++ ">"+        code (TDPtr a) = code a ++ "*"+        code (TDFunction _ as b) = code b ++ "(" ++ intercalate "," (map code as) ++ ")"+        code TDLabel = "label"+        code (TDStruct as packed) = (if packed then "<{" else "{") +++                                    intercalate "," (map code as) +++                                    (if packed then "}>" else "}")+        code TDInvalidType = error "typeName TDInvalidType"++intrinsicTypeName :: (IsType a) => Proxy a -> String+intrinsicTypeName = code . typeDesc+  where code TDFloat  = "f32"+        code TDDouble = "f64"+        code TDFP128  = "f128"+        code (TDInt _ n)  = "i" ++ show n+        code (TDVector n a) = "v" ++ show n ++ code a+        code _ = error "intrinsicTypeName: type not supported in intrinsics"++typeDesc2 :: FFI.TypeRef -> IO TypeDesc+typeDesc2 t = do+    tk <- FFI.getTypeKind t+    case tk of+      FFI.VoidTypeKind -> return TDVoid+      FFI.FloatTypeKind -> return TDFloat+      FFI.DoubleTypeKind -> return TDDouble+      -- FIXME: FFI.X86_FP80TypeKind -> return "X86_FP80"+      FFI.FP128TypeKind -> return TDFP128+      -- FIXME: FFI.PPC_FP128TypeKind -> return "PPC_FP128"+      FFI.LabelTypeKind -> return TDLabel+      FFI.IntegerTypeKind -> do+                n <- FFI.getIntTypeWidth t+                return $ TDInt False (fromIntegral n)+      -- FIXME: FFI.FunctionTypeKind+      -- FIXME: FFI.StructTypeKind -> return "(Struct ...)"+      FFI.ArrayTypeKind -> do+                n <- FFI.getArrayLength t+                et <- FFI.getElementType t+                etd <- typeDesc2 et+                return $ TDArray (fromIntegral n) etd+      FFI.PointerTypeKind -> do+                et <- FFI.getElementType t+                etd <- typeDesc2 et+                return $ TDPtr etd+      -- FIXME: FFI.OpaqueTypeKind -> return "Opaque"+      FFI.VectorTypeKind -> do+                n <- FFI.getVectorSize t+                et <- FFI.getElementType t+                etd <- typeDesc2 et+                return $ TDVector (fromIntegral n) etd+      -- FIXME: LLVMMetadataTypeKind,    /**< Metadata */+      -- FIXME: LLVMX86_MMXTypeKind      /**< X86 MMX */+      _ -> return TDInvalidType++-- |Type descriptor, used to convey type information through the LLVM API.+data TypeDesc = TDFloat | TDDouble | TDFP128 | TDVoid | TDInt Bool Integer+              | TDArray Integer TypeDesc | TDVector Integer TypeDesc+              | TDPtr TypeDesc | TDFunction Bool [TypeDesc] TypeDesc | TDLabel+              | TDStruct [TypeDesc] Bool | TDInvalidType+    deriving (Eq, Ord, Show, Typeable)++-- XXX isFloating and typeName could be extracted from typeRef+-- Usage:+--   superclass of IsConst+--   add, sub, mul, neg context+--   used to get type name to call intrinsic+-- |Arithmetic types, i.e., integral and floating types.+class IsFirstClass a => IsArithmetic a where+    arithmeticType :: ArithmeticType a++data ArithmeticType a = IntegerType | FloatingType++instance Functor ArithmeticType where+    fmap _ IntegerType  = IntegerType+    fmap _ FloatingType = FloatingType++vectorArithmeticType :: ArithmeticType a -> ArithmeticType (Vector n a)+vectorArithmeticType t =+    case t of+        IntegerType  -> IntegerType+        FloatingType -> FloatingType+++-- Usage:+--  constI, allOnes+--  many instructions.  XXX some need vector+--  used to find signedness in Arithmetic+-- |Integral types.+class (IsArithmetic a, IsIntegerOrPointer a) => IsInteger a where+   type Signed a++-- Usage:+--  icmp+-- |Integral or pointer type.+class IsIntegerOrPointer a++isSigned :: (IsArithmetic a) => Proxy a -> Bool+isSigned = is . typeDesc+  where is (TDInt s _) = s+        is (TDVector _ a) = is a+        is TDFloat = True+        is TDDouble = True+        is TDFP128 = True+        is _ = error "isSigned got impossible input"++-- Usage:+--  constF+--  many instructions+-- |Floating types.+class IsArithmetic a => IsFloating a++isFloating :: (IsArithmetic a) => Proxy a -> Bool+isFloating = is . typeDesc+  where is TDFloat = True+        is TDDouble = True+        is TDFP128 = True+        is (TDVector _ a) = is a+        is _ = False++-- Usage:+--  Precondition for Vector+-- |Primitive types.+-- class (IsType a) => IsPrimitive a+class (IsScalarOrVector a, ShapeOf a ~ ScalarShape) => IsPrimitive a++data ScalarShape+data VectorShape n++class Shape shape where+    type ShapedType shape a++instance Shape ScalarShape where+    type ShapedType ScalarShape a = a++instance Shape (VectorShape n) where+    type ShapedType (VectorShape n) a = Vector n a++-- |Number of elements for instructions that handle both primitive and vector types+class (IsFirstClass a) => IsScalarOrVector a where+    type ShapeOf a+++-- Usage:+--  Precondition for function args and result.+--  Used by some instructions, like ret and phi.+-- |First class types, i.e., the types that can be passed as arguments, etc.+class IsType a => IsFirstClass a++-- Usage:+--  Context for Array being a type+--  thus, allocation instructions+-- |Types with a fixed size.+class (IsFirstClass a, Dec.Natural (SizeOf a)) => IsSized a where+    type SizeOf a++sizeOf :: TypeDesc -> Integer+sizeOf TDFloat  = 32+sizeOf TDDouble = 64+sizeOf TDFP128  = 128+sizeOf (TDInt _ bits) = bits+sizeOf (TDArray n typ) = n * sizeOf typ+sizeOf (TDVector n typ) = n * sizeOf typ+sizeOf (TDStruct ts _packed) = sum (map sizeOf ts)+sizeOf _ = error "type has no size"++-- |Function type.+class (IsType a) => IsFunction a where+    funcType :: [TypeDesc] -> Proxy a -> TypeDesc++-- Only make instances for types that make sense in Haskell+-- (i.e., some floating types are excluded).++-- Floating point types.+instance IsType Float  where typeDesc _ = TDFloat+instance IsType Double where typeDesc _ = TDDouble+instance IsType FP128  where typeDesc _ = TDFP128++-- Void type+instance IsType ()     where typeDesc _ = TDVoid++-- Label type+instance IsType Label  where typeDesc _ = TDLabel++-- Variable size integer types+instance (Dec.Positive n) => IsType (IntN n)+    where typeDesc _ =+             TDInt True+                (Dec.integralFromSingleton (Dec.singleton :: Dec.Singleton n))++instance (Dec.Positive n) => IsType (WordN n)+    where typeDesc _ =+             TDInt False+                (Dec.integralFromSingleton (Dec.singleton :: Dec.Singleton n))++-- Fixed size integer types.+instance IsType Bool   where typeDesc _ = TDInt False  1+instance IsType Word8  where typeDesc _ = TDInt False  8+instance IsType Word16 where typeDesc _ = TDInt False 16+instance IsType Word32 where typeDesc _ = TDInt False 32+instance IsType Word64 where typeDesc _ = TDInt False 64+instance IsType Word   where+   typeDesc _ = TDInt False (toInteger $ bitSize(0::Word))+instance IsType Int8   where typeDesc _ = TDInt True   8+instance IsType Int16  where typeDesc _ = TDInt True  16+instance IsType Int32  where typeDesc _ = TDInt True  32+instance IsType Int64  where typeDesc _ = TDInt True  64+instance IsType Int    where+   typeDesc _ = TDInt True  (toInteger $ bitSize(0::Int))++-- Sequence types+instance (Dec.Natural n, IsSized a) => IsType (Array n a)+    where typeDesc _ =+             TDArray+                (Dec.integralFromSingleton (Dec.singleton :: Dec.Singleton n))+                (typeDesc (Proxy :: Proxy a))+instance (Dec.Positive n, IsPrimitive a) => IsType (Vector n a)+    where typeDesc _ =+             TDVector+                (Dec.integralFromSingleton (Dec.singleton :: Dec.Singleton n))+                (typeDesc (Proxy :: Proxy a))++-- Pointer type.+instance IsType (Foreign.Ptr a) where+    typeDesc _ = TDPtr (typeDesc (Proxy :: Proxy (Struct ())))++instance (IsType a) => IsType (Data.Ptr a) where+    typeDesc _ = TDPtr (typeDesc (Proxy :: Proxy a))++instance (IsFunction f) => IsType (FunPtr f) where+    typeDesc _ = TDPtr (typeDesc (Proxy :: Proxy f))++instance IsType (StablePtr a) where+    typeDesc _ = TDPtr (typeDesc (Proxy :: Proxy (Struct ())))+{-+    typeDesc _ = TDPtr TDVoid++List: Type.cpp:1311: static llvm::PointerType* llvm::PointerType::get(const llvm::Type*, unsigned int): Assertion `ValueType != Type::VoidTy && "Pointer to void is not valid, use sbyte* instead!"' failed.+-}+++-- Functions.+instance (IsFirstClass a, IsFunction b) => IsType (a->b) where+    typeDesc = funcType []++-- Function base type, always IO.+instance (IsFirstClass a) => IsType (IO a) where+    typeDesc = funcType []++-- Struct types, basically a list of component types.+instance (StructFields a) => IsType (Struct a) where+    typeDesc p = TDStruct (fieldTypes $ fmap (\(Struct a) -> a) p) False++instance (StructFields a) => IsType (PackedStruct a) where+    typeDesc p = TDStruct (fieldTypes $ fmap (\(PackedStruct a) -> a) p) True++-- Use a nested tuples for struct fields.+class StructFields as where+    fieldTypes :: Proxy as -> [TypeDesc]++instance (IsSized a, StructFields as) => StructFields (a :& as) where+    fieldTypes p = typeDesc (fmap fst p) : fieldTypes (fmap snd p)+instance StructFields () where+    fieldTypes Proxy = []+++-- Simplifies construction, pattern matching and conversion to and from records+class ConsStruct f where+    type PartialStruct f+    type ConsResult f+    curryConsStruct :: (PartialStruct f -> Struct (ConsResult f)) -> f++instance ConsStruct (Struct a) where+    type PartialStruct (Struct a) = ()+    type ConsResult (Struct a) = a+    curryConsStruct g = g ()++instance (ConsStruct f) => ConsStruct (a->f) where+    type PartialStruct (a->f) = (a, PartialStruct f)+    type ConsResult (a->f) = ConsResult f+    curryConsStruct g a = curryConsStruct (\r -> g (a,r))++consStruct :: (ConsStruct f, ConsResult f ~ PartialStruct f) => f+consStruct = curryConsStruct Struct++class CurryStruct a where+    type Curried a b+    curryStruct' :: (a -> b) -> Curried a b+    uncurryStruct' :: Curried a b -> a -> b++instance CurryStruct () where+    type Curried () b = b+    curryStruct' f = f ()+    uncurryStruct' f () = f++instance (CurryStruct r) => CurryStruct (a,r) where+    type Curried (a,r) b = a -> Curried r b+    curryStruct' f a = curryStruct' (\r -> f (a,r))+    uncurryStruct' f (a,r) = uncurryStruct' (f a) r++curryStruct :: (CurryStruct a) => (Struct a -> b) -> Curried a b+curryStruct f = curryStruct' (f . Struct)++uncurryStruct :: (CurryStruct a) => Curried a b -> (Struct a -> b)+uncurryStruct f (Struct a) = uncurryStruct' f a+++-- An alias for pairs to make structs look nicer+infixr :&+type (:&) a as = (a, as)+infixr &+(&) :: a -> as -> a :& as+a & as = (a, as)+++--- Instances to classify types+instance IsArithmetic Float  where arithmeticType = FloatingType+instance IsArithmetic Double where arithmeticType = FloatingType+instance IsArithmetic FP128  where arithmeticType = FloatingType+instance (Dec.Positive n) => IsArithmetic (IntN n)  where arithmeticType = IntegerType+instance (Dec.Positive n) => IsArithmetic (WordN n) where arithmeticType = IntegerType+{-+This instance is more dangerous than useful.+E.g. 'inv' can be mixed up with 'neg'.+For arithmetic on i1 you might better use @IntN D1@ or @WordN D1@.+-}+instance IsArithmetic Bool   where arithmeticType = IntegerType+instance IsArithmetic Int8   where arithmeticType = IntegerType+instance IsArithmetic Int16  where arithmeticType = IntegerType+instance IsArithmetic Int32  where arithmeticType = IntegerType+instance IsArithmetic Int64  where arithmeticType = IntegerType+instance IsArithmetic Int    where arithmeticType = IntegerType+instance IsArithmetic Word8  where arithmeticType = IntegerType+instance IsArithmetic Word16 where arithmeticType = IntegerType+instance IsArithmetic Word32 where arithmeticType = IntegerType+instance IsArithmetic Word64 where arithmeticType = IntegerType+instance IsArithmetic Word   where arithmeticType = IntegerType+instance (Dec.Positive n, IsPrimitive a, IsArithmetic a) =>+         IsArithmetic (Vector n a) where+   arithmeticType = vectorArithmeticType arithmeticType+--   arithmeticType = fmap (pure :: a -> Vector n a) arithmeticType++instance IsFloating Float+instance IsFloating Double+instance IsFloating FP128+instance (Dec.Positive n, IsPrimitive a, IsFloating a) => IsFloating (Vector n a)++data Indecisive++instance (Dec.Positive n) => IsInteger (IntN  n) where type Signed (IntN  n) = True+instance (Dec.Positive n) => IsInteger (WordN n) where type Signed (WordN n) = False+instance IsInteger Bool   where type Signed Bool = Indecisive+instance IsInteger Int8   where type Signed Int8 = True+instance IsInteger Int16  where type Signed Int16 = True+instance IsInteger Int32  where type Signed Int32 = True+instance IsInteger Int64  where type Signed Int64 = True+instance IsInteger Int    where type Signed Int   = True+instance IsInteger Word8  where type Signed Word8 = False+instance IsInteger Word16 where type Signed Word16 = False+instance IsInteger Word32 where type Signed Word32 = False+instance IsInteger Word64 where type Signed Word64 = False+instance IsInteger Word   where type Signed Word   = False+instance (Dec.Positive n, IsPrimitive a, IsInteger a) => IsInteger (Vector n a)+                          where type Signed (Vector n a) = Signed a++instance (Dec.Positive n) => IsIntegerOrPointer (IntN n)+instance (Dec.Positive n) => IsIntegerOrPointer (WordN n)+instance IsIntegerOrPointer Bool+instance IsIntegerOrPointer Int8+instance IsIntegerOrPointer Int16+instance IsIntegerOrPointer Int32+instance IsIntegerOrPointer Int64+instance IsIntegerOrPointer Int+instance IsIntegerOrPointer Word8+instance IsIntegerOrPointer Word16+instance IsIntegerOrPointer Word32+instance IsIntegerOrPointer Word64+instance IsIntegerOrPointer Word+instance (Dec.Positive n, IsPrimitive a, IsInteger a) => IsIntegerOrPointer (Vector n a)+instance IsIntegerOrPointer (Foreign.Ptr a)+instance (IsType a) => IsIntegerOrPointer (Data.Ptr a)++instance IsFirstClass Float+instance IsFirstClass Double+instance IsFirstClass FP128+instance (Dec.Positive n) => IsFirstClass (IntN n)+instance (Dec.Positive n) => IsFirstClass (WordN n)+instance IsFirstClass Bool+instance IsFirstClass Int+instance IsFirstClass Int8+instance IsFirstClass Int16+instance IsFirstClass Int32+instance IsFirstClass Int64+instance IsFirstClass Word+instance IsFirstClass Word8+instance IsFirstClass Word16+instance IsFirstClass Word32+instance IsFirstClass Word64+instance (Dec.Positive n, IsPrimitive a) => IsFirstClass (Vector n a)+instance (Dec.Natural n, IsSized a) => IsFirstClass (Array n a)+instance IsFirstClass (Foreign.Ptr a)+instance (IsType a) => IsFirstClass (Data.Ptr a)+instance (IsFunction a) => IsFirstClass (FunPtr a)+instance IsFirstClass (StablePtr a)+instance IsFirstClass Label+instance IsFirstClass () -- XXX This isn't right, but () can be returned+instance (StructFields as) => IsFirstClass (Struct as)+instance (StructFields as) => IsFirstClass (PackedStruct as)+++{- |+Types where LLVM and 'Foreign.Storable' memory layout are compatible.+-}+class (Foreign.Storable a, IsSized a) => Storable a+instance Storable Float+instance Storable Double+instance Storable Int+instance Storable Int8+instance Storable Int16+instance Storable Int32+instance Storable Int64+instance Storable Word+instance Storable Word8+instance Storable Word16+instance Storable Word32+instance Storable Word64+instance (Foreign.Storable a) => Storable (Foreign.Ptr a)+instance (IsType a) => Storable (Data.Ptr a)+instance (IsFunction a) => Storable (FunPtr a)+instance Storable (StablePtr a) where++fromPtr :: (Storable a) => Foreign.Ptr a -> Data.Ptr a+fromPtr = Data.uncheckedFromPtr++toPtr :: (Storable a) => Data.Ptr a -> Foreign.Ptr a+toPtr = Data.uncheckedToPtr+++instance (Dec.Positive n) => IsSized (IntN n)  where type SizeOf (IntN  n) = n+instance (Dec.Positive n) => IsSized (WordN n) where type SizeOf (WordN n) = n+instance IsSized Float  where type SizeOf Float  = D32+instance IsSized Double where type SizeOf Double = D64+instance IsSized FP128  where type SizeOf FP128  = D128+instance IsSized Bool   where type SizeOf Bool   = D1+instance IsSized Int8   where type SizeOf Int8   = D8+instance IsSized Int16  where type SizeOf Int16  = D16+instance IsSized Int32  where type SizeOf Int32  = D32+instance IsSized Int64  where type SizeOf Int64  = D64+instance IsSized Int    where type SizeOf Int    = IntSize+instance IsSized Word8  where type SizeOf Word8  = D8+instance IsSized Word16 where type SizeOf Word16 = D16+instance IsSized Word32 where type SizeOf Word32 = D32+instance IsSized Word64 where type SizeOf Word64 = D64+instance IsSized Word   where type SizeOf Word   = IntSize+{-+Can we derive Dec.Natural (n :*: SizeOf a)+from (Dec.Natural n, Dec.Natural (n :*: SizeOf a))?+-}+instance+    (Dec.Natural n, IsSized a, Dec.Natural (n :*: SizeOf a)) =>+        IsSized (Array n a) where+    type SizeOf (Array n a) = n :*: SizeOf a+instance+    (Dec.Positive n, IsPrimitive a, IsSized a, Dec.Natural (n :*: SizeOf a)) =>+        IsSized (Vector n a) where+    type SizeOf (Vector n a) = n :*: SizeOf a+instance IsSized (Foreign.Ptr a) where type SizeOf (Foreign.Ptr a) = PtrSize+instance (IsType a) => IsSized (Data.Ptr a) where+    type SizeOf (Data.Ptr a) = PtrSize+instance (IsFunction a) => IsSized (FunPtr a) where+    type SizeOf (FunPtr a) =  PtrSize+instance IsSized (StablePtr a) where type SizeOf (StablePtr a) =  PtrSize+-- instance IsSized Label PtrSize -- labels are not quite first classed+-- We cannot compute the sizes statically :(+instance (StructFields as) => IsSized (Struct as) where+    type SizeOf (Struct as) = UnknownSize+instance (StructFields as) => IsSized (PackedStruct as) where+    type SizeOf (PackedStruct as) = UnknownSize++type UnknownSize = D99   -- XXX this is wrong!++type IntSize = PtrSize+#if WORD_SIZE_IN_BITS == 32+type PtrSize = D32+#elif WORD_SIZE_IN_BITS == 64+type PtrSize = D64+#else+#error cannot determine type of PtrSize+#endif++instance IsPrimitive Float+instance IsPrimitive Double+instance IsPrimitive FP128+instance (Dec.Positive n) => IsPrimitive (IntN n)+instance (Dec.Positive n) => IsPrimitive (WordN n)+instance IsPrimitive Bool+instance IsPrimitive Int8+instance IsPrimitive Int16+instance IsPrimitive Int32+instance IsPrimitive Int64+instance IsPrimitive Int+instance IsPrimitive Word8+instance IsPrimitive Word16+instance IsPrimitive Word32+instance IsPrimitive Word64+instance IsPrimitive Word+instance IsPrimitive Label+instance IsPrimitive ()+instance IsPrimitive (Foreign.Ptr a)+instance (IsType a) => IsPrimitive (Data.Ptr a)+++instance (Dec.Positive n) =>+         IsScalarOrVector (IntN n)  where type ShapeOf (IntN n)  = ScalarShape+instance (Dec.Positive n) =>+         IsScalarOrVector (WordN n) where type ShapeOf (WordN n) = ScalarShape+instance IsScalarOrVector Float  where type ShapeOf Float  = ScalarShape+instance IsScalarOrVector Double where type ShapeOf Double = ScalarShape+instance IsScalarOrVector FP128  where type ShapeOf FP128  = ScalarShape+instance IsScalarOrVector Bool   where type ShapeOf Bool   = ScalarShape+instance IsScalarOrVector Int8   where type ShapeOf Int8   = ScalarShape+instance IsScalarOrVector Int16  where type ShapeOf Int16  = ScalarShape+instance IsScalarOrVector Int32  where type ShapeOf Int32  = ScalarShape+instance IsScalarOrVector Int64  where type ShapeOf Int64  = ScalarShape+instance IsScalarOrVector Int    where type ShapeOf Int    = ScalarShape+instance IsScalarOrVector Word8  where type ShapeOf Word8  = ScalarShape+instance IsScalarOrVector Word16 where type ShapeOf Word16 = ScalarShape+instance IsScalarOrVector Word32 where type ShapeOf Word32 = ScalarShape+instance IsScalarOrVector Word64 where type ShapeOf Word64 = ScalarShape+instance IsScalarOrVector Word   where type ShapeOf Word   = ScalarShape+instance IsScalarOrVector Label  where type ShapeOf Label  = ScalarShape+instance IsScalarOrVector ()     where type ShapeOf ()     = ScalarShape+instance IsScalarOrVector (Foreign.Ptr a) where+    type ShapeOf (Foreign.Ptr a) = ScalarShape+instance (IsType a) => IsScalarOrVector (Data.Ptr a) where+    type ShapeOf (Data.Ptr a) = ScalarShape++instance (Dec.Positive n, IsPrimitive a) =>+         IsScalarOrVector (Vector n a) where+    type ShapeOf (Vector n a) = VectorShape n+++-- Functions.+instance (IsFirstClass a, IsFunction b) => IsFunction (a->b) where+    funcType ts _ = funcType (typeDesc (Proxy :: Proxy a) : ts) (Proxy :: Proxy b)+instance (IsFirstClass a) => IsFunction (IO a) where+    funcType ts _ = TDFunction False (reverse ts) (typeDesc (Proxy :: Proxy a))+instance (IsFirstClass a) => IsFunction (VarArgs a) where+    funcType ts _ = TDFunction True  (reverse ts) (typeDesc (Proxy :: Proxy a))++-- |The 'VarArgs' type is a placeholder for the real 'IO' type that+-- can be obtained with 'castVarArgs'.+data VarArgs a+    deriving (Typeable)+instance IsType (VarArgs a) where+    typeDesc _ = error "typeDesc: Dummy type VarArgs used incorrectly"++-- |Define what vararg types are permissible.+class CastVarArgs a b+instance (x~y, CastVarArgs a b) => CastVarArgs (x -> a) (y -> b)+instance (x~y) => CastVarArgs (VarArgs x) (IO y)+instance (IsFirstClass x, CastVarArgs (VarArgs a) b) =>+            CastVarArgs (VarArgs a) (x -> b)+++++-- XXX Structures not implemented.  Tuples is probably an easy way.+
+ private/LLVM/Core/UnaryVector.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+module LLVM.Core.UnaryVector (+   T, vector, cyclicVector,+   FixedLength.fromFixedList, FixedLength.toFixedList, FixedLength.head,+   FixedList, Length,+   FixedLength.Curried, FixedLength.uncurry, FixedLength.curry,+   ) where++import qualified Type.Data.Num.Unary as Unary++import qualified Data.FixedLength as FixedLength+import Data.FixedLength (T, List, Length, end, (!:))++import qualified Data.NonEmpty as NonEmpty++import Prelude hiding (head)+++type FixedList n = List n+++vector :: (Unary.Natural n, n ~ Length (List n)) => List n a -> T n a+vector = FixedLength.fromFixedList++cyclicVector :: (Unary.Natural n) => NonEmpty.T [] a -> T n a+cyclicVector xt@(NonEmpty.Cons x xs) =+   runOp0 $+   Unary.switchNat+      (Op0 end)+      (Op0 $ x !: cyclicVectorAppend xt xs)++cyclicVectorAppend :: (Unary.Natural n) => NonEmpty.T [] a -> [a] -> T n a+cyclicVectorAppend ys xt =+   runOp0 $+   Unary.switchNat+      (Op0 end)+      (Op0 $+       case xt of+          [] -> cyclicVector ys+          x:xs -> x !: cyclicVectorAppend ys xs)++newtype Op0 a n = Op0 {runOp0 :: T n a}
+ private/LLVM/Core/Util.hs view
@@ -0,0 +1,448 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveDataTypeable #-}+module LLVM.Core.Util(+    -- * Module handling+    Module(..), withModule, createModule, destroyModule, writeBitcodeToFile, readBitcodeFromFile,+    getModuleValues, getFunctions, getGlobalVariables, valueHasType,+    -- * Pass manager handling+    PassManager(..), withPassManager, createPassManager, createFunctionPassManager,+    -- * Instruction builder+    Builder(..), withBuilder, createBuilder, positionAtEnd, getInsertBlock,+    -- * Basic blocks+    BasicBlock,+    appendBasicBlock, getBasicBlocks,+    -- * Functions+    Function,+    FunctionWithType,+    addFunction, getParam, getParams,+    -- * Structs+    structType,+    -- * Globals+    addGlobal,+    constString, constStringNul, constVector, constArray, constStruct,+    -- * Instructions+    makeCall, makeInvoke,+    makeCallWithCc, makeInvokeWithCc,+    withValue, getInstructions, getOperands,+    -- * Uses and Users+    hasUsers, getUsers, getUses, getUser, isChildOf, getDep,+    -- * Misc+    CString, withArrayLen,+    withEmptyCString,+    functionType, buildEmptyPhi, addPhiIns,+    showTypeOf, getValueNameU, getObjList, annotateValueList,+    isConstant, isIntrinsic,+    ) where++import qualified LLVM.FFI.Core as FFI+import qualified LLVM.FFI.BitWriter as FFI+import qualified LLVM.FFI.BitReader as FFI++import Foreign.C.String (withCString, withCStringLen, CString, peekCString)+import Foreign.ForeignPtr (ForeignPtr, newForeignPtr, withForeignPtr)+import Foreign.Ptr (Ptr, nullPtr)+import Foreign.Marshal.Array (withArrayLen, withArray, allocaArray, peekArray)+import Foreign.Marshal.Alloc (alloca)+import Foreign.Storable (Storable(..))+import System.IO.Unsafe (unsafePerformIO)++import Data.Typeable (Typeable)+import Data.List (intercalate)+import Control.Monad (liftM, when)+++type Type = FFI.TypeRef++functionType :: Bool -> Type -> [Type] -> IO Type+functionType varargs retType paramTypes =+    withArrayLen paramTypes $ \ len ptr ->+        FFI.functionType retType ptr (fromIntegral len) (FFI.consBool varargs)++structType :: [Type] -> Bool -> IO Type+structType types packed =+    withArrayLen types $ \ len ptr ->+        FFI.structType ptr (fromIntegral len) (FFI.consBool packed)++--------------------------------------+-- Handle modules++-- Don't use a finalizer for the module, but instead provide an+-- explicit destructor.  This is because handing a module to+-- a module provider changes ownership of the module to the provider,+-- and we don't want to free it by mistake.++-- | Type of top level modules.+newtype Module = Module {+      fromModule :: FFI.ModuleRef+    }+    deriving (Show, Typeable)++withModule :: Module -> (FFI.ModuleRef -> IO a) -> IO a+withModule modul f = f (fromModule modul)++createModule :: String -> IO Module+createModule name =+    withCString name $ \ namePtr -> do+      liftM Module $ FFI.moduleCreateWithName namePtr++-- | Free all storage related to a module.  *Note*, this is a dangerous call, since referring+-- to the module after this call is an error.  The reason for the explicit call to free+-- the module instead of an automatic lifetime management is that modules have a+-- somewhat complicated ownership.  Handing a module to a module provider changes+-- the ownership of the module, and the module provider will free the module when necessary.+destroyModule :: Module -> IO ()+destroyModule = FFI.disposeModule . fromModule++-- |Write a module to a file.+writeBitcodeToFile :: String -> Module -> IO ()+writeBitcodeToFile name mdl =+    withCString name $ \ namePtr ->+      withModule mdl $ \ mdlPtr -> do+        rc <- FFI.writeBitcodeToFile mdlPtr namePtr+        when (rc /= 0) $+          ioError $ userError $ "writeBitcodeToFile: return code " ++ show rc++-- |Read a module from a file.+readBitcodeFromFile :: String -> IO Module+readBitcodeFromFile name =+    withCString name $ \ namePtr ->+      alloca $ \ bufPtr ->+      alloca $ \ modPtr ->+      alloca $ \ errStr -> do+        rrc <- FFI.createMemoryBufferWithContentsOfFile namePtr bufPtr errStr+        if FFI.deconsBool rrc then do+            msg <- peek errStr >>= peekCString+            ioError $ userError $ "readBitcodeFromFile: read return code " ++ show rrc ++ ", " ++ msg+         else do+            buf <- peek bufPtr+            prc <- FFI.parseBitcode buf modPtr errStr+            if FFI.deconsBool prc then do+                msg <- peek errStr >>= peekCString+                ioError $ userError $ "readBitcodeFromFile: parse return code " ++ show prc ++ ", " ++ msg+             else do+                ptr <- peek modPtr+                return $ Module ptr+{-+                liftM Module $ newForeignPtr FFI.ptrDisposeModule ptr+-}++getModuleValues :: Module -> IO [(String, Value)]+getModuleValues mdl = do+  fs <- getFunctions mdl+  gs <- getGlobalVariables mdl+  return (fs ++ gs)++getFunctions :: Module -> IO [(String, Value)]+getFunctions mdl =+    getObjList withModule FFI.getFirstFunction FFI.getNextFunction mdl+      >>= annotateValueList++getGlobalVariables :: Module -> IO [(String, Value)]+getGlobalVariables mdl =+    getObjList withModule FFI.getFirstGlobal FFI.getNextGlobal mdl+      >>= annotateValueList++-- This is safe because we just ask for the type of a value.+valueHasType :: Value -> Type -> Bool+valueHasType v t = unsafePerformIO $ do+    vt <- FFI.typeOf v+    return $ vt == t  -- LLVM uses hash consing for types, so pointer equality works.++showTypeOf :: Value -> IO String+showTypeOf v = FFI.typeOf v >>= showType'++showType' :: Type -> IO String+showType' p = do+    pk <- FFI.getTypeKind p+    case pk of+        FFI.VoidTypeKind -> return "()"+        FFI.FloatTypeKind -> return "Float"+        FFI.DoubleTypeKind -> return "Double"+        FFI.X86_FP80TypeKind -> return "X86_FP80"+        FFI.FP128TypeKind -> return "FP128"+        FFI.PPC_FP128TypeKind -> return "PPC_FP128"+        FFI.LabelTypeKind -> return "Label"+        FFI.IntegerTypeKind -> do w <- FFI.getIntTypeWidth p; return $ "(IntN " ++ show w ++ ")"+        FFI.FunctionTypeKind -> do+            r <- FFI.getReturnType p+            c <- FFI.countParamTypes p+            let n = fromIntegral c+            as <- allocaArray n $ \ args -> do+                     FFI.getParamTypes p args+                     peekArray n args+            ts <- mapM showType' (as ++ [r])+            return $ "(" ++ intercalate " -> " ts ++ ")"+        FFI.StructTypeKind -> return "(Struct ...)"+        FFI.ArrayTypeKind -> do n <- FFI.getArrayLength p; t <- FFI.getElementType p >>= showType'; return $ "(Array " ++ show n ++ " " ++ t ++ ")"+        FFI.PointerTypeKind -> do t <- FFI.getElementType p >>= showType'; return $ "(Ptr " ++ t ++ ")"+        FFI.OpaqueTypeKind -> return "Opaque"+        FFI.VectorTypeKind -> do n <- FFI.getVectorSize p; t <- FFI.getElementType p >>= showType'; return $ "(Vector " ++ show n ++ " " ++ t ++ ")"++--------------------------------------+-- Handle instruction builders++newtype Builder = Builder {+      fromBuilder :: ForeignPtr FFI.Builder+    }+    deriving (Show, Typeable)++withBuilder :: Builder -> (FFI.BuilderRef -> IO a) -> IO a+withBuilder = withForeignPtr . fromBuilder++createBuilder :: IO Builder+createBuilder = do+    ptr <- FFI.createBuilder+    liftM Builder $ newForeignPtr FFI.ptrDisposeBuilder ptr++positionAtEnd :: Builder -> FFI.BasicBlockRef -> IO ()+positionAtEnd bld bblk =+    withBuilder bld $ \ bldPtr ->+      FFI.positionAtEnd bldPtr bblk++getInsertBlock :: Builder -> IO FFI.BasicBlockRef+getInsertBlock bld =+    withBuilder bld $ \ bldPtr ->+      FFI.getInsertBlock bldPtr++--------------------------------------++type BasicBlock = FFI.BasicBlockRef++appendBasicBlock :: Function -> String -> IO BasicBlock+appendBasicBlock func name =+    withCString name $ \ namePtr ->+      FFI.appendBasicBlock func namePtr++getBasicBlocks :: Value -> IO [(String, BasicBlock)]+getBasicBlocks v =+    getObjList withValue FFI.getFirstBasicBlock FFI.getNextBasicBlock v+      >>= annotateBasicBlockList++--------------------------------------++type Function = FFI.ValueRef+type FunctionWithType = (FFI.TypeRef, FFI.ValueRef)++addFunction :: Module -> FFI.Linkage -> String -> Type -> IO Function+addFunction modul linkage name typ =+    withModule modul $ \ modulPtr ->+      withCString name $ \ namePtr -> do+        f <- FFI.addFunction modulPtr namePtr typ+        FFI.setLinkage f (FFI.fromLinkage linkage)+        return f++getParam :: Function -> Int -> Value+getParam f = unsafePerformIO . FFI.getParam f . fromIntegral++getParams :: Value -> IO [(String, Value)]+getParams v =+    getObjList withValue FFI.getFirstParam FFI.getNextParam v+      >>= annotateValueList++--------------------------------------++addGlobal :: Module -> FFI.Linkage -> String -> Type -> IO Value+addGlobal modul linkage name typ =+    withModule modul $ \ modulPtr ->+      withCString name $ \ namePtr -> do+        v <- FFI.addGlobal modulPtr typ namePtr+        FFI.setLinkage v (FFI.fromLinkage linkage)+        return v++-- unsafePerformIO is safe because it's only used for the withCStringLen conversion+constStringInternal :: Bool -> String -> Value+constStringInternal nulTerm s = unsafePerformIO $+    withCStringLen s $ \(sPtr, sLen) ->+      FFI.constString sPtr (fromIntegral sLen) (FFI.consBool (not nulTerm))++constString :: String -> Value+constString = constStringInternal False++constStringNul :: String -> Value+constStringNul = constStringInternal True++--------------------------------------++type Value = FFI.ValueRef++withValue :: Value -> (Value -> IO a) -> IO a+withValue v f = f v++withBasicBlock :: FFI.BasicBlockRef -> (FFI.BasicBlockRef -> IO a) -> IO a+withBasicBlock v f = f v++makeCall :: FunctionWithType -> FFI.BuilderRef -> [Value] -> IO Value+makeCall = makeCallWithCc FFI.C++makeCallWithCc ::+    FFI.CallingConvention -> FunctionWithType -> FFI.BuilderRef ->+    [Value] -> IO Value+makeCallWithCc cc (funcType, func) bldPtr args = do+{-+      print "makeCall"+      FFI.dumpValue func+      mapM_ FFI.dumpValue args+      print "----------------------"+-}+      withArrayLen args $ \ argLen argPtr ->+        withEmptyCString $ \cstr -> do+          i <- FFI.buildCall2 bldPtr funcType func argPtr+                             (fromIntegral argLen) cstr+          FFI.setInstructionCallConv i (FFI.fromCallingConvention cc)+          return i++makeInvoke :: BasicBlock -> BasicBlock -> FunctionWithType -> FFI.BuilderRef ->+              [Value] -> IO Value+makeInvoke = makeInvokeWithCc FFI.C++makeInvokeWithCc ::+    FFI.CallingConvention -> BasicBlock -> BasicBlock ->+    FunctionWithType -> FFI.BuilderRef -> [Value] -> IO Value+makeInvokeWithCc cc norm expt (funcType, func) bldPtr args =+      withArrayLen args $ \ argLen argPtr ->+        withEmptyCString $ \cstr -> do+          i <- FFI.buildInvoke2 bldPtr funcType+                    func argPtr (fromIntegral argLen) norm expt cstr+          FFI.setInstructionCallConv i (FFI.fromCallingConvention cc)+          return i++getInstructions :: BasicBlock -> IO [(String, Value)]+getInstructions bb =+    getObjList withBasicBlock FFI.getFirstInstruction FFI.getNextInstruction bb+      >>= annotateValueList++getOperands :: Value -> IO [(String, Value)]+getOperands ii = geto ii >>= annotateValueList+    where geto i = do+            num <- FFI.getNumOperands i+            let oloop instr number total = if number >= total then return [] else do+                    o <- FFI.getOperand instr number+                    os <- oloop instr (number + 1) total+                    return (o : os)+            oloop i 0 num++--------------------------------------++buildEmptyPhi :: FFI.BuilderRef -> Type -> IO Value+buildEmptyPhi bldPtr typ = do+    withEmptyCString $ FFI.buildPhi bldPtr typ++withEmptyCString :: (CString -> IO a) -> IO a+withEmptyCString = withCString ""++addPhiIns :: Value -> [(Value, BasicBlock)] -> IO ()+addPhiIns inst incoming = do+    let (vals, bblks) = unzip incoming+    withArrayLen vals $ \ count valPtr ->+      withArray bblks $ \ bblkPtr ->+        FFI.addIncoming inst valPtr bblkPtr (fromIntegral count)++--------------------------------------++-- | Manage compile passes.+newtype PassManager = PassManager {+      fromPassManager :: ForeignPtr FFI.PassManager+    }+    deriving (Show, Typeable)++withPassManager :: PassManager -> (FFI.PassManagerRef -> IO a)+                   -> IO a+withPassManager = withForeignPtr . fromPassManager++-- | Create a pass manager.+createPassManager :: IO PassManager+createPassManager = do+    ptr <- FFI.createPassManager+    liftM PassManager $ newForeignPtr FFI.ptrDisposePassManager ptr++-- | Create a pass manager for a module.+createFunctionPassManager :: Module -> IO PassManager+createFunctionPassManager modul =+    withModule modul $ \modulPtr -> do+        ptr <- FFI.createFunctionPassManagerForModule modulPtr+        liftM PassManager $ newForeignPtr FFI.ptrDisposePassManager ptr++--------------------------------------++constVector :: [Value] -> IO Value+constVector xs = do+    withArrayLen xs $ \ len ptr ->+        FFI.constVector ptr (fromIntegral len)++constArray :: Type -> [Value] -> IO Value+constArray t xs = do+    withArrayLen xs $ \ len ptr ->+        FFI.constArray t ptr (fromIntegral len)++constStruct :: [Value] -> Bool -> IO Value+constStruct xs packed = do+    withArrayLen xs $ \ len ptr ->+        FFI.constStruct ptr (fromIntegral len) (FFI.consBool packed)++--------------------------------------++getValueNameU :: Value -> IO String+getValueNameU a = do+    -- sometimes void values need explicit names too+    str <- peekCString =<< FFI.getValueName a+    if str == "" then return (show a) else return str++getBasicBlockNameU :: BasicBlock -> IO String+getBasicBlockNameU a = do+    str <- peekCString =<< FFI.getBasicBlockName a+    if str == "" then return (show a) else return str++getObjList ::+    (obj -> (objPtr -> IO [Ptr a]) -> io) -> (objPtr -> IO (Ptr a)) ->+    (Ptr a -> IO (Ptr a)) -> obj -> io+getObjList withF firstF nextF obj =+    withF obj $ \ objPtr -> do+      let oloop p =+            if p == nullPtr+              then return []+              else fmap (p:) $ oloop =<< nextF p+      oloop =<< firstF objPtr++annotateValueList :: [Value] -> IO [(String, Value)]+annotateValueList vs = do+  names <- mapM getValueNameU vs+  return $ zip names vs++annotateBasicBlockList :: [BasicBlock] -> IO [(String, BasicBlock)]+annotateBasicBlockList vs = do+  names <- mapM getBasicBlockNameU vs+  return $ zip names vs++isConstant :: Value -> IO Bool+isConstant v = fmap FFI.deconsBool $ FFI.isConstant v++isIntrinsic :: Value -> IO Bool+isIntrinsic v = fmap (/=0) $ FFI.getIntrinsicID v++--------------------------------------++type Use = FFI.UseRef++hasUsers :: Value -> IO Bool+hasUsers v = fmap (>0) $ FFI.getNumUses v++getUses :: Value -> IO [Use]+getUses = getObjList withValue FFI.getFirstUse FFI.getNextUse++getUsers :: [Use] -> IO [(String, Value)]+getUsers us = mapM FFI.getUser us >>= annotateValueList++getUser :: Use -> IO Value+getUser = FFI.getUser++isChildOf :: BasicBlock -> Value -> IO Bool+isChildOf bb v = do+  bb2 <- FFI.getInstructionParent v+  return $ bb == bb2++getDep :: Use -> IO (String, String)+getDep u = do+  producer <- FFI.getUsedValue u >>= getValueNameU+  consumer <- FFI.getUser u >>= getValueNameU+  return (producer, consumer)
+ private/LLVM/Core/Vector.hs view
@@ -0,0 +1,285 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE Rank2Types #-}+module LLVM.Core.Vector (MkVector(..), vector, cyclicVector, consVector) where++import qualified LLVM.Core.UnaryVector as UnaryVector+import LLVM.Core.Data (Vector(Vector), FixedList)++import qualified Type.Data.Num.Decimal.Proof as DecProof+import qualified Type.Data.Num.Decimal.Number as Dec+import qualified Type.Data.Num.Unary as Unary+import qualified Type.Base.Proxy as Proxy+import Type.Data.Num.Decimal.Literal (D2, D4, D8)++import qualified Foreign.Storable.Traversable as Store+import Foreign.Storable.FixedArray (sizeOfArray)+import Foreign.Storable (Storable(..))++import qualified Test.QuickCheck as QC++import qualified Control.Monad.Trans.State as MS+import Control.Applicative (Applicative, pure, liftA2, (<*>))+import Control.Functor.HT (unzip, outerProduct)++import qualified Data.Traversable as Trav+import qualified Data.Foldable as Fold+import qualified Data.NonEmpty as NonEmpty+import qualified Data.Empty as Empty+import Data.Traversable (Traversable, foldMapDefault)+import Data.Foldable (Foldable, foldMap)++import Prelude hiding (replicate, map, head, unzip, zipWith, uncurry)+++-- XXX Should these really be here?+class (Dec.Positive n) => MkVector n where+    type Tuple n a+    toVector :: Tuple n a -> Vector n a+    fromVector :: Vector n a -> Tuple n a+++instance MkVector D2 where+    type Tuple D2 a = (a,a)+    toVector (a1, a2) = consVector a1 a2+    fromVector = uncurry (,)++instance MkVector D4 where+    type Tuple D4 a = (a,a,a,a)+    toVector (a1, a2, a3, a4) = consVector a1 a2 a3 a4+    fromVector = uncurry (,,,)++instance MkVector D8 where+    type Tuple D8 a = (a,a,a,a,a,a,a,a)+    toVector (a1, a2, a3, a4, a5, a6, a7, a8) =+        consVector a1 a2 a3 a4 a5 a6 a7 a8+    fromVector = uncurry (,,,,,,,)+++head :: (Dec.Positive n) => Vector n a -> a+head =+    withPosDict1 $ \dict v ->+        case dict of+            DecProof.UnaryPos ->+                UnaryVector.head . unaryFromDecimalVector $ v+++unaryFromDecimalVector :: Vector n a -> UnaryVector.T (Dec.ToUnary n) a+unaryFromDecimalVector (Vector xs) = UnaryVector.fromFixedList xs++decimalFromUnaryVector :: UnaryVector.T (Dec.ToUnary n) a -> Vector n a+decimalFromUnaryVector = Vector . UnaryVector.toFixedList+++type Curried n a b = UnaryVector.Curried (Dec.ToUnary n) a b++uncurry :: (Dec.Natural n) => Curried n a b -> Vector n a -> b+uncurry f =+    withNatDict1 $ \dict v ->+        case dict of+            DecProof.UnaryNat ->+                UnaryVector.uncurry f $ unaryFromDecimalVector v+++withNatDict ::+    (Dec.Natural n) =>+    (DecProof.UnaryNat n -> Vector n a) -> Vector n a+withNatDict f = f DecProof.unaryNat++withNatDict1 ::+    (Dec.Natural n) =>+    (DecProof.UnaryNat n -> Vector n a -> b) -> Vector n a -> b+withNatDict1 f = f DecProof.unaryNat++withPosDict1 ::+    (Dec.Positive n) =>+    (DecProof.UnaryPos n -> Vector n a -> b) -> Vector n a -> b+withPosDict1 f = f DecProof.unaryPos+++withUnaryDecVector ::+    (Dec.Natural n) =>+    (forall m. (Dec.ToUnary n ~ m, Unary.Natural m) => UnaryVector.T m a) ->+    Vector n a+withUnaryDecVector v =+    withNatDict+        (\dict ->+            case dict of DecProof.UnaryNat -> decimalFromUnaryVector v)++instance (Storable a, Dec.Positive n) => Storable (Vector n a) where+    sizeOf v = sizeOfArray (Dec.integralFromProxy $ size v) (head v)+    alignment = alignment . head+    peek = Store.peekApplicative+    poke = Store.poke++size :: Vector n a -> Proxy.Proxy n+size _ = Proxy.Proxy++--------------------------------------++{- maybe we should export this in order to allow NumericPrelude instances+unVector :: (Dec.Positive n) => Vector n a -> FixedList n a+unVector (Vector xs) = xs+-}++vector :: (Dec.Positive n) => FixedList (Dec.ToUnary n) a -> Vector n a+vector = Vector++{- |+Make a constant vector.  Replicates or truncates the list to get length /n/.+This behaviour is consistent uncurry that of 'LLVM.Core.CodeGen.constCyclicVector'.+May be abused for constructing vectors from lists uncurry statically unknown size.+-}+cyclicVector :: (Dec.Positive n) => NonEmpty.T [] a -> Vector n a+cyclicVector xs =+   withUnaryDecVector (UnaryVector.cyclicVector xs)+++class ConsVector f where+   type NumberOfArguments f+   type ResultSize f+   type ResultElement f+   consAux ::+      (NumberOfArguments f ~ m, ResultSize f ~ n, ResultElement f ~ a) =>+      (FixedList m a -> Vector n a) -> f++instance ConsVector (Vector n a) where+   type NumberOfArguments (Vector n a) = Unary.Zero+   type ResultSize (Vector n a) = n+   type ResultElement (Vector n a) = a+   consAux f = f Empty.Cons++instance (a ~ ResultElement f, ConsVector f) => ConsVector (a -> f) where+   type NumberOfArguments (a->f) = Unary.Succ (NumberOfArguments f)+   type ResultSize (a->f) = ResultSize f+   type ResultElement (a->f) = ResultElement f+   consAux f x = consAux (f . NonEmpty.Cons x)++consVector ::+   (ConsVector f, ResultSize f ~ n, NumberOfArguments f ~ u,+    u ~ Dec.ToUnary n, Dec.FromUnary u ~ n, Dec.Natural n) => f+consVector = consAux Vector+++replicate :: (Dec.Positive n) => a -> Vector n a+replicate a = withUnaryDecVector (pure a)+++instance (Dec.Positive n) => Functor (Vector n) where+   fmap f a =+      withUnaryDecVector (fmap f $ unaryFromDecimalVector a)++instance (Dec.Positive n) => Applicative (Vector n) where+   pure = replicate+   f <*> a =+      withUnaryDecVector+         (unaryFromDecimalVector f <*> unaryFromDecimalVector a)++instance (Dec.Positive n) => Foldable (Vector n) where+   foldMap = foldMapDefault++instance (Dec.Positive n) => Traversable (Vector n) where+   sequenceA =+      withNatDict1 $ \dict v ->+         case dict of+            DecProof.UnaryNat ->+               fmap decimalFromUnaryVector $ Trav.sequenceA $+               unaryFromDecimalVector v++++instance (Eq a, Dec.Positive n) => Eq (Vector n a) where+   x == y  =  Fold.and $ liftA2 (==) x y++instance (Ord a, Dec.Positive n) => Ord (Vector n a) where+   compare x y =+      Fold.foldr (\r rs -> if r==EQ then rs else r) EQ $+      liftA2 compare x y++instance (Num a, Dec.Positive n) => Num (Vector n a) where+    (+) = liftA2 (+)+    (-) = liftA2 (-)+    (*) = liftA2 (*)+    negate = fmap negate+    abs = fmap abs+    signum = fmap signum+    fromInteger = pure . fromInteger++instance (Enum a, Dec.Positive n) => Enum (Vector n a) where+    succ = fmap succ+    pred = fmap pred+    fromEnum = error "Vector fromEnum"+    toEnum = pure . toEnum++instance (Real a, Dec.Positive n) => Real (Vector n a) where+    toRational = error "Vector toRational"++instance (Integral a, Dec.Positive n) => Integral (Vector n a) where+    quot = liftA2 quot+    rem  = liftA2 rem+    div  = liftA2 div+    mod  = liftA2 mod+    quotRem xs ys = unzip $ liftA2 quotRem xs ys+    divMod  xs ys = unzip $ liftA2 divMod  xs ys+    toInteger = error "Vector toInteger"++instance (Fractional a, Dec.Positive n) => Fractional (Vector n a) where+    (/) = liftA2 (/)+    fromRational = pure . fromRational++instance (RealFrac a, Dec.Positive n) => RealFrac (Vector n a) where+    properFraction = error "Vector properFraction"++instance (Floating a, Dec.Positive n) => Floating (Vector n a) where+    pi = pure pi+    sqrt = fmap sqrt+    log = fmap log+    logBase = liftA2 logBase+    (**) = liftA2 (**)+    exp = fmap exp+    sin = fmap sin+    cos = fmap cos+    tan = fmap tan+    asin = fmap asin+    acos = fmap acos+    atan = fmap atan+    sinh = fmap sinh+    cosh = fmap cosh+    tanh = fmap tanh+    asinh = fmap asinh+    acosh = fmap acosh+    atanh = fmap atanh++instance (RealFloat a, Dec.Positive n) => RealFloat (Vector n a) where+    floatRadix = floatRadix . head+    floatDigits = floatDigits . head+    floatRange = floatRange . head+    decodeFloat = error "Vector decodeFloat"+    encodeFloat = error "Vector encodeFloat"+    exponent _ = 0+    scaleFloat 0 x = x+    scaleFloat _ _ = error "Vector scaleFloat"+    isNaN = error "Vector isNaN"+    isInfinite = error "Vector isInfinite"+    isDenormalized = error "Vector isDenormalized"+    isNegativeZero = error "Vector isNegativeZero"+    isIEEE = isIEEE . head+++indices :: (Dec.Positive n) => Vector n Int+indices =+    flip MS.evalState 0 $ Trav.sequenceA $ replicate $ MS.state (\k -> (k,k+1))++instance (Dec.Positive n, QC.Arbitrary a) => QC.Arbitrary (Vector n a) where+    arbitrary = Trav.sequenceA $ replicate QC.arbitrary+    shrink v =+        case indices of+            ixs ->+                concatMap+                    (Trav.sequenceA .+                     liftA2+                        (\x doShrink ->+                            if doShrink then QC.shrink x else [x]) v) $+                outerProduct (==) (Fold.toList ixs) ixs
+ private/LLVM/ExecutionEngine/Engine.hs view
@@ -0,0 +1,315 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveDataTypeable #-}+module LLVM.ExecutionEngine.Engine(+       EngineAccess,+       ExecutionEngine(..),+       getEngine,+       runEngineAccess, runEngineAccessWithModule,+       runEngineAccessInterpreterWithModule,+       getExecutionEngineTargetData,+       ExecutionFunction,+       Importer,+       getExecutionFunction,+       getPointerToFunction,+       addModule,+       addFunctionValue, addGlobalMappings,+       runFunction, getRunFunction,+       GenericValue, Generic(..)+       ) where++import qualified LLVM.Core.Proxy as Proxy+import qualified LLVM.Core.Data as Data+import qualified LLVM.Core.Util as U++import LLVM.Core.CodeGen (Value(..), Function)+import LLVM.Core.CodeGenMonad (GlobalMappings(..))+import LLVM.Core.Util (Module, withModule, createModule)+import LLVM.Core.Type (IsFirstClass, typeRef)+import LLVM.Core.Proxy (Proxy(Proxy))++import qualified LLVM.FFI.ExecutionEngine as FFI+import qualified LLVM.FFI.Target as FFI+import qualified LLVM.FFI.Core as FFI (consBool, deconsBool, )++import qualified Control.Monad.Trans.Reader as MR+import Control.Exception (bracket)+import Control.Monad.IO.Class (MonadIO, liftIO, )+import Control.Monad (liftM, )+import Control.Applicative (Applicative, pure, (<*>), (<$>), )++import qualified Data.EnumBitSet as EnumSet+import Data.Int (Int8, Int16, Int32, Int64)+import Data.Word (Word8, Word16, Word32, Word64, Word)++import Foreign.Marshal.Alloc (alloca, free)+import Foreign.Marshal.Array (withArrayLen)+import Foreign.ForeignPtr+         (ForeignPtr, newForeignPtr, withForeignPtr, touchForeignPtr)+import Foreign.C.String (peekCString)+import Foreign.Ptr (Ptr, FunPtr, )+import Foreign.Storable (peek)+import Foreign.StablePtr (StablePtr, castStablePtrToPtr, castPtrToStablePtr, )+import System.IO.Unsafe (unsafePerformIO)+++newtype+    ExecutionEngine = ExecutionEngine {+        fromEngine :: ForeignPtr FFI.ExecutionEngine+    }++withEngine :: ExecutionEngine -> (FFI.ExecutionEngineRef -> IO a) -> IO a+withEngine = withForeignPtr . fromEngine++createExecutionEngineForModule ::+    Bool -> FFI.EngineKindSet -> Module -> IO ExecutionEngine+createExecutionEngineForModule hostCPU kind m =+    alloca $ \eePtr ->+        alloca $ \errPtr -> do+          success <-+            withModule m $ \mPtr ->+              if hostCPU+                then+                  FFI.createExecutionEngineKindForModuleCPU+                    eePtr kind mPtr errPtr+                else+                  if EnumSet.get FFI.JIT kind+                    then FFI.createExecutionEngineForModule eePtr mPtr errPtr+                    else FFI.createInterpreterForModule eePtr mPtr errPtr+          if FFI.deconsBool success+            then ioError . userError =<< bracket (peek errPtr) free peekCString+            else+                liftM ExecutionEngine $+                    newForeignPtr FFI.ptrDisposeExecutionEngine =<<+                    peek eePtr++getTheEngine :: FFI.EngineKindSet -> Module -> IO ExecutionEngine+getTheEngine = createExecutionEngineForModule True++newtype EngineAccess a = EA (MR.ReaderT ExecutionEngine IO a)+    deriving (Functor, Applicative, Monad, MonadIO)++-- |The LLVM execution engine is encapsulated so it cannot be accessed directly.+-- The reason is that (currently) there must only ever be one engine,+-- so access to it is wrapped in a monad.+runEngineAccess :: EngineAccess a -> IO a+runEngineAccess (EA body) = do+    MR.runReaderT body =<< getTheEngine FFI.kindEither =<< createModule "__empty__"++runEngineAccessWithModule :: Module -> EngineAccess a -> IO a+runEngineAccessWithModule m (EA body) = do+    MR.runReaderT body =<< getTheEngine FFI.kindEither m++runEngineAccessInterpreterWithModule :: Module -> EngineAccess a -> IO a+runEngineAccessInterpreterWithModule m (EA body) = do+    MR.runReaderT body =<< getTheEngine FFI.kindInterpreter m+++getEngine :: EngineAccess ExecutionEngine+getEngine = EA MR.ask++accessEngine :: (FFI.ExecutionEngineRef -> IO a) -> EngineAccess a+accessEngine act = do+    engine <- getEngine+    liftIO $ withEngine engine act++getExecutionEngineTargetData :: EngineAccess FFI.TargetDataRef+getExecutionEngineTargetData =+    accessEngine FFI.getExecutionEngineTargetData++{- |+In contrast to 'generateFunction' this compiles a function once.+Thus it is faster for many calls to the same function.+See @examples\/Vector.hs@.++If the function calls back into Haskell code,+you also have to set the function addresses+using 'addFunctionValue' or 'addGlobalMappings'.++You must keep the execution engine alive+as long as you want to call the function.+Better use 'getExecutionFunction' which handles this for you.+-}+getPointerToFunction :: Function f -> EngineAccess (FunPtr f)+getPointerToFunction (Value f) =+    accessEngine $ \eePtr -> FFI.getPointerToFunction eePtr f++class ExecutionFunction f where+    keepAlive :: ExecutionEngine -> f -> f++instance ExecutionFunction (IO a) where+    keepAlive engine act = do+        a <- act+        touchForeignPtr (fromEngine engine)+        return a++instance ExecutionFunction f => ExecutionFunction (a -> f) where+    keepAlive engine act = keepAlive engine . act++type Importer f = FunPtr f -> f++getExecutionFunction ::+    (ExecutionFunction f) => Importer f -> Function f -> EngineAccess f+getExecutionFunction importer (Value f) = do+    engine <- getEngine+    liftIO $ withEngine engine $ \eePtr ->+        keepAlive engine . importer <$> FFI.getPointerToFunction eePtr f++{- |+Tell LLVM the address of an external function+if it cannot resolve a name automatically.+Alternatively you may declare the function+with 'staticFunction' instead of 'externFunction'.+-}+addFunctionValue :: Function f -> FunPtr f -> EngineAccess ()+addFunctionValue (Value g) f =+    accessEngine $ \eePtr -> FFI.addFunctionMapping eePtr g f++{- |+Pass a list of global mappings to LLVM+that can be obtained from 'LLVM.Core.getGlobalMappings'.+-}+addGlobalMappings :: GlobalMappings -> EngineAccess ()+addGlobalMappings (GlobalMappings gms) = accessEngine gms++addModule :: Module -> EngineAccess ()+addModule m =+    accessEngine $ \eePtr -> U.withModule m $ FFI.addModule eePtr+++--------------------------------------++newtype GenericValue = GenericValue {+      fromGenericValue :: ForeignPtr FFI.GenericValue+    }++withGenericValue :: GenericValue -> (FFI.GenericValueRef -> IO a) -> IO a+withGenericValue = withForeignPtr . fromGenericValue++createGenericValueWith :: IO FFI.GenericValueRef -> IO GenericValue+createGenericValueWith f = do+  ptr <- f+  liftM GenericValue $ newForeignPtr FFI.ptrDisposeGenericValue ptr++withAll :: [GenericValue] -> (Int -> Ptr FFI.GenericValueRef -> IO a) -> IO a+withAll ps a = go [] ps+    where go ptrs (x:xs) = withGenericValue x $ \ptr -> go (ptr:ptrs) xs+          go ptrs _ = withArrayLen (reverse ptrs) a++runFunction :: U.Function -> [GenericValue] -> EngineAccess GenericValue+runFunction func args =+    liftIO =<< getRunFunction <*> pure func <*> pure args++getRunFunction :: EngineAccess (U.Function -> [GenericValue] -> IO GenericValue)+getRunFunction = do+    engine <- getEngine+    return $ \ func args ->+             withAll args $ \argLen argPtr ->+             withEngine engine $ \eePtr ->+                 createGenericValueWith $ FFI.runFunction eePtr func+                                              (fromIntegral argLen) argPtr++class Generic a where+    toGeneric :: a -> GenericValue+    fromGeneric :: GenericValue -> a++instance Generic () where+    toGeneric _ = error "toGeneric ()"+    fromGeneric _ = ()++toGenericInt :: (Integral a, IsFirstClass a) => Bool -> a -> GenericValue+toGenericInt signed val = unsafePerformIO $ createGenericValueWith $ do+    typ <- typeRef $ Proxy.fromValue val+    FFI.createGenericValueOfInt+        typ (fromIntegral val) (FFI.consBool signed)++fromGenericInt :: (Integral a, IsFirstClass a) => Bool -> GenericValue -> a+fromGenericInt signed val = unsafePerformIO $+    withGenericValue val $ \ref ->+        fmap fromIntegral $ FFI.genericValueToInt ref (FFI.consBool signed)++--instance Generic Bool where+--    toGeneric = toGenericInt False . FFI.consBool+--    fromGeneric = toBool . fromGenericInt False++instance Generic Int where+    toGeneric = toGenericInt True+    fromGeneric = fromGenericInt True++instance Generic Int8 where+    toGeneric = toGenericInt True+    fromGeneric = fromGenericInt True++instance Generic Int16 where+    toGeneric = toGenericInt True+    fromGeneric = fromGenericInt True++instance Generic Int32 where+    toGeneric = toGenericInt True+    fromGeneric = fromGenericInt True++instance Generic Int64 where+    toGeneric = toGenericInt True+    fromGeneric = fromGenericInt True++instance Generic Word where+    toGeneric = toGenericInt False+    fromGeneric = fromGenericInt False++instance Generic Word8 where+    toGeneric = toGenericInt False+    fromGeneric = fromGenericInt False++instance Generic Word16 where+    toGeneric = toGenericInt False+    fromGeneric = fromGenericInt False++instance Generic Word32 where+    toGeneric = toGenericInt False+    fromGeneric = fromGenericInt False++instance Generic Word64 where+    toGeneric = toGenericInt False+    fromGeneric = fromGenericInt False++toGenericReal :: (Real a, IsFirstClass a) => a -> GenericValue+toGenericReal val = unsafePerformIO $ createGenericValueWith $ do+    typ <- typeRef $ Proxy.fromValue val+    FFI.createGenericValueOfFloat typ (realToFrac val)++fromGenericReal :: forall a . (Fractional a, IsFirstClass a) => GenericValue -> a+fromGenericReal val = unsafePerformIO $+    withGenericValue val $ \ ref -> do+        typ <- typeRef (Proxy :: Proxy a)+        fmap realToFrac $ FFI.genericValueToFloat typ ref++instance Generic Float where+    toGeneric = toGenericReal+    fromGeneric = fromGenericReal++instance Generic Double where+    toGeneric = toGenericReal+    fromGeneric = fromGenericReal++instance Generic (Data.Ptr a) where+    toGeneric =+        unsafePerformIO . createGenericValueWith .+        FFI.createGenericValueOfPointer . Data.uncheckedToPtr+    fromGeneric val =+        Data.uncheckedFromPtr . unsafePerformIO . withGenericValue val $+        FFI.genericValueToPointer++instance Generic (Ptr a) where+    toGeneric =+        unsafePerformIO . createGenericValueWith .+        FFI.createGenericValueOfPointer+    fromGeneric val =+        unsafePerformIO . withGenericValue val $ FFI.genericValueToPointer++instance Generic (StablePtr a) where+    toGeneric =+        unsafePerformIO . createGenericValueWith .+        FFI.createGenericValueOfPointer . castStablePtrToPtr+    fromGeneric val =+        unsafePerformIO . fmap castPtrToStablePtr . withGenericValue val $+        FFI.genericValueToPointer
+ private/LLVM/ExecutionEngine/Marshal.hs view
@@ -0,0 +1,456 @@+module LLVM.ExecutionEngine.Marshal (+    Marshal(..),+    MarshalVector(..),+    sizeOf,+    alignment,+    StructFields,+    sizeOfArray,+    pokeList,++    with,+    alloca,++    Stored(..),+    castToStoredPtr,+    castFromStoredPtr,++    -- * for testing+    expandBits,+    gatherBits,+    adjustSign,+    chop,+    cut,+    split,+    merge,+    ) where++import qualified LLVM.Core.Vector as Vector ()+import qualified LLVM.Core.Data as Data+import qualified LLVM.Core.Type as Type+import qualified LLVM.Core.Proxy as LP+import qualified LLVM.ExecutionEngine.Target as Target+import LLVM.ExecutionEngine.Target (TargetData)+import LLVM.Core.Data (Ptr)++import qualified LLVM.Target.Native as Native+import qualified LLVM.FFI.Core as FFI++import qualified Type.Data.Num.Decimal.Number as Dec+import Type.Base.Proxy (Proxy(Proxy))++import qualified Foreign.Storable as Store+import qualified Foreign+import Foreign.StablePtr (StablePtr)+import Foreign.Ptr (FunPtr)++import System.IO.Unsafe (unsafePerformIO)++import qualified Control.Monad.Trans.State as MS+import Control.Applicative (liftA2, pure, (<$>))++import qualified Data.Traversable as Trav+import qualified Data.Foldable as Fold+import qualified Data.List.HT as ListHT+import Data.Bits (shiftL, shiftR, testBit, (.&.))+import Data.Int (Int8, Int16, Int32, Int64)+import Data.Word (Word8, Word16, Word32, Word64, Word)++++targetData :: TargetData+targetData =+    unsafePerformIO $ Native.initializeNativeTarget >> Target.getTargetData+++sizeOf :: (Type.IsType a) => LP.Proxy a -> Int+sizeOf = Target.storeSizeOfType targetData . Type.unsafeTypeRef++alignment :: (Type.IsType a) => LP.Proxy a -> Int+alignment = Target.abiAlignmentOfType targetData . Type.unsafeTypeRef++sizeOfArray :: (Type.IsType a) => LP.Proxy a -> Int -> Int+sizeOfArray proxy n =+   Target.abiSizeOfType targetData (Type.unsafeTypeRef proxy) * n+++{- |+Exchange data via memory in a format that is compatible with LLVM's data layout.+Prominent differences to 'Foreign.Storable' are:++* LLVM's @i1@ requires a byte in memory,+  whereas Haskell's 'Bool' occupies a 32-bit word with 'Foreign.poke'.++* LLVM's @<4 x i8>@ orders vector elements depending on machine endianess,+  whereas 'Foreign.poke' uses ascending order+  which is compatible with arrays.++This class also supports 'Data.Struct', 'Data.Vector', 'Data.Array'.+-}+class (Type.IsType a) => Marshal a where+    peek :: Ptr a -> IO a+    poke :: Ptr a -> a -> IO ()++peekPrimitive :: (Type.Storable a) => Ptr a -> IO a+peekPrimitive = Store.peek . Type.toPtr++pokePrimitive :: (Type.Storable a) => Ptr a -> a -> IO ()+pokePrimitive = Store.poke . Type.toPtr++instance Marshal Float  where+    peek = peekPrimitive; poke = pokePrimitive+instance Marshal Double where+    peek = peekPrimitive; poke = pokePrimitive++instance Marshal Int   where+    peek = peekPrimitive; poke = pokePrimitive+instance Marshal Int8  where+    peek = peekPrimitive; poke = pokePrimitive+instance Marshal Int16 where+    peek = peekPrimitive; poke = pokePrimitive+instance Marshal Int32 where+    peek = peekPrimitive; poke = pokePrimitive+instance Marshal Int64 where+    peek = peekPrimitive; poke = pokePrimitive+instance Marshal Word   where+    peek = peekPrimitive; poke = pokePrimitive+instance Marshal Word8  where+    peek = peekPrimitive; poke = pokePrimitive+instance Marshal Word16 where+    peek = peekPrimitive; poke = pokePrimitive+instance Marshal Word32 where+    peek = peekPrimitive; poke = pokePrimitive+instance Marshal Word64 where+    peek = peekPrimitive; poke = pokePrimitive+instance (Store.Storable a) => Marshal (Foreign.Ptr a) where+    peek = peekPrimitive; poke = pokePrimitive+instance (Type.IsType a) => Marshal (Ptr a) where+    peek = peekPrimitive; poke = pokePrimitive+instance (Type.IsFunction a) => Marshal (FunPtr a) where+    peek = peekPrimitive; poke = pokePrimitive+instance Marshal (StablePtr a) where+    peek = peekPrimitive; poke = pokePrimitive++instance (Type.Positive d) => Marshal (Data.WordN d) where+    peek ptr =+        fmap (Data.WordN . merge 8 . map toInteger . word8s) $+        peekVectorGen ptr $ sizeOf (proxyFromPtr ptr)+    poke ptr (Data.WordN a) =+        pokeVectorGen ptr . word8s . map fromInteger .+        take (sizeOf (proxyFromPtr ptr)) . split 8 $ a++instance (Type.Positive d) => Marshal (Data.IntN d) where+    peek ptr =+        fmap (consIntN Proxy . merge 8 . map toInteger . word8s) $+        peekVectorGen ptr $ sizeOf (proxyFromPtr ptr)+    poke ptr a =+        pokeVectorGen ptr . word8s . map fromInteger .+        take (sizeOf (proxyFromPtr ptr)) . split 8 $ deconsIntN Proxy a++cut :: Int -> Integer -> Integer+cut n w = (shiftL 1 n - 1) .&. w++split :: Int -> Integer -> [Integer]+split n = map (cut n) . iterate (flip shiftR n)++merge :: Int -> [Integer] -> Integer+merge m xs = sum $ zipWith shiftL xs $ iterate (m+) 0++instance Marshal Bool where+    peek = fmap (/= 0) . Store.peek . castBoolPtr+    poke ptr a = Store.poke (castBoolPtr ptr) (fromIntegral $ fromEnum a)++castBoolPtr :: Ptr Bool -> Foreign.Ptr Word8+castBoolPtr = Foreign.castPtr . Data.uncheckedToPtr++instance+    (Type.Natural n, Marshal a, Type.IsSized a) =>+        Marshal (Data.Array n a) where+    peek = peekArray Proxy LP.Proxy+    poke = pokeArray Fold.toList++peekArray ::+    (Type.Natural n, Marshal a) =>+    Proxy n -> LP.Proxy a ->+    Ptr (Data.Array n a) -> IO (Data.Array n a)+peekArray n proxy =+    let step = Target.abiSizeOfType targetData $ Type.unsafeTypeRef proxy+    in \ptr ->+        fmap Data.Array $ mapM peek $+        take (Dec.integralFromProxy n) $+        iterate (flip plusPtr step) (castElemPtr ptr)++pokeArray :: (Marshal a) => (f a -> [a]) -> Ptr (f a) -> f a -> IO ()+pokeArray toList ptr = pokeList (castElemPtr ptr) . toList++pokeList :: (Marshal a) => Ptr a -> [a] -> IO ()+pokeList = pokeListAux LP.Proxy++pokeListAux :: (Marshal a) => LP.Proxy a -> Ptr a -> [a] -> IO ()+pokeListAux proxy =+    let step = Target.abiSizeOfType targetData $ Type.unsafeTypeRef proxy+    in \ptr -> sequence_ . zipWith poke (iterate (flip plusPtr step) ptr)++castElemPtr :: Ptr (f a) -> Ptr a+castElemPtr = Data.uncheckedFromPtr . Foreign.castPtr . Data.uncheckedToPtr+++instance+    (Type.Positive n, MarshalVector a) =>+        Marshal (Data.Vector n a) where+    peek = peekVector+    poke = pokeVector++class (Type.IsPrimitive a) => MarshalVector a where+    peekVector ::+        (Type.Positive n) =>+        Ptr (Data.Vector n a) -> IO (Data.Vector n a)+    pokeVector ::+        (Type.Positive n) =>+        Ptr (Data.Vector n a) -> Data.Vector n a -> IO ()++instance MarshalVector Bool where+    peekVector ptr =+        fmap (vectorFromList . expandBits) $+        peekVectorGen ptr $ sizeOf (proxyFromPtr ptr)+    pokeVector ptr = pokeVectorGen ptr . gatherBits . Fold.toList++expandBits :: [Word8] -> [Bool]+expandBits = concatMap (\byte -> map (testBit byte) [0..7])++vectorFromList :: (Type.Positive n) => [a] -> Data.Vector n a+vectorFromList =+    MS.evalState $ Trav.sequence $ pure $ MS.state $ \(y:ys) -> (y,ys)++gatherBits :: [Bool] -> [Word8]+gatherBits =+    map (sum . zipWith (flip shiftL) [0..] . map (fromIntegral . fromEnum)) .+    ListHT.sliceVertical 8+++instance (Type.Positive d) => MarshalVector (Data.WordN d) where+    peekVector ptr = fmap Data.WordN <$> peekNVector Proxy ptr+    pokeVector ptr = pokeNVector Proxy ptr . fmap (\(Data.WordN x) -> x)++instance (Type.Positive d) => MarshalVector (Data.IntN d) where+    peekVector ptr = fmap (consIntN Proxy) <$> peekNVector Proxy ptr+    pokeVector ptr = pokeNVector Proxy ptr . fmap (deconsIntN Proxy)++consIntN :: (Type.Positive d) => Proxy d -> Integer -> Data.IntN d+consIntN proxy = Data.IntN . adjustSign (Dec.integralFromProxy proxy)++deconsIntN :: (Type.Positive d) => Proxy d -> Data.IntN d -> Integer+deconsIntN proxy (Data.IntN a) = cut (Dec.integralFromProxy proxy) a++adjustSign :: Int -> Integer -> Integer+adjustSign d =+    let range = shiftL 1 d+    in  \a -> if a < div range 2 then a else a-range++peekNVector ::+    (Type.Positive n, Type.Positive d, Type.IsPrimitive (intn d)) =>+    Proxy d -> Ptr (Data.Vector n (intn d)) -> IO (Data.Vector n Integer)+peekNVector proxy ptr =+    fmap (vectorFromList . chop 8 (Dec.integralFromProxy proxy) .+          map toInteger . word8s) $+    peekVectorGen ptr $ sizeOf (proxyFromPtr ptr)++pokeNVector ::+    (Type.Positive n, Type.Positive d, Type.IsPrimitive (intn d)) =>+    Proxy d ->+    Ptr (Data.Vector n (intn d)) -> Data.Vector n Integer -> IO ()+pokeNVector proxy ptr =+    pokeVectorGen ptr . take (sizeOf (proxyFromPtr ptr)) . word8s .+    map fromInteger . chop (Dec.integralFromProxy proxy) 8 . Fold.toList++word8s :: [Word8] -> [Word8]+word8s = id++proxyFromPtr :: Ptr a -> LP.Proxy a+proxyFromPtr _ = LP.Proxy++chop :: Int -> Int -> [Integer] -> [Integer]+chop m n =+    concat . snd .+    Trav.mapAccumL+        (\(valid,acc) x ->+            let newAcc = acc + cut n (shiftL x valid)+                nextValid = valid+m+            in  if nextValid<n+                    then ((nextValid, newAcc), [])+                    else+                        case divMod nextValid n of+                            (chunks,remd) ->+                                ((remd, shiftR x (m-remd)),+                                 (newAcc :) $+                                 map (cut n . shiftR x) $+                                 take (chunks-1) $ iterate (n+) (n-valid)))+        (0,0) .+    (++ repeat 0)+++instance MarshalVector Float where+    peekVector = peekVectorAuto Proxy+    pokeVector ptr = pokeVectorGen ptr . Fold.toList++instance MarshalVector Double where+    peekVector = peekVectorAuto Proxy+    pokeVector ptr = pokeVectorGen ptr . Fold.toList++instance MarshalVector Word where+    peekVector = peekVectorAuto Proxy+    pokeVector ptr = pokeVectorGen ptr . Fold.toList++instance MarshalVector Word8 where+    peekVector = peekVectorAuto Proxy+    pokeVector ptr = pokeVectorGen ptr . Fold.toList++instance MarshalVector Word16 where+    peekVector = peekVectorAuto Proxy+    pokeVector ptr = pokeVectorGen ptr . Fold.toList++instance MarshalVector Word32 where+    peekVector = peekVectorAuto Proxy+    pokeVector ptr = pokeVectorGen ptr . Fold.toList++instance MarshalVector Word64 where+    peekVector = peekVectorAuto Proxy+    pokeVector ptr = pokeVectorGen ptr . Fold.toList++instance MarshalVector Int where+    peekVector = peekVectorAuto Proxy+    pokeVector ptr = pokeVectorGen ptr . Fold.toList++instance MarshalVector Int8 where+    peekVector = peekVectorAuto Proxy+    pokeVector ptr = pokeVectorGen ptr . Fold.toList++instance MarshalVector Int16 where+    peekVector = peekVectorAuto Proxy+    pokeVector ptr = pokeVectorGen ptr . Fold.toList++instance MarshalVector Int32 where+    peekVector = peekVectorAuto Proxy+    pokeVector ptr = pokeVectorGen ptr . Fold.toList++instance MarshalVector Int64 where+    peekVector = peekVectorAuto Proxy+    pokeVector ptr = pokeVectorGen ptr . Fold.toList+++peekVectorAuto ::+    (Type.Positive n, Type.IsPrimitive a, Store.Storable a) =>+    Proxy n -> Ptr (Data.Vector n a) -> IO (Data.Vector n a)+peekVectorAuto proxy ptr =+    fmap vectorFromList $ peekVectorGen ptr $ Dec.integralFromProxy proxy++peekVectorGen ::+    (Type.IsType b, Store.Storable chunk) =>+    Ptr b -> Int -> IO [chunk]+peekVectorGen = peekVectorAux LP.Proxy (error "vector")++peekVectorAux ::+    (Type.IsType b, Store.Storable chunk) =>+    LP.Proxy b -> chunk -> Ptr b -> Int -> IO [chunk]+peekVectorAux proxy dummyChunk =+    let (offset,step) = arrayParams proxy dummyChunk+    in  \ptr n ->+            mapM (Store.peekByteOff (Data.uncheckedToPtr ptr)) $+            take n $ iterate (step+) offset++pokeVectorGen ::+    (Type.IsType b, Store.Storable chunk) =>+    Ptr b -> [chunk] -> IO ()+pokeVectorGen = pokeVectorAux LP.Proxy (error "vector")++pokeVectorAux ::+    (Type.IsType b, Store.Storable chunk) =>+    LP.Proxy b -> chunk -> Ptr b -> [chunk] -> IO ()+pokeVectorAux proxy dummyChunk =+    let (offset,step) = arrayParams proxy dummyChunk+    in  \ptr xs ->+            sequence_ $+            zipWith (Store.pokeByteOff (Data.uncheckedToPtr ptr))+                (iterate (step+) offset) xs++arrayParams ::+    (Type.IsType b, Store.Storable chunk) =>+    LP.Proxy b -> chunk -> (Int,Int)+arrayParams proxy dummyChunk =+    let chunkSize = Store.sizeOf dummyChunk+    in  if Target.littleEndian targetData+            then (0, chunkSize)+            else (sizeOf proxy - chunkSize, -chunkSize)+++instance (StructFields fields) => Marshal (Data.Struct fields) where+    peek = withPtrProxy $ \proxy ->+        let typeRef = Type.unsafeTypeRef proxy+        in fmap Data.Struct . peekStruct typeRef 0+    poke = withPtrProxy $ \proxy ->+        let typeRef = Type.unsafeTypeRef proxy+            pokePlain = pokeStruct typeRef 0+        in \ptr (Data.Struct as) -> pokePlain ptr as++withPtrProxy :: (LP.Proxy a -> Ptr a -> b) -> Ptr a -> b+withPtrProxy act = act LP.Proxy++class (Type.StructFields fields) => StructFields fields where+    peekStruct :: FFI.TypeRef -> Int -> Ptr struct -> IO fields+    pokeStruct :: FFI.TypeRef -> Int -> Ptr struct -> fields -> IO ()++instance+    (Marshal a, Type.IsSized a, StructFields as) =>+        StructFields (a,as) where+    peekStruct typeRef i =+        let offset = Target.offsetOfElement targetData typeRef i+            peekIs = peekStruct typeRef (i+1)+        in \ptr -> liftA2 (,) (peek $ plusPtr ptr offset) (peekIs ptr)+    pokeStruct typeRef i =+        let offset = Target.offsetOfElement targetData typeRef i+            pokeIs = pokeStruct typeRef (i+1)+        in \ptr (a,as) -> poke (plusPtr ptr offset) a >> pokeIs ptr as++instance StructFields () where+    peekStruct _type _i _ptr = return ()+    pokeStruct _type _i _ptr () = return ()++plusPtr :: Ptr a -> Int -> Ptr b+plusPtr ptr offset =+    Data.uncheckedFromPtr $ Foreign.plusPtr (Data.uncheckedToPtr ptr) offset+++with :: (Marshal a) => a -> (Ptr a -> IO b) -> IO b+with a act = alloca $ \ptr -> poke ptr a >> act ptr++alloca :: (Type.IsType a) => (Ptr a -> IO b) -> IO b+alloca = allocaAux LP.Proxy++allocaAux :: (Type.IsType a) => LP.Proxy a -> (Ptr a -> IO b) -> IO b+allocaAux proxy f =+    Foreign.allocaBytesAligned (sizeOf proxy) (alignment proxy)+        (f . Data.uncheckedFromPtr)+++{- |+Provide @Marshal@ functionality through Haskell's 'Storable' interface.+Thus, @'Ptr' a@ is equivalent to @'Foreign.Ptr' ('Stored' a)@.+You may e.g. use a @'Foreign.ForeignPtr' ('Stored' a)@+to manage LLVM data with Haskell's garbage collector.+-}+newtype Stored a = Stored {getStored :: a}++castToStoredPtr :: Ptr a -> Foreign.Ptr (Stored a)+castToStoredPtr = Foreign.castPtr . Data.uncheckedToPtr++castFromStoredPtr :: Foreign.Ptr (Stored a) -> Ptr a+castFromStoredPtr = Data.uncheckedFromPtr . Foreign.castPtr+++instance (Marshal a) => Store.Storable (Stored a) where+    sizeOf = sizeOf . proxyFromStored+    alignment = alignment . proxyFromStored+    peek = fmap Stored . peek . castFromStoredPtr+    poke ptr = poke (castFromStoredPtr ptr) . getStored++proxyFromStored :: Stored a -> LP.Proxy a+proxyFromStored _ = LP.Proxy
+ private/LLVM/ExecutionEngine/Target.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE EmptyDataDecls #-}+module LLVM.ExecutionEngine.Target (+    TargetData,+    dataLayoutStr,+    abiAlignmentOfType,+    abiSizeOfType,+    littleEndian,+    callFrameAlignmentOfType,+    intPtrType,+    offsetOfElement,+    pointerSize,+    preferredAlignmentOfType,+    sizeOfTypeInBits,+    storeSizeOfType,+    getTargetData,+    targetDataFromString,+    withIntPtrType,+    ) where++import qualified LLVM.ExecutionEngine.Engine as EE+import LLVM.Core.Data (WordN)++import qualified LLVM.FFI.Core as FFI+import qualified LLVM.FFI.Target as FFI++import qualified Type.Data.Num.Decimal.Number as Dec+import Type.Base.Proxy (Proxy)++import Foreign.ForeignPtr+         (ForeignPtr,+          newForeignPtr, withForeignPtr, touchForeignPtr, castForeignPtr)+import Foreign.C.String (withCString, peekCString)++import Control.Monad (liftM2, (<=<))+import Control.Applicative ((<$>))+import Data.Maybe (fromMaybe)+import System.IO.Unsafe (unsafePerformIO)+++type Type = FFI.TypeRef++data TargetDataOwner++data TargetData = TargetData (ForeignPtr TargetDataOwner) FFI.TargetDataRef++dataLayoutStr :: TargetData -> String+dataLayoutStr td = unsafeIO td $ peekCString <=< FFI.copyStringRepOfTargetData++abiAlignmentOfType :: TargetData -> Type -> Int+abiAlignmentOfType td = unsafeIntIO td . flip FFI.abiAlignmentOfType++abiSizeOfType :: TargetData -> Type -> Int+abiSizeOfType td = unsafeIntIO td . flip FFI.abiSizeOfType++littleEndian :: TargetData -> Bool+littleEndian td = FFI.bigEndian /= unsafeIO td FFI.byteOrder++callFrameAlignmentOfType :: TargetData -> Type -> Int+callFrameAlignmentOfType td = unsafeIntIO td . flip FFI.callFrameAlignmentOfType++-- elementAtOffset :: TargetData -> Type -> Word64 -> Int++intPtrType :: TargetData -> Type+intPtrType td = unsafeIO td FFI.intPtrType++offsetOfElement :: TargetData -> Type -> Int -> Int+offsetOfElement td ty k =+    unsafeIntIO td $ \r -> FFI.offsetOfElement r ty (fromIntegral k)++pointerSize :: TargetData -> Int+pointerSize td = unsafeIntIO td FFI.pointerSize++-- preferredAlignmentOfGlobal :: TargetData -> Value a -> Int++preferredAlignmentOfType :: TargetData -> Type -> Int+preferredAlignmentOfType td = unsafeIntIO td . flip FFI.preferredAlignmentOfType++sizeOfTypeInBits :: TargetData -> Type -> Int+sizeOfTypeInBits td = unsafeIntIO td . flip FFI.sizeOfTypeInBits++storeSizeOfType :: TargetData -> Type -> Int+storeSizeOfType td = unsafeIntIO td . flip FFI.storeSizeOfType+++withIntPtrType :: (forall n . (Dec.Positive n) => WordN n -> a) -> a+withIntPtrType f =+    fromMaybe (error "withIntPtrType: pointer size must be non-negative") $+        Dec.reifyPositive (fromIntegral sz) (\ n -> f (g n))+  where g :: Proxy n -> WordN n+        g _ = error "withIntPtrType: argument used"+        sz = pointerSize $ unsafePerformIO getTargetData+++unsafeIO :: TargetData -> (FFI.TargetDataRef -> IO a) -> a+unsafeIO (TargetData fptr td) act =+    unsafePerformIO $ do x <- act td; touchForeignPtr fptr; return x++unsafeIntIO ::+   (Integral i, Num j) => TargetData -> (FFI.TargetDataRef -> IO i) -> j+unsafeIntIO td act = fromIntegral $ unsafeIO td act++-- Normally the TargetDataRef never changes,+-- so the operation are really functions.+-- The ForeignPtr can point to TargetData or to ExecutionEngine.+makeTargetData :: ForeignPtr a -> FFI.TargetDataRef -> TargetData+makeTargetData = TargetData . castForeignPtr++-- Gets the target data for the JIT target.+getTargetData :: IO TargetData+getTargetData =+    EE.runEngineAccess $+    liftM2 makeTargetData+        (EE.fromEngine <$> EE.getEngine)+        EE.getExecutionEngineTargetData++createTargetData :: String -> IO (ForeignPtr FFI.TargetData)+createTargetData s =+    newForeignPtr FFI.ptrDisposeTargetData =<<+    withCString s FFI.createTargetData++targetDataFromString :: String -> TargetData+targetDataFromString s = unsafePerformIO $ do+    td <- createTargetData s+    withForeignPtr td $ return . makeTargetData td
+ src/LLVM/Core.hs view
@@ -0,0 +1,123 @@+-- |The LLVM (Low Level Virtual Machine) is virtual machine at a machine code level.+-- It supports both stand alone code generation and JITing.+-- The Haskell llvm package is a (relatively) high level interface to the LLVM.+-- The high level interface makes it easy to construct LLVM code.+-- There is also an interface to the raw low level LLVM API as exposed by the LLVM C interface.+--+-- LLVM code is organized into modules (type 'Module').+-- Each module contains a number of global variables and functions (type 'Function').+-- Each functions has a number of basic blocks (type 'BasicBlock').+-- Each basic block has a number instructions, where each instruction produces+-- a value (type 'Value').+--+-- Unlike assembly code for a real processor the assembly code for LLVM is+-- in SSA (Static Single Assignment) form.  This means that each instruction generates+-- a new bound variable which may not be assigned again.+-- A consequence of this is that where control flow joins from several execution+-- paths there has to be a phi pseudo instruction if you want different variables+-- to be joined into one.+--+-- The definition of several of the LLVM entities ('Module', 'Function', and 'BasicBlock')+-- follow the same pattern.  First the entity has to be created using @newX@ (where @X@+-- is one of @Module@, @Function@, or @BasicBlock@), then at some later point it has to+-- given its definition using @defineX@.  The reason for splitting the creation and+-- definition is that you often need to be able to refer to an entity before giving+-- it's body, e.g., in two mutually recursive functions.+-- The the @newX@ and @defineX@ function can also be done at the same time by using+-- @createX@.  Furthermore, an explicit name can be given to an entity by the+-- @newNamedX@ function; the @newX@ function just generates a fresh name.+module LLVM.Core(+    -- * Initialize+    Target.initializeNativeTarget,+    -- * Modules+    Module, newModule, newNamedModule, defineModule, destroyModule, createModule,+    getModule,+    setTarget, FFI.hostTriple,+    setDataLayout,+    PassManager, createPassManager, createFunctionPassManager,+    writeBitcodeToFile, readBitcodeFromFile,+    getModuleValues, getFunctions, getGlobalVariables, ModuleValue, castModuleValue,+    -- * Instructions+    module LLVM.Core.Instructions,+    -- * Types classification+    module LLVM.Core.Type,+    -- * Extra types+    module LLVM.Core.Data,+    -- * Values and constants+    Value, ConstValue, valueOf, constOf, value,+    zero, allOnes, undef,+    IsConst, IsConstFields,+    createString, createStringNul,+    withString, withStringNul,+    --constString, constStringNul,+    constVector, constArray,+    constCyclicVector, constCyclicArray,+    constStruct, constPackedStruct,+    toVector, fromVector, vector, cyclicVector, consVector,+    -- * Code generation+    CodeGenFunction, CodeGenModule,+    -- * Functions+    Function, newFunction, newNamedFunction, defineFunction,+    createFunction, createNamedFunction, setFuncCallConv, functionParameter,+    TFunction, liftCodeGenModule, getParams,+    -- * Global variable creation+    Global, newGlobal, newNamedGlobal, defineGlobal, createGlobal, createNamedGlobal,+    externFunction, staticFunction, staticNamedFunction,+    externGlobal, staticGlobal,+    GlobalMappings, getGlobalMappings,+    TGlobal,+    -- * Globals+    Linkage(..),+    -- * Basic blocks+    BasicBlock, newBasicBlock, newNamedBasicBlock, defineBasicBlock, createBasicBlock, getCurrentBasicBlock,+    getBasicBlocks,+    fromLabel, toLabel,+    getInstructions, getOperands, hasUsers, getUsers, getUses, getUser, isChildOf, getDep,+    -- * Misc+    addAttributes, Attribute,+    FFI.AttributeIndex(..),+    FFI.attributeReturnIndex, FFI.attributeFunctionIndex,+    castVarArgs,+    -- * Debugging+    dumpValue, dumpType, getValueName, annotateValueList+    ) where++import qualified LLVM.Target.Native as Target+import LLVM.Core.Util hiding (Function, BasicBlock, createModule, constString, constStringNul, constVector, constArray, constStruct, getModuleValues, valueHasType)+import LLVM.Core.CodeGen+import LLVM.Core.CodeGenMonad+          (CodeGenFunction, CodeGenModule, liftCodeGenModule, getModule,+           GlobalMappings, getGlobalMappings)+import LLVM.Core.Data+import LLVM.Core.Instructions+import LLVM.Core.Type+import LLVM.Core.Vector++import qualified LLVM.FFI.Core as FFI+++-- |Print a value.+dumpValue :: Value a -> IO ()+dumpValue (Value v) = FFI.dumpValue v++-- |Print a type.+dumpType :: Value a -> IO ()+dumpType (Value v) = showTypeOf v >>= putStrLn++-- |Get the name of a 'Value'.+getValueName :: Value a -> IO String+getValueName (Value a) = getValueNameU a++-- |Convert a varargs function to a regular function.+castVarArgs :: (CastVarArgs a b) => Function a -> Function b+castVarArgs (Value a) = Value a++-- TODO for types:+-- Enforce free is only called on malloc memory.  (Enforce only one free?)+-- Enforce phi nodes a accessor of variables outside the bb+-- Enforce bb terminator+-- Enforce phi first+--+-- TODO:+-- Add Struct, PackedStruct types+-- Get alignment from code gen
+ src/LLVM/Core/Attribute.hs view
@@ -0,0 +1,300 @@+module LLVM.Core.Attribute (+    zeroext,+    signext,+    inreg,+    byval,+    sret,+    align,+    noalias,+    nocapture,+    nest,+    returned,+    nonnull,+    dereferenceable,+    dereferenceableOrNull,+    swiftself,+    swifterror,+    immarg,+    alignstack,+    allocsize,+    alwaysinline,+    builtin,+    cold,+    convergent,+    inaccessiblememonly,+    inaccessiblememOrArgmemonly,+    inlinehint,+    jumptable,+    minsize,+    naked,+    noJumpTables,+    nobuiltin,+    noduplicate,+    nofree,+    noimplicitfloat,+    noinline,+    nonlazybind,+    noredzone,+    indirectTlsSegRefs,+    noreturn,+    norecurse,+    willreturn,+    nosync,+    nounwind,+    nullPointerIsValid,+    optforfuzzing,+    optnone,+    optsize,+    patchableFunction,+    probeStack,+    readnone,+    readonly,+    stackProbeSize,+    noStackArgProbe,+    writeonly,+    argmemonly,+    returnsTwice,+    safestack,+    sanitizeAddress,+    sanitizeMemory,+    sanitizeThread,+    sanitizeHwaddress,+    sanitizeMemtag,+    speculativeLoadHardening,+    speculatable,+    ssp,+    sspreq,+    sspstrong,+    strictfp,+    uwtable,+    nocfCheck,+    shadowcallstack,+    ) where++import LLVM.Core.CodeGen (Attribute(Attribute))++import qualified LLVM.FFI.Core.Attribute as Attr++import Data.Word (Word64)+++simple :: Attr.Name -> Attribute+simple name = Attribute name 0++withParam :: Attr.Name -> Word64 -> Attribute+withParam = Attribute++-- * Parameter attributes++zeroext :: Attribute+zeroext = simple Attr.zeroext++signext :: Attribute+signext = simple Attr.signext++inreg :: Attribute+inreg = simple Attr.inreg++byval :: Attribute+byval = simple Attr.byval++sret :: Attribute+sret = simple Attr.sret++align :: Word64 -> Attribute+align = withParam Attr.align++noalias :: Attribute+noalias = simple Attr.noalias++nocapture :: Attribute+nocapture = simple Attr.nocapture++nest :: Attribute+nest = simple Attr.nest++returned :: Attribute+returned = simple Attr.returned++nonnull :: Attribute+nonnull = simple Attr.nonnull++dereferenceable :: Word64 -> Attribute+dereferenceable = withParam Attr.dereferenceable++dereferenceableOrNull :: Word64 -> Attribute+dereferenceableOrNull = withParam Attr.dereferenceableOrNull++swiftself :: Attribute+swiftself = simple Attr.swiftself++swifterror :: Attribute+swifterror = simple Attr.swifterror++immarg :: Attribute+immarg = simple Attr.immarg+++-- * Function attributes++alignstack :: Word64 -> Attribute+alignstack = withParam Attr.alignstack++allocsize :: Attribute+allocsize = simple Attr.allocsize++alwaysinline :: Attribute+alwaysinline = simple Attr.alwaysinline++builtin :: Attribute+builtin = simple Attr.builtin++cold :: Attribute+cold = simple Attr.cold++convergent :: Attribute+convergent = simple Attr.convergent++inaccessiblememonly :: Attribute+inaccessiblememonly = simple Attr.inaccessiblememonly++inaccessiblememOrArgmemonly :: Attribute+inaccessiblememOrArgmemonly = simple Attr.inaccessiblememOrArgmemonly++inlinehint :: Attribute+inlinehint = simple Attr.inlinehint++jumptable :: Attribute+jumptable = simple Attr.jumptable++minsize :: Attribute+minsize = simple Attr.minsize++naked :: Attribute+naked = simple Attr.naked++noJumpTables :: Attribute+noJumpTables = simple Attr.noJumpTables++nobuiltin :: Attribute+nobuiltin = simple Attr.nobuiltin++noduplicate :: Attribute+noduplicate = simple Attr.noduplicate++nofree :: Attribute+nofree = simple Attr.nofree++noimplicitfloat :: Attribute+noimplicitfloat = simple Attr.noimplicitfloat++noinline :: Attribute+noinline = simple Attr.noinline++nonlazybind :: Attribute+nonlazybind = simple Attr.nonlazybind++noredzone :: Attribute+noredzone = simple Attr.noredzone++indirectTlsSegRefs :: Attribute+indirectTlsSegRefs = simple Attr.indirectTlsSegRefs++noreturn :: Attribute+noreturn = simple Attr.noreturn++norecurse :: Attribute+norecurse = simple Attr.norecurse++willreturn :: Attribute+willreturn = simple Attr.willreturn++nosync :: Attribute+nosync = simple Attr.nosync++nounwind :: Attribute+nounwind = simple Attr.nounwind++nullPointerIsValid :: Attribute+nullPointerIsValid = simple Attr.nullPointerIsValid++optforfuzzing :: Attribute+optforfuzzing = simple Attr.optforfuzzing++optnone :: Attribute+optnone = simple Attr.optnone++optsize :: Attribute+optsize = simple Attr.optsize++patchableFunction :: Attribute+patchableFunction = simple Attr.patchableFunction++probeStack :: Attribute+probeStack = simple Attr.probeStack++readnone :: Attribute+readnone = simple Attr.readnone++readonly :: Attribute+readonly = simple Attr.readonly++stackProbeSize :: Attribute+stackProbeSize = simple Attr.stackProbeSize++noStackArgProbe :: Attribute+noStackArgProbe = simple Attr.noStackArgProbe++writeonly :: Attribute+writeonly = simple Attr.writeonly++argmemonly :: Attribute+argmemonly = simple Attr.argmemonly++returnsTwice :: Attribute+returnsTwice = simple Attr.returnsTwice++safestack :: Attribute+safestack = simple Attr.safestack++sanitizeAddress :: Attribute+sanitizeAddress = simple Attr.sanitizeAddress++sanitizeMemory :: Attribute+sanitizeMemory = simple Attr.sanitizeMemory++sanitizeThread :: Attribute+sanitizeThread = simple Attr.sanitizeThread++sanitizeHwaddress :: Attribute+sanitizeHwaddress = simple Attr.sanitizeHwaddress++sanitizeMemtag :: Attribute+sanitizeMemtag = simple Attr.sanitizeMemtag++speculativeLoadHardening :: Attribute+speculativeLoadHardening = simple Attr.speculativeLoadHardening++speculatable :: Attribute+speculatable = simple Attr.speculatable++ssp :: Attribute+ssp = simple Attr.ssp++sspreq :: Attribute+sspreq = simple Attr.sspreq++sspstrong :: Attribute+sspstrong = simple Attr.sspstrong++strictfp :: Attribute+strictfp = simple Attr.strictfp++uwtable :: Attribute+uwtable = simple Attr.uwtable++nocfCheck :: Attribute+nocfCheck = simple Attr.nocfCheck++shadowcallstack :: Attribute+shadowcallstack = simple Attr.shadowcallstack
+ src/LLVM/Core/Guided.hs view
@@ -0,0 +1,5 @@+module LLVM.Core.Guided (+    module LLVM.Core.Instructions.Guided,+    ) where++import LLVM.Core.Instructions.Guided
+ src/LLVM/ExecutionEngine.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE TypeFamilies #-}+ -- |An 'ExecutionEngine' is JIT compiler that is used to generate code for an LLVM module.+module LLVM.ExecutionEngine(+    -- * Execution engine+    EngineAccess,+    ExecutionEngine,+    getEngine,+    runEngineAccess,+    runEngineAccessWithModule,+    addModule,+    ExecutionFunction,+    Importer,+    getExecutionFunction,+    getPointerToFunction,+    addFunctionValue,+    addGlobalMappings,+    -- * Translation+    Translatable, Generic,+    generateFunction,+    -- * Unsafe type conversion+    Unsafe,+    unsafeRemoveIO,+    -- * Simplified interface.+    simpleFunction,+    unsafeGenerateFunction,+    -- * Target information+    module LLVM.ExecutionEngine.Target,+    -- * Exchange data with JIT code in memory+    Marshal.Marshal(..),+    Marshal.MarshalVector(..),+    Marshal.sizeOf,+    Marshal.alignment,+    Marshal.StructFields,+    Marshal.sizeOfArray,+    Marshal.pokeList,+    Marshal.with,+    Marshal.alloca,+    Marshal.Stored(..),+    Marshal.castToStoredPtr,+    Marshal.castFromStoredPtr,+    ) where++import qualified LLVM.ExecutionEngine.Marshal as Marshal+import LLVM.ExecutionEngine.Engine+import LLVM.ExecutionEngine.Target+import LLVM.Core.CodeGen (Value(..))+import LLVM.Core+         (CodeGenModule, Function, newModule, defineModule, getGlobalMappings,+          setTarget, hostTriple)++import LLVM.FFI.Core (ValueRef)++import System.IO.Unsafe (unsafePerformIO)++import Control.Monad (liftM2, )+++-- |Class of LLVM function types that can be translated to the corresponding+-- Haskell type.+class Translatable f where+    translate :: (ValueRef -> [GenericValue] -> IO GenericValue) -> [GenericValue] -> ValueRef -> f++instance (Generic a, Translatable b) => Translatable (a -> b) where+    translate run args f = \ arg -> translate run (toGeneric arg : args) f++instance (Generic a) => Translatable (IO a) where+    translate run args f = fmap fromGeneric $ run f $ reverse args++-- |Generate a Haskell function from an LLVM function.+--+-- Note that the function is compiled for every call (Just-In-Time compilation).+-- If you want to compile the function once and call it a lot of times+-- then you should better use 'getPointerToFunction'.+generateFunction ::+    (Translatable f) =>+    Function f -> EngineAccess f+generateFunction (Value f) = do+    run <- getRunFunction+    return $ translate run [] f++class Unsafe a where+    type RemoveIO a+    unsafeRemoveIO :: a -> RemoveIO a  -- ^Remove the IO from a function return type.  This is unsafe in general.++instance (Unsafe b) => Unsafe (a->b) where+    type RemoveIO (a -> b) = a -> RemoveIO b+    unsafeRemoveIO f = unsafeRemoveIO . f++instance Unsafe (IO a) where+    type RemoveIO (IO a) = a+    unsafeRemoveIO = unsafePerformIO++-- |Translate a function to Haskell code.  This is a simplified interface to+-- the execution engine and module mechanism.+-- It is based on 'generateFunction', so see there for limitations.+simpleFunction :: (Translatable f) => CodeGenModule (Function f) -> IO f+simpleFunction bld = do+    m <- newModule+    (func, mappings) <-+        defineModule m $+            setTarget hostTriple >> liftM2 (,) bld getGlobalMappings+    runEngineAccessInterpreterWithModule m $ do+        addGlobalMappings mappings+        generateFunction func++-- | Combine 'simpleFunction' and 'unsafeRemoveIO'.+unsafeGenerateFunction :: (Unsafe t, Translatable t) =>+                          CodeGenModule (Function t) -> RemoveIO t+unsafeGenerateFunction bld = unsafePerformIO $ do+    fun <- simpleFunction bld+    return $ unsafeRemoveIO fun
+ src/LLVM/Util/Arithmetic.hs view
@@ -0,0 +1,323 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+module LLVM.Util.Arithmetic(+    TValue,+    (%==), (%/=), (%<), (%<=), (%>), (%>=),+    (%&&), (%||),+    (?), (??),+    retrn, set,+    ArithFunction, arithFunction, Return,+    ToArithFunction, toArithFunction, recursiveFunction,+    CallIntrinsic,+    ) where++import qualified LLVM.Util.Intrinsic as Intrinsic+import qualified LLVM.Core as LLVM+import LLVM.Util.Loop (mapVector, mapVector2)+import LLVM.Core.CodeGen (UnValue, CodeValue, CodeResult)+import LLVM.Core++import qualified Type.Data.Num.Decimal.Number as Dec++import Control.Monad (liftM2)++-- |Synonym for @CodeGenFunction r (Value a)@.+type TValue r a = CodeGenFunction r (Value a)+++infix  4  %==, %/=, %<, %<=, %>=, %>+-- |Comparison functions.+(%==), (%/=), (%<), (%<=), (%>), (%>=) :: (CmpRet a) => TValue r a -> TValue r a -> TValue r (CmpResult a)+(%==) = binop $ LLVM.cmp CmpEQ+(%/=) = binop $ LLVM.cmp CmpNE+(%>)  = binop $ LLVM.cmp CmpGT+(%>=) = binop $ LLVM.cmp CmpGE+(%<)  = binop $ LLVM.cmp CmpLT+(%<=) = binop $ LLVM.cmp CmpLE++infixr 3  %&&+infixr 2  %||+-- |Lazy and.+(%&&) :: TValue r Bool -> TValue r Bool -> TValue r Bool+a %&& b = a ? (b, return (valueOf False))+-- |Lazy or.+(%||) :: TValue r Bool -> TValue r Bool -> TValue r Bool+a %|| b = a ? (return (valueOf True), b)++infix  0 ?+-- |Conditional, returns first element of the pair when condition is true, otherwise second.+(?) :: (IsFirstClass a) => TValue r Bool -> (TValue r a, TValue r a) -> TValue r a+c ? (t, f) = do+    lt <- newBasicBlock+    lf <- newBasicBlock+    lj <- newBasicBlock+    c' <- c+    condBr c' lt lf+    defineBasicBlock lt+    rt <- t+    lt' <- getCurrentBasicBlock+    br lj+    defineBasicBlock lf+    rf <- f+    lf' <- getCurrentBasicBlock+    br lj+    defineBasicBlock lj+    phi [(rt, lt'), (rf, lf')]++infix 0 ??+(??) :: (IsFirstClass a, CmpRet a) => TValue r (CmpResult a) -> (TValue r a, TValue r a) -> TValue r a+c ?? (t, f) = do+    c' <- c+    t' <- t+    f' <- f+    select c' t' f'++-- | Return a value from an 'arithFunction'.+retrn :: TValue a a -> CodeGenFunction a ()+retrn x = x >>= ret++-- | Use @x <- set $ ...@ to make a binding.+set :: TValue r a -> CodeGenFunction r (TValue r a)+set x = do x' <- x; return (return x')++instance Eq (CodeGenFunction r av) where+    (==) = error "CodeGenFunction Value: (==)"+instance Ord (CodeGenFunction r av) where+    compare = error "CodeGenFunction Value: compare"++instance+    (IsArithmetic a, CmpRet a, Num a, IsConst a, Value a ~ av) =>+        Num (CodeGenFunction r av) where+    (+) = binop add+    (-) = binop sub+    (*) = binop mul+    negate = (>>= neg)+    abs x = x %< 0 ?? (-x, x)+    signum x = x %< 0 ?? (-1, x %> 0 ?? (1, 0))+    fromInteger = return . valueOf . fromInteger++instance+    (IsArithmetic a, CmpRet a, Num a, IsConst a, Value a ~ av) =>+        Enum (CodeGenFunction r av) where+    succ x = x + 1+    pred x = x - 1+    fromEnum _ = error "CodeGenFunction Value: fromEnum"+    toEnum = fromIntegral++instance+    (IsArithmetic a, CmpRet a, Num a, IsConst a, Value a ~ av) =>+        Real (CodeGenFunction r av) where+    toRational _ = error "CodeGenFunction Value: toRational"++instance+    (CmpRet a, Num a, IsConst a, IsInteger a, Value a ~ av) =>+        Integral (CodeGenFunction r av) where+    quot = binop idiv+    rem  = binop irem+    quotRem x y = (quot x y, rem x y)+    toInteger _ = error "CodeGenFunction Value: toInteger"++instance+    (CmpRet a, Fractional a, IsConst a, IsFloating a, Value a ~ av) =>+        Fractional (CodeGenFunction r av) where+    (/) = binop fdiv+    fromRational = return . valueOf . fromRational++instance+    (CmpRet a, Fractional a, IsConst a, IsFloating a, Value a ~ av) =>+        RealFrac (CodeGenFunction r av) where+    properFraction _ = error "CodeGenFunction Value: properFraction"++instance+    (CmpRet a, CallIntrinsic a, Floating a, IsConst a, IsFloating a, Value a ~ av) =>+        Floating (CodeGenFunction r av) where+    pi = return $ valueOf pi+    sqrt = callIntrinsic1 "sqrt"+    sin = callIntrinsic1 "sin"+    cos = callIntrinsic1 "cos"+    (**) = callIntrinsic2 "pow"+    exp = callIntrinsic1 "exp"+    log = callIntrinsic1 "log"++    asin _ = error "LLVM missing intrinsic: asin"+    acos _ = error "LLVM missing intrinsic: acos"+    atan _ = error "LLVM missing intrinsic: atan"++    sinh x           = (exp x - exp (-x)) / 2+    cosh x           = (exp x + exp (-x)) / 2+    asinh x          = log (x + sqrt (x*x + 1))+    acosh x          = log (x + sqrt (x*x - 1))+    atanh x          = (log (1 + x) - log (1 - x)) / 2++instance+    (CmpRet a, CallIntrinsic a, RealFloat a, IsConst a, IsFloating a, Value a ~ av) =>+        RealFloat (CodeGenFunction r av) where+    floatRadix _ = floatRadix (undefined :: a)+    floatDigits _ = floatDigits (undefined :: a)+    floatRange _ = floatRange (undefined :: a)+    decodeFloat _ = error "CodeGenFunction Value: decodeFloat"+    encodeFloat _ _ = error "CodeGenFunction Value: encodeFloat"+    exponent _ = 0+    scaleFloat 0 x = x+    scaleFloat _ _ = error "CodeGenFunction Value: scaleFloat"+    isNaN _ = error "CodeGenFunction Value: isNaN"+    isInfinite _ = error "CodeGenFunction Value: isInfinite"+    isDenormalized _ = error "CodeGenFunction Value: isDenormalized"+    isNegativeZero _ = error "CodeGenFunction Value: isNegativeZero"+    isIEEE _ = isIEEE (undefined :: a)++binop :: (Value a -> Value b -> TValue r c) ->+         TValue r a -> TValue r b -> TValue r c+binop op x y = do+    x' <- x+    y' <- y+    op x' y'++-------------------------------------------++{- |+Turn+@(a -> b -> CodeGenFunction r c)@+into+@(a -> b -> CodeGenFunction r ())@+for @r ~ Result c@+-}+class (RetB a ~ b, CodeValue a ~ z, RetA z b ~ a) => Return z a b where+    type RetA z b+    type RetB a+    addRet :: a -> b++instance+    (Ret z, Result z ~ r, r ~ ra, r ~ rb, z ~ a, unit ~ ()) =>+        Return z (CodeGenFunction ra a) (CodeGenFunction rb unit) where+    type RetA z (CodeGenFunction rb unit) = CodeGenFunction (Result z) z+    type RetB (CodeGenFunction ra a) = CodeGenFunction ra ()+    addRet code = ret =<< code++instance (Return z b0 b1, a0 ~ a1) => Return z (a0 -> b0) (a1 -> b1) where+    type RetA z (a1 -> b1) = a1 -> RetA z b1+    type RetB (a0 -> b0) = a0 -> RetB b0+    addRet f = addRet . f+++class (FunA r b ~ a, FunB a ~ b, CodeResult a ~ r) => ArithFunction r a b where+    type FunA r b+    type FunB a+    arithFunction' :: a -> b++instance+    (r ~ ra, r ~ rb, a ~ b) =>+        ArithFunction r (CodeGenFunction ra a) (CodeGenFunction rb b) where+    type FunA r (CodeGenFunction rb b) = CodeGenFunction r b+    type FunB (CodeGenFunction ra a) = CodeGenFunction ra a+    arithFunction' x = x++instance+    (ArithFunction r b0 b1, a0 ~ CodeGenFunction r a1) =>+        ArithFunction r (a0 -> b0) (a1 -> b1) where+    type FunA r (a1 -> b1) = CodeGenFunction r a1 -> FunA r b1+    type FunB (a0 -> b0) = CodeValue a0 -> FunB b0+    arithFunction' f = arithFunction' . f . return++-- |Unlift a function with @TValue@ to have @Value@ arguments.+arithFunction :: (ArithFunction r a b, r ~ Result z, Return z b c) => a -> c+arithFunction = addRet . arithFunction'+++class+    (TFunB r a ~ b, TFunA b ~ a, CodeResult b ~ r, IsFunction a) =>+        ToArithFunction r a b where+    type TFunA b+    type TFunB r a+    toArithFunction' :: CodeGenFunction r (Call a) -> b++instance+    (Value a ~ b, IsFirstClass a) =>+        ToArithFunction r (IO a) (CodeGenFunction r b) where+    type TFunA (CodeGenFunction r b) = IO (UnValue b)+    type TFunB r (IO a) = TValue r a+    toArithFunction' cl = runCall =<< cl++instance+    (ToArithFunction r b0 b1, CodeGenFunction r (Value a0) ~ a1,+     IsFirstClass a0) =>+        ToArithFunction r (a0 -> b0) (a1 -> b1) where+    type TFunA (a1 -> b1) = UnValue (CodeValue a1) -> TFunA b1+    type TFunB r (a0 -> b0) = TValue r a0 -> TFunB r b0+    toArithFunction' cl x =+        toArithFunction' (liftM2 applyCall cl x)+++_toArithFunction2 ::+    (IsFirstClass a, IsFirstClass b, IsFirstClass c) =>+    Function (a -> b -> IO c) -> TValue r a -> TValue r b -> TValue r c+_toArithFunction2 f tx ty = do+    x <- tx+    y <- ty+    runCall $ callFromFunction f `applyCall` x `applyCall` y++-- |Lift a function from having @Value@ arguments to having @TValue@ arguments.+toArithFunction :: (ToArithFunction r f g) => Function f -> g+toArithFunction = toArithFunction' . return . callFromFunction++-------------------------------------------++-- |Define a recursive 'arithFunction', gets passed itself as the first argument.+recursiveFunction ::+    (IsFunction f, FunctionArgs f, code ~ FunctionCodeGen f,+     ArithFunction r arith open, r ~ Result z, Return z open code,+     ToArithFunction r f g) =>+    (g -> arith) -> CodeGenModule (Function f)+recursiveFunction af = do+    f <- newFunction ExternalLinkage+    defineFunction f $ arithFunction $ af $ toArithFunction f+    return f+++-------------------------------------------++class CallIntrinsic a where+    callIntrinsic1' :: String -> Value a -> TValue r a+    callIntrinsic2' :: String -> Value a -> Value a -> TValue r a++instance CallIntrinsic Float where+    callIntrinsic1' = Intrinsic.call1+    callIntrinsic2' = Intrinsic.call2++instance CallIntrinsic Double where+    callIntrinsic1' = Intrinsic.call1+    callIntrinsic2' = Intrinsic.call2++{-+I think such a special case for certain systems+would be better handled as in LLVM.Extra.Extension.+(lemming)+-}+macOS :: Bool+#if defined(__MACOS__)+macOS = True+#else+macOS = False+#endif++instance (Dec.Positive n, IsPrimitive a, CallIntrinsic a) => CallIntrinsic (Vector n a) where+    callIntrinsic1' s x =+       if macOS && Dec.integerFromSingleton (Dec.singleton :: Dec.Singleton n) == 4 &&+          elem s ["sqrt", "log", "exp", "sin", "cos", "tan"]+         then do+            op <- externFunction ("v" ++ s ++ "f")+            call op x+         else mapVector (callIntrinsic1' s) x+    callIntrinsic2' s = mapVector2 (callIntrinsic2' s)++callIntrinsic1 :: (CallIntrinsic a) => String -> TValue r a -> TValue r a+callIntrinsic1 s x = do x' <- x; callIntrinsic1' s x'++callIntrinsic2 :: (CallIntrinsic a) => String -> TValue r a -> TValue r a -> TValue r a+callIntrinsic2 s = binop (callIntrinsic2' s)
+ src/LLVM/Util/File.hs view
@@ -0,0 +1,10 @@+module LLVM.Util.File (writeCodeGenModule) where++import qualified LLVM.Core as LLVM+++writeCodeGenModule :: FilePath -> LLVM.CodeGenModule a -> IO ()+writeCodeGenModule path f = do+    m <- LLVM.newModule+    _ <- LLVM.defineModule m f+    LLVM.writeBitcodeToFile path m
+ src/LLVM/Util/Foreign.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE ScopedTypeVariables #-}+-- These are replacements for the broken equivalents in Foreign.*.+-- The functions in Foreign.* do not obey the required alignment.+module LLVM.Util.Foreign where++import qualified LLVM.ExecutionEngine as EE+import qualified LLVM.Util.Proxy as LP+import qualified LLVM.Core as LLVM++import Foreign.Marshal.Alloc (allocaBytes)+import Foreign.Ptr (alignPtr)+++with :: (EE.Marshal a) => a -> (LLVM.Ptr a -> IO b) -> IO b+with x act =+    alloca $ \ p -> do+    EE.poke p x+    act p++alloca :: forall a b. (EE.Marshal a) => (LLVM.Ptr a -> IO b) -> IO b+alloca act =+    allocaBytes (2 * EE.sizeOf (LP.Proxy :: LP.Proxy a)) $ \ p ->+        act $ LLVM.uncheckedFromPtr $+        alignPtr p (EE.alignment (LP.Proxy :: LP.Proxy a))++withArrayLen :: (EE.Marshal a) => [a] -> (Int -> LLVM.Ptr a -> IO b) -> IO b+withArrayLen xs act =+    let l = length xs in+    allocaBytes ((l+1) * EE.sizeOf (proxyFromList xs)) $ \ p -> do+    let p' =+            LLVM.uncheckedFromPtr $+            alignPtr p $ EE.alignment $ proxyFromList xs+    EE.pokeList p' xs+    act l p'++proxyFromList :: [a] -> LP.Proxy a+proxyFromList _ = LP.Proxy
+ src/LLVM/Util/Intrinsic.hs view
@@ -0,0 +1,71 @@+module LLVM.Util.Intrinsic (+   min, max, abs,+   truncate, floor,+   maybeUAddSat, maybeSAddSat, maybeUSubSat, maybeSSubSat,++   call1, call2,+   ) where++import qualified LLVM.Core.Proxy as LP+import qualified LLVM.Core as LLVM+import LLVM.Core+   (CodeGenFunction, Value, IsType, IsFirstClass,+    IsArithmetic, IsInteger, IsFloating)++import qualified LLVM.FFI.Core as FFI++import Data.Maybe.HT (toMaybe)++import Prelude hiding (min, max, abs, truncate, floor)+++valueTypeName :: (IsType a) => Value a -> String+valueTypeName =+   LLVM.intrinsicTypeName . ((\_ -> LP.Proxy) :: Value a -> LP.Proxy a)++functionName :: (IsType a) => String -> Value a -> String+functionName fn x = "llvm." ++ fn ++ "." ++ valueTypeName x++call1 ::+   (IsFirstClass a) =>+   String -> Value a -> CodeGenFunction r (Value a)+call1 fn x = do+   op <- LLVM.externFunction $ functionName fn x+   LLVM.call op x++call2 ::+   (IsFirstClass a) =>+   String -> Value a -> Value a -> CodeGenFunction r (Value a)+call2 fn x y = do+   op <- LLVM.externFunction $ functionName fn x+   LLVM.call op x y++++min, max ::+   (IsArithmetic a) => Value a -> Value a -> CodeGenFunction r (Value a)+min = call2 "minnum"+max = call2 "maxnum"++abs :: (IsArithmetic a) => Value a -> CodeGenFunction r (Value a)+abs = call1 "fabs"++truncate, floor :: (IsFloating a) => Value a -> CodeGenFunction r (Value a)+truncate = call1 "trunc"+floor = call1 "floor"+++{- |+Available since LLVM-8.+-}+maybeUAddSat, maybeSAddSat, maybeUSubSat, maybeSSubSat ::+   (IsInteger a) => Maybe (Value a -> Value a -> CodeGenFunction r (Value a))+maybeUAddSat = opsat "uadd"+maybeSAddSat = opsat "sadd"+maybeUSubSat = opsat "usub"+maybeSSubSat = opsat "ssub"++opsat ::+   (IsFirstClass a) =>+   String -> Maybe (Value a -> Value a -> CodeGenFunction r (Value a))+opsat name = toMaybe (FFI.version >= 800) $ call2 (name++".sat")
+ src/LLVM/Util/Loop.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+module LLVM.Util.Loop(Phi(phis,addPhis), forLoop, mapVector, mapVector2) where++import LLVM.Core+import qualified Type.Data.Num.Decimal.Number as Dec+++class Phi a where+    phis :: BasicBlock -> a -> CodeGenFunction r a+    addPhis :: BasicBlock -> a -> a -> CodeGenFunction r ()++{-+infixr 1 :*+-- XXX should use HList if it was packaged in a nice way.+data a :* b = a :* b+    deriving (Eq, Ord, Show, Read)++instance (IsFirstClass a, Phi b) => Phi (Value a :* b) where+    phis bb (a :* b) = do+        a' <- phi [(a, bb)]+        b' <- phis bb b+        return (a' :* b')+    addPhis bb (a :* b) (a' :* b') = do+        addPhiInputs a [(a', bb)]+        addPhis bb b b'+-}++instance Phi () where+    phis _ _ = return ()+    addPhis _ _ _ = return ()++instance (IsFirstClass a) => Phi (Value a) where+    phis bb a = do+        a' <- phi [(a, bb)]+        return a'+    addPhis bb a a' = do+        addPhiInputs a [(a', bb)]++instance (Phi a, Phi b) => Phi (a, b) where+    phis bb (a, b) = do+        a' <- phis bb a+        b' <- phis bb b+        return (a', b')+    addPhis bb (a, b) (a', b') = do+        addPhis bb a a'+        addPhis bb b b'++instance (Phi a, Phi b, Phi c) => Phi (a, b, c) where+    phis bb (a, b, c) = do+        a' <- phis bb a+        b' <- phis bb b+        c' <- phis bb c+        return (a', b', c')+    addPhis bb (a, b, c) (a', b', c') = do+        addPhis bb a a'+        addPhis bb b b'+        addPhis bb c c'++-- Loop the index variable from low to high.  The state in the loop starts as start, and is modified+-- by incr in each iteration.+forLoop :: forall i a r . (Phi a, Num i, IsConst i, IsInteger i, IsFirstClass i, CmpRet i, CmpResult i ~ Bool) =>+           Value i -> Value i -> a -> (Value i -> a -> CodeGenFunction r a) -> CodeGenFunction r a+forLoop low high start incr = do+    top <- getCurrentBasicBlock+    loop <- newBasicBlock+    body <- newBasicBlock+    exit <- newBasicBlock++    br loop++    defineBasicBlock loop+    i <- phi [(low, top)]+    vars <- phis top start+    t <- cmp CmpNE i high+    condBr t body exit++    defineBasicBlock body++    vars' <- incr i vars+    i' <- add i (valueOf 1 :: Value i)++    body' <- getCurrentBasicBlock+    addPhis body' vars vars'+    addPhiInputs i [(i', body')]+    br loop+    defineBasicBlock exit++    return vars++--------------------------------------++mapVector :: forall a b n r .+             (Dec.Positive n, IsPrimitive a, IsPrimitive b) =>+             (Value a -> CodeGenFunction r (Value b)) ->+             Value (Vector n a) -> CodeGenFunction r (Value (Vector n b))+mapVector f v =+    forLoop (valueOf 0) (valueOf (Dec.integralFromSingleton (Dec.singleton :: Dec.Singleton n))) (value undef) $ \ i w -> do+        x <- extractelement v i+        y <- f x+        insertelement w y i++mapVector2 :: forall a b c n r .+             (Dec.Positive n, IsPrimitive a, IsPrimitive b, IsPrimitive c) =>+             (Value a -> Value b -> CodeGenFunction r (Value c)) ->+             Value (Vector n a) -> Value (Vector n b) -> CodeGenFunction r (Value (Vector n c))+mapVector2 f v1 v2 =+    forLoop (valueOf 0) (valueOf (Dec.integralFromSingleton (Dec.singleton :: Dec.Singleton n))) (value undef) $ \ i w -> do+        x <- extractelement v1 i+        y <- extractelement v2 i+        z <- f x y+        insertelement w z i
+ src/LLVM/Util/Memory.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fsimpl-tick-factor=500 #-}+{-+ToDo: remove simplifier ticket option++Necessary for GHC-9.4 because of bug https://gitlab.haskell.org/ghc/ghc/-/issues/22716+-}+module LLVM.Util.Memory (+    memcpy,+    memmove,+    memset,+    IsLengthType,+    ) where++import LLVM.Core.Proxy (Proxy(Proxy))+import LLVM.Core++import Data.Word (Word8, Word32, Word64, Word)++import Control.Functor.HT (void, )+++class IsFirstClass len => IsLengthType len where++instance IsLengthType Word where+instance IsLengthType Word32 where+instance IsLengthType Word64 where+++memcpyFunc ::+   forall len.+   IsLengthType len =>+   TFunction (Ptr Word8 -> Ptr Word8 -> len -> Word32 -> Bool -> IO ())+memcpyFunc =+   newNamedFunction ExternalLinkage $+      "llvm.memcpy.p0i8.p0i8." ++ intrinsicTypeName (Proxy :: Proxy len)++memcpy ::+   IsLengthType len =>+   CodeGenModule+      (Value (Ptr Word8) ->+       Value (Ptr Word8) ->+       Value len ->+       Value Word32 ->+       Value Bool ->+       CodeGenFunction r ())+memcpy =+   fmap+      (\f dest src len align volatile ->+          void $ call f dest src len align volatile)+      memcpyFunc+++memmoveFunc ::+   forall len.+   IsLengthType len =>+   TFunction (Ptr Word8 -> Ptr Word8 -> len -> Word32 -> Bool -> IO ())+memmoveFunc =+   newNamedFunction ExternalLinkage $+      "llvm.memmove.p0i8.p0i8." ++ intrinsicTypeName (Proxy :: Proxy len)++memmove ::+   IsLengthType len =>+   CodeGenModule+      (Value (Ptr Word8) ->+       Value (Ptr Word8) ->+       Value len ->+       Value Word32 ->+       Value Bool ->+       CodeGenFunction r ())+memmove =+   fmap+      (\f dest src len align volatile ->+          void $ call f dest src len align volatile)+      memmoveFunc+++memsetFunc ::+   forall len.+   IsLengthType len =>+   TFunction (Ptr Word8 -> Word8 -> len -> Word32 -> Bool -> IO ())+memsetFunc =+   newNamedFunction ExternalLinkage $+      "llvm.memset.p0i8." ++ intrinsicTypeName (Proxy :: Proxy len)++memset ::+   IsLengthType len =>+   CodeGenModule+      (Value (Ptr Word8) ->+       Value Word8 ->+       Value len ->+       Value Word32 ->+       Value Bool ->+       CodeGenFunction r ())+memset =+   fmap+      (\f dest val len align volatile ->+          void $ call f dest val len align volatile)+      memsetFunc
+ src/LLVM/Util/Optimize.hs view
@@ -0,0 +1,102 @@+module LLVM.Util.Optimize(optimizeModule) where++import LLVM.Core.Util (Module, withModule)++import qualified LLVM.FFI.Transforms.PassBuilder as PB+import qualified LLVM.FFI.TargetMachine as TM+import qualified LLVM.FFI.Error as Error+import qualified LLVM.FFI.Core as FFI++import qualified Foreign.Marshal.Alloc as Alloc+import qualified Foreign.C.String as CStr+import Foreign.C.String (withCString)+import Foreign.Storable (peek)+import Foreign.Ptr (Ptr, nullPtr)++import Control.Exception (bracket)+import Control.Monad (when)++import Text.Printf (printf)+++failFromError :: Ptr CStr.CString -> IO a+failFromError errorRef =+    bracket (peek errorRef) Alloc.free $ \errorMsg ->+        CStr.peekCString errorMsg >>= fail++getTargetFromTriple :: TM.Triple -> IO TM.TargetRef+getTargetFromTriple triple =+    Alloc.alloca $ \targetRef ->+    Alloc.alloca $ \errorRef -> do+        failure <- TM.getTargetFromTriple triple targetRef errorRef+        if FFI.deconsBool failure+            then failFromError errorRef+            else peek targetRef++{- |+It is very important that you set target triple and target data layout+before optimizing.+Otherwise the optimizer will make wrong assumptions+and e.g. corrupt your record offsets.+See e.g. example/Array for how this can be achieved.++In the future I might enforce via types+that you set target parameters before optimization.+-}+optimizeModule :: Int -> Module -> IO ()+optimizeModule optLevel mdl =+    withModule mdl $ \ modul ->++    (FFI.getTarget modul >>=) $ \triple ->+    (getTargetFromTriple triple >>=) $ \target ->+    (TM.getHostCPUName >>=) $ \cpu ->+    withCString "" $ \features ->++    bracket+        (TM.createTargetMachine target triple cpu features+            TM.codeGenLevelDefault TM.relocDefault TM.codeModelDefault)+        TM.disposeTargetMachine $+            \tm ->++    bracket PB.createPassBuilderOptions PB.disposePassBuilderOptions $+        \pbOpt ->++    withCString (printf "default<O%d>" optLevel) $ \passName -> do+        PB.passBuilderOptionsSetVerifyEach pbOpt FFI.true+        errorRef <- PB.runPasses modul passName tm pbOpt+        when (errorRef /= nullPtr) $+            bracket+                (Error.getErrorMessage errorRef)+                Error.disposeErrorMessage+                    $ \errorMsg ->+                CStr.peekCString errorMsg >>= fail++{-+ToDo:+Function that adds passes according to a list of opt-options.+This would simplify to get consistent behaviour between opt and optimizeModule.++-adce                      addAggressiveDCEPass+-deadargelim               addDeadArgEliminationPass+-deadtypeelim              addDeadTypeEliminationPass+-dse                       addDeadStoreEliminationPass+-functionattrs             addFunctionAttrsPass+-globalopt                 addGlobalOptimizerPass+-indvars                   addIndVarSimplifyPass+-instcombine               addInstructionCombiningPass+-ipsccp                    addIPSCCPPass+-jump-threading            addJumpThreadingPass+-licm                      addLICMPass+-loop-deletion             addLoopDeletionPass+-loop-rotate               addLoopRotatePass+-memcpyopt                 addMemCpyOptPass+-prune-eh                  addPruneEHPass+-reassociate               addReassociatePass+-scalarrepl                addScalarReplAggregatesPass+-sccp                      addSCCPPass+-simplifycfg               addCFGSimplificationPass+-simplify-libcalls         addSimplifyLibCallsPass+-strip-dead-prototypes     addStripDeadPrototypesPass+-tailcallelim              addTailCallEliminationPass+-verify                    addVerifierPass+-}
+ src/LLVM/Util/Proxy.hs view
@@ -0,0 +1,5 @@+module LLVM.Util.Proxy (+   module LLVM.Core.Proxy,+   ) where++import LLVM.Core.Proxy
+ test/Main.hs view
@@ -0,0 +1,21 @@+module Main where++import qualified Test.Marshal as Marshal+import qualified Test.Chop as Chop++import qualified LLVM.Core as LLVM++import Data.Tuple.HT (mapPair, mapFst)++import qualified Test.QuickCheck as QC+++main :: IO ()+main = do+   LLVM.initializeNativeTarget++   mapM_ (\(msg,prop) -> putStr (msg++": ") >> prop >>= QC.quickCheck) $+      map (mapPair (("Chop."++),return)) Chop.tests +++      map (mapPair (("Marshal."++),return)) Marshal.testsRoundTrip +++      map (mapFst ("Marshal."++)) Marshal.testsExtract +++      []
+ test/Test/Chop.hs view
@@ -0,0 +1,63 @@+module Test.Chop where++import qualified LLVM.ExecutionEngine.Marshal as Marshal++import Data.Bits (shiftL)+import Data.Word (Word8)++import qualified Test.QuickCheck as QC+++divUp :: Integral a => a -> a -> a+divUp a b = - div (-a) b++expandBits :: [Word8] -> Bool+expandBits xs  =  xs == Marshal.gatherBits (Marshal.expandBits xs)++gatherBits :: [Bool] -> Bool+gatherBits xs =+    Marshal.gatherBits xs+    ==+    (take (divUp (length xs) 8) $ map fromIntegral $+     Marshal.chop 1 8 $ map (toInteger . fromEnum) xs)++forAllBitWidth :: (Int -> QC.Property) -> QC.Property+forAllBitWidth = QC.forAll (QC.choose (1,100))++chopBig :: QC.NonNegative Int -> QC.Property+chopBig (QC.NonNegative k) =+    forAllBitWidth $ \m ->+    forAllBitWidth $ \n ->+    QC.forAll (QC.listOf $ QC.choose (0, shiftL 1 m - 1)) $ \xs ->+        take k (Marshal.chop m n xs)+        ==+        take k (Marshal.split n $ Marshal.merge m xs)++chop :: QC.NonNegative Int -> QC.Property+chop (QC.NonNegative k) =+    forAllBitWidth $ \m ->+    forAllBitWidth $ \n ->+    QC.forAll (QC.listOf $ QC.choose (0, shiftL 1 m - 1)) $ \xs ->+        take k (Marshal.chop n m $ Marshal.chop m n xs)+        ==+        take k (xs ++ repeat 0)++chopSigned :: QC.NonNegative Int -> QC.Property+chopSigned (QC.NonNegative k) =+    forAllBitWidth $ \m ->+    forAllBitWidth $ \n ->+    QC.forAll (QC.listOf $ QC.choose (- shiftL 1 m, shiftL 1 m - 1)) $ \xs ->+        take k (map (Marshal.adjustSign (m+1)) $ Marshal.chop n (m+1) $+                Marshal.chop (m+1) n $ map (Marshal.cut (m+1)) xs)+        ==+        take k (xs ++ repeat 0)+++tests :: [(String, QC.Property)]+tests =+    ("expandBits", QC.property expandBits) :+    ("gatherBits", QC.property gatherBits) :+    ("chopBig",  QC.property chopBig) :+    ("chop", QC.property chop) :+    ("chopSigned", QC.property chopSigned) :+    []
+ test/Test/Marshal.hs view
@@ -0,0 +1,280 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE Rank2Types #-}+module Test.Marshal (testsRoundTrip, testsExtract) where++import qualified LLVM.ExecutionEngine as EE+import qualified LLVM.Util.Optimize as Opt+import qualified LLVM.Util.Proxy as LP+import qualified LLVM.Core as LLVM++import qualified Type.Data.Num.Decimal as TypeNum+import Type.Base.Proxy (Proxy(Proxy))++import Foreign.Ptr (FunPtr, Ptr, nullPtr, plusPtr, castPtr)++import qualified Data.Foldable as Fold+import Data.Word (Word8, Word16, Word32, Word64)+import Data.Int (Int8, Int16, Int32, Int64)+import Data.Tuple.HT (mapPair, mapFst)++import qualified Test.QuickCheck.Monadic as QCMon+import qualified Test.QuickCheck as QC++import Control.Monad (liftM2, void, (<=<))++++type RoundTrip a = a -> QC.Property+type RoundTripVec n a = RoundTrip (LLVM.Vector n a)++roundTrip :: (EE.Marshal a, Eq a) => RoundTrip a+roundTrip x =+   QCMon.monadicIO $ do+      y <- QCMon.run $ EE.with x EE.peek+      QCMon.assert $ x==y++testsRoundTrip :: [(String, QC.Property)]+testsRoundTrip =+   map (mapFst ("RoundTrip." ++)) $+   ("f32", QC.property (roundTrip :: RoundTrip Float)) :+   ("f64", QC.property (roundTrip :: RoundTrip Double)) :+   ("i1", QC.property (roundTrip :: RoundTrip Bool)) :+   ("i2", QC.property (roundTrip :: RoundTrip Int2)) :+   ("i3", QC.property (roundTrip :: RoundTrip Int3)) :+   ("i24", QC.property (roundTrip :: RoundTrip Int24)) :+   ("i64", QC.property (roundTrip :: RoundTrip Int64)) :+   ("i2", QC.property (roundTrip :: RoundTrip Word2)) :+   ("i3", QC.property (roundTrip :: RoundTrip Word3)) :+   ("i17", QC.property (roundTrip :: RoundTrip Word17)) :+   ("i32", QC.property (roundTrip :: RoundTrip Word32)) :+   ("ptr", QC.property ((roundTrip :: RoundTrip (Ptr Word8)) . plusPtr nullPtr)) :+   ("()", QC.property (roundTrip :: RoundTrip (LLVM.Struct ()))) :+   ("struct-i8",+      QC.property (roundTrip :: RoundTrip (LLVM.Struct (Word8,())))) :+   ("struct-i8-i24",+      QC.property (roundTrip :: RoundTrip (LLVM.Struct (Word8,(Int24,()))))) :+   ("struct-i3-f32",+      QC.property (roundTrip :: RoundTrip (LLVM.Struct (Int3,(Float,()))))) :+   ("struct-i16-i1-i64",+      QC.property+         (roundTrip :: RoundTrip (LLVM.Struct (Int16,(Bool,(Word64,())))))) :+   ("v8f32", QC.property (roundTrip :: RoundTripVec TypeNum.D8 Float)) :+   ("v5f64", QC.property (roundTrip :: RoundTripVec TypeNum.D5 Double)) :+   ("v7i1", QC.property (roundTrip :: RoundTripVec TypeNum.D7 Bool)) :+   ("v13i1", QC.property (roundTrip :: RoundTripVec TypeNum.D13 Bool)) :+   ("v4i2", QC.property (roundTrip :: RoundTripVec TypeNum.D4 Int2)) :+   ("v10i2", QC.property (roundTrip :: RoundTripVec TypeNum.D10 Word2)) :+   ("v7i3", QC.property (roundTrip :: RoundTripVec TypeNum.D7 Int3)) :+   ("v5i3", QC.property (roundTrip :: RoundTripVec TypeNum.D5 Word3)) :+   ("v9i24", QC.property (roundTrip :: RoundTripVec TypeNum.D9 Int24)) :+   ("v3i17", QC.property (roundTrip :: RoundTripVec TypeNum.D3 Word17)) :+   ("v5i8", QC.property (roundTrip :: RoundTripVec TypeNum.D5 Word8)) :+   ("v3i16", QC.property (roundTrip :: RoundTripVec TypeNum.D3 Word16)) :+   ("v4i8", QC.property (roundTrip :: RoundTripVec TypeNum.D4 Int8)) :+   ("v7i32", QC.property (roundTrip :: RoundTripVec TypeNum.D7 Int32)) :+   []+++type Importer func = FunPtr func -> func++generateFunction ::+   EE.ExecutionFunction f =>+   Importer f -> LLVM.CodeGenModule (LLVM.Function f) -> IO f+generateFunction imprt code = do+   td <- EE.getTargetData+   (m,func) <-+      LLVM.createModule $ do+         LLVM.setTarget LLVM.hostTriple+         LLVM.setDataLayout $ EE.dataLayoutStr td+         liftM2 (,) LLVM.getModule code+   LLVM.writeBitcodeToFile "Test.bc" m+   void $ Opt.optimizeModule 3 m+   LLVM.writeBitcodeToFile "TestOpt.bc" m+   EE.runEngineAccessWithModule m $ EE.getExecutionFunction imprt func+++foreign import ccall safe "dynamic" derefTestCasePtr ::+   Importer (LLVM.Ptr inp -> LLVM.Ptr out -> IO ())++modul ::+   (LLVM.IsType inp, LLVM.IsType out) =>+   (LLVM.Value inp -> LLVM.CodeGenFunction () (LLVM.Value out)) ->+   LLVM.CodeGenModule (LLVM.Function (LLVM.Ptr inp -> LLVM.Ptr out -> IO ()))+modul codegen =+   LLVM.createFunction LLVM.ExternalLinkage $ \xPtr yPtr -> do+      flip LLVM.store yPtr =<< codegen =<< LLVM.load xPtr+      LLVM.ret ()++run ::+   (Show inp, EE.Marshal inp, EE.Marshal out) =>+   QC.Gen inp ->+   (LLVM.Value inp -> LLVM.CodeGenFunction () (LLVM.Value out)) ->+   (inp -> out -> Bool) ->+   IO QC.Property+run qcgen codegen predicate = do+   funIO <- generateFunction derefTestCasePtr $ modul codegen+   return $ QC.forAll qcgen $ \x ->+      QCMon.monadicIO $ do+         y <-+            QCMon.run $+               EE.with x $ \xPtr ->+               EE.alloca $ \yPtr -> do+                  funIO xPtr yPtr+                  EE.peek yPtr+         QCMon.assert $ predicate x y+++type Extract n a = QC.Gen (LLVM.Vector n a, Word32)++extractElem ::+   (TypeNum.Positive n,+    (n TypeNum.:*: LLVM.SizeOf a) ~ size, TypeNum.Natural size,+    Show a, Eq a,+    EE.MarshalVector a, EE.Marshal a, LLVM.IsSized a, LLVM.IsPrimitive a) =>+   Extract n a -> IO QC.Property+extractElem qcgen =+   run+      (fmap (uncurry LLVM.consStruct) qcgen)+      (\vi -> do+         v <- LLVM.extractvalue vi TypeNum.d0+         i <- LLVM.extractvalue vi TypeNum.d1+         LLVM.extractelement v i)+      (LLVM.uncurryStruct $ \v i a ->+         a == Fold.toList v !! fromIntegral i)+++vectorSize :: LLVM.Vector n a -> Proxy n+vectorSize _ = Proxy++genVector :: (TypeNum.Positive n, QC.Arbitrary a) => Extract n a+genVector = do+   v <- QC.arbitrary+   i <- QC.choose (0, TypeNum.integralFromProxy (vectorSize v) - 1)+   return (v,i)+++type Int2 = LLVM.IntN TypeNum.D2+type Int3 = LLVM.IntN TypeNum.D3+type Word2 = LLVM.WordN TypeNum.D2+type Word3 = LLVM.WordN TypeNum.D3+type Int24 = LLVM.IntN TypeNum.D24+type Word17 = LLVM.IntN TypeNum.D17+++testsVector :: [(String, IO QC.Property)]+testsVector =+   map (mapFst ("Vector." ++)) $+   ("v8f32", extractElem (genVector :: Extract TypeNum.D8 Float)) :+   ("v5f64", extractElem (genVector :: Extract TypeNum.D5 Double)) :+   ("v7i1", extractElem (genVector :: Extract TypeNum.D7 Bool)) :+   ("v13i1", extractElem (genVector :: Extract TypeNum.D13 Bool)) :+   ("v4i2", extractElem (genVector :: Extract TypeNum.D4 Int2)) :+   ("v10i2", extractElem (genVector :: Extract TypeNum.D10 Word2)) :+   -- ToDo: broken on LLVM<=9: https://bugs.llvm.org/show_bug.cgi?id=44915+   ("v7i3", extractElem (genVector :: Extract TypeNum.D7 Int3)) :+   ("v5i3", extractElem (genVector :: Extract TypeNum.D5 Word3)) :+   ("v9i24", extractElem (genVector :: Extract TypeNum.D9 Int24)) :+   ("v3i17", extractElem (genVector :: Extract TypeNum.D3 Word17)) :+   ("v5i8", extractElem (genVector :: Extract TypeNum.D5 Word8)) :+   ("v3i16", extractElem (genVector :: Extract TypeNum.D3 Word16)) :+   ("v4i8", extractElem (genVector :: Extract TypeNum.D4 Int8)) :+   ("v7i32", extractElem (genVector :: Extract TypeNum.D7 Int32)) :+   []+++{-+Conversion from a Ptr Word8 triggers improper optimization+if target data layout is not set for module prior to optimization.+-}+runViaBytePtr ::+   (Show inp, EE.Marshal inp, EE.Marshal out) =>+   QC.Gen inp ->+   (LLVM.Value inp -> LLVM.CodeGenFunction () (LLVM.Value out)) ->+   (inp -> out -> Bool) ->+   IO QC.Property+runViaBytePtr qcgen codegen predicate = do+   funIO <-+      generateFunction derefTestCasePtr $+         LLVM.createFunction LLVM.ExternalLinkage $ \xPtr yPtr -> do+            flip LLVM.store yPtr =<< codegen =<< LLVM.load =<< LLVM.bitcast xPtr+            LLVM.ret ()+   return $ QC.forAll qcgen $ \x ->+      QCMon.monadicIO $ do+         y <-+            QCMon.run $+               EE.with x $ \xPtr ->+               EE.alloca $ \yPtr -> do+                  funIO (castToBytePtr xPtr) yPtr+                  EE.peek yPtr+         QCMon.assert $ predicate x y++castToBytePtr :: LLVM.Ptr a -> LLVM.Ptr Word8+castToBytePtr = LLVM.fromPtr . castPtr . LLVM.uncheckedToPtr++extractValue ::+   (QC.Arbitrary s, Show s, EE.Marshal s, EE.Marshal a, Eq a) =>+   LP.Proxy s ->+   (s -> a) ->+   (forall r. LLVM.Value s -> LLVM.CodeGenFunction r (LLVM.Value a)) ->+   Bool ->+   IO QC.Property+extractValue LP.Proxy select extract viaBytePtr =+   (if viaBytePtr then runViaBytePtr else run)+      QC.arbitrary extract (\s x -> select s == x)++type Pair a b = LLVM.Struct (a,(b,()))+type Triple a b c = LLVM.Struct (a,(b,(c,())))++sfst :: LLVM.Struct (a,z) -> a+sfst (LLVM.Struct (a,_)) = a+ssnd :: LLVM.Struct (a,(b,z)) -> b+ssnd (LLVM.Struct (_,(b,_))) = b+sthd :: LLVM.Struct (a,(b,(c,z))) -> c+sthd (LLVM.Struct (_,(_,(c,_)))) = c++exv ::+   (LLVM.GetField s i, TypeNum.Natural i, LLVM.FieldType s i ~ a) =>+   Proxy i ->+   LLVM.Value (LLVM.Struct s) -> LLVM.CodeGenFunction r (LLVM.Value a)+exv = flip LLVM.extractvalue++proxyA :: LP.Proxy (Triple Int16 Bool Word64)+proxyA = LP.Proxy++proxyB :: LP.Proxy (Triple Bool Bool Int8)+proxyB = LP.Proxy++proxyC :: LP.Proxy (Pair Bool (Pair Float Word64))+proxyC = LP.Proxy++testsStruct :: [(String, Bool -> IO QC.Property)]+testsStruct =+   ("{i16,i1,i64} 0",+      extractValue proxyA sfst (exv TypeNum.d0)) :+   ("{i16,i1,i64} 1",+      extractValue proxyA ssnd (exv TypeNum.d1)) :+   ("{i16,i1,i64} 2",+      extractValue proxyA sthd (exv TypeNum.d2)) :+   ("{i1,i1,i8} 0",+      extractValue proxyB sfst (exv TypeNum.d0)) :+   ("{i1,i1,i8} 1",+      extractValue proxyB ssnd (exv TypeNum.d1)) :+   ("{i1,i1,i8} 2",+      extractValue proxyB sthd (exv TypeNum.d2)) :+   ("{i1,{float,i64}} 0",+      extractValue proxyC sfst (exv TypeNum.d0)) :+   ("{i1,{float,i64}} 1 0",+      extractValue proxyC (sfst.ssnd) (exv TypeNum.d0 <=< exv TypeNum.d1)) :+   ("{i1,{float,i64}} 1 1",+      extractValue proxyC (ssnd.ssnd) (exv TypeNum.d1 <=< exv TypeNum.d1)) :+   []+++testsExtract :: [(String, IO QC.Property)]+testsExtract =+   map (mapFst ("Extract." ++)) $+      testsVector +++      map (mapPair (("Struct." ++), ($ False))) testsStruct +++      map (mapPair (("StructByte." ++), ($ True))) testsStruct