Ticket #26: ghc-events-unicode.dpatch

1 patch for repository http://code.haskell.org/ghc-events/:

Mon Oct 29 20:00:10 GMT 2012  Duncan Coutts <duncan@well-typed.com>
  * First go at correct unicode handling of strings in eventlogs
  Needs more testing. Should perhaps just switch from String to either
  ByteString or Text, on a case-by-case basis.

New patches:

[First go at correct unicode handling of strings in eventlogs
Duncan Coutts <duncan@well-typed.com>**20121029200010
 Ignore-this: 8980289664f2773476d913bc0f3fc618
 Needs more testing. Should perhaps just switch from String to either
 ByteString or Text, on a case-by-case basis.
] hunk ./GHC/RTS/EventParserUtils.hs 12
 
         getE,
         getH,
-        getString,
+
+        getAsciiString,
+        getUnicodeString,
+        putAsciiString,
+        putBytes,
+        encodeUTF8,
+        decodeUTF8,
+
         mkEventTypeParsers,
         simpleEvent,
         skip,
hunk ./GHC/RTS/EventParserUtils.hs 34
 import qualified Data.Binary.Get as G
 import Data.Binary.Put
 import Data.Char
+import Data.Bits
 import Data.Function
 import Data.IntMap (IntMap)
 import qualified Data.IntMap as M
hunk ./GHC/RTS/EventParserUtils.hs 58
 getE :: Binary a => GetEvents a
 getE = lift $ lift get
 
-nBytes :: Integral a => a -> GetEvents [Word8]
-nBytes n = replicateM (fromIntegral n) getE
+getNBytes :: Integral a => a -> GetEvents [Word8]
+getNBytes n = replicateM (fromIntegral n) getE
 
hunk ./GHC/RTS/EventParserUtils.hs 61
-getString :: Integral a => a -> GetEvents String
-getString len = do
-    bytes <- nBytes len
+getAsciiString :: Integral a => a -> GetEvents String
+getAsciiString len = do
+    bytes <- getNBytes len
     return $ map (chr . fromIntegral) bytes
 
hunk ./GHC/RTS/EventParserUtils.hs 66
+getUnicodeString :: Integral a => a -> GetEvents String
+getUnicodeString len = do
+    bytes <- getNBytes len
+    return (decodeUTF8 bytes)
+
+putAsciiString :: String -> Put
+putAsciiString str =
+    mapM_ (put . c2w) str
+  where
+    c2w :: Char -> Word8
+    c2w = fromIntegral . ord
+
+putBytes :: [Word8] -> Put
+putBytes = mapM_ put
+
 skip :: Integral a => a -> GetEvents ()
 skip n = lift $ lift $ G.skip (fromIntegral n)
 
hunk ./GHC/RTS/EventParserUtils.hs 222
              Nothing -> getE :: GetEvents Word16
   skip bytes
   return UnknownEvent{ ref = fromIntegral num }
