[WIP] Efficient storage of sum data types

accelerate.cabal

@@ -361,6 +361,10 @@ library
         , unique
         , unordered-containers          >= 0.2
         , vector                        >= 0.10
+        , posable                       >= 1.0.0.1
+        , ghc-typelits-knownnat         >= 0.6
+        , generics-sop                  >= 0.4.0
+        , finite-typelits               >= 0.1.4
 
   exposed-modules:
         -- The core language and reference implementation
@@ -400,6 +404,7 @@ library
         Data.Array.Accelerate.Lifetime
         Data.Array.Accelerate.Pretty
         Data.Array.Accelerate.Representation.Array
+        Data.Array.Accelerate.Representation.POS
         Data.Array.Accelerate.Representation.Elt
         Data.Array.Accelerate.Representation.Shape
         Data.Array.Accelerate.Representation.Slice
@@ -463,6 +468,7 @@ library
         Data.Array.Accelerate.Lift
         Data.Array.Accelerate.Orphans
         Data.Array.Accelerate.Pattern
+        Data.Array.Accelerate.Pattern.Matchable
         Data.Array.Accelerate.Pattern.Bool
         Data.Array.Accelerate.Pattern.Either
         Data.Array.Accelerate.Pattern.Maybe

src/Data/Array/Accelerate/AST.hs

