Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

[WIP] Efficient storage of sum data types #522

Open
wants to merge 67 commits into
base: master
Choose a base branch
from
Open
Show file tree
Hide file tree
Changes from 1 commit
Commits
Show all changes
67 commits
Select commit Hold shift + click to select a range
26798bd
link posable library
Riscky Feb 23, 2022
d46f7c7
POS instances for primary types, Vec
Riscky Feb 24, 2022
078d4f0
emptyFields implementation for Vec
Riscky Feb 24, 2022
a327abe
Redefine Elt for Shapes
Riscky Feb 24, 2022
7d24117
actually fill array in replicateVecN
Riscky Feb 24, 2022
df2ecff
Array with Elt'
Riscky Feb 25, 2022
99f482b
don't import Type from POS
Riscky Mar 1, 2022
8476596
convert typelists to tuples
Riscky Mar 1, 2022
d994fdd
Convert POS to EltR
Riscky Mar 2, 2022
27eac67
integrate Elt and POS?
Riscky Mar 2, 2022
3080b14
sorta kinda integrated POS into shapes
Riscky Mar 2, 2022
b878ec6
Slices understand SingletonTypes now
Riscky Mar 3, 2022
a1e1497
shapes with singletontypes
Riscky Mar 3, 2022
1e4a1f5
shape sugar with singletontypes
Riscky Mar 3, 2022
c66b0f7
more array with singletontypes
Riscky Mar 3, 2022
88401e1
reverted elt' change
Riscky Mar 3, 2022
fdca1a2
AST understands POS
Riscky Mar 4, 2022
bce5173
AST understands POS
Riscky Mar 8, 2022
238551f
stencil
Riscky Mar 8, 2022
05b4ade
Make Singletontypes behave as original
Riscky Mar 8, 2022
f714a7d
revert shape, slice singletons
Riscky Mar 8, 2022
ae5f19f
revert sugar shape singleton
Riscky Mar 8, 2022
fd1398f
revert stencil singletontype
Riscky Mar 8, 2022
996ad1b
revert singletontype completely
Riscky Mar 8, 2022
e1e00f7
create groundtypes with POSable instance via TH
Riscky Mar 10, 2022
520adc6
default definition for eltR, including ugly hacks
Riscky Mar 11, 2022
df1fd12
add OuterChoices / outerChoice to POS instances
Riscky Mar 29, 2022
c299d35
remove unused stuff from Representation/POS
Riscky Mar 29, 2022
fac73b7
convert Sums to tuple representation
Riscky Apr 7, 2022
b8d1fa0
pretty print POS structures
Riscky Apr 7, 2022
ead51a2
IsScalar instances for SumScalarType
Riscky Apr 7, 2022
8f825d3
build Maybe in Matchable
Riscky Apr 7, 2022
e13bed1
compiling Maybe Int pattern match
Riscky Apr 7, 2022
09447f7
build TAG
Riscky Apr 8, 2022
6bce206
split EltR with helper function
Riscky Apr 12, 2022
a353044
simplify SumScalarType
Riscky Apr 12, 2022
3314491
more stuff for Matchable
Riscky Apr 12, 2022
0f6cf5b
simpler union operators
Riscky Apr 14, 2022
26b41c8
new union ast constructors
Riscky May 17, 2022
5caac30
only allow singleTypes in sums
Riscky May 17, 2022
2b9a753
rename sumscalar to unionscalar
Riscky May 17, 2022
79fed72
rewrote Matchable without POSable references
Riscky May 19, 2022
da6380e
index operator with beauty notation
Riscky May 20, 2022
02bf6cb
removed outerchoices
Riscky May 20, 2022
5d05a98
more Either build AST
Riscky May 20, 2022
912b66c
cleanup Matchable
Riscky Jun 1, 2022
b17614c
makeLeft works :O
Riscky Jun 1, 2022
25bbffb
more Maybe build
Riscky Jun 2, 2022
7a52b2c
build implemented for Maybe a
Riscky Jun 2, 2022
e183544
match on maybe
Riscky Jun 2, 2022
7f1a7bc
Matchable instance for polymorphic Either
Riscky Jun 2, 2022
15716b7
tag building in terms of tagVal
Riscky Jun 2, 2022
24d2458
pattern matching up to pattern synonyms
Riscky Jun 3, 2022
28fc675
Patterns for Maybe
Riscky Jun 3, 2022
a9b4d34
pattern synonyms for Either and Bool
Riscky Jun 3, 2022
908f47a
make integer synonyms Ground and POSable
Riscky Jun 3, 2022
ff615b9
correct definition of mkEltR and fromEltR
Riscky Jun 22, 2022
6fe8dd3
define mkEltRT in terms of eltRType
Riscky Jun 23, 2022
1930f77
simplify scalarTypeTAGg
Riscky Jun 23, 2022
f845bd2
replace mkMin by correct mkSub
Riscky Jun 23, 2022
781ac2d
use type lists for unionscalars
Riscky Jun 24, 2022
dc522ea
use posable from hackage
Riscky Jun 30, 2022
a338b9f
update version ranges to match posable
Riscky Jun 30, 2022
52a8621
remove unused PrimShiftFinite operator
Riscky Jun 30, 2022
b974e62
revert unchanged file
Riscky Jun 30, 2022
12fa79a
bit of cleanup
Riscky Jun 30, 2022
e2dcdac
remove unused imports
Riscky Jun 30, 2022
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
Prev Previous commit
Next Next commit
create groundtypes with POSable instance via TH
  • Loading branch information