+
+
+-- UTF handling:
+-- Copyright (c) Eric Mertens 2007
+
+encodeUTF8 :: String -> [Word8]
+encodeUTF8 = concatMap (map fromIntegral . go . ord)
+ where
+  go oc
+   | oc <= 0x7f       = [oc]
+
+   | oc <= 0x7ff      = [ 0xc0 + (oc `shiftR` 6)
+                        , 0x80 + oc .&. 0x3f
+                        ]
+
+   | oc <= 0xffff     = [ 0xe0 + (oc `shiftR` 12)
+                        , 0x80 + ((oc `shiftR` 6) .&. 0x3f)
+                        , 0x80 + oc .&. 0x3f
+                        ]
+   | otherwise        = [ 0xf0 + (oc `shiftR` 18)
+                        , 0x80 + ((oc `shiftR` 12) .&. 0x3f)
+                        , 0x80 + ((oc `shiftR` 6) .&. 0x3f)
+                        , 0x80 + oc .&. 0x3f
+                        ]
+
+decodeUTF8 :: [Word8] -> String
+decodeUTF8 [] = ""
+decodeUTF8 (c:cs)
+  | c < 0x80  = chr (fromEnum c) : decodeUTF8 cs
+  | c < 0xc0  = replacement_character : decodeUTF8 cs
+  | c < 0xe0  = multi1
+  | c < 0xf0  = multi_byte 2 0xf  0x800
+  | c < 0xf8  = multi_byte 3 0x7  0x10000
+  | c < 0xfc  = multi_byte 4 0x3  0x200000
+  | c < 0xfe  = multi_byte 5 0x1  0x4000000
+  | otherwise = replacement_character : decodeUTF8 cs
+  where
+    multi1 = case cs of
+      c1 : ds | c1 .&. 0xc0 == 0x80 ->
+        let d = ((fromEnum c .&. 0x1f) `shiftL` 6) .|.  fromEnum (c1 .&. 0x3f)
+        in if d >= 0x000080 then toEnum d : decodeUTF8 ds
+                            else replacement_character : decodeUTF8 ds
+      _ -> replacement_character : decodeUTF8 cs
+
+    multi_byte :: Int -> Word8 -> Int -> [Char]
+    multi_byte i mask overlong = aux i cs (fromEnum (c .&. mask))
+      where
+        aux 0 rs acc
+          | overlong <= acc && acc <= 0x10ffff &&
+            (acc < 0xd800 || 0xdfff < acc)     &&
+            (acc < 0xfffe || 0xffff < acc)      = chr acc : decodeUTF8 rs
+          | otherwise = replacement_character : decodeUTF8 rs
+
+        aux n (r:rs) acc
+          | r .&. 0xc0 == 0x80 = aux (n-1) rs
+                               $ shiftL acc 6 .|. fromEnum (r .&. 0x3f)
+
+        aux _ rs     _ = replacement_character : decodeUTF8 rs
+
+    replacement_character = '\xfffd'
hunk ./GHC/RTS/Events.hs 271
   )),
 
  (VariableSizeParser EVENT_LOG_MSG (do -- (msg)
-      num <- getE :: GetEvents Word16
-      string <- getString num
+      size   <- getE :: GetEvents Word16
+      string <- getUnicodeString size
       return Message{ msg = string }
    )),
  (VariableSizeParser EVENT_USER_MSG (do -- (msg)
hunk ./GHC/RTS/Events.hs 276
-      num <- getE :: GetEvents Word16
-      string <- getString num
+      size   <- getE :: GetEvents Word16
+      string <- getUnicodeString size
       return UserMessage{ msg = string }
    )),
     (VariableSizeParser EVENT_USER_MARKER (do -- (markername)
hunk ./GHC/RTS/Events.hs 281
-      num <- getE :: GetEvents Word16
-      string <- getString num
+      size   <- getE :: GetEvents Word16
+      string <- getUnicodeString size
       return UserMarker{ markername = string }
    )),
  (VariableSizeParser EVENT_PROGRAM_ARGS (do -- (capset, [arg])
hunk ./GHC/RTS/Events.hs 286
-      num <- getE :: GetEvents Word16
-      cs <- getE
-      string <- getString (num - sz_capset)
+      size <- getE :: GetEvents Word16
+      cs   <- getE
+      string <- getAsciiString (size - sz_capset)
       return ProgramArgs{ capset = cs
                         , args = splitNull string }
    )),
hunk ./GHC/RTS/Events.hs 293
  (VariableSizeParser EVENT_PROGRAM_ENV (do -- (capset, [arg])
-      num <- getE :: GetEvents Word16
-      cs <- getE
-      string <- getString (num - sz_capset)
+      size <- getE :: GetEvents Word16
+      cs   <- getE
+      string <- getAsciiString (size - sz_capset)
       return ProgramEnv{ capset = cs
                        , env = splitNull string }
    )),
