Extracs and Event Seer patches from Amos
authorBen Lippmeier <benl@ouroborus.net>
Mon, 13 Aug 2012 05:02:25 +0000 (15:02 +1000)
committerBen Lippmeier <benl@ouroborus.net>
Tue, 21 Aug 2012 06:45:17 +0000 (16:45 +1000)
19 files changed:
dph-event-seer/dph-event-seer.cabal
dph-event-seer/src/DphOps.hs [new file with mode: 0644]
dph-event-seer/src/HecUsage.hs
dph-event-seer/src/HecWake.hs
dph-event-seer/src/Main.hs
dph-event-seer/src/Pretty.hs [new file with mode: 0644]
dph-prim-par/Data/Array/Parallel/Unlifted.hs
dph-prim-par/Data/Array/Parallel/Unlifted/Distributed/Arrays.hs
dph-prim-par/Data/Array/Parallel/Unlifted/Distributed/Combinators.hs
dph-prim-par/Data/Array/Parallel/Unlifted/Distributed/Data/Bool.hs
dph-prim-par/Data/Array/Parallel/Unlifted/Distributed/Data/Scalar.hs
dph-prim-par/Data/Array/Parallel/Unlifted/Distributed/Data/USegd/Split.hs
dph-prim-par/Data/Array/Parallel/Unlifted/Distributed/Primitive/DistST.hs
dph-prim-par/Data/Array/Parallel/Unlifted/Distributed/Primitive/Gang.hs
dph-prim-par/Data/Array/Parallel/Unlifted/Distributed/Primitive/Operators.hs
dph-prim-par/Data/Array/Parallel/Unlifted/Distributed/What.hs
dph-prim-par/Data/Array/Parallel/Unlifted/Parallel/Extracts.hs
dph-prim-seq/Data/Array/Parallel/Unlifted/Stream/Segments.hs
dph-test/test/Unlifted/VSegmented.hs

index 95b9e94..4d28f8f 100644 (file)
@@ -1,5 +1,5 @@
 Name:                dph-event-seer
-Version:             0.0.0.1
+Version:             0.6.0.1
 License:             BSD3
 License-file:        LICENSE
 Author:              The DPH Team
@@ -15,8 +15,10 @@ Synopsis:            Analyse eventlog files for time spent in garbage collection
 Executable dph-event-seer
   Build-depends:
         base                == 4.*,
-        containers          == 0.4.*,
-        ghc-events          == 0.4.*
+        dph-prim-par        == 0.6.*,
+        containers          == 0.5.*,
+        ghc-events          == 0.4.*,
+        pretty              >= 1.1
 
   Main-is:        Main.hs
   hs-source-dirs: src