Riscky committed Jun 30, 2022
commit e1e00f79bfcb51d2db2e2701d0936c31d2bf9d3f
2 changes: 1 addition & 1 deletion src/Data/Array/Accelerate/Pattern/TH.hs
Original file line number Diff line number Diff line change
Expand Up @@ -293,7 +293,7 @@ mkConS tn' tvs' prev' next' tag' con' = do
++ map varE xs
++ map (\t -> [| unExp $(varE 'undef `appTypeE` return t) |] ) (concat fs1)

tagged = [| Exp $ SmartExp $ Pair (SmartExp (Const (SingleScalarType (NumSingleType (IntegralNumType TypeWord8))) $(litE (IntegerL (toInteger tag))))) $vs |]
tagged = [| Exp $ SmartExp $ Pair (SmartExp (Const (SingleScalarType (NumSingleType (IntegralNumType TypeTAG))) $(litE (IntegerL (toInteger tag))))) $vs |]
body = clause (map (\x -> [p| (Exp $(varP x)) |]) xs) (normalB tagged) []

r <- sequence [ sigD fun sig
Expand Down
92 changes: 3 additions & 89 deletions src/Data/Array/Accelerate/Representation/POS.hs
Original file line number Diff line number Diff line change
Expand Up @@ -29,7 +29,8 @@

module Data.Array.Accelerate.Representation.POS (
POSable(..), POS, POST, mkPOS, mkPOST, fromPOS, Product(..), Sum(..),
GroundType, Finite, ProductType(..), SumType(..), POSable.Generic, type (++))
GroundType(..), Finite, ProductType(..), SumType(..), POSable.Generic, type (++),
mkPOSableGroundType)
where

-- import Data.Array.Accelerate.Type
Expand All @@ -45,6 +46,7 @@ import GHC.TypeLits
import Data.Type.POSable.POSable as POSable
import Data.Type.POSable.Representation
import Data.Type.POSable.Instances
import Data.Type.POSable.TH

import Data.Int
import Data.Word
Expand Down Expand Up @@ -89,94 +91,6 @@ type POST a = (Finite (Choices a), ProductType (Fields a))
mkPOST :: forall a . (POSable a) => POST a
mkPOST = (0, emptyFields @a)

runQ $ do
let
-- XXX: we might want to do the digItOut trick used by FromIntegral?
--
integralTypes :: [Name]
integralTypes =
[ ''Int
, ''Int8
, ''Int16
, ''Int32
, ''Int64
, ''Word
, ''Word8
, ''Word16
, ''Word32
, ''Word64
]

floatingTypes :: [Name]
floatingTypes =
[ ''Half
, ''Float
, ''Double
]

newtypes :: [Name]
newtypes =
[ ''CShort
, ''CUShort
, ''CInt
, ''CUInt
, ''CLong
, ''CULong
, ''CLLong
, ''CULLong
, ''CFloat
, ''CDouble
, ''CChar
, ''CSChar
, ''CUChar
]

mkSimple :: Name -> Q [Dec]
mkSimple name =
let t = conT name
in
[d|
instance GroundType $t

instance POSable $t where
type Choices $t = 1
choices _ = 0

type Fields $t = '[ '[$t]]
fields x = Cons (Pick x) Nil

fromPOSable 0 (Cons (Pick x) Nil) = x
fromPOSable _ _ = error "index out of range"

emptyFields = PTCons (STSucc 0 STZero) PTNil
|]

mkTuple :: Int -> Q Dec
mkTuple n =
let
xs = [ mkName ('x' : show i) | i <- [0 .. n-1] ]
ts = map varT xs
res = tupT ts
ctx = mapM (appT [t| POSable |]) ts
in
instanceD ctx [t| POSable $res |] []

mkNewtype :: Name -> Q [Dec]
mkNewtype name = do
r <- reify name
base <- case r of
TyConI (NewtypeD _ _ _ _ (NormalC _ [(_, ConT b)]) _) -> return b
_ -> error "unexpected case generating newtype Elt instance"
--
[d| instance POSable $(conT name)
|]
--
ss <- mapM mkSimple (integralTypes ++ floatingTypes)
ns <- mapM mkNewtype newtypes
-- ts <- mapM mkTuple [2..16]
-- vs <- sequence [ mkVecElt t n | t <- integralTypes ++ floatingTypes, n <- [2,3,4,8,16] ]
return (concat ss ++ concat ns)


type family Snoc2List x = xs | xs -> x where
Snoc2List () = '[]
Expand Down
135 changes: 135 additions & 0 deletions src/Data/Array/Accelerate/Sugar/POS.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,135 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# OPTIONS_HADDOCK hide #-}

{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}
-- This is needed to derive POSable for tuples of size more then 4
{-# OPTIONS_GHC -fconstraint-solver-iterations=16 #-}
-- |
-- Module : Data.Array.Accelerate.Representation.POS
-- Copyright : [2008..2020] The Accelerate Team
-- License : BSD3
--
-- Maintainer : Trevor L. McDonell <trevor.mcdonell@gmail.com>
-- Stability : experimental
-- Portability : non-portable (GHC extensions)
--

module Data.Array.Accelerate.Sugar.POS
where

-- import Data.Array.Accelerate.Type

import Data.Bits
import Data.Char
import Data.Kind
import Language.Haskell.TH.Extra hiding ( Type )

import GHC.Generics
import GHC.TypeLits

import Data.Type.POSable.POSable as POSable
import Data.Type.POSable.Representation
import Data.Type.POSable.Instances
import Data.Type.POSable.TH

import Data.Int
import Data.Word
import Numeric.Half
import Foreign.C.Types

import Data.Array.Accelerate.Type

runQ $ do
let
-- XXX: we might want to do the digItOut trick used by FromIntegral?
--
integralTypes :: [Name]
integralTypes =
[ ''Int
, ''Int8
, ''Int16
, ''Int32
, ''Int64
, ''Word
, ''Word8
, ''Word16
, ''Word32
, ''Word64
]

floatingTypes :: [Name]
floatingTypes =
[ ''Half
, ''Float
, ''Double
]

newtypes :: [Name]
newtypes =
[ ''CShort
, ''CUShort
, ''CInt
, ''CUInt
, ''CLong
, ''CULong
, ''CLLong
, ''CULLong
, ''CFloat
, ''CDouble
, ''CChar
, ''CSChar
, ''CUChar
]

mkSimple :: Name -> Name -> Q [Dec]
mkSimple typ name =
let t = conT name
tt = conT typ
tr = pure $ ConE $ mkName ("Type" ++ nameBase name)
in
[d|
instance GroundType $t where
type TypeRep $t = $tt $t

mkTypeRep = $tr
|]

mkTuple :: Int -> Q Dec
mkTuple n =
let
xs = [ mkName ('x' : show i) | i <- [0 .. n-1] ]
ts = map varT xs
res = tupT ts
ctx = mapM (appT [t| POSable |]) ts
in
instanceD ctx [t| POSable $res |] []

mkNewtype :: Name -> Q [Dec]
mkNewtype name = do
r <- reify name
base <- case r of
TyConI (NewtypeD _ _ _ _ (NormalC _ [(_, ConT b)]) _) -> return b
_ -> error "unexpected case generating newtype Elt instance"
--
mkPOSableGroundType name
--
si <- mapM (mkSimple ''IntegralType) integralTypes
sf <- mapM (mkSimple ''FloatingType) floatingTypes
ns <- mapM mkPOSableGroundType (floatingTypes ++ integralTypes)
-- ns <- mapM mkNewtype newtypes
-- ts <- mapM mkTuple [2..16]
-- vs <- sequence [ mkVecElt t n | t <- integralTypes ++ floatingTypes, n <- [2,3,4,8,16] ]
return (concat si ++ concat sf ++ concat ns)

12 changes: 7 additions & 5 deletions src/Data/Array/Accelerate/Type.hs
Original file line number Diff line number Diff line change
Expand Up @@ -101,11 +101,11 @@ type family POStoEltR (cs :: Nat) fs :: Type where

type family FlattenProduct (xss :: f (g a)) = (r :: Type) where
FlattenProduct '[] = ()
FlattenProduct (x ': xs) = (ScalarType (FlattenSum x), FlattenProduct xs)
FlattenProduct (x ': xs) = (ScalarType (Sum x), FlattenProduct xs)

type family FlattenSum (xss :: f a) = (r :: Type) | r -> f where
FlattenSum '[] = ()
FlattenSum (x ': xs) = (x, FlattenSum xs)
type family FlattenProductType (xss :: f (g a)) = (r :: Type) where
FlattenProductType '[] = ()
FlattenProductType (x ': xs) = (SumType x, FlattenProductType xs)

flattenProduct :: Product a -> FlattenProduct a
flattenProduct Nil = ()
Expand Down Expand Up @@ -194,9 +194,11 @@ data BoundedType a where
-- | All scalar element types implement Eq & Ord
--
data ScalarType a where
SumScalarType :: Sum a -> ScalarType (FlattenSum a)
SumScalarType :: Sum a -> ScalarType (Sum a)
SumScalarTypeR :: SumType a -> ScalarType (SumType a)
TagScalarType :: Finite n -> ScalarType (Finite n)
SingleScalarType :: SingleType a -> ScalarType a
SingletonScalarType :: ScalarType a
VectorScalarType :: VectorType (Vec n a) -> ScalarType (Vec n a)

data SingleType a where
Expand Down