hunk ./GHC/RTS/Events.hs 300
  (VariableSizeParser EVENT_RTS_IDENTIFIER (do -- (capset, str)
-      num <- getE :: GetEvents Word16
-      cs <- getE
-      string <- getString (num - sz_capset)
+      size <- getE :: GetEvents Word16
+      cs   <- getE
+      string <- getAsciiString (size - sz_capset)
       return RtsIdentifier{ capset = cs
                           , rtsident = string }
    )),
hunk ./GHC/RTS/Events.hs 308
 
  (VariableSizeParser EVENT_INTERN_STRING (do -- (str, id)
-      num <- getE :: GetEvents Word16
-      string <- getString (num - sz_string_id)
+      size   <- getE :: GetEvents Word16
+      string <- getAsciiString (size - sz_string_id)
       sId <- getE :: GetEvents StringId
       return (InternString string sId)
     )),
hunk ./GHC/RTS/Events.hs 315
 
  (VariableSizeParser EVENT_THREAD_LABEL (do -- (thread, str)
-      num <- getE :: GetEvents Word16
-      tid <- getE
-      str <- getString (num - sz_tid)
+      size <- getE :: GetEvents Word16
+      tid  <- getE
+      str  <- getAsciiString (size - sz_tid)
       return ThreadLabel{ thread      = tid
                         , threadlabel = str }
     ))
