ghc/compiler/utils/FastString.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1997
   3 %
   4 \section{Fast strings}
   5
   6 Compact representations of character strings with
   7 unique identifiers.
   8
   9 \begin{code}
  10 #include "HsVersions.h"
  11
  12 module FastString
  13        (
  14         FastString(..),     -- not abstract, for now.
  15
  16          --names?
  17         mkFastString,       -- :: String -> FastString
  18         mkFastCharString,   -- :: _Addr -> FastString
  19         mkFastCharString2,  -- :: _Addr -> Int -> FastString
  20         mkFastSubString,    -- :: _Addr -> Int -> Int -> FastString
  21         mkFastSubStringFO,  -- :: ForeignObj -> Int -> Int -> FastString
  22
  23         mkFastString#,      -- :: Addr# -> Int# -> FastString
  24         mkFastSubStringBA#, -- :: ByteArray# -> Int# -> Int# -> FastString
  25         mkFastSubString#,   -- :: Addr# -> Int# -> Int# -> FastString
  26         mkFastSubStringFO#, -- :: ForeignObj# -> Int# -> Int# -> FastString
  27
  28         lengthFS,           -- :: FastString -> Int
  29         nullFastString,     -- :: FastString -> Bool
  30
  31         getByteArray#,      -- :: FastString -> ByteArray#
  32         getByteArray,       -- :: FastString -> _ByteArray Int
  33         unpackFS,           -- :: FastString -> String
  34         appendFS,           -- :: FastString -> FastString -> FastString
  35         headFS,             -- :: FastString -> Char
  36         tailFS,             -- :: FastString -> FastString
  37         concatFS,           -- :: [FastString] -> FastString
  38         consFS,             -- :: Char -> FastString -> FastString
  39
  40         hPutFS,             -- :: Handle -> FastString -> IO ()
  41         tagCmpFS            -- :: FastString -> FastString -> _CMP_TAG
  42        ) where
  43
  44 #if __GLASGOW_HASKELL__ <= 201
  45 import PreludeGlaST
  46 import PreludeGlaMisc
  47 import HandleHack
  48 import Ubiq
  49 #else
  50 import GlaExts
  51 import Foreign
  52 import IOBase
  53 import IOHandle
  54 import ST
  55 import STBase
  56 import {-# SOURCE #-} Unique  ( mkUniqueGrimily, Unique, Uniquable(..) )
  57 #if __GLASGOW_HASKELL__ == 202
  58 import PrelBase ( Char (..) )
  59 #endif
  60 #endif
  61
  62 import PrimPacked
  63
  64 #define hASH_TBL_SIZE 993
  65
  66 \end{code}
  67
  68 @FastString@s are packed representations of strings
  69 with a unique id for fast comparisons. The unique id
  70 is assigned when creating the @FastString@, using
  71 a hash table to map from the character string representation
  72 to the unique ID.
  73
  74 \begin{code}
  75 data FastString
  76   = FastString   -- packed repr. on the heap.
  77       Int#       -- unique id
  78                  --  0 => string literal, comparison
  79                  --  will
  80       Int#       -- length
  81       ByteArray# -- stuff
  82
  83   | CharStr      -- external C string
  84       Addr#      -- pointer to the (null-terminated) bytes in C land.
  85       Int#       -- length  (cached)
  86
  87 instance Eq FastString where
  88   a == b = case tagCmpFS a b of { _LT -> False; _EQ -> True;  _GT -> False }
  89   a /= b = case tagCmpFS a b of { _LT -> True;  _EQ -> False; _GT -> True  }
  90
  91 {-
  92  (FastString u1# _ _) == (FastString u2# _ _) = u1# ==# u2#
  93 -}
  94
  95 instance Uniquable FastString where
  96  uniqueOf (FastString u# _ _) = mkUniqueGrimily u#
  97  uniqueOf (CharStr a# l#) =
  98    {-
  99      [A somewhat moby hack]: to avoid entering all sorts
 100      of junk into the hash table, all C char strings
 101      are by default left out. The benefit of being in
 102      the table is that string comparisons are lightning fast,
 103      just an Int# comparison.
 104
 105      But, if you want to get the Unique of a CharStr, we
 106      enter it into the table and return that unique. This
 107      works, but causes the CharStr to be looked up in the hash
 108      table each time it is accessed..
 109    -}
 110    mkUniqueGrimily (case mkFastString# a# l# of { FastString u# _ _ -> u#}) -- Ugh!
 111
 112 instance Uniquable Int where
 113  uniqueOf (I# i#) = mkUniqueGrimily i#
 114
 115 instance Text FastString  where
 116     showsPrec p ps@(FastString u# _ _) r = showsPrec p (unpackFS ps) r
 117     showsPrec p ps r = showsPrec p (unpackFS ps) r
 118
 119 getByteArray# :: FastString -> ByteArray#
 120 getByteArray# (FastString _ _ ba#) = ba#
 121
 122 getByteArray :: FastString -> _ByteArray Int
 123 getByteArray (FastString _ l# ba#) = _ByteArray (0,I# l#) ba#
 124
 125 lengthFS :: FastString -> Int
 126 lengthFS (FastString _ l# _) = I# l#
 127 lengthFS (CharStr a# l#) = I# l#
 128
 129 nullFastString :: FastString -> Bool
 130 nullFastString (FastString _ l# _) = l# ==# 0#
 131 nullFastString (CharStr _ l#) = l# ==# 0#
 132
 133 unpackFS :: FastString -> String
 134 unpackFS (FastString _ l# ba#) = byteArrayToString (_ByteArray (0,I# l#) ba#)
 135 unpackFS (CharStr addr len#) =
 136  unpack 0#
 137  where
 138     unpack nh
 139       | nh ==# len# = []
 140       | otherwise   = C# ch : unpack (nh +# 1#)
 141       where
 142         ch = indexCharOffAddr# addr nh
 143
 144 appendFS :: FastString -> FastString -> FastString
 145 appendFS fs1 fs2 = mkFastString (unpackFS fs1 ++ unpackFS fs2)
 146
 147 concatFS :: [FastString] -> FastString
 148 concatFS ls = mkFastString (concat (map (unpackFS) ls)) -- ToDo: do better
 149
 150 headFS :: FastString -> Char
 151 headFS f@(FastString _ l# ba#) =
 152  if l# ># 0# then C# (indexCharArray# ba# 0#) else error ("headFS: empty FS: " ++ unpackFS f)
 153 headFS f@(CharStr a# l#) =
 154  if l# ># 0# then C# (indexCharOffAddr# a# 0#) else error ("headFS: empty FS: " ++ unpackFS f)
 155
 156 tailFS :: FastString -> FastString
 157 tailFS (FastString _ l# ba#) = mkFastSubStringBA# ba# 1# (l# -# 1#)
 158
 159 consFS :: Char -> FastString -> FastString
 160 consFS c fs = mkFastString (c:unpackFS fs)
 161
 162 \end{code}
 163
 164 Internally, the compiler will maintain a fast string symbol
 165 table, providing sharing and fast comparison. Creation of
 166 new @FastString@s then covertly does a lookup, re-using the
 167 @FastString@ if there was a hit.
 168
 169 \begin{code}
 170 data FastStringTable =
 171  FastStringTable
 172     Int#
 173     (MutableArray# _RealWorld [FastString])
 174
 175 type FastStringTableVar = MutableVar _RealWorld FastStringTable
 176
 177 string_table :: FastStringTableVar
 178 string_table =
 179  unsafePerformPrimIO (
 180    newArray (0::Int,hASH_TBL_SIZE) [] `thenPrimIO` \ (_MutableArray _ arr#) ->
 181    newVar (FastStringTable 0# arr#))
 182
 183 lookupTbl :: FastStringTable -> Int# -> PrimIO [FastString]
 184 lookupTbl (FastStringTable _ arr#) i# =
 185   MkST ( \ (S# s#) ->
 186   case readArray# arr# i# s# of { StateAndPtr# s2# r ->
 187     (r, S# s2#) })
 188
 189 updTbl :: FastStringTableVar -> FastStringTable -> Int# -> [FastString] -> PrimIO ()
 190 updTbl (_MutableArray _ var#) (FastStringTable uid# arr#) i# ls =
 191  MkST ( \ (S# s#) ->
 192  case writeArray# arr# i# ls s# of { s2# ->
 193  case writeArray# var# 0# (FastStringTable (uid# +# 1#) arr#) s2# of { s3# ->
 194   ((), S# s3#) }})
 195
 196 mkFastString# :: Addr# -> Int# -> FastString
 197 mkFastString# a# len# =
 198  unsafePerformPrimIO  (
 199   readVar string_table `thenPrimIO` \ ft@(FastStringTable uid# tbl#) ->
 200   let
 201    h = hashStr a# len#
 202   in
 203 --  _trace ("hashed: "++show (I# h)) $
 204   lookupTbl ft h        `thenPrimIO` \ lookup_result ->
 205   case lookup_result of
 206     [] ->
 207        -- no match, add it to table by copying out the
 208        -- the string into a ByteArray
 209        -- _trace "empty bucket" $
 210        case copyPrefixStr (A# a#) (I# len#) of
 211          (_ByteArray _ barr#) ->
 212            let f_str = FastString uid# len# barr# in
 213            updTbl string_table ft h [f_str] `seqPrimIO`
 214            ({- _trace ("new: " ++ show f_str)   $ -} returnPrimIO f_str)
 215     ls ->
 216        -- non-empty `bucket', scan the list looking
 217        -- entry with same length and compare byte by byte.
 218        -- _trace ("non-empty bucket"++show ls) $
 219        case bucket_match ls len# a# of
 220          Nothing ->
 221            case copyPrefixStr (A# a#) (I# len#) of
 222             (_ByteArray _ barr#) ->
 223               let f_str = FastString uid# len# barr# in
 224               updTbl string_table ft h (f_str:ls) `seqPrimIO`
 225               ( {- _trace ("new: " ++ show f_str)  $ -} returnPrimIO f_str)
 226          Just v  -> {- _trace ("re-use: "++show v) $ -} returnPrimIO v)
 227   where
 228    bucket_match [] _ _ = Nothing
 229    bucket_match (v@(FastString _ l# ba#):ls) len# a# =
 230       if len# ==# l# && eqStrPrefix a# ba# l# then
 231          Just v
 232       else
 233          bucket_match ls len# a#
 234
 235 mkFastSubString# :: Addr# -> Int# -> Int# -> FastString
 236 mkFastSubString# a# start# len# = mkFastCharString2 (A# (addrOffset# a# start#)) (I# len#)
 237
 238 mkFastSubStringFO# :: ForeignObj# -> Int# -> Int# -> FastString
 239 mkFastSubStringFO# fo# start# len# =
 240  unsafePerformPrimIO  (
 241   readVar string_table `thenPrimIO` \ ft@(FastStringTable uid# tbl#) ->
 242   let
 243    h = hashSubStrFO fo# start# len#
 244   in
 245   lookupTbl ft h        `thenPrimIO` \ lookup_result ->
 246   case lookup_result of
 247     [] ->
 248        -- no match, add it to table by copying out the
 249        -- the string into a ByteArray
 250        case copySubStrFO (_ForeignObj fo#) (I# start#) (I# len#) of
 251          (_ByteArray _ barr#) ->
 252            let f_str = FastString uid# len# barr# in
 253            updTbl string_table ft h [f_str]       `seqPrimIO`
 254            returnPrimIO f_str
 255     ls ->
 256        -- non-empty `bucket', scan the list looking
 257        -- entry with same length and compare byte by byte.
 258        case bucket_match ls start# len# fo# of
 259          Nothing ->
 260            case copySubStrFO (_ForeignObj fo#) (I# start#) (I# len#) of
 261              (_ByteArray _ barr#) ->
 262               let f_str = FastString uid# len# barr# in
 263               updTbl string_table ft  h (f_str:ls) `seqPrimIO`
 264               ( {- _trace ("new: " ++ show f_str) $ -} returnPrimIO f_str)
 265          Just v  -> {- _trace ("re-use: "++show v) $ -} returnPrimIO v)
 266   where
 267    bucket_match [] _ _ _ = Nothing
 268    bucket_match (v@(FastString _ l# barr#):ls) start# len# fo# =
 269       if len# ==# l# && eqStrPrefixFO fo# barr# start# len# then
 270          Just v
 271       else
 272          bucket_match ls start# len# fo#
 273
 274
 275 mkFastSubStringBA# :: ByteArray# -> Int# -> Int# -> FastString
 276 mkFastSubStringBA# barr# start# len# =
 277  unsafePerformPrimIO  (
 278   readVar string_table `thenPrimIO` \ ft@(FastStringTable uid# tbl#) ->
 279   let
 280    h = hashSubStrBA barr# start# len#
 281   in
 282 --  _trace ("hashed(b): "++show (I# h)) $
 283   lookupTbl ft h        `thenPrimIO` \ lookup_result ->
 284   case lookup_result of
 285     [] ->
 286        -- no match, add it to table by copying out the
 287        -- the string into a ByteArray
 288        -- _trace "empty bucket(b)" $
 289        case copySubStrBA (_ByteArray btm barr#) (I# start#) (I# len#) of
 290          (_ByteArray _ ba#) ->
 291           let f_str = FastString uid# len# ba# in
 292           updTbl string_table ft h [f_str]     `seqPrimIO`
 293           -- _trace ("new(b): " ++ show f_str)   $
 294           returnPrimIO f_str
 295     ls ->
 296        -- non-empty `bucket', scan the list looking
 297        -- entry with same length and compare byte by byte.
 298        -- _trace ("non-empty bucket(b)"++show ls) $
 299        case bucket_match ls start# len# barr# of
 300          Nothing ->
 301           case copySubStrBA (_ByteArray (error "") barr#) (I# start#) (I# len#) of
 302             (_ByteArray _ ba#) ->
 303               let f_str = FastString uid# len# ba# in
 304               updTbl string_table ft h (f_str:ls) `seqPrimIO`
 305               -- _trace ("new(b): " ++ show f_str)   $
 306               returnPrimIO f_str
 307          Just v  ->
 308               -- _trace ("re-use(b): "++show v) $
 309               returnPrimIO v
 310   )
 311  where
 312    btm = error ""
 313
 314    bucket_match [] _ _ _ = Nothing
 315    bucket_match (v:ls) start# len# ba# =
 316     case v of
 317      FastString _ l# barr# ->
 318       if len# ==# l# && eqStrPrefixBA barr# ba# start# len# then
 319          Just v
 320       else
 321          bucket_match ls start# len# ba#
 322
 323 mkFastCharString :: _Addr -> FastString
 324 mkFastCharString a@(A# a#) =
 325  case strLength a of{ (I# len#) -> CharStr a# len# }
 326
 327 mkFastCharString2 :: _Addr -> Int -> FastString
 328 mkFastCharString2 a@(A# a#) (I# len#) = CharStr a# len#
 329
 330 mkFastString :: String -> FastString
 331 mkFastString str =
 332  case stringToByteArray str of
 333   (_ByteArray (_,I# len#) frozen#) ->
 334     mkFastSubStringBA# frozen# 0# len#
 335     {- 0-indexed array, len# == index to one beyond end of string,
 336        i.e., (0,1) => empty string.    -}
 337
 338 mkFastSubString :: _Addr -> Int -> Int -> FastString
 339 mkFastSubString (A# a#) (I# start#) (I# len#) =
 340  mkFastString# (addrOffset# a# start#) len#
 341
 342 mkFastSubStringFO :: _ForeignObj -> Int -> Int -> FastString
 343 mkFastSubStringFO (_ForeignObj fo#) (I# start#) (I# len#) =
 344  mkFastSubStringFO# fo# start# len#
 345
 346 \end{code}
 347
 348 \begin{code}
 349 hashStr  :: Addr# -> Int# -> Int#
 350  -- use the Addr to produce a hash value between 0 & m (inclusive)
 351 hashStr a# len# =
 352   case len# of
 353    0# -> 0#
 354    1# -> ((ord# c0 *# 631#) +# len#) `remInt#` hASH_TBL_SIZE#
 355    2# -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# len#) `remInt#` hASH_TBL_SIZE#
 356    _  -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# (ord# c2 *# 43#) +# len#) `remInt#` hASH_TBL_SIZE#
 357 {- Currently UNUSED:
 358   if len# ==# 0# then
 359      0#
 360   else
 361      ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# (ord# c2 *# 43#) +# len#)
 362         `remInt#` hASH_TBL_SIZE#
 363 -}
 364   where
 365     c0 = indexCharOffAddr# a# 0#
 366     c1 = indexCharOffAddr# a# 1# --(len# `quotInt#` 2# -# 1#)
 367     c2 = indexCharOffAddr# a# 2# --(len# -# 1#)
 368
 369 hashSubStrFO  :: ForeignObj# -> Int# -> Int# -> Int#
 370  -- use the Addr to produce a hash value between 0 & m (inclusive)
 371 hashSubStrFO fo# start# len# =
 372   case len# of
 373    0# -> 0#
 374    1# -> ((ord# c0 *# 631#) +# len#) `remInt#` hASH_TBL_SIZE#
 375    2# -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# len#) `remInt#` hASH_TBL_SIZE#
 376    _  -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# (ord# c2 *# 43#) +# len#) `remInt#` hASH_TBL_SIZE#
 377 {-
 378   if len# ==# 0# then
 379      0#
 380   else
 381      ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# (ord# c2 *# 43#) +# len#)
 382         `remInt#` hASH_TBL_SIZE#
 383 -}
 384   where
 385     c0 = indexCharOffFO# fo# 0#
 386     c1 = indexCharOffFO# fo# 1# --(len# `quotInt#` 2# -# 1#)
 387     c2 = indexCharOffFO# fo# 2# --(len# -# 1#)
 388
 389
 390 hashSubStrBA  :: ByteArray# -> Int# -> Int# -> Int#
 391  -- use the Addr to produce a hash value between 0 & m (inclusive)
 392 hashSubStrBA ba# start# len# =
 393   case len# of
 394    0# -> 0#
 395    1# -> ((ord# c0 *# 631#) +# len#) `remInt#` hASH_TBL_SIZE#
 396    2# -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# len#) `remInt#` hASH_TBL_SIZE#
 397    _  -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# (ord# c2 *# 43#) +# len#) `remInt#` hASH_TBL_SIZE#
 398 {-
 399   if len# ==# 0# then
 400      0#
 401   else
 402      ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# (ord# c2 *# 43#) +# len#)
 403         `remInt#` hASH_TBL_SIZE#
 404 -}
 405   where
 406     c0 = indexCharArray# ba# 0#
 407     c1 = indexCharArray# ba# 1# --(len# `quotInt#` 2# -# 1#)
 408     c2 = indexCharArray# ba# 2# --(len# -# 1#)
 409
 410 \end{code}
 411
 412 \begin{code}
 413 tagCmpFS :: FastString -> FastString -> _CMP_TAG
 414 tagCmpFS (FastString u1# _ b1#) (FastString u2# _ b2#) = -- assume non-null chars
 415   if u1# ==# u2# then
 416      _EQ
 417   else
 418    unsafePerformPrimIO (
 419     _ccall_ strcmp (_ByteArray bottom b1#) (_ByteArray bottom b2#) `thenPrimIO` \ (I# res) ->
 420     returnPrimIO (
 421     if      res <#  0# then _LT
 422     else if res ==# 0# then _EQ
 423     else                    _GT
 424     ))
 425   where
 426    bottom :: (Int,Int)
 427    bottom = error "tagCmp"
 428 tagCmpFS (CharStr bs1 len1) (CharStr bs2 len2)
 429   = unsafePerformPrimIO (
 430     _ccall_ strcmp ba1 ba2  `thenPrimIO` \ (I# res) ->
 431     returnPrimIO (
 432     if      res <#  0# then _LT
 433     else if res ==# 0# then _EQ
 434     else                    _GT
 435     ))
 436   where
 437     ba1 = A# bs1
 438     ba2 = A# bs2
 439 tagCmpFS (FastString _ len1 bs1) (CharStr bs2 len2)
 440  = unsafePerformPrimIO (
 441     _ccall_ strcmp ba1 ba2 `thenPrimIO` \ (I# res) ->
 442     returnPrimIO (
 443      if      res <#  0# then _LT
 444      else if res ==# 0# then _EQ
 445      else                   _GT
 446     ))
 447   where
 448     ba1 = _ByteArray ((error "")::(Int,Int)) bs1
 449     ba2 = A# bs2
 450
 451 tagCmpFS a@(CharStr _ _) b@(FastString _ _ _)
 452   = -- try them the other way 'round
 453     case (tagCmpFS b a) of { _LT -> _GT; _EQ -> _EQ; _GT -> _LT }
 454
 455 instance Ord FastString where
 456     a <= b = case tagCmpFS a b of { _LT -> True;  _EQ -> True;  _GT -> False }
 457     a <  b = case tagCmpFS a b of { _LT -> True;  _EQ -> False; _GT -> False }
 458     a >= b = case tagCmpFS a b of { _LT -> False; _EQ -> True;  _GT -> True  }
 459     a >  b = case tagCmpFS a b of { _LT -> False; _EQ -> False; _GT -> True  }
 460     max x y | x >= y    =  x
 461             | otherwise =  y
 462     min x y | x <= y    =  x
 463             | otherwise =  y
 464     _tagCmp a b = tagCmpFS a b
 465
 466 \end{code}
 467
 468 Outputting @FastString@s is quick, just block copying the chunk (using
 469 @fwrite@).
 470
 471 \begin{code}
 472 #if __GLASGOW_HASKELL__ >= 201
 473 #define _ErrorHandle IOBase.ErrorHandle
 474 #define _ReadHandle IOBase.ReadHandle
 475 #define _ClosedHandle IOBase.ClosedHandle
 476 #define _SemiClosedHandle IOBase.SemiClosedHandle
 477 #define _constructError  IOBase.constructError
 478 #define _filePtr IOHandle.filePtr
 479 #define failWith fail
 480 #endif
 481
 482 hPutFS :: Handle -> FastString -> IO ()
 483 hPutFS handle (FastString _ l# ba#) =
 484  if l# ==# 0# then
 485     return ()
 486  else
 487     _readHandle handle                              >>= \ htype ->
 488     case htype of
 489       _ErrorHandle ioError ->
 490           _writeHandle handle htype                 >>
 491           failWith ioError
 492       _ClosedHandle ->
 493           _writeHandle handle htype                 >>
 494           failWith MkIOError(handle,IllegalOperation,"handle is closed")
 495       _SemiClosedHandle _ _ ->
 496           _writeHandle handle htype                 >>
 497           failWith MkIOError(handle,IllegalOperation,"handle is closed")
 498       _ReadHandle _ _ _ ->
 499           _writeHandle handle htype                 >>
 500           failWith MkIOError(handle,IllegalOperation,"handle is not open for writing")
 501       other ->
 502           let fp = _filePtr htype in
 503            -- here we go..
 504           _ccall_ writeFile (_ByteArray ((error "")::(Int,Int)) ba#) fp (I# l#) `CCALL_THEN` \rc ->
 505           if rc==0 then
 506               return ()
 507           else
 508               _constructError "hPutFS"   `CCALL_THEN` \ err ->
 509               failWith err
 510 hPutFS handle (CharStr a# l#) =
 511  if l# ==# 0# then
 512     return ()
 513  else
 514     _readHandle handle                              >>= \ htype ->
 515     case htype of
 516       _ErrorHandle ioError ->
 517           _writeHandle handle htype                 >>
 518           failWith ioError
 519       _ClosedHandle ->
 520           _writeHandle handle htype                 >>
 521           failWith MkIOError(handle,IllegalOperation,"handle is closed")
 522       _SemiClosedHandle _ _ ->
 523           _writeHandle handle htype                 >>
 524           failWith MkIOError(handle,IllegalOperation,"handle is closed")
 525       _ReadHandle _ _ _ ->
 526           _writeHandle handle htype                 >>
 527           failWith MkIOError(handle,IllegalOperation,"handle is not open for writing")
 528       other ->
 529           let fp = _filePtr htype in
 530            -- here we go..
 531           _ccall_ writeFile (A# a#) fp (I# l#) `CCALL_THEN` \rc ->
 532           if rc==0 then
 533               return ()
 534           else
 535               _constructError "hPutFS"   `CCALL_THEN` \ err ->
 536               failWith err
 537
 538 --ToDo: avoid silly code duplic.
 539 \end{code}