diff --git a/ADP/Fusion/Core/Classes.hs b/ADP/Fusion/Core/Classes.hs --- a/ADP/Fusion/Core/Classes.hs +++ b/ADP/Fusion/Core/Classes.hs @@ -20,13 +20,21 @@ deriving (Show) data InsideContext s - = IStatic s - | IVariable s + = IStatic {iGetContext :: s} + | IVariable {iGetContext :: s} deriving (Show) data ComplementContext = Complemented deriving (Show) + +-- | Needed for structures that have long-range interactions and "expand", +-- like sets around edge boundaries: @set set@. requires the sets to +-- be connected. + +data ExtComplementContext s + = CStatic s + | CVariable s class RuleContext i where type Context i :: * diff --git a/ADP/Fusion/SynVar/Array.hs b/ADP/Fusion/SynVar/Array.hs --- a/ADP/Fusion/SynVar/Array.hs +++ b/ADP/Fusion/SynVar/Array.hs @@ -42,8 +42,9 @@ -> Stream m (Elm (ls :!: TwITbl m arr c u x) i) iTblStream (ls :!: TW (ITbl _ _ c t) _) vs us is = map (\(s,tt,ii') -> ElmITbl (t!tt) ii' s) - . addIndexDense1 c vs us is + . addIndexDense1 c vs lb ub us is $ mkStream ls (tableStaticVar (Proxy :: Proxy u) c vs is) us (tableStreamIndex (Proxy :: Proxy u) c vs is) + where (lb,ub) = bounds t {-# Inline iTblStream #-} -- | General function for @Backtrack ITbl@s with skalar indices. @@ -56,10 +57,10 @@ -> i -> Stream mB (Elm (ls :!: TwITblBt arr c u x mF mB r) i) btITblStream (ls :!: TW (BtITbl c t) bt) vs us is - = mapM (\(s,tt,ii') -> bt us' tt >>= \ ~bb -> return $ ElmBtITbl (t!tt) bb ii' s) - . addIndexDense1 c vs us is + = mapM (\(s,tt,ii') -> bt ub tt >>= \ ~bb -> return $ ElmBtITbl (t!tt) bb ii' s) + . addIndexDense1 c vs lb ub us is $ mkStream ls (tableStaticVar (Proxy :: Proxy u) c vs is) us (tableStreamIndex (Proxy :: Proxy u) c vs is) - where !us' = snd $ bounds t + where (lb,ub) = bounds t {-# Inline btITblStream #-} diff --git a/ADP/Fusion/SynVar/Array/Type.hs b/ADP/Fusion/SynVar/Array/Type.hs --- a/ADP/Fusion/SynVar/Array/Type.hs +++ b/ADP/Fusion/SynVar/Array/Type.hs @@ -124,8 +124,9 @@ ) => MkStream m (ls :!: TwITbl m arr (cs:.c) (us:.u) x) (is:.i) where mkStream (ls :!: TW (ITbl _ _ c t) _) vs us is = map (\(s,tt,ii') -> ElmITbl (t!tt) ii' s) - . addIndexDense c vs us is + . addIndexDense c vs lb ub us is $ mkStream ls (tableStaticVar (Proxy :: Proxy (us:.u)) c vs is) us (tableStreamIndex (Proxy :: Proxy (us:.u)) c vs is) + where (lb,ub) = bounds t {-# Inline mkStream #-} instance @@ -137,9 +138,9 @@ , PrimArrayOps arr (us:.u) x ) => MkStream mB (ls :!: TwITblBt arr (cs:.c) (us:.u) x mF mB r) (is:.i) where mkStream (ls :!: TW (BtITbl c t) bt) vs us is - = mapM (\(s,tt,ii') -> bt us' tt >>= \ ~bb -> return $ ElmBtITbl (t!tt) bb ii' s) - . addIndexDense c vs us is + = mapM (\(s,tt,ii') -> bt ub tt >>= \ ~bb -> return $ ElmBtITbl (t!tt) bb ii' s) + . addIndexDense c vs lb ub us is $ mkStream ls (tableStaticVar (Proxy :: Proxy (us:.u)) c vs is) us (tableStreamIndex (Proxy :: Proxy (us:.u)) c vs is) - where !us' = snd $ bounds t + where (lb,ub) = bounds t {-# Inline mkStream #-} diff --git a/ADP/Fusion/SynVar/Fill.hs b/ADP/Fusion/SynVar/Fill.hs --- a/ADP/Fusion/SynVar/Fill.hs +++ b/ADP/Fusion/SynVar/Fill.hs @@ -1,6 +1,7 @@ module ADP.Fusion.SynVar.Fill where +import Control.Monad import Control.Monad.Morph (hoist, MFunctor (..)) import Control.Monad.Primitive (PrimMonad (..)) import Control.Monad.ST @@ -10,9 +11,15 @@ import qualified Data.Vector.Fusion.Stream.Monadic as SM import System.IO.Unsafe import Control.Monad (when,forM_) -import Data.List (nub,sort) +import Data.List (nub,sort,group) import qualified Data.Vector.Unboxed as VU import Data.Proxy +import qualified GHC.Generics as G +import qualified Data.Typeable as T +import qualified Data.Data as D +import Data.Dynamic +import Data.Type.Equality +import qualified Data.List as L import Data.PrimitiveArray @@ -24,41 +31,6 @@ --- * Specialized table-filling wrapper for 'MTbl's --- --- TODO table-filling does /not/ work for single-dimensional stuff - --- | Run and freeze 'MTbl's. Since actually running the table-filling part --- is usually the last thing to do, we can freeze as well. - -runFreezeMTbls ts = do - unsafeRunFillTables $ expose ts - freezeTables $ onlyTables ts -{-# INLINE runFreezeMTbls #-} - - - --- * Expose inner mutable tables - --- | Expose the actual mutable table with an 'MTbl'. (Should be temporary --- until 'MTbl's get a more thorough treatment for auto-filling. - -class ExposeTables t where - type TableFun t :: * - type OnlyTables t :: * - expose :: t -> TableFun t - onlyTables :: t -> OnlyTables t - -instance ExposeTables Z where - type TableFun Z = Z - type OnlyTables Z = Z - expose Z = Z - onlyTables Z = Z - {-# INLINE expose #-} - {-# INLINE onlyTables #-} - - - -- | A vanilla context-free grammar data CFG @@ -78,13 +50,13 @@ -- /not/ want to have this state influence forward results, unless that can -- be made deterministic, or we'll break Bellman) -class MutateCell (h :: *) (s :: *) (im :: * -> *) (om :: * -> *) i where - mutateCell :: Proxy h -> Int -> Int -> (forall a . im a -> om a) -> s -> i -> i -> om () +class MutateCell (h :: *) (s :: *) (im :: * -> *) i where + mutateCell :: (Monad om, PrimMonad om) => Proxy h -> Int -> Int -> (forall a . im a -> om a) -> s -> i -> i -> om () -- | -class MutateTables (h :: *) (s :: *) (im :: * -> *) (om :: * -> *) where - mutateTables :: Proxy h -> (forall a . im a -> om a) -> s -> om s +class MutateTables (h :: *) (s :: *) (im :: * -> *) where + mutateTables :: (Monad om, PrimMonad om) => Proxy h -> (forall a . im a -> om a) -> s -> om s class TableOrder (s :: *) where tableLittleOrder :: s -> [Int] @@ -113,15 +85,14 @@ -- ** individual instances for filling a *single cell* instance - ( Monad om - ) => MutateCell p Z im om i where + ( + ) => MutateCell p Z im i where mutateCell _ _ _ _ Z _ _ = return () {-# INLINE mutateCell #-} instance - ( MutateCell CFG ts im om i - , PrimMonad om - ) => MutateCell CFG (ts:.TwIRec im c i x) im om i where + ( MutateCell CFG ts im i + ) => MutateCell CFG (ts:.TwIRec im c i x) im i where mutateCell h bo lo mrph (ts:._) lu i = do mutateCell h bo lo mrph ts lu i {-# Inline mutateCell #-} @@ -129,9 +100,8 @@ instance ( PrimArrayOps arr i x , MPrimArrayOps arr i x - , MutateCell CFG ts im om i - , PrimMonad om - ) => MutateCell CFG (ts:.TwITbl im arr c i x) im om i where + , MutateCell CFG ts im i + ) => MutateCell CFG (ts:.TwITbl im arr c i x) im i where mutateCell h bo lo mrph (ts:.TW (ITbl tbo tlo c arr) f) lu i = do mutateCell h bo lo mrph ts lu i when (bo==tbo && lo==tlo) $ do @@ -145,9 +115,8 @@ instance ( PrimArrayOps arr ZS2 x , MPrimArrayOps arr ZS2 x - , MutateCell MonotoneMCFG ts im om ZS2 - , PrimMonad om - ) => MutateCell MonotoneMCFG (ts:.TwITbl im arr c ZS2 x) im om ZS2 where + , MutateCell MonotoneMCFG ts im ZS2 + ) => MutateCell MonotoneMCFG (ts:.TwITbl im arr c ZS2 x) im ZS2 where mutateCell h bo lo mrph (ts:.TW (ITbl tbo tlo c arr) f) lu iklj@(Z:.Subword (i:.k):.Subword(l:.j)) = do mutateCell h bo lo mrph ts lu iklj when (bo==tbo && lo==tlo && k<=l) $ do @@ -159,9 +128,8 @@ instance ( PrimArrayOps arr (Subword I) x , MPrimArrayOps arr (Subword I) x - , MutateCell h ts im om (Z:.Subword I:.Subword I) - , PrimMonad om - ) => MutateCell h (ts:.TwITbl im arr c (Subword I) x) im om (Z:.Subword I:.Subword I) where + , MutateCell h ts im (Z:.Subword I:.Subword I) + ) => MutateCell h (ts:.TwITbl im arr c (Subword I) x) im (Z:.Subword I:.Subword I) where mutateCell h bo lo mrph (ts:.TW (ITbl tbo tlo c arr) f) lu@(Z:.Subword (l:._):.Subword(_:.u)) ix@(Z:.Subword (i1:.j1):.Subword (i2:.j2)) = do mutateCell h bo lo mrph ts lu ix when (bo==tbo && lo==tlo && i1==i2 && j1==j2) $ do @@ -178,13 +146,12 @@ -- bounds instance - ( Monad om - , MutateCell h (ts:.TwITbl im arr c i x) im om i + ( MutateCell h (ts:.TwITbl im arr c i x) im i , PrimArrayOps arr i x , Show i , IndexStream i , TableOrder (ts:.TwITbl im arr c i x) - ) => MutateTables h (ts:.TwITbl im arr c i x) im om where + ) => MutateTables h (ts:.TwITbl im arr c i x) im where mutateTables h mrph tt@(_:.TW (ITbl _ _ _ arr) _) = do let (from,to) = bounds arr -- TODO (1) find the set of orders for the synvars @@ -195,6 +162,9 @@ 1 -> let lo = VU.head tlos in flip SM.mapM_ (streamUp from to) $ \k -> mutateCell h bo lo (inline mrph) tt to k + -- TODO each big-order group should be allowed to have its own sets + -- of bounds. within a group, it doesn't make a lot of sense to + -- have different bounds? Is there a use case for that even? _ -> flip SM.mapM_ (streamUp from to) $ \k -> VU.forM_ tlos $ \lo -> mutateCell h bo lo (inline mrph) tt to k @@ -205,13 +175,145 @@ -- -- TODO generalize to @MonadIO@ or @MonadPrim@. -mutateTablesDefault :: MutateTables CFG t Id IO => t -> t +mutateTablesDefault :: MutateTables CFG t Id => t -> t mutateTablesDefault t = unsafePerformIO $ mutateTables (Proxy :: Proxy CFG) (return . unId) t {-# INLINE mutateTablesDefault #-} -- | Mutate tables, but observe certain hints. We use this for monotone -- mcfgs for now. -mutateTablesWithHints :: MutateTables h t Id IO => Proxy h -> t -> t +mutateTablesWithHints :: MutateTables h t Id => Proxy h -> t -> t mutateTablesWithHints h t = unsafePerformIO $ mutateTables h (return . unId) t + + + + + + +mutateTablesST t = runST $ mutateTablesNew t +{-# Inline mutateTablesST #-} + +-- | +-- +-- TODO new way how to do table filling. Because we now have heterogeneous +-- tables (i) group tables by @big order@ into different bins; (ii) check +-- that each bin has the same bounds (needed? -- could we have +-- smaller-sized tables once in a while); (iii) run each bin one after the +-- other +-- +-- TODO measure performance penalty, if any. We might need liberal +-- INLINEABLE, and specialization. On the other hand, we can do the +-- freeze/unfreeze outside of table filling. + +mutateTablesNew + :: forall t m . + ( TableOrder t + , TSBO t + , Monad m + , PrimMonad m + ) + => t + -> m t +mutateTablesNew ts = do + -- sort the tables according to [bigorder,type,littleorder]. For each + -- @bigorder@, we should have only one @type@ and can therefor do the + -- following (i) get subset of the @ts@, (ii) use outermost of @ts@ to + -- get bounds, (iii) fill these tables + let !tbos = VU.fromList . nub . sort $ tableBigOrder ts + let ds = L.sort $ asDyn ts + let goM :: (Monad m, PrimMonad m) => [Q] -> m () + goM [] = return () + goM xs = do + ys <- fillWithDyn xs ts + if null ys + then return () + else goM ys + {-# Inlinable goM #-} + goM ds + return ts +{-# Inline mutateTablesNew #-} + +data Q = Q + { qBigOrder :: Int + , qLittleOrder :: Int + , qTypeRep :: T.TypeRep + , qObject :: Dynamic + } + deriving (Show) + +instance Eq Q where + Q bo1 lo1 tr1 _ == Q bo2 lo2 tr2 _ = (bo1,tr1,lo1) == (bo2,tr2,lo2) + +instance Ord Q where + Q bo1 lo1 tr1 _ `compare` Q bo2 lo2 tr2 _ = (bo1,tr1,lo1) `compare` (bo2,tr2,lo2) + +-- | Find the outermost table that has a certain big order and then fill +-- from there. + +class TSBO t where + asDyn :: t -> [Q] + fillWithDyn :: (Monad m, PrimMonad m) => [Q] -> t -> m [Q] + +instance TSBO Z where + asDyn Z = [] + fillWithDyn qs Z = return qs + {-# Inlinable asDyn #-} + {-# Inline fillWithDyn #-} + +instance + ( TSBO ts + , Typeable arr + , Typeable c + , Typeable i + , Typeable x + , PrimArrayOps arr i x + , MPrimArrayOps arr i x + , IndexStream i + ) => TSBO (ts:.TwITbl Id arr c i x) where + asDyn (ts:.t@(TW (ITbl bo lo _ _) _)) = Q bo lo (T.typeOf t) (toDyn t) : asDyn ts + fillWithDyn qs (ts:.t@(TW (ITbl bo lo _ arr) f)) = do + let (from,to) = bounds arr + -- @hs@ are all tables that can be filled here + -- @ns@ are all tables we can't fill and need to process further down + -- the line + let (hs,ns) = L.span (\Q{..} -> qBigOrder == bo && qTypeRep == T.typeOf t) qs + if null hs + then fillWithDyn qs ts + else do + let ms = Prelude.map concrete hs + concrete = (maybe (error "fromDynamic should not fail!") + (\x -> x `asTypeOf` t) + . fromDynamic . qObject) + -- We have a single table and should short-circuit here + -- + -- TODO we should specialize for tables of lengh @1..k@ for some + -- small k. For @1@ and Needleman-Wunsch, we have a very nice @1.8@ + -- seconds down to @1.25@ seconds. :-) + case (length ms) of + 1 -> do marr <- unsafeThaw arr + flip SM.mapM_ (streamUp from to) $ \k -> do + -- TODO @inline mrph@ ... + z <- (return . unId) $ f to k + writeM marr k z + -- We have more than one table in will work over the list of tables + _ -> do marrfs <- Prelude.mapM (\(TW (ITbl _ _ _ arr) f) -> unsafeThaw arr >>= \marr -> return (marr,f)) ms + flip SM.mapM_ (streamUp from to) $ \k -> + forM_ marrfs $ \(marr,f) -> do + z <- (return . unId) $ f to k + writeM marr k z + -- traceShow (hs,length ms) $ + return ns + {-# Inline fillWithDyn #-} + +-- We don't need to capture @IRec@ tables as no table-filling takes place +-- for those tables. @asDyn@ therefore just collects on the remaining @ts@, +-- while @fillWithDyn@ hands of to the next possible table. + +instance + ( TSBO ts + ) => TSBO (ts:.TwIRec Id c i x) where + asDyn (ts:.t@(TW (IRec _ _ _) _)) = asDyn ts + fillWithDyn qs (ts:._) = fillWithDyn qs ts + {-# Inlinable asDyn #-} + {-# Inline fillWithDyn #-} diff --git a/ADP/Fusion/SynVar/Indices/Classes.hs b/ADP/Fusion/SynVar/Indices/Classes.hs --- a/ADP/Fusion/SynVar/Indices/Classes.hs +++ b/ADP/Fusion/SynVar/Indices/Classes.hs @@ -25,10 +25,10 @@ class AddIndexDense s u c i where addIndexDenseGo :: (Monad m) - => c -> Context i -> i -> i -> Stream m (SvState s a Z Z) -> Stream m (SvState s a u i) + => c -> Context i -> u -> u -> i -> i -> Stream m (SvState s a Z Z) -> Stream m (SvState s a u i) instance AddIndexDense a Z Z Z where - addIndexDenseGo _ _ _ _ = id + addIndexDenseGo _ _ _ _ _ _ = id {-# Inline addIndexDenseGo #-} -- | @SvState@ holds the state that is currently being built up by @@ -53,8 +53,8 @@ , s ~ Elm x0 i0 , Element x0 i0 ) - => c -> Context i -> i -> i -> Stream m s -> Stream m (s,u,RunningIndex i) -addIndexDense t c u i = map (\(SvS s z i') -> (s,z,i')) . addIndexDenseGo t c u i . map (\s -> (SvS s Z RiZ)) + => c -> Context i -> u -> u -> i -> i -> Stream m s -> Stream m (s,u,RunningIndex i) +addIndexDense t c lb ub u i = map (\(SvS s z i') -> (s,z,i')) . addIndexDenseGo t c lb ub u i . map (\s -> (SvS s Z RiZ)) {-# Inline addIndexDense #-} -- | In case of 1-dim tables, we wrap the index creation in a multi-dim @@ -68,10 +68,10 @@ , s ~ Elm x0 a , Element x0 a ) - => c -> Context i -> i -> i -> Stream m s -> Stream m (s,u,RunningIndex i) -addIndexDense1 t c u i = map (\(SvS (ElmSynVar1 s) (Z:.z) (RiZ:.:i')) -> (s,z,i')) - . addIndexDenseGo (Z:.t) (Z:.c) (Z:.u) (Z:.i) - . map (\s -> (SvS (elmSynVar1 s i) Z RiZ)) + => c -> Context i -> u -> u -> i -> i -> Stream m s -> Stream m (s,u,RunningIndex i) +addIndexDense1 t c lb ub u i = map (\(SvS (ElmSynVar1 s) (Z:.z) (RiZ:.:i')) -> (s,z,i')) + . addIndexDenseGo (Z:.t) (Z:.c) (Z:.lb) (Z:.ub) (Z:.u) (Z:.i) + . map (\s -> (SvS (elmSynVar1 s i) Z RiZ)) {-# Inline addIndexDense1 #-} newtype SynVar1 s = SynVar1 s diff --git a/ADP/Fusion/SynVar/Indices/Point.hs b/ADP/Fusion/SynVar/Indices/Point.hs --- a/ADP/Fusion/SynVar/Indices/Point.hs +++ b/ADP/Fusion/SynVar/Indices/Point.hs @@ -19,11 +19,11 @@ ( IndexHdr s x0 i0 us (PointL I) cs c is (PointL I) , MinSize c ) => AddIndexDense s (us:.PointL I) (cs:.c) (is:.PointL I) where - addIndexDenseGo (cs:._) (vs:.IStatic d) (us:.u) (is:.i) + addIndexDenseGo (cs:._) (vs:.IStatic d) (lbs:.lb) (ubs:.ub) (us:.u) (is:.i) = map (\(SvS s t y') -> SvS s (t:.i) (y' :.: RiPlI (fromPointL i))) - . addIndexDenseGo cs vs us is - addIndexDenseGo (cs:.c) (vs:.IVariable d) (us:.u) (is:.PointL i) - = flatten mk step . addIndexDenseGo cs vs us is + . addIndexDenseGo cs vs lbs ubs us is + addIndexDenseGo (cs:.c) (vs:.IVariable d) (lbs:.lb) (ubs:.ub) (us:.u) (is:.PointL i) + = flatten mk step . addIndexDenseGo cs vs lbs ubs us is where mk svS = let RiPlI k = getIndex (getIdx $ sS svS {- sIx svS -} ) (Proxy :: PRI is (PointL I)) in return $ svS :. k step (svS@(SvS s t y') :. k) @@ -37,27 +37,27 @@ instance ( IndexHdr s x0 i0 us (PointL O) cs c is (PointL O) ) => AddIndexDense s (us:.PointL O) (cs:.c) (is:.PointL O) where - addIndexDenseGo (cs:._) (vs:.OStatic d) (us:.u) (is:.i) + addIndexDenseGo (cs:._) (vs:.OStatic d) (lbs:.lb) (ubs:.ub) (us:.u) (is:.i) = map (\(SvS s t y') -> let RiPlO oi oo = getIndex (getIdx s) (Proxy :: PRI is (PointL O)) in SvS s (t:.PointL oo) (y' :.: RiPlO oi oo) ) - . addIndexDenseGo cs vs us is + . addIndexDenseGo cs vs lbs ubs us is {-# Inline addIndexDenseGo #-} instance ( IndexHdr s x0 i0 us (PointL I) cs c is (PointL C) ) => AddIndexDense s (us:.PointL I) (cs:.c) (is:.PointL C) where - addIndexDenseGo (cs:._) (vs:.Complemented) (us:.u) (is:.i) + addIndexDenseGo (cs:._) (vs:.Complemented) (lbs:.lb) (ubs:.ub) (us:.u) (is:.i) = map (\(SvS s t y) -> let RiPlC k = getIndex (getIdx s) (Proxy :: PRI is (PointL C)) in SvS s (t:.PointL k) (y :.: RiPlC k) ) - . addIndexDenseGo cs vs us is + . addIndexDenseGo cs vs lbs ubs us is {-# Inline addIndexDenseGo #-} instance ( IndexHdr s x0 i0 us (PointL O) cs c is (PointL C) ) => AddIndexDense s (us:.PointL O) (cs:.c) (is:.PointL C) where - addIndexDenseGo (cs:._) (vs:.Complemented) (us:.u) (is:.i) + addIndexDenseGo (cs:._) (vs:.Complemented) (lbs:.lb) (ubs:.ub) (us:.u) (is:.i) = map (\(SvS s t y) -> let RiPlC k = getIndex (getIdx s) (Proxy :: PRI is (PointL C)) in SvS s (t:.PointL k) (y:.:RiPlC k) ) - . addIndexDenseGo cs vs us is + . addIndexDenseGo cs vs lbs ubs us is {-# Inline addIndexDenseGo #-} diff --git a/ADP/Fusion/SynVar/Indices/Unit.hs b/ADP/Fusion/SynVar/Indices/Unit.hs --- a/ADP/Fusion/SynVar/Indices/Unit.hs +++ b/ADP/Fusion/SynVar/Indices/Unit.hs @@ -19,32 +19,32 @@ instance ( IndexHdr s x0 i0 us (Unit I) cs c is (Unit I) ) => AddIndexDense s (us:.Unit I) (cs:.c) (is:.Unit I) where - addIndexDenseGo (cs:._) (vs:.IStatic ()) (us:._) (is:._) + addIndexDenseGo (cs:._) (vs:.IStatic ()) (lbs:._) (ubs:._) (us:._) (is:._) = map (\(SvS s t y') -> SvS s (t:.Unit) (y':.:RiU)) - . addIndexDenseGo cs vs us is + . addIndexDenseGo cs vs lbs ubs us is {-# Inline addIndexDenseGo #-} instance ( IndexHdr s x0 i0 us (Unit O) cs c is (Unit O) ) => AddIndexDense s (us:.Unit O) (cs:.c) (is:.Unit O) where - addIndexDenseGo (cs:._) (vs:.OStatic ()) (us:._) (is:._) + addIndexDenseGo (cs:._) (vs:.OStatic ()) (lbs:.lb) (ubs:.ub) (us:._) (is:._) = map (\(SvS s t y') -> SvS s (t:.Unit) (y':.:RiU)) - . addIndexDenseGo cs vs us is + . addIndexDenseGo cs vs lbs ubs us is {-# Inline addIndexDenseGo #-} instance ( IndexHdr s x0 i0 us (Unit I) cs c is (Unit C) ) => AddIndexDense s (us:.Unit I) (cs:.c) (is:.Unit C) where - addIndexDenseGo (cs:._) (vs:.Complemented) (us:._) (is:._) + addIndexDenseGo (cs:._) (vs:.Complemented) (lbs:._) (ubs:._) (us:._) (is:._) = map (\(SvS s t y') -> SvS s (t:.Unit) (y':.:RiU)) - . addIndexDenseGo cs vs us is + . addIndexDenseGo cs vs lbs ubs us is {-# Inline addIndexDenseGo #-} instance ( IndexHdr s x0 i0 us (Unit O) cs c is (Unit C) ) => AddIndexDense s (us:.Unit O) (cs:.c) (is:.Unit C) where - addIndexDenseGo (cs:._) (vs:.Complemented) (us:._) (is:._) + addIndexDenseGo (cs:._) (vs:.Complemented) (lbs:._) (ubs:._) (us:._) (is:._) = map (\(SvS s t y') -> SvS s (t:.Unit) (y':.:RiU)) - . addIndexDenseGo cs vs us is + . addIndexDenseGo cs vs lbs ubs us is {-# Inline addIndexDenseGo #-} diff --git a/ADP/Fusion/SynVar/Recursive/Type.hs b/ADP/Fusion/SynVar/Recursive/Type.hs --- a/ADP/Fusion/SynVar/Recursive/Type.hs +++ b/ADP/Fusion/SynVar/Recursive/Type.hs @@ -103,7 +103,7 @@ ) => MkStream m (ls :!: TwIRec m (cs:.c) (us:.u) x) (is:.i) where mkStream (ls :!: TW (IRec c l h) fun) vs us is = mapM (\(s,tt,ii) -> (\res -> ElmIRec res ii s) <$> fun h tt) - . addIndexDense c vs us is + . addIndexDense c vs l h us is $ mkStream ls (tableStaticVar (Proxy :: Proxy (us:.u)) c vs is) us (tableStreamIndex (Proxy :: Proxy (us:.u)) c vs is) {-# Inline mkStream #-} @@ -117,7 +117,7 @@ ) => MkStream mB (ls :!: TwIRecBt (cs:.c) (us:.u) x mF mB r) (is:.i) where mkStream (ls :!: TW (BtIRec c l h fun) bt) vs us is = mapM (\(s,tt,ii) -> (\res bb -> ElmBtIRec res bb ii s) <$> fun h tt <*> bt h tt) - . addIndexDense c vs us is + . addIndexDense c vs l h us is $ mkStream ls (tableStaticVar (Proxy :: Proxy (us:.u)) c vs is) us (tableStreamIndex (Proxy :: Proxy (us:.u)) c vs is) {-# Inline mkStream #-} diff --git a/ADP/Fusion/Term/Edge/Type.hs b/ADP/Fusion/Term/Edge/Type.hs --- a/ADP/Fusion/Term/Edge/Type.hs +++ b/ADP/Fusion/Term/Edge/Type.hs @@ -10,22 +10,30 @@ -data Edge e where - Edge :: (Int -> Int -> e) -> Edge e +newtype From = From { getFrom :: Int } + deriving (Eq,Ord,Show) -instance Build (Edge e) +newtype To = To { getTo :: Int } + deriving (Eq,Ord,Show) +-- | An edge in a graph. As a parsing symbol, it will provide (From:.To) +-- pairs. + +data Edge = Edge + +instance Build Edge + instance ( Element ls i - ) => Element (ls :!: Edge e) i where - data Elm (ls :!: Edge e) i = ElmEdge !e !(RunningIndex i) (Elm ls i) - type Arg (ls :!: Edge e) = Arg ls :. e + ) => Element (ls :!: Edge) i where + data Elm (ls :!: Edge) i = ElmEdge !(From:.To) !(RunningIndex i) (Elm ls i) + type Arg (ls :!: Edge) = Arg ls :. (From:.To) getArg (ElmEdge e _ ls) = getArg ls :. e getIdx (ElmEdge _ i _ ) = i {-# Inline getArg #-} {-# Inline getIdx #-} -deriving instance (Show i, Show (RunningIndex i), Show e, Show (Elm ls i)) => Show (Elm (ls :!: Edge e) i) +deriving instance (Show i, Show (RunningIndex i), Show (Elm ls i)) => Show (Elm (ls :!: Edge) i) -type instance TermArg (Edge e) = e +type instance TermArg Edge = (From:.To) diff --git a/ADPfusion.cabal b/ADPfusion.cabal --- a/ADPfusion.cabal +++ b/ADPfusion.cabal @@ -1,5 +1,5 @@ name: ADPfusion -version: 0.5.2.0 +version: 0.5.2.2 author: Christian Hoener zu Siederdissen, 2011-2016 copyright: Christian Hoener zu Siederdissen, 2011-2016 homepage: https://github.com/choener/ADPfusion @@ -11,7 +11,7 @@ build-type: Simple stability: experimental cabal-version: >= 1.10.0 -tested-with: GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1 +tested-with: GHC == 7.10.3, GHC == 8.0.1 synopsis: Efficient, high-level dynamic programming. description: @@ -49,16 +49,26 @@ -flag examples - description: build the examples +flag debug + description: Enable bounds checking and various other debug operations at the cost of a significant performance penalty. default: False manual: True -flag debug - description: dump intermediate Core files +flag debugoutput + description: Enable debug output, which spams the screen full of index information default: False manual: True +flag debugdump + description: Enable dumping intermediate / core files + default: False + manual: True + +flag examples + description: build the examples + default: False + manual: True + flag spectest description: build the spec-ctor test case default: False @@ -78,22 +88,22 @@ library build-depends: base >= 4.7 && < 5.0 - , bits >= 0.4 && < 0.6 + , bits >= 0.4 , containers - , mmorph >= 1.0 && < 1.1 - , mtl >= 2.0 && < 2.3 - , primitive >= 0.5.4 && < 0.7 - , QuickCheck >= 2.7 && < 2.9 - , strict >= 0.3 && < 0.4 - , template-haskell >= 2.0 && < 3.0 - , th-orphans >= 0.12 && < 0.14 - , transformers >= 0.3 && < 0.6 - , tuple >= 0.3 && < 0.4 - , vector >= 0.11 && < 0.12 + , mmorph >= 1.0 + , mtl >= 2.0 + , primitive >= 0.5.4 + , QuickCheck >= 2.7 + , strict >= 0.3 + , template-haskell >= 2.0 + , th-orphans >= 0.12 + , transformers >= 0.3 + , tuple >= 0.3 + , vector >= 0.11 -- - , DPutils == 0.0.0.* + , DPutils == 0.0.1.* , OrderedBits == 0.0.1.* - , PrimitiveArray == 0.7.1.* + , PrimitiveArray == 0.8.0.* exposed-modules: -- multi imports @@ -144,6 +154,8 @@ , CPP , DataKinds , DefaultSignatures + , DeriveDataTypeable + , DeriveGeneric , FlexibleContexts , FlexibleInstances , GADTs @@ -164,6 +176,11 @@ Haskell2010 ghc-options: -O2 -funbox-strict-fields + if flag(debugdump) + ghc-options: + -ddump-to-file + -ddump-simpl + -dsuppress-all @@ -200,9 +217,9 @@ , PrimitiveArray , QuickCheck , strict - , test-framework >= 0.8 && < 0.9 - , test-framework-quickcheck2 >= 0.3 && < 0.4 - , test-framework-th >= 0.2 && < 0.3 + , tasty >= 0.11 + , tasty-quickcheck >= 0.8 + , tasty-th >= 0.1 , vector @@ -216,6 +233,7 @@ True build-depends: base , ADPfusion + , primitive , PrimitiveArray , template-haskell , vector @@ -241,7 +259,7 @@ -funbox-strict-fields -funfolding-use-threshold1000 -funfolding-keeness-factor1000 - if flag(debug) + if flag(debugdump) ghc-options: -ddump-to-file -ddump-simpl @@ -283,11 +301,11 @@ -funbox-strict-fields -funfolding-use-threshold1000 -funfolding-keeness-factor1000 - if flag(debug) - ghc-options: - -ddump-to-file - -ddump-simpl - -dsuppress-all +-- if flag(debug) +-- ghc-options: +-- -ddump-to-file +-- -ddump-simpl +-- -dsuppress-all @@ -300,9 +318,9 @@ True build-depends: base , template-haskell - , fmlist >= 0.9 && < 0.10 + , fmlist >= 0.9 , vector - , criterion >= 1.1 && < 1.2 + , criterion >= 1.1 else buildable: False diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,15 @@ +0.5.2.2 +------- + +- Modified signature of Edge to make explicit the @From@ and @To@ nodes of the + edge. Minor version bump, because @Edge@ is not official yet. +- optimized table filling yields large improvements for linear languages + +0.5.2.1 +------- + +- removed upper bounds + 0.5.2.0 ------- diff --git a/src/NeedlemanWunsch.hs b/src/NeedlemanWunsch.hs --- a/src/NeedlemanWunsch.hs +++ b/src/NeedlemanWunsch.hs @@ -83,6 +83,8 @@ import Control.Monad (forM_) import System.Environment (getArgs) import Text.Printf +import Control.Monad.Primitive +import Control.Monad.ST -- Streams of parses are the streams defined in the @vector@ package. @@ -272,7 +274,7 @@ -- 'runOutsideNeedlemanWunsch'. nwInsideForward :: VU.Vector Char -> VU.Vector Char -> Z:.TwITbl Id Unboxed (Z:.EmptyOk:.EmptyOk) (Z:.PointL I:.PointL I) Int -nwInsideForward i1 i2 = {-# SCC "nwInsideForward" #-} mutateTablesDefault $ +nwInsideForward i1 i2 = {-# SCC "nwInsideForward" #-} mutateTablesST $ grammar sScore (ITbl 0 0 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.PointL 0:.PointL 0) (Z:.PointL n1:.PointL n2) (-999999) [])) i1 i2 @@ -307,7 +309,7 @@ -- outside-table-filling part. nwOutsideForward :: VU.Vector Char -> VU.Vector Char -> Z:.TwITbl Id Unboxed (Z:.EmptyOk:.EmptyOk) (Z:.PointL O:.PointL O) Int -nwOutsideForward i1 i2 = {-# SCC "nwOutsideForward" #-} mutateTablesDefault $ +nwOutsideForward i1 i2 = {-# SCC "nwOutsideForward" #-} mutateTablesST $ grammar sScore (ITbl 0 0 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.PointL 0:.PointL 0) (Z:.PointL n1:.PointL n2) (-999999) [])) i1 i2 diff --git a/tests/QuickCheck/Point.hs b/tests/QuickCheck/Point.hs --- a/tests/QuickCheck/Point.hs +++ b/tests/QuickCheck/Point.hs @@ -15,8 +15,8 @@ import Test.QuickCheck.All import Test.QuickCheck.Monadic #ifdef ADPFUSION_TEST_SUITE_PROPERTIES -import Test.Framework.TH -import Test.Framework.Providers.QuickCheck2 +import Test.Tasty.TH +import Test.Tasty.QuickCheck #endif import Data.PrimitiveArray diff --git a/tests/properties.hs b/tests/properties.hs --- a/tests/properties.hs +++ b/tests/properties.hs @@ -3,12 +3,12 @@ module Main where -import Test.Framework +import Test.Tasty import QuickCheck.Point (testgroup_point) main :: IO () -main = defaultMain [testgroup_point] +main = defaultMain testgroup_point