hunk ./GHC/RTS/Events.hs 576
 
 perfParsers = [
  (VariableSizeParser EVENT_PERF_NAME (do -- (perf_num, name)
-      num     <- getE :: GetEvents Word16
+      size    <- getE :: GetEvents Word16
       perfNum <- getE
hunk ./GHC/RTS/Events.hs 578
-      name    <- getString (num - sz_perf_num)
+      name    <- getAsciiString (size - sz_perf_num)
       return PerfName{perfNum, name}
    )),
 
hunk ./GHC/RTS/Events.hs 940
 putMarker :: Word32 -> PutEvents ()
 putMarker = putE
 
-putEStr :: String -> PutEvents ()
-putEStr = mapM_ putE
-
 putEventLog :: EventLog -> PutEvents ()
 putEventLog (EventLog hdr es) = do
     putHeader hdr
hunk ./GHC/RTS/Events.hs 1144
     putE t
     putCap c
 
-putEventSpec (ThreadLabel t l) = do
-    putE (fromIntegral (length l) + sz_tid :: Word16)
-    putE t
-    putEStr l
+putEventSpec (ThreadLabel tid label) = do
+    putE size
+    putE tid
+    putBytes bytes
+  where
+    size :: Word16
+    size  = fromIntegral (length bytes) + sz_tid
+    bytes = encodeUTF8 label
 
 putEventSpec Shutdown = do
     return ()
hunk ./GHC/RTS/Events.hs 1257
 putEventSpec (RtsIdentifier cs rts) = do
     putE (fromIntegral (length rts) + sz_capset :: Word16)
     putE cs
-    putEStr rts
+    putAsciiString rts
 
 putEventSpec (ProgramArgs cs as) = do
     let as' = unsep as
hunk ./GHC/RTS/Events.hs 1263
     putE (fromIntegral (length as') + sz_capset :: Word16)
     putE cs
-    mapM_ putE as'
+    putAsciiString as'
 
 putEventSpec (ProgramEnv cs es) = do
     let es' = unsep es
hunk ./GHC/RTS/Events.hs 1269
     putE (fromIntegral (length es') + sz_capset :: Word16)
     putE cs
-    mapM_ putE es'
+    putAsciiString es'
 
 putEventSpec (OsProcessPid cs pid) = do
     putE cs
hunk ./GHC/RTS/Events.hs 1284
     putE sec
     putE nsec
 
-putEventSpec (Message s) = do
-    putE (fromIntegral (length s) :: Word16)
-    mapM_ putE s
+putEventSpec (Message str) = do
+    putE size
+    putBytes bytes
+  where
+    size  :: Word16
+    size   = fromIntegral (length bytes)
+    bytes  = encodeUTF8 str
 
hunk ./GHC/RTS/Events.hs 1292
-putEventSpec (UserMessage s) = do
-    putE (fromIntegral (length s) :: Word16)
-    mapM_ putE s
+putEventSpec (UserMessage str) = do
+    putE size
+    putBytes bytes
+  where
+    size  :: Word16
+    size   = fromIntegral (length bytes)
+    bytes  = encodeUTF8 str
 
hunk ./GHC/RTS/Events.hs 1300
-putEventSpec (UserMarker s) = do
-    putE (fromIntegral (length s) :: Word16)
-    mapM_ putE s
+putEventSpec (UserMarker str) = do
+    putE size
+    putBytes bytes
+  where
+    size  :: Word16
+    size   = fromIntegral (length bytes)
+    bytes  = encodeUTF8 str
 
 putEventSpec (UnknownEvent {}) = error "putEventSpec UnknownEvent"
 
hunk ./GHC/RTS/Events.hs 1311
 putEventSpec (InternString str id) = do
-    putE len
-    mapM_ putE str
+    putE size
+    putAsciiString str
     putE id
hunk ./GHC/RTS/Events.hs 1314
-  where len = (fromIntegral (length str) :: Word16) + sz_string_id
+  where
+    size :: Word16
+    size = fromIntegral (length str) + sz_string_id
 
 putEventSpec (MerStartParConjunction dyn_id static_id) = do
     putE dyn_id
hunk ./GHC/RTS/Events.hs 1358
 putEventSpec PerfName{..} = do
     putE (fromIntegral (length name) + sz_perf_num :: Word16)
     putE perfNum
-    mapM_ putE name
+    putAsciiString name
 
 putEventSpec PerfCounter{..} = do
     putE perfNum

Context:

[Add support for the new EVENT_USER_MARKER
Duncan Coutts <duncan@well-typed.com>**20121015205209
 Ignore-this: 52d05bf9497ef50b746cd2617f6138a1
] 
[Relax dependency on mtl
Mikolaj Konarski <mikolaj@well-typed.com>**20120808002136
 Ignore-this: 469f655b2c5f8f3db59754840d908b2d
] 
[Fix merging for the case of no caps or capsets or threads
Mikolaj Konarski <mikolaj@well-typed.com>**20121018114837
 Ignore-this: eea70b9c6f1deb6055d515e729e3f522
 
 Up to now it worked correctly only if the eventlog with no caps or capsets
 or threads was given second on the commandline.
] 
[Bump mtl upper bound for GHC 7.6
bgamari.foss@gmail.com**20120925215415
 Ignore-this: 4a51845e2eff3a2c2c159f0e29c762df
] 
[Update authors and copyright dates
Mikolaj Konarski <mikolaj@well-typed.com>**20121012125627
 Ignore-this: 9d4a60ac4bc1cc2a0483fc6b30259dd
] 
[Fix writing GC stat events to a file
Mikolaj Konarski <mikolaj@well-typed.com>**20121012071034
 Ignore-this: 4f8e27c07d87d758e6c058ee0cb5c0eb
] 
[Relax dependencies
Mikolaj Konarski <mikolaj@well-typed.com>**20121008215952
 Ignore-this: f992ced3edf32376cfc54b0c05910981
] 
[Bump version to 0.4.2.0
Mikolaj Konarski <mikolaj@well-typed.com>**20121008091007
 Ignore-this: 35b6a7049454a18b9ce2d559593c8723
] 
[Make the tests compile (and pass) again
Mikolaj Konarski <mikolaj@well-typed.com>**20121008090808
 Ignore-this: c2cdfc3cdbbe6e4720d5d9437d0c332
] 
[Fill in missing events in merge alpha-conversion
Mikolaj Konarski <mikolaj@well-typed.com>**20121008080900
 Ignore-this: 1018e11290f2c11198ae53f4d6a40abd
] 
[Handle merges of merged eventlogs
Mikolaj Konarski <mikolaj@well-typed.com>**20121005215657
 Ignore-this: 552a5f88c7e81dd73394e65f44d7d909
] 
[add "many merges" and "merge by wall clock" TODO items from edsko and dcoutts
Mikolaj Konarski <mikolaj@well-typed.com>**20121003203843
 Ignore-this: e834a3dfabf0f1409c3a489748a0e150
] 
[Print task ids in hex; the same as in GHC debug prints
Mikolaj Konarski <mikolaj@well-typed.com>**20120725223106
 Ignore-this: b98357838e9dcda79d61bf7e6eb8cd4
] 
[Merge eventlogs with different but consistent headers
Mikolaj Konarski <mikolaj@well-typed.com>**20120709175733
 Ignore-this: b0cdbb1ec50aaa03bfb3bdac9f83051e
 
 This is needed for merging perf eventlogs with main eventlogs
 for Haskell programs.
] 
[Expose perf event constants to sync with haskell-linux-perf
Mikolaj Konarski <mikolaj@well-typed.com>**20120709143753
 Ignore-this: 9d0524be8b6a569fa3bcffca12bbcfd4
] 
[Rename the types of task Id and kernel thread Id to match GHC
Duncan Coutts <duncan@well-typed.com>**20120703115736
 Ignore-this: 79b9be8edea12c6f40ee5b5b7b0cf3a8
 
 Additionally, strengthen the simpler task events verification machine a bit.
] 
[Modify the PerfCounter event
Mikolaj Konarski <mikolaj@well-typed.com>**20120630215420
 Ignore-this: 1e38aa3f3fdcbd0289e8438ebb52852f
 
 It now records the number of samples since last PerfCounter events,
 instead of the running sum of samples and it includes the OS thread ID
 so that we can assign it to cap (HEC).
] 
[Change "elem . keys" to "member" for conciseness and speed
Mikolaj Konarski <mikolaj@well-typed.com>**20120627100102
 Ignore-this: cf77dca54a3bc622e2bf130177f4d74e
] 
[Add machines to verify tasks and track their caps and OS threads
Mikolaj Konarski <mikolaj@well-typed.com>**20120627094218
 Ignore-this: 5863e4c56b22e974a6af1b6368132aaa
] 
[Distinguish Haskell thread ids and OS thread ids via a newtype
Mikolaj Konarski <mikolaj@well-typed.com>**20120625034423
 Ignore-this: 9d0a369db7dca5e11c9967d34e48511a
] 
[Add the 3 Task events, as emitted by GHC
Mikolaj Konarski <mikolaj@well-typed.com>**20120613004929
 Ignore-this: 57cd2769f9b14a83debe0f1ea8454ef4
] 
[Bump version to 0.4.1.0
Mikolaj Konarski <mikolaj@well-typed.com>**20120625034335
 Ignore-this: 7352ebd67cff335779c4b642046674b2
] 
[Add perf events
Mikolaj Konarski <mikolaj@well-typed.com>**20120625034321
 Ignore-this: c96d4993c28a3675cdeb5910caf1b229
] 
[Relax dependencies to compile with current GHC HEAD
Mikolaj <mikolaj.konarski@gmail.com>**20120330160649
 Ignore-this: be79c105a0676961721b2d5a8562751e
] 
[Add support for EVENT_GC_GLOBAL_SYNC
Mikolaj <mikolaj.konarski@gmail.com>**20120330160646
 Ignore-this: 1b68f74909ea30f5e9fdb9b7322c3df
] 
[Add support for 2 more GHC commits about new GC and heap events
Mikolaj <mikolaj.konarski@gmail.com>**20120330160643
 Ignore-this: ac437c6b2997341808cabc00d6b2a460
 
 The new commits are the following.
 Change the presentation of parallel GC work balance in +RTS -s
 Emit final heap alloc events and rearrange code to calculate alloc totals
] 
[Basic support for the new events from 2 pending GHC commits
Mikolaj Konarski <mikolaj@well-typed.com>**20120209130731
 Ignore-this: 3a46c6cc1945bc20f9c37f18b8499599
 
 The pending commits are:
 Add eventlog/trace stuff for capabilities: create/delete/enable/disable
 Add new eventlog events for various heap and GC statistics
] 
[Merge EventLogFormat.h changes from 2 pending GHC events commits
Mikolaj Konarski <mikolaj@well-typed.com>**20120208104744
 Ignore-this: 2e5512f7e18aa73cb8ca50b55db95190
 
 The pending commits are:
 Add eventlog/trace stuff for capabilities: create/delete/enable/disable
 Add new eventlog events for various heap and GC statistics
] 
[Revert "Simplify code by eliminating the gcd/fiz swap"
Mikolaj Konarski <mikolaj@well-typed.com>**20120207102509
 Ignore-this: 539f6a65078e24791b0bd851f7df1363
 
 This reverts commit ec4dd1311502f52edce721ea1cefa1becc66706e.
 Here's the justification:
 
 <mikolaj> dcoutts: should I go ahead with breaking the API?
           http://hackage.haskell.org/trac/ghc/ticket/5818#comment:3
 <mikolaj> dcoutts: I can leave the ghc-events and GHC orders distinct
 <mikolaj> dcoutts: or make them the same, at the cost of some code changes and breaking the API
 <dcoutts> oh you mean the order of the fields in the Haskell data constructor
 <mikolaj> yes, there's many enough fields that they are refered to by position most of the time
 <dcoutts> I don't think it's vital to make them the same
 <mikolaj> dcoutts: me neither, but it's error-prone
 <mikolaj> dcoutts: against the principle of least surpise
 <dcoutts> mikolaj: but only error prone for the person writing the binary parser
 <dcoutts> and we already made that mistake :-)
 <dcoutts> I don't think there's other places where it should matter
 <mikolaj> dcoutts: when somebody looks at the GHC code, perhaps copy-pastes and then tweaks something
           using ghc (e.g. TS)
 <mikolaj> like I did when simulating RTS -s in TS
 <mikolaj> I had to swap the order in TS, after a copy-paste from GHC
 <mikolaj> dcoutts: anyway, your call
 <dcoutts> mikolaj: the danger is if someone else is already using the event
 <mikolaj> yes
 <dcoutts> then we silently break their stuff
 <mikolaj> yes, we break the API
 <dcoutts> but not in a way that is noticeable (no compile error)
 <dcoutts> mikolaj: so I think we should leave it
 <mikolaj> dcoutts: ok, I will revert the commit and paste our discussion as a justification
 <dcoutts> ok
] 
[Simplify code by eliminating the gcd/fiz swap
Mikolaj Konarski <mikolaj@well-typed.com>**20120207081310
 Ignore-this: 500e3a358475b4b37ce99d136ee276fb
 
 This change requires fixes in TS (and in any other code using SparkCounters).
] 
[Fix #5818 from GHC Trac, with minimal changes
Mikolaj Konarski <mikolaj@well-typed.com>**20120207080416
 Ignore-this: 4db4ea26a2a2220f79da238adadf9ce9
 
 This change does not break any other code (e.g. TS) that uses
 the SparkCounters event.
] 
[TAG 0.4.0.0
Duncan Coutts <duncan@well-typed.com>**20120114021408
 Ignore-this: c5dd879927d04e7c5cd7c392c4cf3841
] 
Patch bundle hash:
6dc3ce9aecd2fed4150a45636d7ebaa38eb72a1a