ADPfusion 0.0.1.2 → 0.1.0.0

raw patch · 7 files changed

+941/−20 lines, 7 filesdep +QuickCheckdep +criteriondep +ghc-primdep ~PrimitiveArraydep ~primitivedep ~vectornew-component:exe:GAPcriterionPVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck, criterion, ghc-prim

Dependency ranges changed: PrimitiveArray, primitive, vector

API changes (from Hackage documentation)

Files

• ADP/Fusion/GAPlike.hs +571/−0
• ADP/Fusion/GAPlike/Criterion.hs +179/−0
• ADP/Fusion/GAPlike/DevelCommon.hs +22/−0
• ADP/Fusion/GAPlike/QuickCheck.hs +57/−0
• ADP/Fusion/Monadic/Internal.hs +13/−13
• ADPfusion.cabal +90/−7
• Tests/GAPcriterion.hs +9/−0

@@ -0,0 +1,571 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- | +--+-- HINTS for writing your own (Non-) terminals:+--+-- - ALWAYS provide types for local functions of 'mkStream' and+-- 'mkStreamInner'. Otherwise stream-fusion gets confused and doesn't optimize.+-- (Observable in core by looking for 'Left', 'RIght' constructors and 'SPEC'+-- constructors.++module ADP.Fusion.GAPlike where++import Control.Monad.Primitive+import Data.Primitive.Types (Prim(..))+import Data.Vector.Fusion.Stream.Size+import GHC.Prim (Constraint)+import qualified Data.Vector.Fusion.Stream.Monadic as S+import qualified Data.Vector.Unboxed as VU++import Data.PrimitiveArray (PrimArrayOps(..), MPrimArrayOps(..))+import "PrimitiveArray" Data.Array.Repa.Index+import qualified Data.PrimitiveArray as PA+import qualified Data.PrimitiveArray.Zero.Unboxed as ZU++++-- * The required type classes. Each class does its own thing.++-- | The 'Build' class. Combines the arguments into a stack before they are+-- turned into a stream.+--+--+--+-- To use, simply write "instance Build MyDataCtor" as we have sensible default+-- instances.++class Build x where+  -- | The stack of arguments we are building.+  type BuildStack x :: *+  -- | The default is for the left-most element.+  type BuildStack x = None :. x+  -- | Given an element, create the stack.+  build :: x -> BuildStack x+  -- | Default for the left-most element.+  default build :: (BuildStack x ~ (None :. x)) => x -> BuildStack x+  build x = None :. x+  {-# INLINE build #-}++-- | The stream element. Creates a type-level recursive data type containing+-- the extracted arguments.++class StreamElement x where+  -- | one element of the stream, recursively defined+  data StreamElm x :: *+  -- | top-most index of the stream -- typically int+  type StreamTopIdx  x :: *+  -- | complete, recursively defined argument of the stream+  type StreamArg  x :: *+  -- | Given a stream element, we extract the top-most idx+  getTopIdx :: StreamElm x -> StreamTopIdx x+  -- | extract the recursively defined argument in a well-defined way for 'apply'+  getArg :: StreamElm x -> StreamArg x++-- | Given the arguments, creates a stream of 'StreamElement's.++class (StreamConstraint x) => MkStream m x where+  type StreamConstraint x :: Constraint+  type StreamConstraint x = ()+  mkStream      :: (StreamConstraint x) => x -> (Int,Int) -> S.Stream m (StreamElm x)+  mkStreamInner :: (StreamConstraint x) => x -> (Int,Int) -> S.Stream m (StreamElm x)++++-- * Terminates the stack of arguments++-- | Very simple data ctor++data None = None++-- | For CORE-language, we have our own Arg-terminator++data ArgZ = ArgZ++instance StreamElement None where+  data StreamElm None    = SeNone !Int+  type StreamTopIdx None = Int+  type StreamArg    None = ArgZ+  getTopIdx (SeNone k) = k+  getArg _ = ArgZ+  {-# INLINE getTopIdx #-}+  {-# INLINE getArg #-}++instance (Monad m) => MkStream m None where+  mkStream None (i,j) = S.unfoldr step i where+    step k+      | k<=j = Just (SeNone i, j+1)+      | otherwise = Nothing+    {-# INLINE step #-}+  {-# INLINE mkStream #-}+  mkStreamInner = mkStream+  {-# INLINE mkStreamInner #-}++++-- * A single character terminal. Using unboxed vector to hold the input. Note+-- that "character" means parsing a scalar, not that the 'Chr' parser only+-- accepts "Char"s.++data Chr e = Chr !(VU.Vector e)++instance Build (Chr e)++instance (StreamElement x) => StreamElement (x:.Chr e) where+  data StreamElm (x:.Chr e) = SeChr !(StreamElm x) !Int !e+  type StreamTopIdx (x:.Chr e) = Int+  type StreamArg (x:.Chr e) = StreamArg x :. e+  getTopIdx (SeChr _ k _) = k+  getArg (SeChr x _ e) = getArg x :. e+  {-# INLINE getTopIdx #-}+  {-# INLINE getArg #-}++-- TODO I think, we can rewrite both versions to use S.map instead of S.flatten.++instance (Monad m, MkStream m x, StreamElement x, StreamTopIdx x ~ Int, VU.Unbox e) => MkStream m (x:.Chr e) where+  mkStream (x:.Chr es) (i,j) = S.flatten mk step Unknown $ mkStream x (i,j-1) where+    mk :: StreamElm x -> m (StreamElm x, Int)+    mk x = return (x, getTopIdx x)+    step :: (StreamElm x, Int) -> m (S.Step (StreamElm x, Int) (StreamElm (x:.Chr e)))+    step (x,k)+      | k+1 == j = return $ S.Yield (SeChr x (k+1) (VU.unsafeIndex es k)) (x,j+1)+      | otherwise = return S.Done+    {-# INLINE mk #-}+    {-# INLINE step #-}+  {-# INLINE mkStream #-}+  mkStreamInner (x:.Chr es) (i,j) = S.flatten mk step Unknown $ mkStreamInner x (i,j-1) where+    mk :: StreamElm x -> m (StreamElm x, Int)+    mk x = return (x, getTopIdx x)+    step :: (StreamElm x, Int) -> m (S.Step (StreamElm x, Int) (StreamElm (x:.Chr e)))+    step (x,k)+      | k < j     = return $ S.Yield (SeChr x (k+1) (VU.unsafeIndex es k)) (x,j+1)+      | otherwise = return $ S.Done+    {-# INLINE mk #-}+    {-# INLINE step #-}+  {-# INLINE mkStreamInner #-}++++-- * Empty and non-empty tables.+--+-- TODO This will probably become more funny with triangular tables ...++-- | empty subwords allowed++data E++-- | only non-empty subwords++data N++class TransToN t where+  type TransTo t :: *+  transToN :: t -> TransTo t++-- | Used by the instances below for index calculations.++class TblType tt where+  initDeltaIdx :: tt -> Int++instance TblType E where+  initDeltaIdx _ = 0+  {-# INLINE initDeltaIdx #-}++instance TblType N where+  initDeltaIdx _ = 1+  {-# INLINE initDeltaIdx #-}++-- ** Immutable tables++data Tbl c es = Tbl !es++instance TransToN (Tbl c es) where+  type TransTo (Tbl c es) = Tbl N es+  transToN (Tbl es) = Tbl es+  {-# INLINE transToN #-}++instance Build (Tbl c es)++instance (StreamElement x, PrimArrayOps arr DIM2 e, TblType c) => StreamElement (x:.Tbl c (arr DIM2 e)) where+  data StreamElm    (x:.Tbl c (arr DIM2 e)) = SeTbl !(StreamElm x) !Int !e+  type StreamTopIdx (x:.Tbl c (arr DIM2 e)) = Int+  type StreamArg    (x:.Tbl c (arr DIM2 e)) = StreamArg x :. e+  getTopIdx (SeTbl _ k _) = k+  getArg    (SeTbl x _ e) = getArg x :. e+  {-# INLINE getTopIdx #-}+  {-# INLINE getArg #-}++instance (Monad m, MkStream m x, StreamElement x, StreamTopIdx x ~ Int, PrimArrayOps arr DIM2 e, TblType c) => MkStream m (x:.Tbl c (arr DIM2 e)) where+  -- | The outer stream function assumes that mkStreamInner generates a valid+  -- stream that does not need to be checked. (This should always be true!).+  -- The table entry to read is [k,j], as we supposedly are generating the+  -- outermost stream. Even more "outermost" streams will have changed 'j'+  -- beforehand. 'mkStream' should only ever be used if 'j' can be fixed.+  mkStream (x:.Tbl t) (i,j) = S.map step $ mkStreamInner x (i,j - initDeltaIdx (undefined :: c)) where+    step :: StreamElm x -> StreamElm (x:.Tbl c (arr DIM2 e))+    step x = let k = getTopIdx x in SeTbl x j (t PA.! (Z:.k:.j))+    {-# INLINE step #-}+  -- | The inner stream will, in each step, check if the current subword [k,l]+  -- (forall l>=k) is valid and terminate the stream once l>j.+  mkStreamInner (x:.Tbl t) (i,j) = S.flatten mk step Unknown $ mkStreamInner x (i,j) where+    mk :: StreamElm x -> m (StreamElm x, Int)+    mk x = return (x, getTopIdx x + initDeltaIdx (undefined :: c))+    step :: (StreamElm x, Int) -> m (S.Step (StreamElm x, Int) (StreamElm (x:.Tbl c (arr DIM2 e))))+    step (x,l)+      | l<=j      = return $ S.Yield (SeTbl x l (t PA.! (Z:.k:.l))) (x,l+1)+      | otherwise = return $ S.Done+      where k = getTopIdx x+    {-# INLINE mk #-}+    {-# INLINE step #-}+  {-# INLINE mkStream #-}+  {-# INLINE mkStreamInner #-}++-- ** Mutable tables in some monad.++data MTbl c es = MTbl !es++instance TransToN (MTbl c es) where+  type TransTo (MTbl c es) = MTbl N es+  transToN (MTbl es) = MTbl es+  {-# INLINE transToN #-}++mtblN :: es -> MTbl N es+mtblN es = MTbl es+{-# INLINE mtblN #-}++mtblE :: es -> MTbl E es+mtblE es = MTbl es+{-# INLINE mtblE #-}++instance Build (MTbl c es)++instance (StreamElement x, MPrimArrayOps marr DIM2 e, TblType c) => StreamElement (x:.MTbl c (marr s DIM2 e)) where+  data StreamElm    (x:.MTbl c (marr s DIM2 e)) = SeMTbl !(StreamElm x) !Int !e+  type StreamTopIdx (x:.MTbl c (marr s DIM2 e)) = Int+  type StreamArg    (x:.MTbl c (marr s DIM2 e)) = StreamArg x :. e+  getTopIdx (SeMTbl _ k _) = k+  getArg    (SeMTbl x _ e) = getArg x :. e+  {-# INLINE getTopIdx #-}+  {-# INLINE getArg #-}++instance+  ( Monad m+  , PrimMonad m+  , MkStream m x+  , StreamElement x+  , StreamTopIdx x ~ Int+  , MPrimArrayOps marr DIM2 e+  , TblType c+  , s ~ PrimState m+  ) => MkStream m (x:.MTbl c (marr s DIM2 e)) where+  -- | The outer stream function assumes that mkStreamInner generates a valid+  -- stream that does not need to be checked. (This should always be true!).+  -- The table entry to read is [k,j], as we supposedly are generating the+  -- outermost stream. Even more "outermost" streams will have changed 'j'+  -- beforehand. 'mkStream' should only ever be used if 'j' can be fixed.+  mkStream (x:.MTbl t) (i,j) = S.mapM step $ mkStreamInner x (i,j - initDeltaIdx (undefined :: c)) where+    step :: StreamElm x -> m (StreamElm (x:.MTbl c (marr s DIM2 e)))+    step x = let k = getTopIdx x in PA.readM t (Z:.k:.j) >>= \e -> return $ SeMTbl x j e+    {-# INLINE step #-}+  -- | The inner stream will, in each step, check if the current subword [k,l]+  -- (forall l>=k) is valid and terminate the stream once l>j.+  mkStreamInner (x:.MTbl t) (i,j) = S.flatten mk step Unknown $ mkStreamInner x (i,j) where+    mk :: StreamElm x -> m (StreamElm x, Int)+    mk x = return (x, getTopIdx x + initDeltaIdx (undefined :: c))+    step :: (StreamElm x, Int) -> m (S.Step (StreamElm x, Int) (StreamElm (x:.MTbl c (marr s DIM2 e))))+    step (x,l)+      | l<=j      = readM t (Z:.k:.l) >>= \e -> return $ S.Yield (SeMTbl x l e) (x,l+1)+      | otherwise = return $ S.Done+      where k = getTopIdx x+    {-# INLINE mk #-}+    {-# INLINE step #-}+  {-# INLINE mkStream #-}+  {-# INLINE mkStreamInner #-}++-- ** Some convenience functions.++tNtoE :: Tbl N x -> Tbl E x+tNtoE (Tbl x) = Tbl x+{-# INLINE tNtoE #-}++tEtoN :: Tbl E x -> Tbl N x+tEtoN (Tbl x) = Tbl x+{-# INLINE tEtoN #-}++++-- * Parses an empty subword.++-- | The empty subword. Can not be part of a more complex RHS for obvious+-- reasons: "S -> E S" doesn't make sense. Used in some grammars as the base+-- case.++data Empty = Empty++instance Build Empty where+  type BuildStack Empty = Empty+  build c = c+  {-# INLINE build #-}++instance StreamElement (Empty) where+  data StreamElm    Empty = SeEmpty !Int+  type StreamTopIdx Empty = Int+  type StreamArg    Empty = ArgZ :. ()+  getTopIdx (SeEmpty k) = k+  getArg    (SeEmpty _) = ArgZ :. ()+  {-# INLINE getTopIdx #-}+  {-# INLINE getArg #-}++instance (Monad m) => MkStream m (Empty) where+  mkStream Empty (i,j) = S.unfoldr step i where+    step k+      | k==j      = Just (SeEmpty k, j+1)+      | otherwise = Nothing+    {-# INLINE step #-}+  mkStreamInner = error "undefined for Empty"+  {-# INLINE mkStream #-}+  {-# INLINE mkStreamInner #-}++++-- * Parsing subwords with restriced size. Both min- and max-size are given+-- when binding input.++data RestrictedRegion e = RRegion !Int !Int !(VU.Vector e)++instance Build (RestrictedRegion e)++instance (StreamElement x) => StreamElement (x:.RestrictedRegion e) where+  data StreamElm (x:.RestrictedRegion e) = SeResRegion !(StreamElm x) !Int (VU.Vector e)+  type StreamTopIdx (x:.RestrictedRegion e) = Int+  type StreamArg (x:.RestrictedRegion e) = StreamArg x :. (VU.Vector e)+  getTopIdx (SeResRegion _ k _) = k+  getArg (SeResRegion x _ e) = getArg x :. e+  {-# INLINE getTopIdx #-}+  {-# INLINE getArg #-}++instance (Monad m, MkStream m x, StreamElement x, StreamTopIdx x ~ Int, VU.Unbox e) => MkStream m (x:.RestrictedRegion e) where+  mkStream (x:.RRegion minR maxR xs) (i,j) = S.flatten mk step Unknown $ mkStream x (i,j-1) where+    mk :: StreamElm x -> m (StreamElm x, Int)+    mk x = return (x, getTopIdx x)+    step :: (StreamElm x, Int) -> m (S.Step (StreamElm x, Int) (StreamElm (x:.RestrictedRegion e)))+    step (x,k)+      | k+minR <= j && k+maxR >= j = return $ S.Yield (SeResRegion x k (VU.unsafeSlice k (max maxR (j-k)) xs)) (x,j+1)+      | otherwise = return S.Done+    {-# INLINE mk #-}+    {-# INLINE step #-}+  {-# INLINE mkStream #-}+  mkStreamInner (x:.RRegion minR maxR xs) (i,j) = S.flatten mk step Unknown $ mkStream x (i,j) where+    mk :: StreamElm x -> m (StreamElm x, Int)+    mk x = return (x, getTopIdx x + minR)+    step :: (StreamElm x, Int) -> m (S.Step (StreamElm x, Int) (StreamElm (x:.RestrictedRegion e)))+    step (x,l)+      | l<=j && (l-k)<=maxR = return $ S.Yield (SeResRegion x l (VU.unsafeSlice k (l-k) xs)) (x,j+1)+      | otherwise           = return S.Done+      where k = getTopIdx x+    {-# INLINE mk #-}+    {-# INLINE step #-}+  {-# INLINE mkStreamInner #-}++++-- * Backtracking tables.+--+-- Since we want the slow forward phase to be fast, in the backtracking phase,+-- we need to keep track of additional things. The backtracking table 'BTtbl'+-- requires the table and an additional backtracking function. You should use+-- the same composed function as for the forward pahse creating the bound table+-- in the first place.++-- | The backtracking table 'BTtbl" captures a DP table and the function used+-- to fill it.++data BTtbl c t g = BTtbl t g++instance TransToN (BTtbl c t g) where+  type TransTo (BTtbl c t g) = BTtbl N t g+  transToN (BTtbl t g) = BTtbl t g+  {-# INLINE transToN #-}++bttblN :: t -> g -> BTtbl N t g+bttblN t g = BTtbl t g+{-# INLINE bttblN #-}++bttblE :: t -> g -> BTtbl E t g+bttblE t g = BTtbl t g+{-# INLINE bttblE #-}++instance Build (BTtbl c t g)++-- | The backtracking function, given our index pair, return a stream of+-- backtracked results. (Return as in we are in a monad).+--+-- TODO Should this be "(Int,Int) -> m (SM.Stream Id b)" or are there cases+-- where we'd like to have monadic effects on the "b"s?++type BTfun m b = (Int,Int) -> m (S.Stream m b)++instance (Monad m, StreamElement x, TblType c) => StreamElement (x:.BTtbl c (ZU.Arr0 DIM2 e) (BTfun m b)) where+  data StreamElm    (x:.BTtbl c (ZU.Arr0 DIM2 e) (BTfun m b)) = SeBTtbl !(StreamElm x) !Int !e (m (S.Stream m b))+  type StreamTopIdx (x:.BTtbl c (ZU.Arr0 DIM2 e) (BTfun m b)) = Int+  type StreamArg    (x:.BTtbl c (ZU.Arr0 DIM2 e) (BTfun m b)) = StreamArg x :. (e, m (S.Stream m b))+  getTopIdx (SeBTtbl _ k _ _) = k+  getArg    (SeBTtbl x _ e g) = getArg x :. (e,g)+  {-# INLINE getTopIdx #-}+  {-# INLINE getArg #-}++instance+  ( Monad m+  , MkStream m x+  , StreamElement x+  , VU.Unbox e+  , StreamTopIdx x ~ Int+  , TblType c+  ) => MkStream m (x:.BTtbl c (ZU.Arr0 DIM2 e) (BTfun m b)) where+  mkStream (x:.BTtbl t g) (i,j) = S.map step $ mkStreamInner x (i,j - initDeltaIdx (undefined :: c)) where+    step :: StreamElm x -> StreamElm (x:.BTtbl c (ZU.Arr0 DIM2 e) (BTfun m b))+    step x = let k = getTopIdx x in SeBTtbl x j (t PA.! (Z:.k:.j)) (g (k,j))+    {-# INLINE step #-}+  mkStreamInner (x:.BTtbl t g) (i,j) = S.flatten mk step Unknown $ mkStreamInner x (i,j) where+    mk :: StreamElm x -> m (StreamElm x, Int)+    mk x = return (x, getTopIdx x + initDeltaIdx (undefined :: c))+    step :: (StreamElm x, Int) -> m (S.Step (StreamElm x, Int) (StreamElm (x:.BTtbl c (ZU.Arr0 DIM2 e) (BTfun m b))))+    step (x,l)+      | l<=j      = return $ S.Yield (SeBTtbl x l (t PA.! (Z:.k:.l)) (g (k,l))) (x,l+1)+      | otherwise = return $ S.Done+      where k = getTopIdx x+    {-# INLINE mk #-}+    {-# INLINE step #-}+  {-# INLINE mkStream #-}+  {-# INLINE mkStreamInner #-}++++-- * Build complex stacks++instance Build x => Build (x,y) where+  type BuildStack (x,y) = BuildStack x :. y+  build (x,y) = build x :. y+  {-# INLINE build #-}++++-- * combinators++infixl 8 <<<+(<<<) f t ij = S.map (\s -> apply f $ getArg s) $ mkStream (build t) ij+{-# INLINE (<<<) #-}++infixl 7 |||+(|||) xs ys ij = xs ij S.++ ys ij+{-# INLINE (|||) #-}++infixl 6 ...+(...) s h ij = h $ s ij+{-# INLINE (...) #-}++infixl 6 ..@+(..@) s h ij = h ij $ s ij+{-# INLINE (..@) #-}++infixl 9 ~~+(~~) = (,)+{-# INLINE (~~) #-}++infixl 9 %+(%) = (,)+{-# INLINE (%) #-}++++-- * Apply function 'f' in '(<<<)'++class Apply x where+  type Fun x :: *+  apply :: Fun x -> x++instance Apply (ArgZ:.a -> res) where+  type Fun (ArgZ:.a -> res) = a -> res+  apply fun (ArgZ:.a) = fun a+  {-# INLINE apply #-}++instance Apply (ArgZ:.a:.b -> res) where+  type Fun (ArgZ:.a:.b -> res) = a->b -> res+  apply fun (ArgZ:.a:.b) = fun a b+  {-# INLINE apply #-}++instance Apply (ArgZ:.a:.b:.c -> res) where+  type Fun (ArgZ:.a:.b:.c -> res) = a->b->c -> res+  apply fun (ArgZ:.a:.b:.c) = fun a b c+  {-# INLINE apply #-}++instance Apply (ArgZ:.a:.b:.c:.d -> res) where+  type Fun (ArgZ:.a:.b:.c:.d -> res) = a->b->c->d -> res+  apply fun (ArgZ:.a:.b:.c:.d) = fun a b c d+  {-# INLINE apply #-}++instance Apply (ArgZ:.a:.b:.c:.d:.e -> res) where+  type Fun (ArgZ:.a:.b:.c:.d:.e -> res) = a->b->c->d->e -> res+  apply fun (ArgZ:.a:.b:.c:.d:.e) = fun a b c d e+  {-# INLINE apply #-}++instance Apply (ArgZ:.a:.b:.c:.d:.e:.f -> res) where+  type Fun (ArgZ:.a:.b:.c:.d:.e:.f -> res) = a->b->c->d->e->f -> res+  apply fun (ArgZ:.a:.b:.c:.d:.e:.f) = fun a b c d e f+  {-# INLINE apply #-}++instance Apply (ArgZ:.a:.b:.c:.d:.e:.f:.g -> res) where+  type Fun (ArgZ:.a:.b:.c:.d:.e:.f:.g -> res) = a->b->c->d->e->f->g -> res+  apply fun (ArgZ:.a:.b:.c:.d:.e:.f:.g) = fun a b c d e f g+  {-# INLINE apply #-}++instance Apply (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h -> res) where+  type Fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h -> res) = a->b->c->d->e->f->g->h -> res+  apply fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h) = fun a b c d e f g h+  {-# INLINE apply #-}++instance Apply (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i -> res) where+  type Fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i -> res) = a->b->c->d->e->f->g->h->i -> res+  apply fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i) = fun a b c d e f g h i+  {-# INLINE apply #-}++instance Apply (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j -> res) where+  type Fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j -> res) = a->b->c->d->e->f->g->h->i->j -> res+  apply fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j) = fun a b c d e f g h i j+  {-# INLINE apply #-}++instance Apply (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k -> res) where+  type Fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k -> res) = a->b->c->d->e->f->g->h->i->j->k -> res+  apply fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k) = fun a b c d e f g h i j k+  {-# INLINE apply #-}++instance Apply (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l -> res) where+  type Fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l -> res) = a->b->c->d->e->f->g->h->i->j->k->l -> res+  apply fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l) = fun a b c d e f g h i j k l+  {-# INLINE apply #-}++instance Apply (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m -> res) where+  type Fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m -> res) = a->b->c->d->e->f->g->h->i->j->k->l->m -> res+  apply fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m) = fun a b c d e f g h i j k l m+  {-# INLINE apply #-}++instance Apply (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n -> res) where+  type Fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n -> res) = a->b->c->d->e->f->g->h->i->j->k->l->m->n -> res+  apply fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n) = fun a b c d e f g h i j k l m n+  {-# INLINE apply #-}++instance Apply (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n:.o -> res) where+  type Fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n:.o -> res) = a->b->c->d->e->f->g->h->i->j->k->l->m->n->o -> res+  apply fun (ArgZ:.a:.b:.c:.d:.e:.f:.g:.h:.i:.j:.k:.l:.m:.n:.o) = fun a b c d e f g h i j k l m n o+  {-# INLINE apply #-}+

@@ -0,0 +1,179 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE PackageImports #-}++module ADP.Fusion.GAPlike.Criterion where++import Control.Monad.ST+import Criterion.Main+import Data.Char+import qualified Data.Vector.Fusion.Stream.Monadic as S+import qualified Data.Vector.Fusion.Stream as SP++import Data.PrimitiveArray+import Data.PrimitiveArray.Unboxed.VectorZero as UVZ+import Data.PrimitiveArray.Unboxed.Zero as UZ+import "PrimitiveArray" Data.Array.Repa.Index+import "PrimitiveArray" Data.Array.Repa.Shape++import ADP.Fusion.GAPlike+import ADP.Fusion.GAPlike.DevelCommon++++criterionMain = defaultMain+  [ bgroup "testTTT3"+    [ bench "  10" (whnf (testTTT 0)   10)+    , bench " 100" (whnf (testTTT 0)  100)+    , bench "1000" (whnf (testTTT 0) 1000)+    ]+  , bgroup "testTTTT4"+    [ bench "  10" (whnf (testTTTT 0)   10)+    , bench " 100" (whnf (testTTTT 0)  100)+    , bench "1000" (whnf (testTTTT 0) 1000)+    ]+  , bgroup "testTTTT4ga"+    [ bench "  10" (whnf (testTTTTga 0)   10)+    , bench " 100" (whnf (testTTTTga 0)  100)+    , bench "1000" (whnf (testTTTTga 0) 1000)+    ]+  , bgroup "testTTTT4gaPA"+    [ bench "  10" (whnf (testTTTTgaPA 0)   10)+    , bench " 100" (whnf (testTTTTgaPA 0)  100)+    , bench "1000" (whnf (testTTTTgaPA 0) 1000)+    ]+  , bgroup "testTTTT4gaImmu"+    [ bench "  10" (whnf (testTTTTgaImmu 0)   10)+    , bench " 100" (whnf (testTTTTgaImmu 0)  100)+    , bench "1000" (whnf (testTTTTgaImmu 0) 1000)+    ]+  , bgroup "testTTTT4gaImmuPA"+    [ bench "  10" (whnf (testTTTTgaImmuPA 0)   10)+    , bench " 100" (whnf (testTTTTgaImmuPA 0)  100)+    , bench "1000" (whnf (testTTTTgaImmuPA 0) 1000)+    ]+  ]++++-- * Criterion tests++testC :: Int -> Int -> Int+testC i j = runST doST where+  doST :: ST s Int+  doST = do+    let c = Chr dvu+    (gord1 <<< c ... ghsum) (i,j)+{-# NOINLINE testC #-}++gTestC (ord1,hsum) c =+  (ord1 <<< c ... hsum)++aTestC = (ord1,hsum) where+  ord1 = gord1+  hsum = ghsum++testCC :: Int -> Int -> Int+testCC i j = runST doST where+  doST :: ST s Int+  doST = do+    let c = Chr dvu+    let d = Chr dvu+    (gord2 <<< c % d ... ghsum) (i,j)+{-# NOINLINE testCC #-}++type TBL s = Tbl N (UVZ.MArr0 s DIM2 Int)++testT :: Int -> Int -> Int+testT i j = runST doST where+  doST :: ST s Int+  doST = do+    tbl :: TBL s <- Tbl `fmap` fromAssocsM (Z:.0:.0) (Z:.j:.j) 1 []+    (id <<< tbl ... ghsum) (i,j)+{-# NOINLINE testT #-}++testTT :: Int -> Int -> Int+testTT i j = runST doST where+  doST :: ST s Int+  doST = do+    tbl :: TBL s <- Tbl `fmap` fromAssocsM (Z:.0:.0) (Z:.j:.j) 1 []+    (gplus2 <<< tbl % tbl ... ghsum) (i,j)+  {-# INLINE doST #-}+{-# NOINLINE testTT #-}++testTTT :: Int -> Int -> Int+testTTT i j = runST doST where+  doST :: ST s Int+  doST = do+    tbl :: TBL s <- Tbl `fmap` fromAssocsM (Z:.0:.0) (Z:.j:.j) 1 []+    (gplus3 <<< tbl % tbl % tbl ... ghsum) (i,j)+{-# NOINLINE testTTT #-}++testTTTT :: Int -> Int -> Int+testTTTT i j = runST doST where+  doST :: ST s Int+  doST = do+    tbl :: TBL s <- Tbl `fmap` fromAssocsM (Z:.0:.0) (Z:.j:.j) (1::Int) []+    (gplus4 <<< tbl % tbl % tbl % tbl ... ghsum) (i,j)+  {-# INLINE doST #-}+{-# NOINLINE testTTTT #-}++testTTTTga :: Int -> Int -> Int+testTTTTga i j = runST doST where+  doST :: ST s Int+  doST = do+    tbl :: TBL s <- Tbl `fmap` fromAssocsM (Z:.0:.0) (Z:.j:.j) (1::Int) []+    gTTTga aTTTga tbl (i,j)+  {-# INLINE doST #-}+{-# NOINLINE testTTTTga #-}++testTTTTgaPA :: Int -> Int -> Int+testTTTTgaPA i j = runST doST where+  doST :: ST s Int+  doST = do+    tbl :: Tbl N (UZ.MArr0 s DIM2 Int) <- Tbl `fmap` fromAssocsM (Z:.0:.0) (Z:.j:.j) (1::Int) []+    gTTTga aTTTga tbl (i,j)+  {-# INLINE doST #-}+{-# NOINLINE testTTTTgaPA #-}++testTTTTgaImmu :: Int -> Int -> Int+testTTTTgaImmu i j =+    let tbl = (Tbl $ fromAssocs (Z:.0:.0) (Z:.j:.j) 1 []) :: Tbl N (UVZ.Arr0 DIM2 Int) +    in tbl `seq` gTTTga aTTTgaImmu tbl (i,j)+{-# NOINLINE testTTTTgaImmu #-}++testTTTTgaImmuPA :: Int -> Int -> Int+testTTTTgaImmuPA i j =+    let tbl = (Tbl $ fromAssocs (Z:.0:.0) (Z:.j:.j) 1 []) :: Tbl N (UZ.Arr0 DIM2 Int) +    in tbl `seq` gTTTga aTTTgaImmu tbl (i,j)+{-# NOINLINE testTTTTgaImmuPA #-}++gTTTga (plus4, hsum) tbl =+  (plus4 <<< tbl % tbl % tbl % tbl ... hsum)+{-# INLINE gTTTga #-}++aTTTga = (plus4, hsum) where+  plus4 = gplus4+  hsum = ghsum++aTTTgaImmu = (plus4, hsum) where+  plus4 = gplus4+  hsum = gihsum+{-# INLINE aTTTgaImmu #-}++gord1 a = ord a++gord2 a b = ord a + ord b++gord3 a b c = ord a + ord b + ord c++gplus2 a b = a+b++gplus3 a b c = a+b+c++gplus4 a b c d = a+b+c+d++ghsum :: S.Stream (ST s) Int -> ST s Int+ghsum = S.foldl' (+) 0++gihsum :: SP.Stream Int -> Int+gihsum = SP.foldl' (+) 0

@@ -0,0 +1,22 @@+{-# LANGUAGE PackageImports #-}++module ADP.Fusion.GAPlike.DevelCommon where++import qualified Data.PrimitiveArray as PA+import qualified Data.Vector.Unboxed as VU++import Data.PrimitiveArray.Unboxed.VectorZero as UVZ+import Data.PrimitiveArray.Unboxed.Zero as UZ+import "PrimitiveArray" Data.Array.Repa.Index+import "PrimitiveArray" Data.Array.Repa.Shape++++dvu = VU.fromList $ concat $ replicate 10 ['a'..'z']+{-# NOINLINE dvu #-}++type PAT = UVZ.Arr0 DIM2 Int+pat :: PAT+pat = PA.fromAssocs (Z:.0:.0) (Z:.1000:.1000) 0 [(Z:.i:.j,j-i) | i <-[0..1000], j<-[i..1000] ]+{-# NOINLINE pat #-}+

@@ -0,0 +1,57 @@+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE TemplateHaskell #-}++module ADP.Fusion.GAPlike.QuickCheck where++import Test.QuickCheck+import Test.QuickCheck.All+import qualified Data.Vector.Fusion.Stream as SP+import qualified Data.Vector.Unboxed as VU++import "PrimitiveArray" Data.Array.Repa.Index+import "PrimitiveArray" Data.Array.Repa.Shape+import Data.PrimitiveArray++import ADP.Fusion.QuickCheck.Arbitrary+import ADP.Fusion.GAPlike.DevelCommon+import ADP.Fusion.GAPlike++++-- * QuickCheck++checkC_fusion (i,j) = id <<< Chr dvu ... SP.toList $ (i,j)+checkC_list   (i,j) = [dvu VU.! i | i+1==j]+prop_checkC = checkC_fusion === checkC_list++checkCC_fusion (i,j) = (,) <<< Chr dvu % Chr dvu ... SP.toList $ (i,j)+checkCC_list   (i,j) = [ (dvu VU.! i, dvu VU.! (i+1)) | i+2==j ]+prop_checkCC = checkCC_fusion === checkCC_list++checkP_fusion (i,j) = id <<< (Tbl pat :: Tbl E PAT)  ... SP.toList $ (i,j)+checkP_list   (i,j) = [ (pat!(Z:.i:.j)) | i<=j ]+prop_checkP = checkP_fusion === checkP_list++checkPP_fusion (i,j) = let tbl = Tbl pat :: Tbl E PAT+                       in  (,) <<< tbl % tbl ... SP.toList $ (i,j)+checkPP_list   (i,j) = [ (pat!(Z:.i:.k), pat!(Z:.k:.j)) | k<-[i..j] ]+prop_checkPP = checkPP_fusion === checkPP_list++checkCPC_fusion (i,j) = let tbl = Tbl pat :: Tbl E PAT+                        in  (,,) <<< Chr dvu % tbl % Chr dvu ... SP.toList $ (i,j)+checkCPC_list (i,j) = [ (dvu VU.! i, pat!(Z:.i+1:.j-1), dvu VU.! (j-1)) | i+2<=j ]+prop_checkCPC = checkCPC_fusion === checkCPC_list++checkNN_fusion (i,j) = let tbl = Tbl pat :: Tbl N PAT+                       in  (,) <<< tbl % tbl ... SP.toList $ (i,j)+checkNN_list   (i,j) = [ (pat!(Z:.i:.k), pat!(Z:.k:.j)) | k<-[i+1..j-1] ]+prop_checkNN = checkNN_fusion === checkNN_list++++options = stdArgs {maxSuccess = 1000}++customCheck = quickCheckWithResult options++allProps = $forAllProperties customCheck+

@@ -39,7 +39,7 @@ import Text.Printf  import qualified Data.PrimitiveArray as PA-import qualified Data.PrimitiveArray.Unboxed.Zero as UZ+import qualified Data.PrimitiveArray.Zero.Unboxed as ZU import qualified Data.PrimitiveArray.Zero as Z  @@ -62,8 +62,8 @@ mkStreamGen(DIM2 -> ScalarM elm) mkStreamGen(DIM2 -> Vect elm) mkStreamGen(DIM2 -> VectM elm)-mkStreamGen(UZ.MArr0 s sh elm)-mkStreamGen(UZ.Arr0 sh elm)+mkStreamGen(ZU.MArr0 s sh elm)+mkStreamGen(ZU.Arr0 sh elm)  mkStreamGen(Z.MArr0 s sh (VU.Vector elm)) mkStreamGen(Z.Arr0 sh (VU.Vector elm))@@ -114,8 +114,8 @@ mkPreStreamGen(DIM2 -> ScalarM elm) mkPreStreamGen(DIM2 -> Vect elm) mkPreStreamGen(DIM2 -> VectM elm)-mkPreStreamGen(UZ.MArr0 s sh elm)-mkPreStreamGen(UZ.Arr0 sh elm)+mkPreStreamGen(ZU.MArr0 s sh elm)+mkPreStreamGen(ZU.Arr0 sh elm)  mkPreStreamGen(Z.MArr0 s sh (VU.Vector elm)) mkPreStreamGen(Z.Arr0 sh (VU.Vector elm))@@ -178,12 +178,12 @@  instance   ( PrimMonad m-  , Prim elm+  , VU.Unbox elm   , PrimState m ~ s   , DIM2 ~ sh-  ) => ExtractValue m (UZ.MArr0 s sh elm) where-  type Asor (UZ.MArr0 s sh elm) = Z-  type Elem (UZ.MArr0 s sh elm) = elm+  ) => ExtractValue m (ZU.MArr0 s sh elm) where+  type Asor (ZU.MArr0 s sh elm) = Z+  type Elem (ZU.MArr0 s sh elm) = elm   extractValue cnt ij z = do     x <- PA.readM cnt ij     x `seq` return x@@ -203,11 +203,11 @@  instance   ( Monad m-  , Prim elm+  , VU.Unbox elm   , DIM2 ~ sh-  ) => ExtractValue m (UZ.Arr0 sh elm) where-  type Asor (UZ.Arr0 sh elm) = Z-  type Elem (UZ.Arr0 sh elm) = elm+  ) => ExtractValue m (ZU.Arr0 sh elm) where+  type Asor (ZU.Arr0 sh elm) = Z+  type Elem (ZU.Arr0 sh elm) = elm   extractValue cnt ij z = do     let x = PA.index cnt ij     x `seq` return x

