diff --git a/Changes.md b/Changes.md new file mode 100644 --- /dev/null +++ b/Changes.md @@ -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. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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 + http://www.serpentine.com/blog/ + + Lennart Augustsson + +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 . + + diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/cbits/malloc.c b/cbits/malloc.c new file mode 100644 --- /dev/null +++ b/cbits/malloc.c @@ -0,0 +1,188 @@ +#include +#include + +#ifdef DEBUG +#include +#endif + +#ifdef TEST +#include +#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 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 diff --git a/example/Array.hs b/example/Array.hs new file mode 100644 --- /dev/null +++ b/example/Array.hs @@ -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 diff --git a/example/BrainF.hs b/example/BrainF.hs new file mode 100644 --- /dev/null +++ b/example/BrainF.hs @@ -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 diff --git a/example/CallConv.hs b/example/CallConv.hs new file mode 100644 --- /dev/null +++ b/example/CallConv.hs @@ -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} diff --git a/example/Convert.hs b/example/Convert.hs new file mode 100644 --- /dev/null +++ b/example/Convert.hs @@ -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 + diff --git a/example/DotProd.hs b/example/DotProd.hs new file mode 100644 --- /dev/null +++ b/example/DotProd.hs @@ -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 ()) diff --git a/example/Fibonacci.hs b/example/Fibonacci.hs new file mode 100644 --- /dev/null +++ b/example/Fibonacci.hs @@ -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 diff --git a/example/HelloJIT.hs b/example/HelloJIT.hs new file mode 100644 --- /dev/null +++ b/example/HelloJIT.hs @@ -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 diff --git a/example/Intrinsic.hs b/example/Intrinsic.hs new file mode 100644 --- /dev/null +++ b/example/Intrinsic.hs @@ -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 diff --git a/example/List.hs b/example/List.hs new file mode 100644 --- /dev/null +++ b/example/List.hs @@ -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 diff --git a/example/Struct.hs b/example/Struct.hs new file mode 100644 --- /dev/null +++ b/example/Struct.hs @@ -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" diff --git a/example/Varargs.hs b/example/Varargs.hs new file mode 100644 --- /dev/null +++ b/example/Varargs.hs @@ -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 diff --git a/example/Vector.hs b/example/Vector.hs new file mode 100644 --- /dev/null +++ b/example/Vector.hs @@ -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 diff --git a/example/structCheck.c b/example/structCheck.c new file mode 100644 --- /dev/null +++ b/example/structCheck.c @@ -0,0 +1,9 @@ +#include + +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; +} diff --git a/llvm-tf.cabal b/llvm-tf.cabal new file mode 100644 --- /dev/null +++ b/llvm-tf.cabal @@ -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 +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 diff --git a/private/LLVM/Core/CodeGen.hs b/private/LLVM/Core/CodeGen.hs new file mode 100644 --- /dev/null +++ b/private/LLVM/Core/CodeGen.hs @@ -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 +. +-} +staticFunction :: forall f r. + (IsFunction f) => FunPtr f -> CodeGenFunction r (Function f) +staticFunction = staticNamedFunction "" + +{- | +Due to +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 _ = [] diff --git a/private/LLVM/Core/CodeGenMonad.hs b/private/LLVM/Core/CodeGenMonad.hs new file mode 100644 --- /dev/null +++ b/private/LLVM/Core/CodeGenMonad.hs @@ -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 diff --git a/private/LLVM/Core/Data.hs b/private/LLVM/Core/Data.hs new file mode 100644 --- /dev/null +++ b/private/LLVM/Core/Data.hs @@ -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 diff --git a/private/LLVM/Core/Instructions.hs b/private/LLVM/Core/Instructions.hs new file mode 100644 --- /dev/null +++ b/private/LLVM/Core/Instructions.hs @@ -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) +-} diff --git a/private/LLVM/Core/Instructions/Guided.hs b/private/LLVM/Core/Instructions/Guided.hs new file mode 100644 --- /dev/null +++ b/private/LLVM/Core/Instructions/Guided.hs @@ -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) diff --git a/private/LLVM/Core/Instructions/Private.hs b/private/LLVM/Core/Instructions/Private.hs new file mode 100644 --- /dev/null +++ b/private/LLVM/Core/Instructions/Private.hs @@ -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 diff --git a/private/LLVM/Core/Proxy.hs b/private/LLVM/Core/Proxy.hs new file mode 100644 --- /dev/null +++ b/private/LLVM/Core/Proxy.hs @@ -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 diff --git a/private/LLVM/Core/Type.hs b/private/LLVM/Core/Type.hs new file mode 100644 --- /dev/null +++ b/private/LLVM/Core/Type.hs @@ -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. + diff --git a/private/LLVM/Core/UnaryVector.hs b/private/LLVM/Core/UnaryVector.hs new file mode 100644 --- /dev/null +++ b/private/LLVM/Core/UnaryVector.hs @@ -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} diff --git a/private/LLVM/Core/Util.hs b/private/LLVM/Core/Util.hs new file mode 100644 --- /dev/null +++ b/private/LLVM/Core/Util.hs @@ -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) diff --git a/private/LLVM/Core/Vector.hs b/private/LLVM/Core/Vector.hs new file mode 100644 --- /dev/null +++ b/private/LLVM/Core/Vector.hs @@ -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 diff --git a/private/LLVM/ExecutionEngine/Engine.hs b/private/LLVM/ExecutionEngine/Engine.hs new file mode 100644 --- /dev/null +++ b/private/LLVM/ExecutionEngine/Engine.hs @@ -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 diff --git a/private/LLVM/ExecutionEngine/Marshal.hs b/private/LLVM/ExecutionEngine/Marshal.hs new file mode 100644 --- /dev/null +++ b/private/LLVM/ExecutionEngine/Marshal.hs @@ -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 + ((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 diff --git a/private/LLVM/ExecutionEngine/Target.hs b/private/LLVM/ExecutionEngine/Target.hs new file mode 100644 --- /dev/null +++ b/private/LLVM/ExecutionEngine/Target.hs @@ -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 diff --git a/src/LLVM/Core.hs b/src/LLVM/Core.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Core.hs @@ -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 diff --git a/src/LLVM/Core/Attribute.hs b/src/LLVM/Core/Attribute.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Core/Attribute.hs @@ -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 diff --git a/src/LLVM/Core/Guided.hs b/src/LLVM/Core/Guided.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Core/Guided.hs @@ -0,0 +1,5 @@ +module LLVM.Core.Guided ( + module LLVM.Core.Instructions.Guided, + ) where + +import LLVM.Core.Instructions.Guided diff --git a/src/LLVM/ExecutionEngine.hs b/src/LLVM/ExecutionEngine.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/ExecutionEngine.hs @@ -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 diff --git a/src/LLVM/Util/Arithmetic.hs b/src/LLVM/Util/Arithmetic.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Util/Arithmetic.hs @@ -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) diff --git a/src/LLVM/Util/File.hs b/src/LLVM/Util/File.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Util/File.hs @@ -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 diff --git a/src/LLVM/Util/Foreign.hs b/src/LLVM/Util/Foreign.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Util/Foreign.hs @@ -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 diff --git a/src/LLVM/Util/Intrinsic.hs b/src/LLVM/Util/Intrinsic.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Util/Intrinsic.hs @@ -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") diff --git a/src/LLVM/Util/Loop.hs b/src/LLVM/Util/Loop.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Util/Loop.hs @@ -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 diff --git a/src/LLVM/Util/Memory.hs b/src/LLVM/Util/Memory.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Util/Memory.hs @@ -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 diff --git a/src/LLVM/Util/Optimize.hs b/src/LLVM/Util/Optimize.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Util/Optimize.hs @@ -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" 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 +-} diff --git a/src/LLVM/Util/Proxy.hs b/src/LLVM/Util/Proxy.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Util/Proxy.hs @@ -0,0 +1,5 @@ +module LLVM.Util.Proxy ( + module LLVM.Core.Proxy, + ) where + +import LLVM.Core.Proxy diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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 ++ + [] diff --git a/test/Test/Chop.hs b/test/Test/Chop.hs new file mode 100644 --- /dev/null +++ b/test/Test/Chop.hs @@ -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) : + [] diff --git a/test/Test/Marshal.hs b/test/Test/Marshal.hs new file mode 100644 --- /dev/null +++ b/test/Test/Marshal.hs @@ -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