diff --git a/set-cover.cabal b/set-cover.cabal --- a/set-cover.cabal +++ b/set-cover.cabal @@ -1,5 +1,5 @@ Name: set-cover -Version: 0.1 +Version: 0.1.1 License: BSD3 License-File: LICENSE Author: Henning Thielemann, Helmut Podhaisky @@ -45,7 +45,7 @@ Default: False Source-Repository this - Tag: 0.1 + Tag: 0.1.1 Type: darcs Location: http://hub.darcs.net/thielema/set-cover/ @@ -89,11 +89,12 @@ If flag(llvm) Build-Depends: - knead >=0.4 && <0.5, - llvm-extra >=0.8 && <0.9, - llvm-tf >=3.1.1 && <3.2, + knead >=0.4 && <0.6, + llvm-extra >=0.10 && <0.11, + llvm-tf >=9.2 && <9.3, tfp >=1.0 && <1.1, comfort-array >=0.3 && <0.5, + storable-record >=0.0.5 && <0.1, storable-endian >=0.2.6 && <0.3, bool8 >=0.0 && <0.1, lazyio >=0.1 && <0.2 diff --git a/src/Math/SetCover/Exact.hs b/src/Math/SetCover/Exact.hs --- a/src/Math/SetCover/Exact.hs +++ b/src/Math/SetCover/Exact.hs @@ -320,7 +320,7 @@ If a set is chosen for a partition, then its label is included in the output. E.g. @set0 = Set.fromList [0,1], set1 = Set.fromList [2], set2 = Set.fromList [0,1,2]@, -then 'partitions' returns @["01", "2"]@. +then 'partitions' returns @[\"01\", \"2\"]@. The order of partitions and the order of labels depends on the implementation diff --git a/src/Math/SetCover/Exact/Knead.hs b/src/Math/SetCover/Exact/Knead.hs --- a/src/Math/SetCover/Exact/Knead.hs +++ b/src/Math/SetCover/Exact/Knead.hs @@ -139,6 +139,7 @@ keepMinimum :: IO (Phys.Array BlockDim Block -> IO (BlockId,Block)) keepMinimum = Render.run $ \xs -> + Render.MarshalExp $ Expr.maybe Expr.zero (Expr.mapSnd keepMinimumBit) $ Symb.findAll (Expr.not . nullBlock . Expr.snd) $ Symb.zip (Symb.id (Symb.shape xs)) xs diff --git a/src/Math/SetCover/Exact/Knead/Saturated.hs b/src/Math/SetCover/Exact/Knead/Saturated.hs --- a/src/Math/SetCover/Exact/Knead/Saturated.hs +++ b/src/Math/SetCover/Exact/Knead/Saturated.hs @@ -10,13 +10,13 @@ import Math.SetCover.Exact.Knead.Vector (Block) import Math.SetCover.Exact.Knead.Symbolic (SetId, SetDim, BlockId, BlockDim, blocksFromSets, - nullSet, disjoint, disjointRows, differenceWithRow, - findIndices, collectRows) + nullSet, disjoint, differenceWithRow, + filterDisjointRows, findIndices) import qualified Control.Monad.HT as Monad import Control.Monad.HT ((<=<)) import Control.Monad (foldM) -import Control.Applicative (liftA2, liftA3, pure, (<$>), (<*>)) +import Control.Applicative (liftA3, pure, (<$>)) import qualified Data.Array.Knead.Parameterized.Render as Render import qualified Data.Array.Knead.Simple.Physical as Phys @@ -30,14 +30,12 @@ import qualified Data.Array.Comfort.Boxed as Array import Data.Array.Comfort.Boxed (Array) -import qualified LLVM.Extra.Extension.X86 as X86 -import qualified LLVM.Extra.Extension as Ext import qualified LLVM.Extra.Multi.Vector as MultiVector import qualified LLVM.Extra.Multi.Value.Vector as MultiValueVec import qualified LLVM.Extra.Multi.Value as MultiValue -import LLVM.Extra.Multi.Vector.Memory () import LLVM.Extra.Multi.Value (atom) +import qualified LLVM.Util.Intrinsic as Intr import qualified LLVM.Core as LLVM import qualified Type.Data.Num.Decimal as TypeNum @@ -53,8 +51,8 @@ import qualified Data.Int as Int import qualified Data.Bool8 as Bool8 import qualified Data.Bits as Bits -import Data.Functor.Compose (Compose(Compose,getCompose)) import Data.Set (Set) +import Data.Maybe (fromMaybe) import Prelude2010 import Prelude () @@ -133,21 +131,13 @@ LLVM.Value Counters -> LLVM.Value Counters -> LLVM.CodeGenFunction r (LLVM.Value Counters) incSatGeneric x y = - (\(MultiValue.Cons z) -> getCompose z) + (\(MultiValue.Cons z) -> z) <$> - Expr.unliftM2 incSat - (MultiValue.Cons (Compose x)) (MultiValue.Cons (Compose y)) + Expr.unliftM2 incSat (MultiValue.Cons x) (MultiValue.Cons y) incSatX86 :: Exp Counters -> Exp Counters -> Exp Counters incSatX86 = - Expr.liftM2 - (MultiValue.liftM2 - (\xc yc -> - Compose <$> - case (getCompose xc, getCompose yc) of - (x,y) -> - Ext.run (incSatGeneric x y) - (X86.paddusb128 <*> pure x <*> pure y))) + Expr.liftTupleM2 (\x y -> fromMaybe incSatGeneric Intr.maybeUAddSat x y) sumRows :: Symb.Array (SetDim, blockDim) Counters -> @@ -168,8 +158,7 @@ Expr.fromInteger' numCounters toCounters :: Exp Block -> Exp Counters -toCounters = - Expr.liftM (MultiValue.liftM (fmap Compose . LLVM.bitcast)) +toCounters = Expr.liftTupleM LLVM.bitcast _pickBits :: Exp BitId -> Exp Block -> Exp Counters _pickBits k block = @@ -177,15 +166,13 @@ word16 :: Exp BitId -> Exp Word.Word16 -word16 = Expr.liftM (MultiValue.liftM LLVM.ext) . bitPos +word16 = Expr.liftTupleM LLVM.ext . bitPos toBlock16 :: Exp Block -> Exp Block16 -toBlock16 = - Expr.liftM (MultiValue.liftM (fmap Compose . LLVM.bitcast)) +toBlock16 = Expr.liftTupleM LLVM.bitcast fromBlock16 :: Exp Block16 -> Exp Counters -fromBlock16 = - Expr.liftM (MultiValue.liftM (fmap Compose . LLVM.bitcast . getCompose)) +fromBlock16 = Expr.liftTupleM LLVM.bitcast pickBitsX86 :: Exp BitId -> Exp Block -> Exp Counters pickBitsX86 k block = @@ -200,20 +187,6 @@ Slice.apply (Slice.second extrudeBits) -filterDisjointRows :: - IO (SetId -> - (Array SetDim label, Phys.Array (SetDim,BlockDim) Block) -> - IO (Array SetDim label, Phys.Array (SetDim,BlockDim) Block)) -filterDisjointRows = do - disjRows <- Render.run $ \k -> findIndices . disjointRows k - collect <- Render.run collectRows - return $ \k0 (labels,sets) -> do - perm <- disjRows k0 sets - liftA2 (,) - (Array.fromList (Phys.shape perm) . map (labels Array.!) - <$> Phys.toList perm) - (collect perm sets) - updateStateIO :: IO (SetId -> State label -> LazyIO.T (State label)) updateStateIO = do filt <- filterDisjointRows @@ -239,9 +212,7 @@ extractBlock :: Exp CounterId -> Exp Block -> Exp Subblock extractBlock = - Expr.liftM2 - (\(MultiValue.Cons k) (MultiValue.Cons v) -> - MultiValue.Cons <$> (LLVM.extractelement v =<< LLVM.zext k)) + Expr.liftTupleM2 (\k v -> LLVM.extractelement v =<< LLVM.zext k) flattenCounters :: Symb.Array (BlockDim, BitDim) Counters -> @@ -252,7 +223,7 @@ bitPos :: Exp BitId -> Exp Subblock -bitPos = Expr.liftM (MultiValue.liftM LLVM.bitcast) +bitPos = Expr.liftTupleM LLVM.bitcast singleBit :: Exp BitId -> Exp Subblock singleBit = Expr.shl 1 . bitPos @@ -272,7 +243,8 @@ IO (Phys.Array (BlockDim, BitDim) Counters -> IO ((BlockId,CounterId),Counter)) _keepMinimum = - Render.run $ Expr.mapSnd singleBit . argMinimum . flattenCounters + Render.run $ + Render.MarshalExp . Expr.mapSnd singleBit . argMinimum . flattenCounters argMinMasked :: @@ -311,6 +283,7 @@ IO ((BlockId,CounterId),Counter)) _keepMinimumMasked = Render.run $ \free -> + Render.MarshalExp . Expr.mapSnd singleBit . argMinimumMasked free . flattenCounters @@ -419,6 +392,7 @@ IO ((BlockId,CounterId),Subblock)) keepMinimumMaskedVec = Render.run $ \free -> + Render.MarshalExp . Expr.mapSnd singleBit . keepMinimumMaskedCascade . argMinimumMaskedVec free diff --git a/src/Math/SetCover/Exact/Knead/Symbolic.hs b/src/Math/SetCover/Exact/Knead/Symbolic.hs --- a/src/Math/SetCover/Exact/Knead/Symbolic.hs +++ b/src/Math/SetCover/Exact/Knead/Symbolic.hs @@ -8,11 +8,9 @@ getRow, nullSet, disjoint, - disjointRows, differenceWithRow, findIndices, filterDisjointRows, - collectRows, ) where import qualified Math.SetCover.Exact.Block as Blocks @@ -36,12 +34,15 @@ import Data.Array.Comfort.Boxed (Array) import qualified LLVM.Extra.Multi.Value as MultiValue +import qualified LLVM.Extra.Storable as Storable import LLVM.Extra.Multi.Value (atom) import qualified Data.Word as Word import qualified Data.Int as Int import Data.Set (Set) +import Foreign.Storable.Record.Tuple (Tuple(Tuple)) + import Prelude2010 import Prelude () @@ -101,10 +102,10 @@ add2 = Render.run $ \xs -> Render.MapAccumLSimple - (Expr.modify2 atom (atom,atom) $ \carry (a,b) -> + (Expr.modify2 atom (Tuple (atom,atom)) $ \carry (Tuple (a,b)) -> (addHigh a b carry, addLow a b carry)) (Symb.fill (Expr.fst (Symb.shape xs)) Expr.zero) - (halfBags xs) + (Symb.map Expr.tuple $ halfBags xs) zbAtom :: Shape.ZeroBased (MultiValue.Atom a) @@ -278,6 +279,14 @@ Render.MapFilter Expr.fst Expr.snd (Symb.zip (Symb.id $ Symb.shape arr) arr) +findDisjointRows :: + (BitSet block, Storable.C block) => + IO (SetId -> + Phys.Array (SetDim,BlockDim) block -> + IO (Phys.Array SetDim SetId)) +findDisjointRows = + Render.run $ \k -> findIndices . disjointRows k + collectRows :: (MultiValue.C block) => Symb.Array SetDim SetId -> @@ -289,11 +298,12 @@ sets filterDisjointRows :: + (BitSet block, Storable.C block) => IO (SetId -> - (Array SetDim label, Phys.Array (SetDim,BlockDim) Block) -> - IO (Array SetDim label, Phys.Array (SetDim,BlockDim) Block)) + (Array SetDim label, Phys.Array (SetDim,BlockDim) block) -> + IO (Array SetDim label, Phys.Array (SetDim,BlockDim) block)) filterDisjointRows = do - disjRows <- Render.run $ \k sets -> findIndices $ disjointRows k sets + disjRows <- findDisjointRows collect <- Render.run collectRows return $ \k (labels,sets) -> do perm <- disjRows k sets diff --git a/src/Math/SetCover/Exact/Knead/Vector.hs b/src/Math/SetCover/Exact/Knead/Vector.hs --- a/src/Math/SetCover/Exact/Knead/Vector.hs +++ b/src/Math/SetCover/Exact/Knead/Vector.hs @@ -7,12 +7,14 @@ import qualified Math.SetCover.Exact.Block as Blocks import Math.SetCover.Exact.Knead (BitSet) +import Control.Monad ((<=<)) import Control.Applicative (liftA2) import qualified Data.Array.Knead.Expression as Expr -import qualified LLVM.Extra.Multi.Value.Memory as MultiValueMem +import qualified LLVM.Extra.Storable as Storable import qualified LLVM.Extra.Multi.Value as MultiValue +import qualified LLVM.Extra.Tuple as Tuple import qualified LLVM.Extra.Arithmetic as A import qualified LLVM.Core as LLVM @@ -21,7 +23,7 @@ import qualified Foreign.Storable as Store import Foreign.Storable (Storable) import Foreign.Marshal.Array (advancePtr) -import Foreign.Ptr (castPtr) +import Foreign.Ptr (Ptr, castPtr) import Data.Storable.Endian (peekLE, pokeLE) import qualified Data.NonEmpty.Mixed as NonEmptyM @@ -41,11 +43,11 @@ {-# INLINE getByte #-} getByte :: Int -> Word64 -> Word8 -getByte k x = fromIntegral $ shiftR x k +getByte k x = fromIntegral $ shiftR x (k*8) {-# INLINE _putByte #-} _putByte :: Int -> Word8 -> Word64 -_putByte k x = shiftL (fromIntegral x) k +_putByte k x = shiftL (fromIntegral x) (k*8) instance Storable Block where @@ -59,28 +61,40 @@ let ptr64 = castPtr ptr in liftA2 Block (peekLE ptr64) (peekLE (advancePtr ptr64 1)) +instance Tuple.Value Block where + type ValueOf Block = LLVM.Value ByteVector + valueOf = LLVM.valueOf . blockVector + instance MultiValue.C Block where - type Repr f Block = f ByteVector - cons (Block x0 x1) = - MultiValue.consPrimitive $ LLVM.vector $ - fmap (\k -> if k<8 then getByte k x0 else getByte k x1) $ - NonEmptyC.iterate (1+) 0 + cons = MultiValue.consPrimitive . blockVector undef = MultiValue.undefPrimitive zero = MultiValue.zeroPrimitive - phis = MultiValue.phisPrimitive - addPhis = MultiValue.addPhisPrimitive + phi = MultiValue.phiPrimitive + addPhi = MultiValue.addPhiPrimitive +blockVector :: Block -> ByteVector +blockVector (Block x0 x1) = + LLVM.vector $ + fmap + (\k -> + let split = Store.sizeOf x0 + in if k + LLVM.CodeGenFunction r (LLVM.Value (Ptr ByteVector)) +castBlockPtr = LLVM.bitcast + + toWord128 :: LLVM.Value ByteVector -> LLVM.CodeGenFunction r (LLVM.Value (LLVM.WordN TypeNum.D128)) @@ -93,8 +107,8 @@ instance BitSet Block where nullBlock = - Expr.liftM (MultiValue.liftM (\x -> - A.cmp LLVM.CmpEQ (LLVM.value LLVM.zero) =<< toWord128 x)) + Expr.liftTupleM (\x -> + A.cmp LLVM.CmpEQ (LLVM.value LLVM.zero) =<< toWord128 x) blocksFromSets sets = let (avails, free) = Blocks.blocksFromSets sets numBlocks = - div (- length free) blockSize @@ -105,5 +119,5 @@ NonEmptyM.sliceVertical . (++ repeat 0) in (map sliceRow avails, sliceRow free) keepMinimumBit = - Expr.liftM (MultiValue.liftM (\x0 -> - do x <- toWord128 x0; fromWord128 =<< A.and x =<< A.neg x)) + Expr.liftTupleM (\x0 -> + do x <- toWord128 x0; fromWord128 =<< A.and x =<< A.neg x)