@@ -9,6 +9,7 @@
 {-# LANGUAGE TemplateHaskell       #-}
 {-# LANGUAGE TypeFamilies          #-}
 {-# LANGUAGE TypeOperators         #-}
+{-# LANGUAGE TypeApplications      #-}
 {-# OPTIONS_HADDOCK hide #-}
 -- |
 -- Module      : Data.Array.Accelerate.AST
@@ -146,6 +147,7 @@ import Data.Array.Accelerate.Representation.Tag
 import Data.Array.Accelerate.Representation.Type
 import Data.Array.Accelerate.Representation.Vec
 import Data.Array.Accelerate.Sugar.Foreign
+import Data.Array.Accelerate.Sugar.Elt
 import Data.Array.Accelerate.Type
 import Data.Primitive.Vec
 
@@ -198,9 +200,8 @@ type ArrayVar       = Var ArrayR
 type ArrayVars aenv = Vars ArrayR aenv
 
 -- Bool is not a primitive type
-type PrimBool    = TAG
-type PrimMaybe a = (TAG, ((), a))
-
+type PrimBool    = EltR Bool
+type PrimMaybe a = EltR (Maybe a)
 -- Trace messages
 data Message a where
   Message :: (a -> String)                    -- embedded show
@@ -940,8 +941,10 @@ primFunType = \case
     integral = num . IntegralNumType
     floating = num . FloatingNumType
 
-    tbool    = TupRsingle scalarTypeWord8
-    tint     = TupRsingle scalarTypeInt
+    tbool :: TypeR PrimBool
+    tbool    = TupRpair (TupRsingle (scalarType @TAG)) TupRunit
+    tint :: TypeR Int
+    tint     = TupRsingle (scalarType @Int)
 
 
 -- Normal form data

src/Data/Array/Accelerate/Pattern.hs

@@ -114,107 +114,107 @@ instance (Elt a, Elt b) => IsPattern Exp (a :. b) (Exp a :. Exp b) where
 -- IsPattern instances for up to 16-tuples (Acc and Exp). TH takes care of
 -- the (unremarkable) boilerplate for us.
 --
-runQ $ do
-    let
-        -- Generate instance declarations for IsPattern of the form:
-        -- instance (Arrays x, ArraysR x ~ (((), ArraysR a), ArraysR b), Arrays a, Arrays b,) => IsPattern Acc x (Acc a, Acc b)
-        mkAccPattern :: Int -> Q [Dec]
-        mkAccPattern n = do
-          a <- newName "a"
-          let
-              -- Type variables for the elements
-              xs       = [ mkName ('x' : show i) | i <- [0 .. n-1] ]
-              -- Last argument to `IsPattern`, eg (Acc a, Acc b) in the example
-              b        = tupT (map (\t -> [t| Acc $(varT t)|]) xs)
-              -- Representation as snoc-list of pairs, eg (((), ArraysR a), ArraysR b)
-              snoc     = foldl (\sn t -> [t| ($sn, ArraysR $(varT t)) |]) [t| () |] xs
-              -- Constraints for the type class, consisting of Arrays constraints on all type variables,
-              -- and an equality constraint on the representation type of `a` and the snoc representation `snoc`.
-              context  = tupT
-                       $ [t| Arrays $(varT a) |]
-                       : [t| ArraysR $(varT a) ~ $snoc |]
-                       : map (\t -> [t| Arrays $(varT t)|]) xs
-              --
-              get x 0 = [| Acc (SmartAcc (Aprj PairIdxRight $x)) |]
-              get x i = get  [| SmartAcc (Aprj PairIdxLeft $x) |] (i-1)
-          --
-          _x <- newName "_x"
-          [d| instance $context => IsPattern Acc $(varT a) $b where
-                builder $(tupP (map (\x -> [p| Acc $(varP x)|]) xs)) =
-                  Acc $(foldl (\vs v -> [| SmartAcc ($vs `Apair` $(varE v)) |]) [| SmartAcc Anil |] xs)
-                matcher (Acc $(varP _x)) =
-                  $(tupE (map (get (varE _x)) [(n-1), (n-2) .. 0]))
-            |]
+-- runQ $ do
+--     let
+--         -- Generate instance declarations for IsPattern of the form:
+--         -- instance (Arrays x, ArraysR x ~ (((), ArraysR a), ArraysR b), Arrays a, Arrays b,) => IsPattern Acc x (Acc a, Acc b)
+--         mkAccPattern :: Int -> Q [Dec]
+--         mkAccPattern n = do
+--           a <- newName "a"
+--           let
+--               -- Type variables for the elements
+--               xs       = [ mkName ('x' : show i) | i <- [0 .. n-1] ]
+--               -- Last argument to `IsPattern`, eg (Acc a, Acc b) in the example
+--               b        = tupT (map (\t -> [t| Acc $(varT t)|]) xs)
+--               -- Representation as snoc-list of pairs, eg (((), ArraysR a), ArraysR b)
+--               snoc     = foldl (\sn t -> [t| ($sn, ArraysR $(varT t)) |]) [t| () |] xs
+--               -- Constraints for the type class, consisting of Arrays constraints on all type variables,
+--               -- and an equality constraint on the representation type of `a` and the snoc representation `snoc`.
+--               context  = tupT
+--                        $ [t| Arrays $(varT a) |]
+--                        : [t| ArraysR $(varT a) ~ $snoc |]
+--                        : map (\t -> [t| Arrays $(varT t)|]) xs
+--               --
+--               get x 0 = [| Acc (SmartAcc (Aprj PairIdxRight $x)) |]
+--               get x i = get  [| SmartAcc (Aprj PairIdxLeft $x) |] (i-1)
+--           --
+--           _x <- newName "_x"
+--           [d| instance $context => IsPattern Acc $(varT a) $b where
+--                 builder $(tupP (map (\x -> [p| Acc $(varP x)|]) xs)) =
+--                   Acc $(foldl (\vs v -> [| SmartAcc ($vs `Apair` $(varE v)) |]) [| SmartAcc Anil |] xs)
+--                 matcher (Acc $(varP _x)) =
+--                   $(tupE (map (get (varE _x)) [(n-1), (n-2) .. 0]))
+--             |]
 
-        -- Generate instance declarations for IsPattern of the form:
-        -- instance (Elt x, EltR x ~ (((), EltR a), EltR b), Elt a, Elt b,) => IsPattern Exp x (Exp a, Exp b)
-        mkExpPattern :: Int -> Q [Dec]
-        mkExpPattern n = do
-          a <- newName "a"
-          let
-              -- Type variables for the elements
-              xs       = [ mkName ('x' : show i) | i <- [0 .. n-1] ]
-              -- Variables for sub-pattern matches
-              ms       = [ mkName ('m' : show i) | i <- [0 .. n-1] ]
-              tags     = foldl (\ts t -> [p| $ts `TagRpair` $(varP t) |]) [p| TagRunit |] ms
-              -- Last argument to `IsPattern`, eg (Exp, a, Exp b) in the example
-              b        = tupT (map (\t -> [t| Exp $(varT t)|]) xs)
-              -- Representation as snoc-list of pairs, eg (((), EltR a), EltR b)
-              snoc     = foldl (\sn t -> [t| ($sn, EltR $(varT t)) |]) [t| () |] xs
-              -- Constraints for the type class, consisting of Elt constraints on all type variables,
-              -- and an equality constraint on the representation type of `a` and the snoc representation `snoc`.
-              context  = tupT
-                       $ [t| Elt $(varT a) |]
-                       : [t| EltR $(varT a) ~ $snoc |]
-                       : map (\t -> [t| Elt $(varT t)|]) xs
-              --
-              get x 0 =     [| SmartExp (Prj PairIdxRight $x) |]
-              get x i = get [| SmartExp (Prj PairIdxLeft $x)  |] (i-1)
-          --
-          _x <- newName "_x"
-          _y <- newName "_y"
-          [d| instance $context => IsPattern Exp $(varT a) $b where
-                builder $(tupP (map (\x -> [p| Exp $(varP x)|]) xs)) =
-                  let _unmatch :: SmartExp a -> SmartExp a
-                      _unmatch (SmartExp (Match _ $(varP _y))) = $(varE _y)
-                      _unmatch x = x
-                  in
-                  Exp $(foldl (\vs v -> [| SmartExp ($vs `Pair` _unmatch $(varE v)) |]) [| SmartExp Nil |] xs)
-                matcher (Exp $(varP _x)) =
-                  case $(varE _x) of
-                    SmartExp (Match $tags $(varP _y))
-                      -> $(tupE [[| Exp (SmartExp (Match $(varE m) $(get (varE _x) i))) |] | m <- ms | i <- [(n-1), (n-2) .. 0]])
-                    _ -> $(tupE [[| Exp $(get (varE _x) i) |] | i <- [(n-1), (n-2) .. 0]])
-            |]
+--         -- Generate instance declarations for IsPattern of the form:
+--         -- instance (Elt x, EltR x ~ (((), EltR a), EltR b), Elt a, Elt b,) => IsPattern Exp x (Exp a, Exp b)
+--         mkExpPattern :: Int -> Q [Dec]
+--         mkExpPattern n = do
+--           a <- newName "a"
+--           let
+--               -- Type variables for the elements
+--               xs       = [ mkName ('x' : show i) | i <- [0 .. n-1] ]
+--               -- Variables for sub-pattern matches
+--               ms       = [ mkName ('m' : show i) | i <- [0 .. n-1] ]
+--               tags     = foldl (\ts t -> [p| $ts `TagRpair` $(varP t) |]) [p| TagRunit |] ms
+--               -- Last argument to `IsPattern`, eg (Exp, a, Exp b) in the example
+--               b        = tupT (map (\t -> [t| Exp $(varT t)|]) xs)
+--               -- Representation as snoc-list of pairs, eg (((), EltR a), EltR b)
+--               snoc     = foldl (\sn t -> [t| ($sn, EltR $(varT t)) |]) [t| () |] xs
+--               -- Constraints for the type class, consisting of Elt constraints on all type variables,
+--               -- and an equality constraint on the representation type of `a` and the snoc representation `snoc`.
+--               context  = tupT
+--                        $ [t| Elt $(varT a) |]
+--                        : [t| EltR $(varT a) ~ $snoc |]
+--                        : map (\t -> [t| Elt $(varT t)|]) xs
+--               --
+--               get x 0 =     [| SmartExp (Prj PairIdxRight $x) |]
+--               get x i = get [| SmartExp (Prj PairIdxLeft $x)  |] (i-1)
+--           --
+--           _x <- newName "_x"
+--           _y <- newName "_y"
+--           [d| instance $context => IsPattern Exp $(varT a) $b where
+--                 builder $(tupP (map (\x -> [p| Exp $(varP x)|]) xs)) =
+--                   let _unmatch :: SmartExp a -> SmartExp a
+--                       _unmatch (SmartExp (Match _ $(varP _y))) = $(varE _y)
+--                       _unmatch x = x
+--                   in
+--                   Exp $(foldl (\vs v -> [| SmartExp ($vs `Pair` _unmatch $(varE v)) |]) [| SmartExp Nil |] xs)
+--                 matcher (Exp $(varP _x)) =
+--                   case $(varE _x) of
+--                     SmartExp (Match $tags $(varP _y))
+--                       -> $(tupE [[| Exp (SmartExp (Match $(varE m) $(get (varE _x) i))) |] | m <- ms | i <- [(n-1), (n-2) .. 0]])
+--                     _ -> $(tupE [[| Exp $(get (varE _x) i) |] | i <- [(n-1), (n-2) .. 0]])
+--             |]
 
-        -- Generate instance declarations for IsVector of the form:
-        -- instance (Elt v, EltR v ~ Vec 2 a, Elt a) => IsVector Exp v (Exp a, Exp a)
-        mkVecPattern :: Int -> Q [Dec]
-        mkVecPattern n = do
-          a <- newName "a"
-          v <- newName "v"
-          let
-              -- Last argument to `IsVector`, eg (Exp, a, Exp a) in the example
-              tup      = tupT (replicate n ([t| Exp $(varT a)|]))
-              -- Representation as a vector, eg (Vec 2 a)
-              vec      = [t| Vec $(litT (numTyLit (fromIntegral n))) $(varT a) |]
-              -- Constraints for the type class, consisting of Elt constraints on all type variables,
-              -- and an equality constraint on the representation type of `a` and the vector representation `vec`.
-              context  = [t| (Elt $(varT v), VecElt $(varT a), EltR $(varT v) ~ $vec) |]
-              --
-              vecR     = foldr appE ([| VecRnil |] `appE` (varE 'singleType `appTypeE` varT a)) (replicate n [| VecRsucc |])
-              tR       = tupT (replicate n (varT a))
-          --
-          [d| instance $context => IsVector Exp $(varT v) $tup where
-                vpack x = case builder x :: Exp $tR of
-                            Exp x' -> Exp (SmartExp (VecPack $vecR x'))
-                vunpack (Exp x) = matcher (Exp (SmartExp (VecUnpack $vecR x)) :: Exp $tR)
-            |]
-    --
-    es <- mapM mkExpPattern [0..16]
-    as <- mapM mkAccPattern [0..16]
-    vs <- mapM mkVecPattern [2,3,4,8,16]
-    return $ concat (es ++ as ++ vs)
+--         -- Generate instance declarations for IsVector of the form:
+--         -- instance (Elt v, EltR v ~ Vec 2 a, Elt a) => IsVector Exp v (Exp a, Exp a)
+--         mkVecPattern :: Int -> Q [Dec]
+--         mkVecPattern n = do
+--           a <- newName "a"
+--           v <- newName "v"
+--           let
+--               -- Last argument to `IsVector`, eg (Exp, a, Exp a) in the example
+--               tup      = tupT (replicate n ([t| Exp $(varT a)|]))
+--               -- Representation as a vector, eg (Vec 2 a)
+--               vec      = [t| Vec $(litT (numTyLit (fromIntegral n))) $(varT a) |]
+--               -- Constraints for the type class, consisting of Elt constraints on all type variables,
+--               -- and an equality constraint on the representation type of `a` and the vector representation `vec`.
+--               context  = [t| (Elt $(varT v), VecElt $(varT a), EltR $(varT v) ~ $vec) |]
+--               --
+--               vecR     = foldr appE ([| VecRnil |] `appE` (varE 'singleType `appTypeE` varT a)) (replicate n [| VecRsucc |])
+--               tR       = tupT (replicate n (varT a))
+--           --
+--           [d| instance $context => IsVector Exp $(varT v) $tup where
+--                 vpack x = case builder x :: Exp $tR of
+--                             Exp x' -> Exp (SmartExp (VecPack $vecR x'))
+--                 vunpack (Exp x) = matcher (Exp (SmartExp (VecUnpack $vecR x)) :: Exp $tR)
+--             |]
+--     --
+--     es <- mapM mkExpPattern [0..16]
+--     as <- mapM mkAccPattern [0..16]
+--     vs <- mapM mkVecPattern [2,3,4,8,16]
+--     return $ concat (es ++ as ++ vs)
 
 
 -- | Specialised pattern synonyms for tuples, which may be more convenient to

src/Data/Array/Accelerate/Pattern/Bool.hs

@@ -1,9 +1,9 @@
 {-# LANGUAGE GADTs               #-}
 {-# LANGUAGE PatternSynonyms     #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TemplateHaskell     #-}
 {-# LANGUAGE TypeApplications    #-}
 {-# LANGUAGE ViewPatterns        #-}
+{-# LANGUAGE DataKinds #-}
 -- |
 -- Module      : Data.Array.Accelerate.Pattern.Bool
 -- Copyright   : [2018..2020] The Accelerate Team
@@ -20,7 +20,33 @@ module Data.Array.Accelerate.Pattern.Bool (
 
 ) where
 
-import Data.Array.Accelerate.Pattern.TH
+import           Data.Array.Accelerate.Smart as Smart
+import Data.Array.Accelerate.Sugar.Elt
+import Data.Array.Accelerate.Pattern.Matchable
+import           Generics.SOP as SOP
+import Data.Array.Accelerate.Representation.POS as POS
 
-mkPattern ''Bool
+{-# COMPLETE False_, True_ #-}
+pattern False_ :: Exp Bool
+pattern False_ <- (matchFalse -> Just ()) where
+  False_ = buildFalse
 
+matchFalse :: Exp Bool -> Maybe ()
+matchFalse x = case match (Proxy @0) x of
+  Just SOP.Nil -> Just ()
+  Nothing -> Nothing
+
+buildFalse :: Exp Bool
+buildFalse = build (Proxy @0) SOP.Nil
+
+pattern True_ :: Exp Bool
+pattern True_ <- (matchTrue -> Just x) where
+  True_ = buildTrue
+
+matchTrue :: Exp Bool -> Maybe ()
+matchTrue x = case match (Proxy @1) x of
+  Just SOP.Nil -> Just ()
+  Nothing -> Nothing
+
+buildTrue :: Exp Bool
+buildTrue = build (Proxy @1) SOP.Nil

src/Data/Array/Accelerate/Pattern/Either.hs

@@ -1,9 +1,9 @@
 {-# LANGUAGE GADTs               #-}
 {-# LANGUAGE PatternSynonyms     #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TemplateHaskell     #-}
 {-# LANGUAGE TypeApplications    #-}
 {-# LANGUAGE ViewPatterns        #-}
+{-# LANGUAGE DataKinds #-}
 -- |
 -- Module      : Data.Array.Accelerate.Pattern.Either
 -- Copyright   : [2018..2020] The Accelerate Team
@@ -20,7 +20,45 @@ module Data.Array.Accelerate.Pattern.Either (
 
 ) where
 
-import Data.Array.Accelerate.Pattern.TH
+import           Data.Array.Accelerate.Smart as Smart
+import Data.Array.Accelerate.Sugar.Elt
+import Data.Array.Accelerate.Pattern.Matchable
+import           Generics.SOP as SOP
+import Data.Array.Accelerate.Representation.POS as POS
 
-mkPattern ''Either
+{-# COMPLETE Left_, Right_ #-}
+pattern Left_ ::
+  forall a b .
+  ( Elt a
+  , POSable a
+  , POSable b
+  , Matchable a
+  ) => Exp a -> Exp (Either a b)
+pattern Left_ x <- (matchLeft -> Just x) where
+  Left_ = buildLeft
 
+matchLeft :: forall a b . (POSable a, Elt a, POSable b) => Exp (Either a b) -> Maybe (Exp a)
+matchLeft x = case match (Proxy @0) x of
+  Just (x' :* SOP.Nil) -> Just x'
+  Nothing -> Nothing
+
+buildLeft :: forall a b . (Elt a, POSable a, POSable b) => Exp a -> Exp (Either a b)
+buildLeft x = build (Proxy @0) (x :* SOP.Nil)
+
+pattern Right_ ::
+  forall a b .
+  ( Elt a
+  , POSable a
+  , POSable b
+  , Matchable a
+  ) => Exp b -> Exp (Either a b)
+pattern Right_ x <- (matchRight -> Just x) where
+  Right_ = buildRight
+
+matchRight :: forall a b . (Elt a, POSable a, POSable b) => Exp (Either a b) -> Maybe (Exp b)
+matchRight x = case match (Proxy @1) x of
+  Just (x' :* SOP.Nil) -> Just x'
+  Nothing -> Nothing
+
+buildRight :: forall a b . (Elt a, POSable a, POSable b) => Exp b -> Exp (Either a b)
+buildRight x = build (Proxy @1) (x :* SOP.Nil)