@@ -1,5 +1,5 @@ name:           ADPfusion-version:        0.0.1.2+version:        0.1.0.0 author:         Christian Hoener zu Siederdissen, 2011-2012 copyright:      Christian Hoener zu Siederdissen, 2011-2012 homepage:       http://www.tbi.univie.ac.at/~choener/adpfusion@@ -31,10 +31,27 @@                 tables can be strict, removing indirections present in lazy,                 boxed tables.                 .-                As an example, even rather complex ADP code tends to be-                completely optimized to loops that use only unboxed variables-                (Int# and others, indexIntArray# and others).+                As a simple benchmark, consider the Nussinov78 algorithm which+                translates to three nested for loops (for C). In the figure,+                four different approaches are compared using inputs with size+                100 characters to 1000 characters in increments of 100+                characters. "C" is an implementation ("./C/" directory) in "C"+                using "gcc -O3". "ADP" is the original ADP approach (see link+                above), while "GAPC" uses the "GAP" language+                (<http://gapc.eu/>).+                <<https://github.com/choener/ADPfusion/gaplike-performance.png>>                 .+                Please note that actual performance will depend much on table+                layout and data structures accessed during calculations, but in+                general performance is very good: close to C and better than+                other high-level approaches (that I know of).+                .+                .+                .+                Even complex ADP code tends to be completely optimized to loops+                that use only unboxed variables (Int# and others,+                indexIntArray# and others).+                .                 Completely novel (compared to ADP), is the idea of allowing                 efficient monadic combinators. This facilitates writing code                 that performs backtracking, or samples structures@@ -44,6 +61,29 @@                 multiple recent improvements in GHC. This is particularly true                 for the monadic interface.                 .+                .+                .+                Newley added are the ADP.Fusion.GAPlike modules. These allow+                for writing grammars with only one (non)-terminal combinator.+                The logic for index manipulation is now moved into data types+                for terminals and non-terminals.+                .+                While this change leads to slightly more complicated instances+                for each new terminal or non-terminal, the overall code+                complexity is significantly lower. In addition, Constraint+                Kinds make complex interactions between (non)-terminals+                possible, while still managing to produce high-performance+                code.+                .+                The final goal would, of course, be to have no inter-terminal+                combinators anymore.+                .+                * GHC 7.6, LLVM, and -fnew-codegen recommended: gives a speedup+                  of x2 for GAPcriterion+                .+                .+                .+                .                 Long term goals: Outer indices with more than two dimensions,                 specialized table design, a combinator library, a library for                 computational biology.@@ -54,11 +94,28 @@                 <http://hackage.haskell.org/package/Nussinov78> and                 <http://hackage.haskell.org/package/RNAFold>.                 .+                Changes since 0.0.1.2:+                .+                * require GHC 7.6+                .+                * ADP.Fusion.GAPlike module for (almost) combinator-less grammars+                .+                * ConstraintKinds for constrained parsers in GAPlike.+                .+                .+                .                 Changes since 0.0.1.0:                 .                 * compatibility with GHC 7.4                 .                 * note: still using fundeps & and TFs together. The TF-only version does not optimize as well (I know why but not yet how to fix it)+                .+                .+                .+                Using the new code generator?+                .+                The new code generator is not official yet, but I recommend trying it out:+                <<https://github.com/choener/ADPfusion/gaplike-newcodegen.png>>   @@ -68,21 +125,47 @@   ADP/Fusion/QuickCheck/Arbitrary.hs  +Flag devel+  description: build criterion benchmarks and pull in QuickCheck+  default: False + library   build-depends:     base >= 4 && < 5,-    primitive      == 0.4.*   ,-    vector         == 0.9.*   ,-    PrimitiveArray == 0.2.2.0+    ghc-prim,+    primitive      == 0.5.*   ,+    vector         == 0.10.*  ,+    PrimitiveArray == 0.4.*   exposed-modules:     ADP.Fusion     ADP.Fusion.Monadic     ADP.Fusion.Monadic.Internal+    ADP.Fusion.GAPlike    ghc-options:     -O2 -funbox-strict-fields +executable GAPcriterion+  buildable:+    False+  if flag(devel)+    buildable:+      True+    build-depends:+      criterion  == 0.6.* ,+      QuickCheck == 2.5+  other-modules:+    ADP.Fusion.GAPlike.DevelCommon+    ADP.Fusion.GAPlike.Criterion+    ADP.Fusion.GAPlike.QuickCheck+  main-is:+    Tests/GAPcriterion.hs+  ghc-options:+    -fllvm -O2 -funbox-strict-fields -optlo-O3 -optlo-std-compile-opts+  if impl(GHC > 7.4)+    ghc-options:+      -fnew-codegen   source-repository head

@@ -0,0 +1,9 @@++module Main where++import ADP.Fusion.GAPlike2.Criterion++++main = criterionMain+