diff --git a/dph-event-seer/src/DphOps.hs b/dph-event-seer/src/DphOps.hs
new file mode 100644 (file)
index 0000000..e8a393a
--- /dev/null
@@ -0,0 +1,251 @@
+module DphOps
+        ( dphOpsMachine
+        , dphOpsSumMachine
+        , pprDphOpsState
+        , pprDphOpsSumState
+        , getGangEvents
+        , pprGangEvents)
+where
+
+import qualified Data.Array.Parallel.Unlifted.Distributed.What as W
+
+import GHC.RTS.Events
+import GHC.RTS.Events.Analysis
+
+import Data.Map (Map)
+import qualified Data.Map as M
+
+import Data.List        (sortBy, stripPrefix)
+import Data.Function    (on)
+
+import Pretty
+
+import Debug.Trace
+
+-- | result of attempting to parse a CapEvent
+data ParseComp
+    = POk W.Comp Timestamp -- ^ valid Comp and its duration
+    | PUnparsable        -- ^ looks like a comp, but invalid
+    | PIgnored           -- ^ not a comp at all, just ignore
+-- | attempt to get a Comp
+-- eg "GANG Complete par CompMap{...} in 44us"
+parseComp :: GangEvent -> ParseComp
+parseComp (GangEvent _ _ msg)
+   | Just compStr   <- stripPrefix "Complete par " msg
+   , (comp,inStr):_ <- reads compStr
+   , Just muStr     <- stripPrefix " in " inStr
+   , (mus,"us."):_  <- reads muStr
+   = POk comp (mus*10^3)
+   -- prefix is there, but the rest didn't parse properly
+   | Just compStr   <- stripPrefix "Complete par " msg
+   = PUnparsable
+   -- prefix isn't there, so just ignore it
+   | otherwise
+   = PIgnored
+parseComp _
+   = PIgnored
+
+data GangEvent = GangEvent (Maybe Int) Timestamp String
+        deriving Show
+
+-- | potentially merge multiple CapEvents into single GangEvent
+getGangEvents :: [CapEvent] -> [GangEvent]
+getGangEvents xs = snd $ foldl (flip gang) (Nothing,[]) xs
+ where
+  -- GANG[1/4] Complete par ...
+  gang (CapEvent c (Event t (UserMessage msg)))
+       (no,ls)
+   | Just numS      <- stripPrefix "GANG[" msg
+   , [(n,'/':n2S)]  <- reads numS :: [(Int,String)]
+   , [(m,']':' ':restS)]<- reads n2S  :: [(Int,String)]
+   = app (n,m) no (GangEvent c t restS) ls
+   | otherwise
+   = (no,ls)
+  gang _ acc                = acc
+
+  app (n,m) se ge ls
+        | n == 1 && m == 1
+        = (Nothing, ls ++ [ge])
+        | n == 1
+        = (Just ge, ls)
+        | n == m
+        = (Nothing, ls ++ [se `merge` ge])
+        | otherwise
+        = (Just $ se `merge` ge, ls)
+        
+
+  merge Nothing ge
+        = ge
+  merge (Just (GangEvent c t s)) (GangEvent _ _ s')
+        = GangEvent c t (s++s')
+
+pprGangEvents :: [GangEvent] -> Doc
+pprGangEvents gs = vcat $ map ppr gs
+instance Pretty GangEvent where
+  ppr (GangEvent c t s) =
+        padL 10 (text $ show c) <>
+        padR 15 (pprTimestampAbs t) <>
+        text s
+
+-- Display all operations and duration, ordered decreasing
+data DphOpsState = DphOpsState (Map Timestamp [W.Comp]) Timestamp Int
+
+dphOpsMachine :: Machine DphOpsState GangEvent
+dphOpsMachine = Machine
+  { initial = DphOpsState M.empty 0 0
+  , final   = const False
+  , alpha   = alph
+  , delta   = delt
+  }
+ where
+  alph _ = True
+
+  delt (DphOpsState ops total unparse) evt
+   = case parseComp evt of
+     POk comp duration  ->
+      Just $ DphOpsState (update ops duration comp) (total + duration) unparse
+     PUnparsable        ->
+      Just $ DphOpsState ops total (unparse+1)
+     PIgnored           ->
+      Just $ DphOpsState ops total unparse
+  delt s _ = Just s
+
+  update !counts !k !v = M.insertWith' (++) k [v] counts
+
+
+pprDphOpsState :: DphOpsState -> Doc
+pprDphOpsState (DphOpsState ops total unparse) = vcat [unparse', ops']
+ where
+  unparse'
+        = if unparse == 0
+          then text ""
+          else text "Errors: " <> ppr unparse <> text " events unable to be parsed"
+
+  ops' = vcat $ map pprOps $ reverse $ M.assocs ops
+
+  pprOps (duration,cs) = vcat $ map (pprOp duration) cs
+  pprOp duration c     = padLines (cat
+        [ pprPercent duration
+        , text " "
+        , padR 10 (text "(" <> pprTimestampEng duration <> text ")")
+        , text " "
+        ]) (show $ ppr c)
+  pprPercent   v = padR 5  $ ppr (v * 100 `div` total) <> text "%"
+
+padLines left right
+ = let (x:xs) = chunks' trunc_len right
+       pad'   = text $ replicate (length (render left)) ' '
+   in  vcat ((left <> text x) : map (\x-> pad' <> text x) xs)
+
+trunc_len = 100
+trunc l
+  | length l > trunc_len
+  = take (trunc_len-4) l ++ " ..."
+  | otherwise
+  = l
+
+data DphOpsSumState = DphOpsSumState (Map W.Comp (Int,Timestamp)) Timestamp Int
+
+dphOpsSumMachine :: Machine DphOpsSumState GangEvent
+dphOpsSumMachine = Machine
+  { initial = DphOpsSumState M.empty 0 0
+  , final   = const False
+  , alpha   = alph
+  , delta   = delt
+  }
+ where
+  alph _ = True
+
+  -- "GANG Complete par CompMap{...} in 44us"
+  delt (DphOpsSumState ops total unparse) evt
+   = case parseComp evt of
+     POk comp duration  ->
+      Just $ DphOpsSumState (update ops (clearJoinComp comp) (1,duration)) (total + duration) unparse
+     PUnparsable        ->
+      Just $ DphOpsSumState ops total (unparse+1)
+     PIgnored           ->
+      Just $ DphOpsSumState ops total unparse
+  delt s _ = Just s
+
+  update !counts !k !v = M.insertWith' pairAdd k v counts
+  pairAdd (aa,ab) (ba,bb) = (aa+ba, ab+bb)
+
+  -- reset the elements arg of all JoinCopies so they show up as total
+  clearJoinComp (W.CGen c w)   = W.CGen c $ clearJoinWhat w
+  clearJoinComp (W.CMap  w)    = W.CMap   $ clearJoinWhat w
+  clearJoinComp (W.CFold w)    = W.CFold  $ clearJoinWhat w
+  clearJoinComp (W.CScan w)    = W.CScan  $ clearJoinWhat w
+  clearJoinComp (W.CDist w)    = W.CDist  $ clearJoinWhat w
+
+  clearJoinWhat (W.WJoinCopy _)= W.WJoinCopy (-1)
+  clearJoinWhat (W.WFMapMap p q) = W.WFMapMap (clearJoinWhat p) (clearJoinWhat q)
+  clearJoinWhat (W.WFMapGen p q) = W.WFMapGen (clearJoinWhat p) (clearJoinWhat q)
+  clearJoinWhat (W.WFZipMap p q) = W.WFZipMap (clearJoinWhat p) (clearJoinWhat q)
+  clearJoinWhat w = w
+
+
+
+pprDphOpsSumState :: DphOpsSumState -> Doc
+pprDphOpsSumState (DphOpsSumState ops total unparse) = vcat [unparse', ops']
+ where
+  unparse'
+        = if unparse == 0
+          then text ""
+          else text "Errors: " <> ppr unparse <> text " events unable to be parsed"
+
+  ops' = vcat $ map pprOp $ sortBy cmp $ M.assocs ops
+  cmp (_,(_,p)) (_,(_,q))
+        = case compare p q of
+          GT -> LT
+          EQ -> EQ
+          LT -> GT
+
+  pprOp (c,(calls,duration)) = padLines (cat
+        [ pprPercent duration
+        , text " "
+        , padR 10 (text "(" <> pprTimestampEng duration <> text ")")
+        , text " "
+        , padR 10 (ppr calls)
+        , text " "
+        ]) (show $ ppr c)
+  pprPercent   v = padR 5  $ ppr (v * 100 `div` total) <> text "%"
+
+instance Pretty W.Comp where
+  ppr (W.CGen cheap what)
+        = cheap' <> ppr what
+        where
+        cheap' = if cheap
+                 then text "GenC "
+                 else text "Gen  "
+  ppr (W.CMap what)
+        = text "Map  " <> ppr what
+  ppr (W.CFold what)
+        = text "Fold " <> ppr what
+  ppr (W.CScan what)
+        = text "Scan " <> ppr what
+  ppr (W.CDist what)
+        = text "Dist " <> ppr what
+
+instance Pretty W.What where
+  ppr (W.What str)            = text $ show str
+  ppr (W.WScalar)          = text "Scalar"
+  ppr (W.WZip)             = text "Zip"
+  ppr (W.WSlice)           = text "Slice"
+  ppr (W.WLength)          = text "Length"
+  ppr (W.WLengthIdx)       = text "LengthIdx"
+  ppr (W.WBpermute)        = text "Bpermute"
+  ppr (W.WJoinCopy (-1))   = text  "JoinCp"
+  ppr (W.WJoinCopy n)      = text ("JoinCp(" ++ show n ++ ")")
+  ppr (W.WFMapMap p q) = text "(" <> ppr p <> text " mapMap " <> ppr q <> text ")"
+  ppr (W.WFMapGen p q) = text "(" <> ppr p <> text " mapGen " <> ppr q <> text ")"
+  ppr (W.WFZipMap p q) = text "(" <> ppr p <> text " zipMap " <> ppr q <> text ")"
+
+chunks' len str
+ = case chunks len str of
+        (x:xs) -> (x:xs)
+        []     -> [""]
+
+chunks len [] = []
+chunks len str
+ = let (f,r) = splitAt len str
+   in  f : chunks len r
index c609bd0..94d7545 100644 (file)
@@ -5,6 +5,8 @@ module HecUsage where
 import GHC.RTS.Events
 import GHC.RTS.Events.Analysis
 
+import Pretty
+
 import Data.Map (Map)
 import qualified Data.Map as M
 
@@ -68,23 +70,20 @@ hecUsageMachine = Machine
 
   update !counts !k !v = M.insertWith' (+) k v counts
 
+instance Pretty HecCurrentCap where
+  ppr (HecCap n) = ppr n <> text " caps"
+  ppr (HecGC)    = text "In GC"
 
-showValidate :: (s -> String) -> (i -> String) -> Either (s, i) s -> String
-showValidate showState showInput (Left (state, input)) =
-  "Invalid eventlog:"
-  ++ "\nState:\n" ++ ( showState state )
-  ++ "\nInput:\n" ++ ( showInput input )
-showValidate showState _ (Right state) =
-  "Valid eventlog: " ++ ( showState state )
-
-showMap :: Ord k => (k -> String) -> (a -> String) -> M.Map k a -> String
-showMap showKey showValue m =
-  concat $ zipWith (++)
-    (map showKey . M.keys $ m :: [String])
-    (map (showValue . (M.!) m) . M.keys $ m :: [String])
-
-showHecUsage :: HecUsageState -> String
-showHecUsage (HecUsageState counts runR runG _ total) = "\n" ++ counts' ++ running'
+pprHecUsage :: HecUsageState -> Doc
+pprHecUsage (HecUsageState counts runR runG _ total) = vcat [ counts', running' ]
  where
-  counts' = showMap show (\v -> ":\t" ++ show (v * 100 `div` total) ++ "%\t(" ++ show v ++ ")\n") counts
-  running'= if (runR,runG) == (0,0) then "" else "\nSome threads still running? " ++ show (runR,runG)
+  counts'        = pprMap (padL 10 . (<>text ":") . ppr) pprTimestamp counts
+  pprTimestamp v = pprPercent v <> text " " <> pprTime v
+  pprPercent   v = padR 5  $ ppr (v * 100 `div` total) <> text "%"
+  pprTime      v = padR 10 $ cat
+                [ text "("
+                , pprTimestampEng v
+                , text ")"
+                ]
+
+  running'= if (runR,runG) == (0,0) then text "" else text "Some threads still running? " <> (text $ show (runR,runG))
index 0f8424d..8245349 100644 (file)
@@ -10,6 +10,8 @@ import qualified Data.Map as M
 
 import Data.List (sortBy)
 
+import Pretty
+
 
 -- | A single wake-up event. List of these used for results.
 data HecWake = HecWake
@@ -51,27 +53,27 @@ hecWakeMachine = Machine
 
 
 
-showHecWake :: HecWakeState -> String
-showHecWake (HecWakeState waketimes lens) = waketimes' ++ "\n" ++ lens'
+pprHecWake :: HecWakeState -> Doc
+pprHecWake (HecWakeState waketimes lens) = vcat [ waketimes', lens' ]
  where
-  waketimes' = if M.null waketimes then "" else "not all threads scheduled to wake up actually woke up!"
+  waketimes' = if M.null waketimes then text "" else text "not all threads scheduled to wake up actually woke up!"
 
   lens'
    = if null lens
-        then "No wakes"
-        else concat
-            [   "Min: ", show minL
-            , "\nMax: ", show maxL
-            , "\nMed: ", show medianL
-            , "\nAvg: ", show avgL
-            , "\nCount: ", show (length lens)
+        then text "No wakes"
+        else vcat
+            [ text "Min:   " <> ppr minL
+            , text "Max:   " <> ppr maxL
+            , text "Med:   " <> (padR 10 $ pprTimestampEng medianL)
+            , text "Avg:   " <> (padR 10 $ pprTimestampEng avgL)
+            , text "Count: " <> (padR 10 $ ppr lenL)
             ]
   sorted  = sortBy cmp lens
   lenL    = length sorted
 
   minL    = head sorted
   maxL    = last sorted
-  avgL    = fromEnum (sum $ map lenOf sorted) `div` lenL
+  avgL    = (sum $ map lenOf sorted) `div` fromIntegral lenL
 
   medianL = if lenL `mod` 2 == 0
             then (lenOf (sorted !! lenL_2) + lenOf (sorted !! (lenL_2 - 1))) `div` 2
@@ -81,5 +83,12 @@ showHecWake (HecWakeState waketimes lens) = waketimes' ++ "\n" ++ lens'
   cmp x y = lenOf x `compare` lenOf y
   lenOf (HecWake len _ _) = len
 
-instance Show HecWake where
-  show (HecWake len when what) = concat [show len, " (@", show when, ", thread " , show what, ")"]
+instance Pretty HecWake where
+  ppr (HecWake len when what) = cat
+        [ padR 10 $ pprTimestampEng len
+        , text " (@"
+        , padR 10 $ pprTimestampAbs when
+        , text ", thread "
+        , text $ show what
+        , text ")"
+        ]
index 674f081..9df71fd 100644 (file)
@@ -11,8 +11,10 @@ import System.Environment
 import System.IO
 import System.Exit
 
+import DphOps
 import HecUsage
 import HecWake
+import Pretty
 
 main :: IO ()
 main = getArgs >>= command
@@ -26,31 +28,49 @@ command ["show", file] = do
     eventLog <- readLogOrDie file
     putStrLn $ ppEventLog eventLog
 
-command ["usage", file] = do
-    eventLog <- readLogOrDie file
-    let capEvents = sortEvents . events . dat $ eventLog
-    let result = validate hecUsageMachine capEvents
-    putStrLn $ showValidate showHecUsage show result
+command ["usage", file]         = runOnFile file hecUsageMachine pprHecUsage
+command ["wake", file]          = runOnFile file hecWakeMachine pprHecWake
+command ["ops", file]           = runOnFile' file
+        (runMachine dphOpsMachine . getGangEvents)
+        pprDphOpsState
+command ["ops-sum", file]       = runOnFile' file
+        (runMachine dphOpsSumMachine . getGangEvents)
+        pprDphOpsSumState
+
+command ["gang-events", file]   = runOnFile' file getGangEvents pprGangEvents
+
+command _                       = putStr usage >> die "Unrecognized command"
+
+runOnFile :: String -> Machine s CapEvent -> (s -> Doc) -> IO ()
+runOnFile file machine pprState = runOnFile' file (runMachine machine) pprState
+
+runMachine machine = getState . validate machine
+ where
+  getState (Left (s,_)) = s
+  getState (Right s)    = s
 
-command ["wake", file] = do
+runOnFile' :: String -> ([CapEvent] -> s) -> (s -> Doc) -> IO ()
+runOnFile' file process pprState = do
     eventLog <- readLogOrDie file
     let capEvents = sortEvents . events . dat $ eventLog
-    let result = validate hecWakeMachine capEvents
-    putStrLn $ showValidate showHecWake show result
+    let result = process capEvents
+    putStrLn $ renderLong $ pprState result
 
-command _ = putStr usage >> die "Unrecognized command"
 
 usage :: String
 usage = unlines $ map pad strings
  where
     align = 4 + (maximum . map (length . fst) $ strings)
     pad (x, y) = zipWith const (x ++ repeat ' ') (replicate align ()) ++ y
-    strings = [ ("dph-event-seer --help:",                     "Display this help.")
+    strings = [ ("dph-event-seer --help:",              "Display this help.")
 
-              , ("dph-event-seer show <file>:",                "Raw event log data.")
+              , ("dph-event-seer show <file>:",         "Raw event log data.")
 
               , ("dph-event-seer usage <file>:",        "Show amount of time spent with n HECs active, and in GC")
-              , ("dph-event-seer wake <file>:",        "Times between waking a thread on a different HEC and it starting")
+              , ("dph-event-seer wake <file>:",         "Times between waking a thread on a different HEC and it starting")
+              , ("dph-event-seer ops <file>:",          "All DPH operations ordered by duration")
+              , ("dph-event-seer ops-sum <file>:",      "DPH operations total times")
+              , ("dph-event-seer gang-events <file>:",  "Show all gang events, un-split")
               , ("", "")
               , ("", "Compile your program with '-eventlog' then run with '+RTS -l' to produce a .eventlog.")
               , ("", "Then analyse the output with this program.")
diff --git a/dph-event-seer/src/Pretty.hs b/dph-event-seer/src/Pretty.hs
new file mode 100644 (file)
index 0000000..d33d9ff
--- /dev/null
@@ -0,0 +1,175 @@
+{-# LANGUAGE ScopedTypeVariables, TypeSynonymInstances, FlexibleInstances,
+             OverlappingInstances, IncoherentInstances #-}
+
+-- | Pretty printing utils.
+-- Taken from BuildBox 2.1.0.1:
+--      http://hackage.haskell.org/packages/archive/buildbox/2.1.0.1/doc/html/BuildBox-Pretty.html
+module Pretty
+       ( module Text.PrettyPrint
+       , Pretty(..)
+       , padRc, padR
+       , padLc, padL
+       , blank
+       , pprEngDouble
+       , pprEngInteger
+
+        , pprTimestampAbs
+        , pprTimestampEng
+
+        , pprValidate
+        , pprMap
+        , renderLong)
+where
+import Text.PrettyPrint
+import Text.Printf
+import Control.Monad
+
+import GHC.RTS.Events (Timestamp)
+
+import qualified Data.Map as M
+import Data.Maybe (fromMaybe)
+
+-- Things that can be pretty printed
+class Pretty a where
+       ppr :: a -> Doc
+
+-- Basic instances
+instance Pretty Doc where
+       ppr = id
+       
+instance Pretty Float where
+       ppr = text . show
+
+instance Pretty Int where
+       ppr = int
+       
+instance Pretty Integer where
+       ppr = text . show
+
+{-
+instance Pretty UTCTime where
+       ppr = text . show
+        -}
+
+instance Pretty Timestamp where
+       ppr = text . show
+
+       
+instance Pretty a => Pretty [a] where
+       ppr xx 
+               = lbrack <> (hcat $ punctuate (text ", ") (map ppr xx)) <> rbrack
+
+instance Pretty String where
+       ppr = text
+
+
+-- | Right justify a doc, padding with a given character.
+padRc :: Int -> Char -> Doc -> Doc
+padRc n c str
+       = (text $ replicate (n - length (render str)) c) <> str
+       
+
+-- | Right justify a string with spaces.
+padR :: Int -> Doc -> Doc
+padR n str     = padRc n ' ' str
+
+
+-- | Left justify a string, padding with a given character.
+padLc :: Int -> Char -> Doc -> Doc
+padLc n c str
+       = str <> (text $ replicate (n - length (render str)) c)
+
+
+-- | Left justify a string with spaces.
+padL :: Int -> Doc -> Doc
+padL n str     = padLc n ' ' str
+
+-- | Blank text. This is different different from `empty` because it comes out a a newline when used in a `vcat`.
+blank :: Doc
+blank = ppr ""
+
+
+-- | Like `pprEngDouble` but don't display fractional part when the value is < 1000.
+--   Good for units where fractional values might not make sense (like bytes).
+pprEngInteger :: String -> Integer -> Maybe Doc
+pprEngInteger unit k
+    | k < 0     = liftM (text "-" <>) $ pprEngInteger unit (-k)
+    | k > 1000  = pprEngDouble unit (fromRational $ toRational k)
+    | otherwise  = Just $ text $ printf "%5d%s " k unit
+
+
+-- | Pretty print an engineering value, to 4 significant figures.
+--   Valid range is  10^(-24) (y\/yocto) to 10^(+24) (Y\/Yotta).
+--   Out of range values yield Nothing.
+--
+--   examples:
+--
+--   @
+--   liftM render $ pprEngDouble \"J\" 102400    ==>   Just \"1.024MJ\"
+--   liftM render $ pprEngDouble \"s\" 0.0000123 ==>   Just \"12.30us\"
+--   @
+--
+pprEngDouble :: String -> Double -> Maybe Doc
+pprEngDouble unit k
+    | k < 0      = liftM (text "-" <>) $ pprEngDouble unit (-k)
+    | k >= 1e+27 = Nothing
+    | k >= 1e+24 = Just $ (k*1e-24) `with` ("Y" ++ unit)
+    | k >= 1e+21 = Just $ (k*1e-21) `with` ("Z" ++ unit)
+    | k >= 1e+18 = Just $ (k*1e-18) `with` ("E" ++ unit)
+    | k >= 1e+15 = Just $ (k*1e-15) `with` ("P" ++ unit)
+    | k >= 1e+12 = Just $ (k*1e-12) `with` ("T" ++ unit)
+    | k >= 1e+9  = Just $ (k*1e-9)  `with` ("G" ++ unit)
+    | k >= 1e+6  = Just $ (k*1e-6)  `with` ("M" ++ unit)
+    | k >= 1e+3  = Just $ (k*1e-3)  `with` ("k" ++ unit)
+    | k >= 1     = Just $ k         `with` (unit ++ " ")
+    | k >= 1e-3  = Just $ (k*1e+3)  `with` ("m" ++ unit)
+    | k >= 1e-6  = Just $ (k*1e+6)  `with` ("u" ++ unit)
+    | k >= 1e-9  = Just $ (k*1e+9)  `with` ("n" ++ unit)
+    | k >= 1e-12 = Just $ (k*1e+12) `with` ("p" ++ unit)
+    | k >= 1e-15 = Just $ (k*1e+15) `with` ("f" ++ unit)
+    | k >= 1e-18 = Just $ (k*1e+18) `with` ("a" ++ unit)
+    | k >= 1e-21 = Just $ (k*1e+21) `with` ("z" ++ unit)
+    | k >= 1e-24 = Just $ (k*1e+24) `with` ("y" ++ unit)
+    | k >= 1e-27 = Nothing
+    | otherwise  = Just $ text $ printf "%5.0f%s " k unit
+     where with (t :: Double) (u :: String)
+               | t >= 1e3  = text $ printf "%.0f%s" t u
+               | t >= 1e2  = text $ printf "%.1f%s" t u
+               | t >= 1e1  = text $ printf "%.2f%s" t u
+               | otherwise = text $ printf "%.3f%s" t u
+
+-- | print an absolute time, in the format used by threadscope 
+pprTimestampAbs :: Timestamp -> Doc
+pprTimestampAbs v
+ = text (printf "%.9fs" v')
+ where
+  v' = fromIntegral v / 1e+9 :: Double
+
+pprTimestampEng :: Timestamp -> Doc
+pprTimestampEng v
+ = fromMaybe (text "-") (pprEngDouble "s" v')
+ where
+  v' = fromIntegral v / 1e+9
+
+pprValidate :: (s -> Doc) -> (i -> Doc) -> Either (s, i) s -> Doc
+pprValidate pprState pprInput (Left (state, input)) =
+  vcat
+    [ text "Invalid eventlog:"
+    , text "State:"
+    , pprState state 
+    , text "Input:"
+    , pprInput input
+    ]
+pprValidate pprState _ (Right state) =
+  vcat [ text "Valid eventlog: ", pprState state ]
+
+pprMap :: Ord k => (k -> Doc) -> (a -> Doc) -> M.Map k a -> Doc
+pprMap pprKey pprValue m =
+  vcat $ zipWith (<>)
+    (map pprKey . M.keys $ m)
+    (map (pprValue . (M.!) m) . M.keys $ m)
+
+
+
+renderLong :: Doc -> String
+renderLong = renderStyle (style { lineLength = 200 })
index 394fe3a..2977a90 100644 (file)
@@ -119,7 +119,7 @@ extract arr i n
 
 extracts_nss    = extractsFromNestedUPSSegd
 extracts_ass    = extractsFromVectorsUPSSegd
-extracts_avs    = extractsFromVectorsUPVSegd
+extracts_avs    = extractsFromVectorsUPVSegdP
 
 drop n arr
         =  tracePrim (TraceDrop n (Seq.length arr))
index 7ca98a8..a7efb77 100644 (file)
@@ -66,7 +66,7 @@ unbalanced = error $ here "unbalanced: touched"
 -- 
 splitLenD :: Gang -> Int -> Dist Int
 splitLenD gang n 
- = generateD_cheap WhatLength gang len
+ = generateD_cheap WLength gang len
  where
     !p = gangSize gang
     !l = n `quotInt` p
@@ -89,7 +89,7 @@ splitLenD gang n
 --
 splitLenIdxD :: Gang -> Int -> Dist (Int, Int)
 splitLenIdxD gang n 
- = generateD_cheap WhatLengthIdx gang len_idx
+ = generateD_cheap WLengthIdx gang len_idx
  where
     !p = gangSize gang
     !l = n `quotInt` p
@@ -126,7 +126,7 @@ splitAsD
         => Gang -> Dist Int -> Vector a -> Dist (Vector a)
 
 splitAsD gang dlen !arr 
-  = zipWithD WhatSlice (seqGang gang) (Seq.slice "splitAsD" arr) is dlen
+  = zipWithD WSlice (seqGang gang) (Seq.slice "splitAsD" arr) is dlen
   where
     is  = fst $ scanD (What "splitAsD") gang (+) 0 dlen
 {-# INLINE_DIST splitAsD #-}
@@ -145,7 +145,7 @@ splitD g _ arr
 
 splitD_impl :: Unbox a => Gang -> Vector a -> Dist (Vector a)
 splitD_impl g !arr 
-  = generateD_cheap WhatSlice g 
+  = generateD_cheap WSlice g 
         (\i -> Seq.slice "splitD_impl" arr (idx i) (len i))
 
   where n       = Seq.length arr
@@ -204,7 +204,7 @@ joinD_impl gang !darr
 
    in   Seq.new n $ \ma 
          -> zipWithDST_ 
-                (WhatJoinCopy n) 
+                (WJoinCopy n) 
                 gang (copy ma) di darr
 {-# INLINE_DIST joinD_impl #-}
 
@@ -214,7 +214,7 @@ joinDM :: Unbox a => Gang -> Dist (Vector a) -> ST s (MVector s a)
 joinDM gang darr 
  = checkGangD (here "joinDM") gang darr 
  $ do   marr <- Seq.newM n
-        zipWithDST_ (WhatJoinCopy n) gang (copy marr) di darr
+        zipWithDST_ (WJoinCopy n) gang (copy marr) di darr
         return marr
  where
         (!di,!n) = scanD (What "joinDM/count") gang (+) 0 
@@ -248,18 +248,18 @@ joinDM gang darr
 
 "Seq.zip/joinD[1]" forall g xs ys.
   Seq.zip (joinD g balanced xs) ys
-    = joinD g balanced (zipWithD WhatZip g Seq.zip xs (splitD g balanced ys))
+    = joinD g balanced (zipWithD WZip g Seq.zip xs (splitD g balanced ys))
 
 "Seq.zip/joinD[2]" forall g xs ys.
   Seq.zip xs (joinD g balanced ys)
-    = joinD g balanced (zipWithD WhatZip g Seq.zip (splitD g balanced xs) ys)
+    = joinD g balanced (zipWithD WZip g Seq.zip (splitD g balanced xs) ys)
 
 "Seq.zip/splitJoinD" 
   forall what1 what2 gang f g xs ys
   . Seq.zip (splitJoinD gang (imapD what1 gang f) xs) 
             (splitJoinD gang (imapD what2 gang g) ys)
   = splitJoinD gang 
-        (imapD (WhatFusedZipMap what1 what2)
+        (imapD (WFZipMap what1 what2)
                gang (\i zs -> let (as,bs) = Seq.unzip zs
                               in Seq.zip (f i as) (g i bs)))
                     (Seq.zip xs ys)
@@ -291,7 +291,7 @@ bpermuteD :: Unbox a
         -> Dist (Vector a)
 
 bpermuteD gang !as ds 
-        = mapD WhatBpermute gang (Seq.bpermute as) ds
+        = mapD WBpermute gang (Seq.bpermute as) ds
 {-# INLINE_DIST bpermuteD #-}
 
 
index a43c416..8050cbe 100644 (file)
@@ -5,7 +5,7 @@
 
 -- | Standard combinators for distributed types.
 module Data.Array.Parallel.Unlifted.Distributed.Combinators 
-        ( What (..)
+        ( W.What (..)
         , imapD, mapD
         , zipD, unzipD
         , fstD, sndD
@@ -18,7 +18,7 @@ import Data.Array.Parallel.Base ( ST, runST)
 import Data.Array.Parallel.Unlifted.Distributed.Primitive
 import Data.Array.Parallel.Unlifted.Distributed.Data.Tuple
 import Data.Array.Parallel.Unlifted.Distributed.Data.Maybe      ()
-import Data.Array.Parallel.Unlifted.Distributed.What
+import qualified Data.Array.Parallel.Unlifted.Distributed.What as W
 
 
 here s = "Data.Array.Parallel.Unlifted.Distributed.Combinators." ++ s
@@ -44,7 +44,7 @@ here s = "Data.Array.Parallel.Unlifted.Distributed.Combinators." ++ s
 --   @mapD theGang (V.map (+ 1)) :: Dist (Vector Int) -> Dist (Vector Int)@
 --
 mapD    :: (DT a, DT b) 
-        => What         -- ^ What is the worker function doing.
+        => W.What         -- ^ What is the worker function doing.
         -> Gang 
         -> (a -> b) 
         -> Dist a 
@@ -62,7 +62,7 @@ mapD wFn gang
 --   As opposed to `imapD'` this version also deepSeqs each element before
 --   passing it to the function.
 imapD   :: (DT a, DT b) 
-        => What         -- ^ What is the worker function doing.
+        => W.What         -- ^ What is the worker function doing.
         -> Gang 
         -> (Int -> a -> b) 
         -> Dist a -> Dist b
@@ -79,17 +79,17 @@ imapD wFn gang f d
 "imapD/generateD" 
   forall wMap wGen gang f g
   . imapD wMap gang f (generateD wGen gang g) 
-  = generateD (WhatFusedMapGen wMap wGen) gang (\i -> f i (g i))
+  = generateD (W.WFMapGen wMap wGen) gang (\i -> f i (g i))
 
 "imapD/generateD_cheap" 
   forall wMap wGen gang f g
   . imapD wMap gang f (generateD_cheap wGen gang g) 
-  = generateD (WhatFusedMapGen wMap wGen) gang (\i -> f i (g i))
+  = generateD (W.WFMapGen wMap wGen) gang (\i -> f i (g i))
 
 "imapD/imapD" 
   forall wMap1 wMap2 gang f g d
   . imapD wMap1 gang f (imapD wMap2 gang g d) 
-  = imapD (WhatFusedMapMap wMap1 wMap2) gang (\i x -> f i (g i x)) d
+  = imapD (W.WFMapMap wMap1 wMap2) gang (\i x -> f i (g i x)) d
 
   #-}
 
@@ -97,7 +97,7 @@ imapD wFn gang f d
 -- Zipping --------------------------------------------------------------------
 -- | Combine two distributed values with the given function.
 zipWithD :: (DT a, DT b, DT c)
-        => What                 -- ^ What is the worker function doing.
+        => W.What                 -- ^ What is the worker function doing.
         -> Gang 
         -> (a -> b -> c) 
         -> Dist a -> Dist b -> Dist c
@@ -110,7 +110,7 @@ zipWithD what g f dx dy
 -- | Combine two distributed values with the given function.
 --   The worker function also gets the index of the current thread.
 izipWithD :: (DT a, DT b, DT c)
-          => What               -- ^ What is the worker function doing.
+          => W.What               -- ^ What is the worker function doing.
           -> Gang 
           -> (Int -> a -> b -> c) 
           -> Dist a -> Dist b -> Dist c
index 3cd94c3..780b469 100644 (file)
@@ -9,7 +9,7 @@ where
 import Data.Array.Parallel.Unlifted.Distributed.Data.Scalar.Base        ()
 import Data.Array.Parallel.Unlifted.Distributed.Primitive.DPrim
 import Data.Array.Parallel.Unlifted.Distributed.Primitive
-import Data.Array.Parallel.Unlifted.Distributed.What
+import qualified Data.Array.Parallel.Unlifted.Distributed.What  as W
 import qualified Data.Array.Parallel.Unlifted.Sequential.Vector as V
 import qualified Data.Vector.Unboxed.Mutable                    as MV
 import Prelude as P
@@ -38,13 +38,13 @@ instance DT Bool where
 
 -- | OR together all instances of a distributed 'Bool'.
 orD :: Gang -> Dist Bool -> Bool
-orD g   = foldD (What "orD") g (||)
+orD g   = foldD (W.What "orD") g (||)
 {-# INLINE_DIST orD #-}
 
 
 -- | AND together all instances of a distributed 'Bool'.
 andD :: Gang -> Dist Bool -> Bool
-andD g  = foldD (What "andD") g (&&)
+andD g  = foldD (W.What "andD") g (&&)
 {-# INLINE_DIST andD #-}
 
 
index d4dcb53..01bff57 100644 (file)
@@ -12,7 +12,7 @@ import Data.Array.Parallel.Unlifted.Distributed.Data.Scalar.Base
 import Data.Array.Parallel.Unlifted.Distributed.Data.Unit
 import Data.Array.Parallel.Unlifted.Distributed.Combinators
 import Data.Array.Parallel.Unlifted.Distributed.Primitive
-import Data.Array.Parallel.Unlifted.Distributed.What
+import qualified Data.Array.Parallel.Unlifted.Distributed.What  as W
 import Data.Array.Parallel.Pretty
 import qualified Data.Array.Parallel.Unlifted.Sequential.Vector as V
 import Prelude as P
@@ -29,10 +29,10 @@ instance PprPhysical (Dist Int) where
 --   Example:  scalarD theGangN4 10 = [10, 10, 10, 10] 
 scalarD :: DT a => Gang -> a -> Dist a
 scalarD gang x 
-        = mapD WhatScalar gang (const x) (unitD gang)
+        = mapD W.WScalar gang (const x) (unitD gang)
 {-# INLINE_DIST scalarD #-}
 
 -- | Sum all instances of a distributed number.
 sumD :: (Num a, DT a) => Gang -> Dist a -> a
-sumD g  = foldD (What "sumD") g (+)
+sumD g  = foldD (W.What "sumD") g (+)
 {-# INLINE_DIST sumD #-}
index 3625552..fd404c0 100644 (file)
@@ -354,7 +354,7 @@ splitSD g dsegd xs
 "splitSD/Seq.zip" 
   forall g d xs ys
   . splitSD g d (Seq.zip xs ys) 
-  = zipWithD WhatZip g Seq.zip 
+  = zipWithD WZip g Seq.zip 
         (splitSD g d xs)
         (splitSD g d ys)
 
index a08b6d0..a41ad5b 100644 (file)
@@ -26,7 +26,7 @@ module Data.Array.Parallel.Unlifted.Distributed.Primitive.DistST
           -- * Monadic combinators
         , mapDST_, mapDST, zipWithDST_, zipWithDST)
 where
-import Data.Array.Parallel.Unlifted.Distributed.What
+import qualified Data.Array.Parallel.Unlifted.Distributed.What as W
 import Data.Array.Parallel.Unlifted.Distributed.Primitive.DT
 import Data.Array.Parallel.Unlifted.Distributed.Primitive.Gang
 import Data.Array.Parallel.Unlifted.Distributed.Data.Tuple
@@ -89,7 +89,7 @@ writeMyMD mdt x
 
 -- Running --------------------------------------------------------------------
 -- | Run a data-parallel computation, yielding the distributed result.
-runDistST :: DT a => Comp -> Gang -> (forall s. DistST s a) -> Dist a
+runDistST :: DT a => W.Comp -> Gang -> (forall s. DistST s a) -> Dist a
 runDistST comp g p 
  = runST $ distST comp g p
 {-# NOINLINE runDistST #-}
@@ -116,7 +116,7 @@ runDistST_seq g p
 
 -- | Execute a data-parallel computation, yielding the distributed result.
 distST  :: DT a 
-        => Comp -> Gang 
+        => W.Comp -> Gang 
         -> DistST s a -> ST s (Dist a)
 distST comp g p 
  = do   md <- newMD g
@@ -130,7 +130,7 @@ distST comp g p
 
 -- | Execute a data-parallel computation on a 'Gang'.
 --   The same DistST comutation runs on each thread.
-distST_ :: Comp -> Gang -> DistST s () -> ST s ()
+distST_ :: W.Comp -> Gang -> DistST s () -> ST s ()
 distST_ comp gang proc
         = gangST gang 
                 (show comp) 
@@ -138,16 +138,16 @@ distST_ comp gang proc
         $ unDistST proc
 {-# INLINE distST_ #-}
 
-workloadOfComp :: Comp -> Workload
+workloadOfComp :: W.Comp -> Workload
 workloadOfComp cc
  = case cc of
-        CompDist w              -> workloadOfWhat w
+        W.CDist w               -> workloadOfWhat w
         _                       -> WorkUnknown
 
-workloadOfWhat :: What -> Workload
+workloadOfWhat :: W.What -> Workload
 workloadOfWhat ww
  = case ww of
-        WhatJoinCopy elems      -> WorkCopy elems 
+        W.WJoinCopy elems       -> WorkCopy elems 
         _                       -> WorkUnknown
 
 -- Combinators ----------------------------------------------------------------
@@ -158,35 +158,35 @@ workloadOfWhat ww
 -- model andlead to a deadlock. Hence the bangs.
 
 mapDST  :: (DT a, DT b) 
-        => What -> Gang -> (a -> DistST s b) -> Dist a -> ST s (Dist b)
+        => W.What -> Gang -> (a -> DistST s b) -> Dist a -> ST s (Dist b)
 mapDST what g p !d 
  = mapDST' what g (\x -> x `deepSeqD` p x) d
 {-# INLINE mapDST #-}
 
 
-mapDST_ :: DT a => What -> Gang -> (a -> DistST s ()) -> Dist a -> ST s ()
+mapDST_ :: DT a => W.What -> Gang -> (a -> DistST s ()) -> Dist a -> ST s ()
 mapDST_ what g p !d 
  = mapDST_' what g (\x -> x `deepSeqD` p x) d
 {-# INLINE mapDST_ #-}
 
 
-mapDST' :: (DT a, DT b) => What -> Gang -> (a -> DistST s b) -> Dist a -> ST s (Dist b)
+mapDST' :: (DT a, DT b) => W.What -> Gang -> (a -> DistST s b) -> Dist a -> ST s (Dist b)
 mapDST' what g p !d 
- = distST (CompDist what) g (myD d >>= p)
+ = distST (W.CDist what) g (myD d >>= p)
 {-# INLINE mapDST' #-}
 
 
 mapDST_' 
         :: DT a 
-        => What -> Gang -> (a -> DistST s ()) -> Dist a -> ST s ()
+        => W.What -> Gang -> (a -> DistST s ()) -> Dist a -> ST s ()
 mapDST_' what g p !d 
- = distST_ (CompDist what) g (myD d >>= p)
+ = distST_ (W.CDist what) g (myD d >>= p)
 {-# INLINE mapDST_' #-}
 
 
 zipWithDST 
         :: (DT a, DT b, DT c)
-        => What 
+        => W.What 
         -> Gang
         -> (a -> b -> DistST s c) -> Dist a -> Dist b -> ST s (Dist c)
 zipWithDST what g p !dx !dy 
@@ -196,7 +196,7 @@ zipWithDST what g p !dx !dy
 
 zipWithDST_ 
         :: (DT a, DT b)
-        => What -> Gang -> (a -> b -> DistST s ()) -> Dist a -> Dist b -> ST s ()
+        => W.What -> Gang -> (a -> b -> DistST s ()) -> Dist a -> Dist b -> ST s ()
 zipWithDST_ what g p !dx !dy 
  = mapDST_ what g (uncurry p) (zipD dx dy)
 {-# INLINE zipWithDST_ #-}
index 4c0c860..32ccc85 100644 (file)
@@ -239,7 +239,7 @@ parIO what n mvs p
         mapM_ waitReq reqs
         end     <- getGangTime
 
-        traceGang $ "Complete par   " ++ what ++ " in " ++ diffTime start end ++ "us."
+        traceGangSplit $ "Complete par   " ++ what ++ " in " ++ diffTime start end ++ "us."
 
 
 -- | Same as 'gangIO' but in the 'ST' monad.
@@ -261,11 +261,23 @@ getGangTime
 diffTime :: Integer -> Integer -> String
 diffTime x y = show (y-x)
 
--- | Emit a GHC event for debugging.
+-- | Emit a GHC event for debugging, but don't mind if it gets truncated
 traceGang :: String -> IO ()
 traceGang s
  = do   traceEventIO $ "GANG " ++ s
 
+-- | Emit a GHC event for debugging. Split across multiple events if necessary.
+traceGangSplit :: String -> IO ()
+traceGangSplit s
+ = do   let xs = chunks 500 s
+        let max= show $ length xs
+        mapM_ (\(x,i) -> traceEventIO $ "GANG[" ++ show i ++ "/" ++ max ++ "] " ++ x) (xs `zip` [1..])
+ where
+        chunks len [] = []
+        chunks len str
+         = let (f,r) = splitAt len str
+           in  f : chunks len r
+
 #else
 getGangTime :: IO ()
 getGangTime = return ()
@@ -276,4 +288,7 @@ diffTime _ _ = ""
 -- | Emit a GHC event for debugging.
 traceGang :: String -> IO ()
 traceGang _ = return ()
+
+traceGangSplit :: String -> IO ()
+traceGangSplit _ = return ()
 #endif
index 7b527b3..d64d772 100644 (file)
@@ -20,7 +20,7 @@ import Data.Array.Parallel.Base ( ST, runST)
 import Data.Array.Parallel.Unlifted.Distributed.Primitive.DistST
 import Data.Array.Parallel.Unlifted.Distributed.Primitive.DT
 import Data.Array.Parallel.Unlifted.Distributed.Primitive.Gang
-import Data.Array.Parallel.Unlifted.Distributed.What
+import qualified Data.Array.Parallel.Unlifted.Distributed.What as W
 import Debug.Trace
 
 here s = "Data.Array.Parallel.Unlifted.Distributed.Combinators." ++ s
@@ -30,13 +30,13 @@ here s = "Data.Array.Parallel.Unlifted.Distributed.Combinators." ++ s
 --   for each thread.
 generateD 
         :: DT a 
-        => What         -- ^ What is the worker function doing.
+        => W.What         -- ^ What is the worker function doing.
         -> Gang 
         -> (Int -> a) 
         -> Dist a
 
 generateD what gang f 
- = runDistST (CompGen False what) 
+ = runDistST (W.CGen False what) 
         gang 
         (myIndex >>= return . f)
 {-# NOINLINE generateD #-}
@@ -51,13 +51,13 @@ generateD what gang f
 --   
 generateD_cheap 
         :: DT a 
-        => What          -- ^ What is the worker function doing.
+        => W.What          -- ^ What is the worker function doing.
         -> Gang 
         -> (Int -> a) 
         -> Dist a
 
 generateD_cheap what g f 
-        = traceEvent (show $ CompGen True what) 
+        = traceEvent (show $ W.CGen True what) 
         $ runDistST_seq g (myIndex >>= return . f)
 {-# NOINLINE generateD_cheap #-}
 
@@ -66,9 +66,9 @@ generateD_cheap what g f
 -- | Map a function across all elements of a distributed value.
 --   The worker function also gets the current thread index.
 imapD'  :: (DT a, DT b) 
-        => What -> Gang -> (Int -> a -> b) -> Dist a -> Dist b
+        => W.What -> Gang -> (Int -> a -> b) -> Dist a -> Dist b
 imapD' what gang f !d 
-  = runDistST (CompMap what) gang 
+  = runDistST (W.CMap what) gang 
   $ do  i               <- myIndex
         x               <- myD d
         let result      = f i x
@@ -79,9 +79,9 @@ imapD' what gang f !d
 
 -- Folding --------------------------------------------------------------------
 -- | Fold all the instances of a distributed value.
-foldD :: DT a => What -> Gang -> (a -> a -> a) -> Dist a -> a
+foldD :: DT a => W.What -> Gang -> (a -> a -> a) -> Dist a -> a
 foldD what gang f !d 
-  = traceEvent (show (CompFold what))
+  = traceEvent (show (W.CFold what))
   $ checkGangD ("here foldD") gang d 
   $ fold 1 (indexD (here "foldD") d 0)
   where
@@ -95,9 +95,9 @@ foldD what gang f !d
 
 -- Scanning -------------------------------------------------------------------
 -- | Prefix sum of the instances of a distributed value.
-scanD :: forall a. DT a => What -> Gang -> (a -> a -> a) -> a -> Dist a -> (Dist a, a)
+scanD :: forall a. DT a => W.What -> Gang -> (a -> a -> a) -> a -> Dist a -> (Dist a, a)
 scanD what gang f z !d
-  = traceEvent (show (CompScan what))
+  = traceEvent (show (W.CScan what))
   $ checkGangD (here "scanD") gang d 
   $ runST (do
         md <- newMD gang
index 18ae9c7..013e57d 100644 (file)
@@ -8,29 +8,29 @@ where
 
 -- | What distributed computation we are doing.
 data Comp
-        = CompGen       { compCheap     :: Bool
-                        , compWhat      :: What}
+        = CGen          Bool            -- ^ cheap
+                        What
 
-        | CompMap       { compWhat      :: What }
-        | CompFold      { compWhat      :: What }
-        | CompScan      { compWhat      :: What }
-        | CompDist      What
-        deriving Show
+        | CMap          What
+        | CFold         What
+        | CScan         What
+        | CDist         What
+        deriving (Eq,Ord,Read,Show)
 
 -- | What sort of thing is being computed.
 data What
-        = What            String
-        | WhatScalar 
-        | WhatZip
-        | WhatSlice
-        | WhatLength
-        | WhatLengthIdx
-        | WhatBpermute
+        = What          String
+        | WScalar 
+        | WZip
+        | WSlice
+        | WLength
+        | WLengthIdx
+        | WBpermute
 
         -- Copy due to a join instruction.
-        | WhatJoinCopy  { whatElems     :: Int }
+        | WJoinCopy     Int             -- ^ number elements
 
-        | WhatFusedMapMap What What
-        | WhatFusedMapGen What What
-        | WhatFusedZipMap What What
-        deriving Show
+        | WFMapMap      What What
+        | WFMapGen      What What
+        | WFZipMap      What What
+        deriving (Eq,Ord,Read,Show)
index 7dbf78d..f40a6b7 100644 (file)
@@ -25,6 +25,9 @@ import Data.Array.Parallel.Unlifted.Sequential.Vector                   as Seq
 import qualified Data.Array.Parallel.Unlifted.Parallel.UPSSegd          as UPSSegd
 import qualified Data.Array.Parallel.Unlifted.Parallel.UPVSegd          as UPVSegd
 import qualified Data.Array.Parallel.Unlifted.Sequential.UVSegd         as UVSegd
+import qualified Data.Array.Parallel.Unlifted.Sequential.USegd          as USegd
+import qualified Data.Array.Parallel.Unlifted.Distributed.Data.USegd    as USegd
+import qualified Data.Array.Parallel.Unlifted.Sequential.USSegd         as USSegd
 import qualified Data.Array.Parallel.Unlifted.Vectors                   as US
 import qualified Data.Array.Parallel.Unlifted.Stream                    as US
 import qualified Data.Array.Parallel.Unlifted.Sequential                as Seq
@@ -118,22 +121,49 @@ extractsFromVectorsUPVSegdP
         -> Vector a
 
 extractsFromVectorsUPVSegdP upvsegd vectors
- =      splitJoinD theGang 
               (mapD   (what upvsegd)
-                        theGang
-                        (extractsFromVectorsUPSSegdSegmap 
-                                (UPVSegd.takeUPSSegdRedundant upvsegd)
-                                vectors))
-                (UPVSegd.takeVSegidsRedundant upvsegd)
-
+ = joinD theGang balanced
$ mapD (what upvsegd)
+        theGang
+        (extractsFromVectorsUPSSegd_split
+                ussegd
+                vsegids
+                vectors)
+        segs
  where  what upvsegd
          = let  lens    = UPVSegd.takeLengths upvsegd
            in   (What $ "dph-prim-par: extractsFromVectorsUPVSegdP." 
                       P.++ show (UPVSegd.takeLengths upvsegd))
         {-# NOINLINE what #-}
 
+        segs    = USegd.splitSegdOnElemsD theGang
+                $ USegd.fromLengths
+                $ UPVSegd.takeLengths upvsegd
+        {-# INLINE segs #-}
+
+        vsegids = UPVSegd.takeVSegids upvsegd
+        ussegd  = UPSSegd.takeUSSegd 
+                $ UPVSegd.takeUPSSegdRedundant upvsegd
+        --        $ UPVSegd.unsafeDemoteToUPSSegd upvsegd
+        -- TODO fixme
+        --      $ UPVSegd.takeUPSSegdRedundant upvsegd
+
 {-# INLINE_UP extractsFromVectorsUPVSegdP #-}
 
+-- | Sequential extracts from USSegd and Segmap
+extractsFromVectorsUPSSegd_split
+        :: (Unbox a, US.Unboxes a)
+        => USSegd.USSegd
+        -> Vector Int
+        -> Vectors a
+        -> ((USegd.USegd,Int),Int)
+        -> Vector a
+
+extractsFromVectorsUPSSegd_split ussegd vsegids vectors which
+        = Seq.unstream 
+        $ US.streamSegsFromVectorsUSSegd_split vectors
+                ussegd vsegids which
+{-# INLINE_UP extractsFromVectorsUPSSegd_split #-}
+
 
 -- | Sequential extracts from UPVSegd.
 extractsFromVectorsUPVSegd
index 8496630..754b56e 100644 (file)
@@ -4,12 +4,14 @@ module Data.Array.Parallel.Unlifted.Stream.Segments
         ( streamSegsFromNestedUSSegd
         , streamSegsFromVectorsUSSegd
         , streamSegsFromVectorsUVSegd
-        , streamSegsFromVectorsUSSegdSegmap)
+        , streamSegsFromVectorsUSSegdSegmap
+        , streamSegsFromVectorsUSSegd_split)
 where
 import Data.Vector.Fusion.Stream.Size
 import Data.Vector.Fusion.Stream.Monadic
 import Data.Array.Parallel.Unlifted.Sequential.Vector           (Unbox,   Vector, index)
 import Data.Array.Parallel.Unlifted.Vectors                     (Unboxes, Vectors)
+import Data.Array.Parallel.Unlifted.Sequential.USegd            (USegd(..))
 import Data.Array.Parallel.Unlifted.Sequential.USSegd           (USSegd(..))
 import Data.Array.Parallel.Unlifted.Sequential.UVSegd           (UVSegd(..))
 import qualified Data.Array.Parallel.Unlifted.Vectors           as US
@@ -235,3 +237,72 @@ streamSegsFromVectorsUSSegdSegmap
 {-# INLINE_STREAM streamSegsFromVectorsUSSegdSegmap #-}
 
 
+
+
+streamSegsFromVectorsUSSegd_split
+        :: (Unboxes a, Monad m)
+        => Vectors a            -- ^ Vectors holding source data.
+        -> USSegd               -- ^ Scattered segment descriptor
+        -> Vector Int           -- ^ Virtual segment ids
+        -> ((USegd,Int),Int)    -- ^ Segmap
+        -> Stream m a
+
+streamSegsFromVectorsUSSegd_split
+        vectors (USSegd _ segStarts segSources usegd)
+        vsegids ((segd,seg_off),el_off)
+ = segStarts `seq` segSources `seq` usegd `seq` segd `seq` seg_off `seq` el_off `seq`
+   let  here            = "streamSegsFromVectorsUSSegd_split"
+
+        -- Total number of elements to be streamed
+        !lengths        = USegd.takeLengths segd
+        !elemsTotal     = U.sum lengths
+
+
+
+        -- Total number of segments.
+        !segsTotal      = U.length lengths
+        
+        -- seg, ix of that seg in usegd, length of seg, elem in seg
+        {-# INLINE_INNER fnSeg #-}
+        fnSeg (ixSeg, baSeg, ixEnd, ixElem)
+         = ixSeg `seq` baSeg `seq`
+           if ixElem >= ixEnd                   -- Was that the last elem in the current seg?
+            then if ixSeg + 1 >= segsTotal      -- Was that last seg?
+
+                       -- That was the last seg, we're done.
+                  then return $ Done
+                  
+                       -- Move to the next seg.
+                  else let ixSeg'       = ixSeg + 1
+                           ixPSeg       = index here vsegids (ixSeg' + seg_off)
+                           sourceSeg    = index here segSources ixPSeg
+                           startSeg     = index here segStarts  ixPSeg
+                           lenSeg       = index here lengths ixSeg'
+                           el_off'      = if ixSeg' == 0 then el_off else 0
+                           (arr, startArr, _) 
+                                        = US.unsafeIndexUnpack vectors sourceSeg
+                       in  return $ Skip
+                                  ( ixSeg'
+                                  , arr
+                                  , startArr + startSeg + lenSeg
+                                  , startArr + startSeg + el_off')
+
+                 -- Stream the next element from the segment.
+            else let !result  = P.indexByteArray baSeg ixElem
+                 in  return   $ Yield result (ixSeg, baSeg, ixEnd, ixElem + 1)
+                                 
+        -- Starting state of the stream.
+        !dummy  = unsafePerformIO 
+                $ P.newByteArray 0 >>= P.unsafeFreezeByteArray
+
+        !initState
+         =      ( -1    -- force fnSeg loop to load first seg
+                , dummy -- dummy array data to start with
+                , 0     -- force fnSeg loop to load first seg
+                , 0)           
+
+        -- It's important that we set the result stream size, so Data.Vector
+        -- doesn't need to add code to grow the result when it overflows.
+   in   Stream fnSeg initState (Exact elemsTotal)
+{-# INLINE_STREAM streamSegsFromVectorsUSSegd_split #-}
+
index f131bb5..5a5e83a 100644 (file)
@@ -9,6 +9,8 @@ import qualified Data.Vector                             as V
 import qualified Data.Array.Parallel.PArray.PData        as PD
 import qualified Data.Array.Parallel.PArray.PData.Nested as PDN
 
+import qualified Data.Array.Parallel.Unlifted.Parallel.Extracts as Ex
+
 import Debug.Trace
 
 $(testcases [ ""        <@ [t| ( Int, Float, Double ) |]
@@ -39,5 +41,15 @@ $(testcases [ ""        <@ [t| ( Int, Float, Double ) |]
             interleave (x : xs) (y : ys) = x : y : interleave xs ys
             interleave (x : xs) _        = [x]
             interleave _        _        = []
+
+    prop_extracts :: (Eq a, Elt a, Elts a, Arbitrary a, Show a) => a -> Property
+    prop_extracts phantom =
+      forAll (sized (\n -> return n)) $ \len ->
+      forAll (vsegdOfLength len) $ \segd ->
+      forAll (arraysForVSegd segd phantom) $ \arr ->
+      let xPar   = toList $ Ex.extractsFromVectorsUPVSegdP segd arr
+          xSeq   = toList $ Ex.extractsFromVectorsUPVSegd  segd arr
+      in 
+          xPar == xSeq
   |])