Use TH to generate PR instances for tuples
authorRoman Leshchinskiy <rl@cse.unsw.edu.au>
Fri, 6 Nov 2009 03:52:55 +0000 (03:52 +0000)
committerRoman Leshchinskiy <rl@cse.unsw.edu.au>
Fri, 6 Nov 2009 03:52:55 +0000 (03:52 +0000)
dph-common/Data/Array/Parallel/Lifted/Repr.hs
dph-common/Data/Array/Parallel/Lifted/TH/Repr.hs [new file with mode: 0644]
dph-common/dph-common.cabal

index 2555fd5..0e0d793 100644 (file)
@@ -1,4 +1,4 @@
-{-# LANGUAGE EmptyDataDecls #-}
+{-# LANGUAGE EmptyDataDecls, TemplateHaskell #-}
 {-# LANGUAGE CPP #-}
 
 #include "fusion-phases.h"
@@ -16,6 +16,8 @@ module Data.Array.Parallel.Lifted.Repr (
   segdPA#, concatPA#, segmentPA#, copySegdPA#
 ) where
 
+import Data.Array.Parallel.Lifted.TH.Repr
+
 import Data.Array.Parallel.Lifted.PArray
 import Data.Array.Parallel.Lifted.Selector
 import Data.Array.Parallel.Lifted.Unboxed ( elementsSegd# )
@@ -24,7 +26,7 @@ import qualified Data.Array.Parallel.Unlifted as U
 import Data.Array.Parallel.Base ((:*:)(..), fromBool)
 import Data.Array.Parallel.Base.DTrace ( traceFn, traceArg )
 
-import qualified Data.List as L
+import Data.List (unzip4, unzip5)
 import GHC.Exts  (Int#, Int(..), (+#), (-#), (*#))
 import GHC.Word  ( Word8 )
 
@@ -392,106 +394,85 @@ instance PA a => PR (Wrap a) where
 ------------
 -- Tuples --
 
-data instance PData (a,b)
-  = P_2 (PData a)
-        (PData b)
+$(tupleInstances [2..5])
 
-data instance PData (a,b,c)
-  = P_3 (PData a)
-        (PData b)
-        (PData c)
+{-
+ - Here is what gets generated
+ -
 
-data instance PData (a,b,c,d)
-  = P_4 (PData a)
-        (PData b)
-        (PData c)
-        (PData d)
-
-data instance PData (a,b,c,d,e)
-  = P_5 (PData a)
+data instance PData (a,b)
+  = P_2 (PData a)
         (PData b)
-        (PData c)
-        (PData d)
-        (PData e)
 
 instance (PR a, PR b) => PR (a,b) where
   {-# INLINE emptyPR #-}
-  emptyPR = traceFn "emptyPR" "(a,b)" $
-            P_2 emptyPR emptyPR
+  emptyPR = P_2 emptyPR emptyPR
 
   {-# INLINE replicatePR #-}
-  replicatePR n# (a,b) = traceFn "replicatePR" "(a,b)"
-                       $ traceArg "n#" (I# n#)
-                       $
-    P_2 (replicatePR n# a)
-        (replicatePR n# b)
+  replicatePR n# (a,b) = 
+      P_2 (replicatePR n# a)
+          (replicatePR n# b)
 
   {-# INLINE replicatelPR #-}
-  replicatelPR segd (P_2 as bs)
-    = traceFn "replicatelPR" "(a,b)" $
+  replicatelPR segd (P_2 as bs) =
       P_2 (replicatelPR segd as)
           (replicatelPR segd bs) 
 
   {-# INLINE repeatPR #-}
-  repeatPR n# len# (P_2 as bs)
-    = traceFn "repeatPR" "(a,b)" $
+  repeatPR n# len# (P_2 as bs) =
       P_2 (repeatPR n# len# as)
           (repeatPR n# len# bs)
 
   {-# INLINE repeatcPR #-}
-  repeatcPR n# ns segd (P_2 as bs)
-    = traceFn "repeatcPR" "(a,b)" $
+  repeatcPR n# ns segd (P_2 as bs) =
       P_2 (repeatcPR n# ns segd as)
           (repeatcPR n# ns segd bs)
 
   {-# INLINE indexPR #-}
-  indexPR (P_2 as bs) i# = traceFn "indexPR" "(a,b)" $
-                                     (indexPR as i#, indexPR bs i#)
+  indexPR (P_2 as bs) i# = (indexPR as i#, indexPR bs i#)
 
   {-# INLINE extractPR #-}
-  extractPR (P_2 as bs) i# n# = traceFn "extractPR" "(a,b)"
-                                          P_2 (extractPR as i# n#)
-                                              (extractPR bs i# n#)
+  extractPR (P_2 as bs) i# n# = 
+      P_2 (extractPR as i# n#)
+          (extractPR bs i# n#)
 
   {-# INLINE bpermutePR #-}
-  bpermutePR (P_2 as bs) n# is
-    = traceFn "bpermutePR" "(a,b)" $
-      P_2 (bpermutePR as n# is) (bpermutePR bs n# is)
+  bpermutePR (P_2 as bs) n# is =
+      P_2 (bpermutePR as n# is)
+          (bpermutePR bs n# is)
 
   {-# INLINE appPR #-}
-  appPR (P_2 as1 bs1) (P_2 as2 bs2)
-    = P_2 (appPR as1 as2) (appPR bs1 bs2)
+  appPR (P_2 as1 bs1) (P_2 as2 bs2) =
+      P_2 (appPR as1 as2) (appPR bs1 bs2)
 
   {-# INLINE applPR #-}
-  applPR is (P_2 as1 bs1) js (P_2 as2 bs2)
-    = traceFn "applPR" "(a,b)" $
+  applPR is (P_2 as1 bs1) js (P_2 as2 bs2) =
       P_2 (applPR is as1 js as2)
           (applPR is bs1 js bs2)
 
   {-# INLINE packPR #-}
-  packPR (P_2 as bs) n# sel# = traceFn "packPR" "(a,b)" $
-         P_2 (packPR as n# sel#)
-             (packPR bs n# sel#)
+  packPR (P_2 as bs) n# sel# =
+      P_2 (packPR as n# sel#)
+          (packPR bs n# sel#)
 
   {-# INLINE packByTagPR #-}
-  packByTagPR (P_2 as bs) n# tags t#
-    = P_2 (packByTagPR as n# tags t#)
+  packByTagPR (P_2 as bs) n# tags t# =
+      P_2 (packByTagPR as n# tags t#)
           (packByTagPR bs n# tags t#)
 
   {-# INLINE combine2PR #-}
-  combine2PR n# sel (P_2 as1 bs1) (P_2 as2 bs2)
-    = traceFn "combine2PR" "(a,b)" $
+  combine2PR n# sel (P_2 as1 bs1) (P_2 as2 bs2) =
       P_2 (combine2PR n# sel as1 as2)
           (combine2PR n# sel bs1 bs2)
 
   {-# INLINE fromListPR #-}
-  fromListPR n# xs = P_2 (fromListPR n# as)
-                         (fromListPR n# bs)
-    where
-      (as,bs) = unzip xs
+  fromListPR n# xs = let (as,bs) = unzip xs in
+      P_2 (fromListPR n# as)
+          (fromListPR n# bs)
 
   {-# INLINE nfPR #-}
   nfPR (P_2 as bs) = nfPR as `seq` nfPR bs
+-}
 
 zipPA# :: PArray a -> PArray b -> PArray (a,b)
 {-# INLINE_PA zipPA# #-}
@@ -502,369 +483,10 @@ unzipPA# :: PArray (a,b) -> (PArray a, PArray b)
 unzipPA# (PArray n# (P_2 xs ys)) = (PArray n# xs, PArray n# ys)
 
 
-instance (PR a, PR b, PR c) => PR (a,b,c) where
-  {-# INLINE emptyPR #-}
-  emptyPR = traceFn "emptyPR" "(a,b,c)" $
-          P_3 emptyPR emptyPR emptyPR
-
-  {-# INLINE replicatePR #-}
-  replicatePR n# (a,b,c)
-    = traceFn "replicatePR" "(a,b,c)" $
-      P_3 (replicatePR n# a)
-          (replicatePR n# b)
-          (replicatePR n# c)
-
-  {-# INLINE replicatelPR #-}
-  replicatelPR segd (P_3 as bs cs)
-    = traceFn "replicatelPR" "(a,b,c)" $
-      P_3 (replicatelPR segd as)
-          (replicatelPR segd bs)
-          (replicatelPR segd cs)
-
-  {-# INLINE repeatPR #-}
-  repeatPR n# len# (P_3 as bs cs)
-    = traceFn "repeatPR" "(a,b,c)" $
-      P_3 (repeatPR n# len# as)
-          (repeatPR n# len# bs)
-          (repeatPR n# len# cs)
-
-  {-# INLINE repeatcPR #-}
-  repeatcPR n# ns segd (P_3 as bs cs)
-    = traceFn "repeatcPR" "(a,b,c)" $
-      P_3 (repeatcPR n# ns segd as)
-          (repeatcPR n# ns segd bs)
-          (repeatcPR n# ns segd cs)
-
-  {-# INLINE indexPR #-}
-  indexPR (P_3 as bs cs) i#
-    = traceFn "indexPR" "(a,b,c)" $
-      (indexPR as i#, indexPR bs i#, indexPR cs i#)
-
-  {-# INLINE extractPR #-}
-  extractPR (P_3 as bs cs) i# n# = traceFn "extractPR" "(a,b,c)" $
-          P_3 (extractPR as i# n#)
-              (extractPR bs i# n#)
-              (extractPR cs i# n#)
-
-  {-# INLINE bpermutePR #-}
-  bpermutePR (P_3 as bs cs) n# is
-    = traceFn "bpermutePR" "(a,b,c)" $
-      P_3 (bpermutePR as n# is)
-          (bpermutePR bs n# is)
-          (bpermutePR cs n# is)
-
-  {-# INLINE appPR #-}
-  appPR (P_3 as1 bs1 cs1) (P_3 as2 bs2 cs2)
-    = traceFn "appPR" "(a,b,c)" $
-      P_3 (appPR as1 as2)
-          (appPR bs1 bs2)
-          (appPR cs1 cs2)
-
-  {-# INLINE applPR #-}
-  applPR is (P_3 as1 bs1 cs1) js (P_3 as2 bs2 cs2)
-    = traceFn "applPR" "(a,b,c)" $
-      P_3 (applPR is as1 js as2)
-          (applPR is bs1 js bs2)
-          (applPR is cs1 js cs2)
-
-  {-# INLINE packPR #-}
-  packPR (P_3 as bs cs) n# sel#
-    = traceFn "packPR" "(a,b,c)" $
-      P_3 (packPR as n# sel#)
-          (packPR bs n# sel#)
-          (packPR cs n# sel#)
-
-  {-# INLINE packByTagPR #-}
-  packByTagPR (P_3 as bs cs) n# tags t#
-    = P_3 (packByTagPR as n# tags t#)
-          (packByTagPR bs n# tags t#)
-          (packByTagPR cs n# tags t#)
-
-  {-# INLINE combine2PR #-}
-  combine2PR n# sel (P_3 as1 bs1 cs1)
-                                  (P_3 as2 bs2 cs2)
-    = traceFn "combine2PR" "(a,b,c)" $
-      P_3 (combine2PR n# sel as1 as2)
-          (combine2PR n# sel bs1 bs2)
-          (combine2PR n# sel cs1 cs2)
-
-  {-# INLINE fromListPR #-}
-  fromListPR n# xs
-    = P_3 (fromListPR n# as)
-          (fromListPR n# bs)
-          (fromListPR n# cs)
-    where
-      (as,bs,cs) = unzip3 xs
-
-  {-# INLINE nfPR #-}
-  nfPR (P_3 as bs cs)
-    = nfPR as
-      `seq` nfPR bs
-      `seq` nfPR cs
-
 zip3PA# :: PArray a -> PArray b -> PArray c -> PArray (a,b,c)
 {-# INLINE_PA zip3PA# #-}
 zip3PA# (PArray n# xs) (PArray _ ys) (PArray _ zs) = PArray n# (P_3 xs ys zs)
 
-
-instance (PR a, PR b, PR c, PR d) => PR (a,b,c,d) where
-  {-# INLINE emptyPR #-}
-  emptyPR = traceFn "emptyPR" "(a,b,c,d)" $
-          P_4 emptyPR
-              emptyPR
-              emptyPR
-              emptyPR
-
-  {-# INLINE replicatePR #-}
-  replicatePR n# (a,b,c,d)
-    = traceFn "replicatePR" "(a,b,c,d)" $
-      P_4 (replicatePR n# a)
-          (replicatePR n# b)
-          (replicatePR n# c)
-          (replicatePR n# d)
-
-  {-# INLINE replicatelPR #-}
-  replicatelPR segd (P_4 as bs cs ds)
-    = traceFn "replicatelPR" "(a,b,c,d)" $
-      P_4 (replicatelPR segd as)
-          (replicatelPR segd bs)
-          (replicatelPR segd cs)
-          (replicatelPR segd ds)
-
-  {-# INLINE repeatPR #-}
-  repeatPR n# len# (P_4 as bs cs ds)
-    = traceFn "repeatPR" "(a,b,c,d)" $
-      P_4 (repeatPR n# len# as)
-          (repeatPR n# len# bs)
-          (repeatPR n# len# cs)
-          (repeatPR n# len# ds)
-
-  {-# INLINE repeatcPR #-}
-  repeatcPR n# ns segd (P_4 as bs cs ds)
-    = traceFn "repeatcPR" "(a,b,c,d)" $
-      P_4 (repeatcPR n# ns segd as)
-          (repeatcPR n# ns segd bs)
-          (repeatcPR n# ns segd cs)
-          (repeatcPR n# ns segd ds)
-
-  {-# INLINE indexPR #-}
-  indexPR (P_4 as bs cs ds) i#
-    = traceFn "indexPR" "(a,b,c,d)" $
-      (indexPR as i#,
-       indexPR bs i#,
-       indexPR cs i#,
-       indexPR ds i#)
-
-  {-# INLINE extractPR #-}
-  extractPR (P_4 as bs cs ds) i# n#
-    = traceFn "extractPR" "(a,b,c,d)" $
-        P_4 (extractPR as i# n#)
-            (extractPR bs i# n#)
-            (extractPR cs i# n#)
-            (extractPR ds i# n#)
-
-  {-# INLINE bpermutePR #-}
-  bpermutePR (P_4 as bs cs ds) n# is
-    = traceFn "bpermutePR" "(a,b,c,d)" $
-      P_4 (bpermutePR as n# is)
-          (bpermutePR bs n# is)
-          (bpermutePR cs n# is)
-          (bpermutePR ds n# is)
-
-  {-# INLINE appPR #-}
-  appPR (P_4 as1 bs1 cs1 ds1) (P_4 as2 bs2 cs2 ds2)
-    = traceFn "appPR" "(a,b,c,d)" $
-      P_4 (appPR as1 as2)
-          (appPR bs1 bs2)
-          (appPR cs1 cs2)
-          (appPR ds1 ds2)
-
-  {-# INLINE applPR #-}
-  applPR is (P_4 as1 bs1 cs1 ds1) js (P_4 as2 bs2 cs2 ds2)
-    = traceFn "applPR" "(a,b,c,d)" $
-      P_4 (applPR is as1 js as2)
-          (applPR is bs1 js bs2)
-          (applPR is cs1 js cs2)
-          (applPR is ds1 js ds2)
-
-  {-# INLINE packPR #-}
-  packPR (P_4 as bs cs ds) n# sel#
-    = traceFn "packPR" "(a,b,c,d)" $
-      P_4 (packPR as n# sel#)
-          (packPR bs n# sel#)
-          (packPR cs n# sel#)
-          (packPR ds n# sel#)
-
-  {-# INLINE packByTagPR #-}
-  packByTagPR (P_4 as bs cs ds) n# tags t#
-    = P_4 (packByTagPR as n# tags t#)
-          (packByTagPR bs n# tags t#)
-          (packByTagPR cs n# tags t#)
-          (packByTagPR ds n# tags t#)
-
-  {-# INLINE combine2PR #-}
-  combine2PR n# sel (P_4 as1 bs1 cs1 ds1)
-                                    (P_4 as2 bs2 cs2 ds2)
-    = traceFn "combine2PR" "(a,b,c,d)" $
-      P_4 (combine2PR n# sel as1 as2)
-          (combine2PR n# sel bs1 bs2)
-          (combine2PR n# sel cs1 cs2)
-          (combine2PR n# sel ds1 ds2)
-
-  {-# INLINE fromListPR #-}
-  fromListPR n# xs
-    = P_4 (fromListPR n# as)
-          (fromListPR n# bs)
-          (fromListPR n# cs)
-          (fromListPR n# ds)
-    where
-      (as,bs,cs,ds) = L.unzip4 xs
-
-  {-# INLINE nfPR #-}
-  nfPR (P_4 as bs cs ds)
-    = nfPR as
-      `seq` nfPR bs
-      `seq` nfPR cs
-      `seq` nfPR ds
-
-instance (PR a, PR b, PR c, PR d, PR e) => PR (a,b,c,d,e) where
-  {-# INLINE emptyPR #-}
-  emptyPR
-    = traceFn "emptyPR" "(a,b,c,d,e)" $
-    P_5 emptyPR
-        emptyPR
-        emptyPR
-        emptyPR
-        emptyPR
-
-  {-# INLINE replicatePR #-}
-  replicatePR n# (a,b,c,d,e)
-    = traceFn "replicatePR" "(a,b,c,d,e)" $
-    P_5 (replicatePR n# a)
-        (replicatePR n# b)
-        (replicatePR n# c)
-        (replicatePR n# d)
-        (replicatePR n# e)
-
-  {-# INLINE replicatelPR #-}
-  replicatelPR segd (P_5 as bs cs ds es)
-    = traceFn "replicatelPR" "(a,b,c,d,e)" $
-    P_5 (replicatelPR segd as)
-        (replicatelPR segd bs)
-        (replicatelPR segd cs)
-        (replicatelPR segd ds)
-        (replicatelPR segd es)
-
-  {-# INLINE repeatPR #-}
-  repeatPR n# len# (P_5 as bs cs ds es)
-    = traceFn "repeatPR" "(a,b,c,d,e)" $
-    P_5 (repeatPR n# len# as)
-        (repeatPR n# len# bs)
-        (repeatPR n# len# cs)
-        (repeatPR n# len# ds)
-        (repeatPR n# len# es)
-
-  {-# INLINE repeatcPR #-}
-  repeatcPR n# ns segd (P_5 as bs cs ds es)
-    = traceFn "repeatcPR" "(a,b,c,d,e)" $
-    P_5 (repeatcPR n# ns segd as)
-        (repeatcPR n# ns segd bs)
-        (repeatcPR n# ns segd cs)
-        (repeatcPR n# ns segd ds)
-        (repeatcPR n# ns segd es)
-
-  {-# INLINE indexPR #-}
-  indexPR (P_5 as bs cs ds es) i#
-    = traceFn "indexPR" "(a,b,c,d,e)" $
-    (indexPR as i#,
-     indexPR bs i#,
-     indexPR cs i#,
-     indexPR ds i#,
-     indexPR es i#)
-
-  {-# INLINE extractPR #-}
-  extractPR (P_5 as bs cs ds es) i# n#
-    = traceFn "extractPR" "(a,b,c,d,e)" $
-      P_5 (extractPR as i# n#)
-          (extractPR bs i# n#)
-          (extractPR cs i# n#)
-          (extractPR ds i# n#)
-          (extractPR es i# n#)
-
-  {-# INLINE bpermutePR #-}
-  bpermutePR (P_5 as bs cs ds es) n# is
-    = traceFn "bpermutePR" "(a,b,c,d,e)" $
-    P_5 (bpermutePR as n# is)
-        (bpermutePR bs n# is)
-        (bpermutePR cs n# is)
-        (bpermutePR ds n# is)
-        (bpermutePR es n# is)
-
-  {-# INLINE appPR #-}
-  appPR (P_5 as1 bs1 cs1 ds1 es1)
-                              (P_5 as2 bs2 cs2 ds2 es2)
-    = traceFn "appPR" "(a,b,c,d,e)" $
-    P_5 (appPR as1 as2)
-        (appPR bs1 bs2)
-        (appPR cs1 cs2)
-        (appPR ds1 ds2)
-        (appPR es1 es2)
-
-  {-# INLINE applPR #-}
-  applPR is (P_5 as1 bs1 cs1 ds1 es1)
-                               js (P_5 as2 bs2 cs2 ds2 es2)
-    = traceFn "applPR" "(a,b,c,d,e)" $
-    P_5 (applPR is as1 js as2)
-        (applPR is bs1 js bs2)
-        (applPR is cs1 js cs2)
-        (applPR is ds1 js ds2)
-        (applPR is es1 js es2)
-
-  {-# INLINE packPR #-}
-  packPR (P_5 as bs cs ds es) n# sel#
-    = traceFn "packPR" "(a,b,c,d,e)" $
-    P_5 (packPR as n# sel#)
-        (packPR bs n# sel#)
-        (packPR cs n# sel#)
-        (packPR ds n# sel#)
-        (packPR es n# sel#)
-
-  {-# INLINE packByTagPR #-}
-  packByTagPR (P_5 as bs cs ds es) n# tags t#
-    = P_5 (packByTagPR as n# tags t#)
-          (packByTagPR bs n# tags t#)
-          (packByTagPR cs n# tags t#)
-          (packByTagPR ds n# tags t#)
-          (packByTagPR es n# tags t#)
-
-  {-# INLINE combine2PR #-}
-  combine2PR n# sel (P_5 as1 bs1 cs1 ds1 es1)
-                                          (P_5 as2 bs2 cs2 ds2 es2)
-    = traceFn "combine2PR" "(a,b,c,d,e)" $
-    P_5 (combine2PR n# sel as1 as2)
-        (combine2PR n# sel bs1 bs2)
-        (combine2PR n# sel cs1 cs2)
-        (combine2PR n# sel ds1 ds2)
-        (combine2PR n# sel es1 es2)
-
-  {-# INLINE fromListPR #-}
-  fromListPR n# xs
-    = P_5 (fromListPR n# as)
-          (fromListPR n# bs)
-          (fromListPR n# cs)
-          (fromListPR n# ds)
-          (fromListPR n# es)
-    where
-      (as,bs,cs,ds,es) = L.unzip5 xs
-
-  {-# INLINE nfPR #-}
-  nfPR (P_5 as bs cs ds es)
-    = nfPR as
-      `seq` nfPR bs
-      `seq` nfPR cs
-      `seq` nfPR ds
-      `seq` nfPR es
-
 ----------
 -- Sums --
 
diff --git a/dph-common/Data/Array/Parallel/Lifted/TH/Repr.hs b/dph-common/Data/Array/Parallel/Lifted/TH/Repr.hs
new file mode 100644 (file)
index 0000000..b6689a3
--- /dev/null
@@ -0,0 +1,156 @@
+{-# LANGUAGE TemplateHaskell, Rank2Types #-}
+module Data.Array.Parallel.Lifted.TH.Repr (
+  tupleInstances
+) where
+
+import Data.Array.Parallel.Lifted.PArray
+
+import Language.Haskell.TH
+import Data.List (transpose)
+
+pdataTupCon :: Int -> Name
+pdataTupCon n = mkName ("P_" ++ show n)
+
+varTs = map varT
+appTs = foldl appT
+
+varEs = map varE
+appEs = foldl appE
+
+patLetE pat exp body = letE [valD pat (normalB exp) []] body
+
+varPs = map varP
+
+vanillaC con tys = normalC con (map (strictType notStrict) tys)
+
+simpleFunD name pats exp
+  = funD name [clause pats (normalB exp) []]
+
+inlineD :: Name -> DecQ
+inlineD name = pragInlD name (inlineSpecNoPhase True False)
+
+instance_PData :: TypeQ -> [Name] -> Name -> [TypeQ] -> DecQ
+instance_PData tycon tyargs con tys
+  = dataInstD (cxt []) ''PData [tycon `appTs` varTs tyargs]
+                               [vanillaC con tys]
+                               []
+
+
+tupleInstances :: [Int] -> Q [Dec]
+tupleInstances ns
+  = do
+      pdatas <- mapM instance_PData_tup ns
+      prs    <- mapM instance_PR_tup ns
+      return $ pdatas ++ prs
+
+instance_PData_tup :: Int -> DecQ
+instance_PData_tup arity
+  = instance_PData (tupleT arity) vars (pdataTupCon arity)
+                [conT ''PData `appT` varT v | v <- vars]
+  where
+    vars = take arity $ [mkName [c] | c <- ['a' .. ]]
+
+
+instance_PR_tup :: Int -> DecQ
+instance_PR_tup arity
+  = instanceD (cxt [classP ''PR [ty] | ty <- tys])
+              (conT ''PR `appT` (tupleT arity `appTs` tys))
+              (map (inlineD . mkName . fst) methods ++ map snd methods)
+  where
+    tyvars = take arity $ [mkName [c] | c <- ['a' .. ]]
+    tys    = map varT tyvars
+
+    pcon   = pdataTupCon arity
+
+    pconApp = appEs (conE pcon)
+    pconPat = conP pcon
+
+    vars   = take arity $ [mkName [c] | c <- ['a' .. ]]
+    pvars  = take arity $ [mkName (c : "s") | c <- ['a' .. ]]
+    pvars1 = take arity $ [mkName (c : "s1") | c <- ['a' .. ]]
+    pvars2 = take arity $ [mkName (c : "s2") | c <- ['a' .. ]]
+
+    methods = [ ("emptyPR",             m_empty                 )
+              , ("replicatePR",         m_replicate             )
+              , ("replicatelPR",        m_replicatel            )
+              , ("repeatPR",            m_repeat                )
+              , ("repeatcPR",           m_repeatc               )
+              , ("indexPR",             m_index                 )
+              , ("extractPR",           m_extract               )
+              , ("bpermutePR",          m_bpermute              )
+              , ("appPR",               m_app                   )
+              , ("applPR",              m_appl                  )
+              , ("packPR",              m_pack                  )
+              , ("packByTagPR",         m_packByTag             )
+              , ("combine2PR",          m_combine2              )
+              , ("fromListPR",          m_fromList              )
+              , ("nfPR",                m_nf                    )
+              ]
+
+    method :: String -> [String] -> [[Name]]
+            -> ([PatQ] -> PatQ) -> ([ExpQ] -> ExpQ)
+            -> (forall a. [a] -> [a] -> [a]) -> DecQ
+    method s args vs mk_pat mk_con insert 
+      = simpleFunD (mkName s)
+                   (insert (varPs args') (map (mk_pat . varPs) vs))
+        $ mk_con 
+            [varE (mkName s) `appEs` insert (varEs args') (map varE v)
+                | v <- transpose vs]
+      where
+        args' = map mkName args
+
+    m_empty = simpleFunD (mkName "emptyPR") []
+            $ conE pcon `appEs` replicate arity (varE 'emptyPR)
+
+    m_replicate = method "replicatePR" ["n#"] [vars] tupP pconApp
+                $ \[n] [x] -> [n,x]
+
+    m_replicatel = method "replicatelPR" ["segd"] [pvars] pconPat pconApp
+                $ \[segd] [x] -> [segd,x]
+
+    m_repeat = method "repeatPR" ["n#", "len#"] [pvars] pconPat pconApp
+                $ \[n,len] [x] -> [n,len,x]
+
+    m_repeatc = method "repeatcPR" ["n#","ns","segd"] [pvars] pconPat pconApp
+                $ \[n,ns,segd] [x] -> [n,ns,segd,x]
+
+    m_index = method "indexPR" ["i#"] [pvars] pconPat tupE
+                $ \[i] [x] -> [x,i]
+
+    m_extract = method "extractPR" ["i#","n#"] [pvars] pconPat pconApp
+                $ \[i,n] [x] -> [x,i,n]
+
+    m_bpermute = method "bpermutePR" ["n#","is"] [pvars] pconPat pconApp
+                $ \[n,is] [x] -> [x,n,is]
+
+    m_app = method "appPR" [] [pvars1, pvars2] pconPat pconApp
+                $ \[] [x,y] -> [x,y]
+
+    m_appl = method "applPR" ["is","js"] [pvars1, pvars2] pconPat pconApp
+                $ \[is,js] [x,y] -> [is,x,js,y]
+
+    m_pack = method "packPR" ["n#","sel"] [pvars] pconPat pconApp
+                $ \[n,sel] [x] -> [x,n,sel]
+
+    m_packByTag = method "packByTagPR" ["n#","tags","t#"] [pvars] pconPat pconApp
+                $ \[n,tags,t] [x] -> [x,n,tags,t]
+
+    m_combine2 = method "combine2PR" ["n#","sel"] [pvars1,pvars2] pconPat pconApp
+                $ \[n,sel] [x,y] -> [n,sel,x,y]
+
+    m_fromList = method "fromListPR" ["n#"] [pvars] (const $ varP xs) mk_body
+                $ \[n] [x] -> [n,x]
+      where
+        mk_body = patLetE (tupP $ varPs pvars) (varE unzip `appE` varE xs)
+                . pconApp
+
+        xs = mkName "xs"
+
+        unzip | arity == 2 = mkName "unzip"
+              | otherwise  = mkName ("unzip" ++ show arity)
+
+    m_nf = method "nfPR" [] [pvars] pconPat mk_body
+                $ \[] [x] -> [x]
+      where
+        mk_body = foldl1 (\e1 e2 -> varE 'seq `appEs` [e1,e2])
+
index 02f2a68..9aa5cae 100644 (file)
@@ -30,6 +30,7 @@ Library
         Data.Array.Parallel.Lifted.PArray
         Data.Array.Parallel.Lifted.Unboxed
         Data.Array.Parallel.Lifted.Scalar
+        Data.Array.Parallel.Lifted.TH.Repr
         Data.Array.Parallel.Lifted.Repr
         Data.Array.Parallel.Lifted.Closure
         Data.Array.Parallel.Lifted.Instances
@@ -54,7 +55,7 @@ Library
   else
     GHC-Options: -O2 -fdicts-cheap -fno-method-sharing
 
-  Build-Depends:  base >= 3 && < 5, array, random, ghc
+  Build-Depends:  base >= 3 && < 5, array, random, ghc, template-haskell
   if impl(ghc >= 6.9)
     Build-Depends: ghc-prim
   Build-Depends: dph-base