llvm-extra 0.9 → 0.9.1
raw patch · 3 files changed
+215/−28 lines, 3 filesdep −storable-tupledep ~llvm-tf
Dependencies removed: storable-tuple
Dependency ranges changed: llvm-tf
Files
- llvm-extra.cabal +4/−4
- src/LLVM/Extra/Marshal.hs +180/−0
- test/Test/Vector.hs +31/−24
llvm-extra.cabal view
@@ -1,6 +1,6 @@ Cabal-Version: 2.2 Name: llvm-extra-Version: 0.9+Version: 0.9.1 License: BSD-3-Clause License-File: LICENSE Author: Henning Thielemann <haskell@henning-thielemann.de>@@ -55,7 +55,7 @@ default: False Source-Repository this- Tag: 0.9+ Tag: 0.9.1 Type: darcs Location: http://code.haskell.org/~thielema/llvm-extra/ @@ -66,7 +66,7 @@ Library Build-Depends: private,- llvm-tf >=9.0 && <9.1,+ llvm-tf >=9.1 && <9.2, tfp >=1.0 && <1.1, non-empty >=0.2.1 && <0.4, containers >=0.1 && <0.7,@@ -86,6 +86,7 @@ LLVM.Extra.Arithmetic LLVM.Extra.Monad LLVM.Extra.Memory+ LLVM.Extra.Marshal LLVM.Extra.Maybe LLVM.Extra.MaybeContinuation LLVM.Extra.Either@@ -151,7 +152,6 @@ llvm-extra, llvm-tf, tfp,- storable-tuple >=0.0.3 && <0.1, utility-ht >=0.0.1 && <0.1, base >=3 && <5 Default-Language: Haskell98
+ src/LLVM/Extra/Marshal.hs view
@@ -0,0 +1,180 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{- |+Transfer values between Haskell and JIT generated code+in an LLVM-compatible format.+E.g. 'Bool' is stored as 'i1' and Haskell tuples are stored as LLVM structs.+-}+module LLVM.Extra.Marshal where++import qualified LLVM.Extra.Class as Class+import qualified LLVM.Util.Proxy as LP+import qualified LLVM.ExecutionEngine as EE+import qualified LLVM.Core as LLVM+import LLVM.Core (CodeGenFunction, Value)++import qualified Type.Data.Num.Decimal as TypeNum++import Control.Applicative (liftA2, liftA3, (<$>))++import Foreign.Marshal.Alloc (allocaBytes)+import Foreign.Ptr (Ptr)++import Data.Tuple.HT (fst3, snd3, thd3)+import Data.Word (Word8, Word16, Word32, Word64, )+import Data.Int (Int8, Int16, Int32, Int64, )++++peek :: (C a, Struct a ~ struct, EE.Marshal struct) => Ptr struct -> IO a+peek ptr = unpack <$> EE.peek ptr++poke :: (C a, Struct a ~ struct, EE.Marshal struct) => Ptr struct -> a -> IO ()+poke ptr = EE.poke ptr . pack++load ::+ (C a, Struct a ~ struct, EE.Marshal struct) =>+ LP.Proxy a ->+ Value (Ptr struct) -> CodeGenFunction r (Class.ValueTuple a)+load proxy ptr = decompose proxy =<< LLVM.load ptr++store ::+ (C a, Struct a ~ struct, EE.Marshal struct) =>+ LP.Proxy a ->+ Class.ValueTuple a -> Value (Ptr struct) -> CodeGenFunction r ()+store proxy tuple ptr = flip LLVM.store ptr =<< compose proxy tuple+++class+ (Class.MakeValueTuple a, EE.Marshal (Struct a), LLVM.IsSized (Struct a)) =>+ C a where+ type Struct a+ pack :: a -> Struct a+ unpack :: Struct a -> a+ compose ::+ LP.Proxy a ->+ Class.ValueTuple a -> CodeGenFunction r (Value (Struct a))+ decompose ::+ LP.Proxy a ->+ Value (Struct a) -> CodeGenFunction r (Class.ValueTuple a)++instance C Bool where+ type Struct Bool = Bool+ pack = id; compose LP.Proxy = return+ unpack = id; decompose LP.Proxy = return++instance C Float where+ type Struct Float = Float+ pack = id; compose LP.Proxy = return+ unpack = id; decompose LP.Proxy = return++instance C Double where+ type Struct Double = Double+ pack = id; compose LP.Proxy = return+ unpack = id; decompose LP.Proxy = return++instance C Word8 where+ type Struct Word8 = Word8+ pack = id; compose LP.Proxy = return+ unpack = id; decompose LP.Proxy = return++instance C Word16 where+ type Struct Word16 = Word16+ pack = id; compose LP.Proxy = return+ unpack = id; decompose LP.Proxy = return++instance C Word32 where+ type Struct Word32 = Word32+ pack = id; compose LP.Proxy = return+ unpack = id; decompose LP.Proxy = return++instance C Word64 where+ type Struct Word64 = Word64+ pack = id; compose LP.Proxy = return+ unpack = id; decompose LP.Proxy = return++instance C Int8 where+ type Struct Int8 = Int8+ pack = id; compose LP.Proxy = return+ unpack = id; decompose LP.Proxy = return++instance C Int16 where+ type Struct Int16 = Int16+ pack = id; compose LP.Proxy = return+ unpack = id; decompose LP.Proxy = return++instance C Int32 where+ type Struct Int32 = Int32+ pack = id; compose LP.Proxy = return+ unpack = id; decompose LP.Proxy = return++instance C Int64 where+ type Struct Int64 = Int64+ pack = id; compose LP.Proxy = return+ unpack = id; decompose LP.Proxy = return++instance (LLVM.IsType a) => C (Ptr a) where+ type Struct (Ptr a) = Ptr a+ pack = id; compose LP.Proxy = return+ unpack = id; decompose LP.Proxy = return++instance+ (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: LLVM.SizeOf a),+ EE.Marshal a, LLVM.IsConst a, LLVM.IsPrimitive a, LLVM.IsSized a) =>+ C (LLVM.Vector n a) where+ type Struct (LLVM.Vector n a) = LLVM.Vector n a+ pack = id; compose LP.Proxy = return+ unpack = id; decompose LP.Proxy = return++instance C () where+ type Struct () = LLVM.Struct ()+ pack = LLVM.Struct+ unpack (LLVM.Struct unit) = unit+ compose LP.Proxy () = return $ LLVM.valueOf $ LLVM.Struct ()+ decompose LP.Proxy _ = return ()++instance+ (LLVM.IsSized (Struct a), LLVM.IsSized (Struct b), C a, C b) =>+ C (a,b) where+ type Struct (a,b) = LLVM.Struct (Struct a, (Struct b, ()))+ pack (a,b) = LLVM.Struct (pack a, (pack b, ()))+ unpack (LLVM.Struct (a,(b,()))) = (unpack a, unpack b)+ compose proxy (a,b) = do+ ac <- compose (fst <$> proxy) a+ bc <- compose (snd <$> proxy) b+ struct0 <- LLVM.insertvalue (LLVM.value LLVM.undef) ac TypeNum.d0+ LLVM.insertvalue struct0 bc TypeNum.d1+ decompose proxy struct =+ liftA2 (,)+ (decompose (fst <$> proxy) =<< LLVM.extractvalue struct TypeNum.d0)+ (decompose (snd <$> proxy) =<< LLVM.extractvalue struct TypeNum.d1)++instance+ (LLVM.IsSized (Struct a), LLVM.IsSized (Struct b), LLVM.IsSized (Struct c),+ C a, C b, C c) =>+ C (a,b,c) where+ type Struct (a,b,c) = LLVM.Struct (Struct a, (Struct b, (Struct c, ())))+ pack (a,b,c) = LLVM.Struct (pack a, (pack b, (pack c, ())))+ unpack (LLVM.Struct (a,(b,(c,())))) = (unpack a, unpack b, unpack c)+ compose proxy (a,b,c) = do+ ac <- compose (fst3 <$> proxy) a+ bc <- compose (snd3 <$> proxy) b+ cc <- compose (thd3 <$> proxy) c+ struct0 <- LLVM.insertvalue (LLVM.value LLVM.undef) ac TypeNum.d0+ struct1 <- LLVM.insertvalue struct0 bc TypeNum.d1+ LLVM.insertvalue struct1 cc TypeNum.d2+ decompose proxy struct =+ liftA3 (,,)+ (decompose (fst3 <$> proxy) =<< LLVM.extractvalue struct TypeNum.d0)+ (decompose (snd3 <$> proxy) =<< LLVM.extractvalue struct TypeNum.d1)+ (decompose (thd3 <$> proxy) =<< LLVM.extractvalue struct TypeNum.d2)+++with :: (C a) => a -> (Ptr (Struct a) -> IO b) -> IO b+with a act = alloca LP.Proxy $ \ptr -> poke ptr a >> act ptr++alloca ::+ (LLVM.IsType struct) => LP.Proxy struct -> (Ptr struct -> IO b) -> IO b+alloca proxy = allocaBytes (EE.sizeOf proxy)
test/Test/Vector.hs view
@@ -7,17 +7,16 @@ import qualified LLVM.Extra.ScalarOrVector as SoV import qualified LLVM.Extra.VectorAlt as VectorAlt import qualified LLVM.Extra.Vector as Vector-import qualified LLVM.Extra.Memory as Mem+import qualified LLVM.Extra.Marshal as Marshal import qualified LLVM.Extra.Class as Class import qualified LLVM.ExecutionEngine as EE+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 qualified Foreign.Marshal as Marsh-import Foreign.Storable.Tuple ()-import Foreign.Storable (Storable, peek) import Foreign.Ptr (FunPtr, Ptr) import qualified Data.Traversable as Trav@@ -59,34 +58,43 @@ Importer (Ptr inp -> Ptr out -> IO ()) modul ::- (Mem.Struct inp ~ minp, LLVM.IsType minp, Mem.C inp,- Mem.Struct out ~ mout, LLVM.IsType mout, Mem.C out) =>- (inp -> LLVM.CodeGenFunction () out) ->+ (Marshal.C inp, Marshal.Struct inp ~ minp, LLVM.IsType minp,+ Marshal.C out, Marshal.Struct out ~ mout, LLVM.IsType mout,+ Class.ValueTuple inp ~ linp, Class.ValueTuple out ~ lout) =>+ (LP.Proxy inp, LP.Proxy out) ->+ (linp -> LLVM.CodeGenFunction () lout) -> LLVM.CodeGenModule (LLVM.Function (Ptr minp -> Ptr mout -> IO ()))-modul codegen =+modul (xProxy,yProxy) codegen = LLVM.createFunction LLVM.ExternalLinkage $ \xPtr yPtr -> do- flip Mem.store yPtr =<< codegen =<< Mem.load xPtr+ flip (Marshal.store yProxy) yPtr =<< codegen =<< Marshal.load xProxy xPtr LLVM.ret () +proxies :: (inp -> out -> Bool) -> (LP.Proxy inp, LP.Proxy out)+proxies _ = (LP.Proxy, LP.Proxy)++alloca :: (LLVM.IsType a) => LP.Proxy a -> (Ptr a -> IO b) -> IO b+alloca proxy = Marsh.allocaBytes (EE.sizeOf proxy)+ run ::- (Mem.Struct inp ~ minp, LLVM.IsType minp, Mem.C inp,- Mem.Struct out ~ mout, LLVM.IsType mout, Mem.C out,- Storable a, Class.MakeValueTuple a, Class.ValueTuple a ~ inp,- Storable b, Class.MakeValueTuple b, Class.ValueTuple b ~ out,- Show a, QC.Arbitrary a) =>- (inp -> LLVM.CodeGenFunction () out) ->- (a -> b -> Bool) ->+ (Marshal.C inp, Marshal.Struct inp ~ minp, LLVM.IsType minp,+ Marshal.C out, Marshal.Struct out ~ mout, LLVM.IsType mout,+ Class.ValueTuple inp ~ linp, Class.ValueTuple out ~ lout) =>+ (Show inp, QC.Arbitrary inp) =>+ (linp -> LLVM.CodeGenFunction () lout) ->+ (inp -> out -> Bool) -> IO QC.Property run codegen predicate = do- funIO <- generateFunction derefTestCasePtr $ modul codegen+ funIO <-+ generateFunction derefTestCasePtr $ modul (proxies predicate) codegen return $ QC.property $ \x -> QCMon.monadicIO $ do y <- QCMon.run $- Marsh.with x $ \xPtr ->- Marsh.alloca $ \yPtr ->- funIO (Mem.castTuplePtr xPtr) (Mem.castTuplePtr yPtr) >>- peek yPtr+ alloca LP.Proxy $ \xPtr ->+ alloca LP.Proxy $ \yPtr -> do+ Marshal.poke xPtr x+ funIO xPtr yPtr+ Marshal.peek yPtr QCMon.assert $ predicate x y @@ -110,10 +118,9 @@ binop ::- ((TypeNum.D4 TypeNum.:*: LLVM.SizeOf am) ~ size, TypeNum.Natural size,- Mem.FirstClass a, Mem.Stored a ~ am, LLVM.IsSized am,- QC.Arbitrary a, Show a, Eq a, Storable a, LLVM.IsConst a,- LLVM.IsPrimitive a, LLVM.IsPrimitive am) =>+ ((TypeNum.D4 TypeNum.:*: LLVM.SizeOf a) ~ size, TypeNum.Natural size,+ QC.Arbitrary a, Show a, Eq a, EE.Marshal a,+ LLVM.IsConst a, LLVM.IsSized a, LLVM.IsPrimitive a) => (LLVM.Value (V4 a) -> LLVM.Value (V4 a) -> LLVM.CodeGenFunction () (LLVM.Value (V4 a))) -> (a -> a -> a) ->