ghc/compiler/simplCore/SimplCore.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[SimplCore]{Driver for simplifying @Core@ programs}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module SimplCore ( core2core ) where
  10
  11 import Ubiq{-uitous-}
  12
  13 import AnalFBWW         ( analFBWW )
  14 import Bag              ( isEmptyBag, foldBag )
  15 import BinderInfo       ( BinderInfo{-instance Outputable-} )
  16 import CgCompInfo       ( uNFOLDING_CREATION_THRESHOLD,
  17                           uNFOLDING_USE_THRESHOLD,
  18                           uNFOLDING_OVERRIDE_THRESHOLD,
  19                           uNFOLDING_CON_DISCOUNT_WEIGHT
  20                         )
  21 import CmdLineOpts      ( CoreToDo(..), SimplifierSwitch(..), switchIsOn,
  22                           opt_D_show_passes,
  23                           opt_D_simplifier_stats,
  24                           opt_D_verbose_core2core,
  25                           opt_DoCoreLinting,
  26                           opt_FoldrBuildOn,
  27                           opt_ReportWhyUnfoldingsDisallowed,
  28                           opt_ShowImportSpecs,
  29                           opt_UnfoldingCreationThreshold,
  30                           opt_UnfoldingOverrideThreshold,
  31                           opt_UnfoldingUseThreshold
  32                         )
  33 import CoreLint         ( lintCoreBindings )
  34 import CoreSyn
  35 import CoreUnfold
  36 import CoreUtils        ( substCoreBindings, manifestlyWHNF )
  37 import ErrUtils         ( ghcExit )
  38 import FloatIn          ( floatInwards )
  39 import FloatOut         ( floatOutwards )
  40 import FoldrBuildWW     ( mkFoldrBuildWW )
  41 import Id               ( idType, toplevelishId, idWantsToBeINLINEd,
  42                           unfoldingUnfriendlyId,
  43                           nullIdEnv, addOneToIdEnv, delOneFromIdEnv,
  44                           lookupIdEnv, IdEnv(..),
  45                           GenId{-instance Outputable-}
  46                         )
  47 import IdInfo           ( mkUnfolding )
  48 import LiberateCase     ( liberateCase )
  49 import MagicUFs         ( MagicUnfoldingFun )
  50 import Maybes           ( maybeToBool )
  51 import Outputable       ( Outputable(..){-instance * (,) -} )
  52 import PprCore          ( pprCoreBinding, GenCoreExpr{-instance Outputable-} )
  53 import PprStyle         ( PprStyle(..) )
  54 import PprType          ( GenType{-instance Outputable-}, GenTyVar{-ditto-} )
  55 import Pretty           ( ppShow, ppAboves, ppAbove, ppCat, ppStr )
  56 import SAT              ( doStaticArgs )
  57 import SCCauto          ( addAutoCostCentres )
  58 import SimplMonad       ( zeroSimplCount, showSimplCount, SimplCount )
  59 import SimplPgm         ( simplifyPgm )
  60 import SimplVar         ( leastItCouldCost )
  61 import Specialise
  62 import SpecUtils        ( pprSpecErrs )
  63 import StrictAnal       ( saWwTopBinds )
  64 import TyVar            ( nullTyVarEnv, GenTyVar{-instance Eq-} )
  65 import Unique           ( Unique{-instance Eq-} )
  66 import UniqSupply       ( splitUniqSupply )
  67 import Util             ( panic{-ToDo:rm-} )
  68
  69 #if ! OMIT_DEFORESTER
  70 import Deforest         ( deforestProgram )
  71 import DefUtils         ( deforestable )
  72 #endif
  73
  74 isWrapperFor = panic "SimplCore.isWrapperFor (ToDo)"
  75 isWrapperId = panic "SimplCore.isWrapperId (ToDo)"
  76 \end{code}
  77
  78 \begin{code}
  79 core2core :: [CoreToDo]                 -- spec of what core-to-core passes to do
  80           -> FAST_STRING                -- module name (profiling only)
  81           -> PprStyle                   -- printing style (for debugging only)
  82           -> UniqSupply         -- a name supply
  83           -> [TyCon]                    -- local data tycons and tycon specialisations
  84           -> FiniteMap TyCon [(Bool, [Maybe Type])]
  85           -> [CoreBinding]              -- input...
  86           -> IO
  87               ([CoreBinding],   -- results: program, plus...
  88                IdEnv UnfoldingDetails,  --  unfoldings to be exported from here
  89               SpecialiseData)           --  specialisation data
  90
  91 core2core core_todos module_name ppr_style us local_tycons tycon_specs binds
  92   = _scc_ "Core2Core"
  93     if null core_todos then -- very rare, I suspect...
  94         -- well, we still must do some renumbering
  95         return (
  96         (substCoreBindings nullIdEnv nullTyVarEnv binds us,
  97          nullIdEnv,
  98          init_specdata)
  99         )
 100     else
 101         (if do_verbose_core2core then
 102             hPutStr stderr "VERBOSE CORE-TO-CORE:\n"
 103          else return ()) >>
 104
 105         -- better do the main business
 106         foldl_mn do_core_pass
 107                 (binds, us, nullIdEnv, init_specdata, zeroSimplCount)
 108                 core_todos
 109                 >>= \ (processed_binds, _, inline_env, spec_data, simpl_stats) ->
 110
 111         (if  opt_D_simplifier_stats
 112          then hPutStr stderr ("\nSimplifier Stats:\n")
 113                 >>
 114               hPutStr stderr (showSimplCount simpl_stats)
 115                 >>
 116               hPutStr stderr "\n"
 117          else return ()
 118         ) >>
 119
 120         return (processed_binds, inline_env, spec_data)
 121   where
 122     init_specdata = initSpecData local_tycons tycon_specs
 123
 124     do_verbose_core2core = opt_D_verbose_core2core
 125
 126     lib_case_threshold  -- ToDo: HACK HACK HACK : FIX ME FIX ME FIX ME
 127                         -- Use 4x a known threshold
 128       = case opt_UnfoldingOverrideThreshold of
 129           Nothing -> 4 * uNFOLDING_USE_THRESHOLD
 130           Just xx -> 4 * xx
 131
 132     -------------
 133     core_linter = if opt_DoCoreLinting
 134                   then lintCoreBindings ppr_style
 135                   else ( \ whodunnit spec_done binds -> binds )
 136
 137     --------------
 138     do_core_pass info@(binds, us, inline_env, spec_data, simpl_stats) to_do
 139       = let
 140             (us1, us2) = splitUniqSupply us
 141         in
 142         case to_do of
 143           CoreDoSimplify simpl_sw_chkr
 144             -> _scc_ "CoreSimplify"
 145                begin_pass ("Simplify" ++ if switchIsOn simpl_sw_chkr SimplDoFoldrBuild
 146                                          then " (foldr/build)" else "") >>
 147                case (simplifyPgm binds simpl_sw_chkr simpl_stats us1) of
 148                  (p, it_cnt, simpl_stats2)
 149                    -> end_pass False us2 p inline_env spec_data simpl_stats2
 150                                ("Simplify (" ++ show it_cnt ++ ")"
 151                                  ++ if switchIsOn simpl_sw_chkr SimplDoFoldrBuild
 152                                     then " foldr/build" else "")
 153
 154           CoreDoFoldrBuildWorkerWrapper
 155             -> _scc_ "CoreDoFoldrBuildWorkerWrapper"
 156                begin_pass "FBWW" >>
 157                case (mkFoldrBuildWW us1 binds) of { binds2 ->
 158                end_pass False us2 binds2 inline_env spec_data simpl_stats "FBWW" }
 159
 160           CoreDoFoldrBuildWWAnal
 161             -> _scc_ "CoreDoFoldrBuildWWAnal"
 162                begin_pass "AnalFBWW" >>
 163                case (analFBWW binds) of { binds2 ->
 164                end_pass False us2 binds2 inline_env spec_data simpl_stats "AnalFBWW" }
 165
 166           CoreLiberateCase
 167             -> _scc_ "LiberateCase"
 168                begin_pass "LiberateCase" >>
 169                case (liberateCase lib_case_threshold binds) of { binds2 ->
 170                end_pass False us2 binds2 inline_env spec_data simpl_stats "LiberateCase" }
 171
 172           CoreDoCalcInlinings1  -- avoid inlinings w/ cost-centres
 173             -> _scc_ "CoreInlinings1"
 174                begin_pass "CalcInlinings" >>
 175                case (calcInlinings False inline_env binds) of { inline_env2 ->
 176                end_pass False us2 binds inline_env2 spec_data simpl_stats "CalcInlinings" }
 177
 178           CoreDoCalcInlinings2  -- allow inlinings w/ cost-centres
 179             -> _scc_ "CoreInlinings2"
 180                begin_pass "CalcInlinings" >>
 181                case (calcInlinings True inline_env binds) of { inline_env2 ->
 182                end_pass False us2 binds inline_env2 spec_data simpl_stats "CalcInlinings" }
 183
 184           CoreDoFloatInwards
 185             -> _scc_ "FloatInwards"
 186                begin_pass "FloatIn" >>
 187                case (floatInwards binds) of { binds2 ->
 188                end_pass False us2 binds2 inline_env spec_data simpl_stats "FloatIn" }
 189
 190           CoreDoFullLaziness
 191             -> _scc_ "CoreFloating"
 192                begin_pass "FloatOut" >>
 193                case (floatOutwards us1 binds) of { binds2 ->
 194                end_pass False us2 binds2 inline_env spec_data simpl_stats "FloatOut" }
 195
 196           CoreDoStaticArgs
 197             -> _scc_ "CoreStaticArgs"
 198                begin_pass "StaticArgs" >>
 199                case (doStaticArgs binds us1) of { binds2 ->
 200                end_pass False us2 binds2 inline_env spec_data simpl_stats "StaticArgs" }
 201                 -- Binds really should be dependency-analysed for static-
 202                 -- arg transformation... Not to worry, they probably are.
 203                 -- (I don't think it *dies* if they aren't [WDP 94/04/15])
 204
 205           CoreDoStrictness
 206             -> _scc_ "CoreStranal"
 207                begin_pass "StrAnal" >>
 208                case (saWwTopBinds us1 binds) of { binds2 ->
 209                end_pass False us2 binds2 inline_env spec_data simpl_stats "StrAnal" }
 210
 211           CoreDoSpecialising
 212             -> _scc_ "Specialise"
 213                begin_pass "Specialise" >>
 214                case (specProgram us1 binds spec_data) of {
 215                  (p, spec_data2@(SpecData _ spec_noerrs _ _ _
 216                                           spec_errs spec_warn spec_tyerrs)) ->
 217
 218                    -- if we got errors, we die straight away
 219                    (if not spec_noerrs ||
 220                        (opt_ShowImportSpecs && not (isEmptyBag spec_warn)) then
 221                         hPutStr stderr (ppShow 1000 {-pprCols-}
 222                             (pprSpecErrs module_name spec_errs spec_warn spec_tyerrs))
 223                         >> hPutStr stderr "\n"
 224                     else
 225                         return ()) >>
 226
 227                    (if not spec_noerrs then -- Stop here if specialisation errors occured
 228                         ghcExit 1
 229                    else
 230                         return ()) >>
 231
 232                    end_pass False us2 p inline_env spec_data2 simpl_stats "Specialise"
 233                }
 234
 235           CoreDoDeforest
 236 #if OMIT_DEFORESTER
 237             -> error "ERROR: CoreDoDeforest: not built into compiler\n"
 238 #else
 239             -> _scc_ "Deforestation"
 240                begin_pass "Deforestation" >>
 241                case (deforestProgram binds us1) of { binds2 ->
 242                end_pass False us2 binds2 inline_env spec_data simpl_stats "Deforestation" }
 243 #endif
 244
 245           CoreDoAutoCostCentres
 246             -> _scc_ "AutoSCCs"
 247                begin_pass "AutoSCCs" >>
 248                case (addAutoCostCentres module_name binds) of { binds2 ->
 249                end_pass False us2 binds2 inline_env spec_data simpl_stats "AutoSCCs" }
 250
 251           CoreDoPrintCore       -- print result of last pass
 252             -> end_pass True us2 binds inline_env spec_data simpl_stats "Print"
 253
 254
 255     -------------------------------------------------
 256
 257     begin_pass
 258       = if opt_D_show_passes
 259         then \ what -> hPutStr stderr ("*** Core2Core: "++what++"\n")
 260         else \ what -> return ()
 261
 262     end_pass print us2 binds2 inline_env2
 263              spec_data2@(SpecData spec_done _ _ _ _ _ _ _)
 264              simpl_stats2 what
 265       = -- report verbosely, if required
 266         (if (do_verbose_core2core && not print) ||
 267             (print && not do_verbose_core2core)
 268          then
 269             hPutStr stderr ("\n*** "++what++":\n")
 270                 >>
 271             hPutStr stderr (ppShow 1000
 272                 (ppAboves (map (pprCoreBinding ppr_style) binds2)))
 273                 >>
 274             hPutStr stderr "\n"
 275          else
 276             return ()) >>
 277         let
 278             linted_binds = core_linter what spec_done binds2
 279         in
 280         return
 281         (linted_binds,  -- processed binds, possibly run thru CoreLint
 282          us2,           -- UniqueSupply for the next guy
 283          inline_env2,   -- possibly-updated inline env
 284          spec_data2,    -- possibly-updated specialisation info
 285          simpl_stats2   -- accumulated simplifier stats
 286         )
 287
 288 -- here so it can be inlined...
 289 foldl_mn f z []     = return z
 290 foldl_mn f z (x:xs) = f z x     >>= \ zz ->
 291                      foldl_mn f zz xs
 292 \end{code}
 293
 294 --- ToDo: maybe move elsewhere ---
 295
 296 For top-level, exported binders that either (a)~have been INLINEd by
 297 the programmer or (b)~are sufficiently ``simple'' that they should be
 298 inlined, we want to record this info in a suitable IdEnv.
 299
 300 But: if something has a ``wrapper unfolding,'' we do NOT automatically
 301 give it a regular unfolding (exception below).  We usually assume its
 302 worker will get a ``regular'' unfolding.  We can then treat these two
 303 levels of unfolding separately (we tend to be very friendly towards
 304 wrapper unfoldings, for example), giving more fine-tuned control.
 305
 306 The exception is: If the ``regular unfolding'' mentions no other
 307 global Ids (i.e., it's all PrimOps and cases and local Ids) then we
 308 assume it must be really good and we take it anyway.
 309
 310 We also need to check that everything in the RHS (values and types)
 311 will be visible on the other side of an interface, too.
 312
 313 \begin{code}
 314 calcInlinings :: Bool   -- True => inlinings with _scc_s are OK
 315               -> IdEnv UnfoldingDetails
 316               -> [CoreBinding]
 317               -> IdEnv UnfoldingDetails
 318
 319 calcInlinings scc_s_OK inline_env_so_far top_binds
 320   = let
 321         result = foldl calci inline_env_so_far top_binds
 322     in
 323     --pprTrace "inline env:\n" (ppAboves (map pp_item (getIdEnvMapping result)))
 324     result
 325   where
 326     pp_item (binder, details)
 327       = ppCat [ppr PprDebug binder, ppStr "=>", pp_det details]
 328       where
 329         pp_det NoUnfoldingDetails   = ppStr "_N_"
 330 --LATER:        pp_det (IWantToBeINLINEd _) = ppStr "INLINE"
 331         pp_det (GenForm _ _ expr guide)
 332           = ppAbove (ppr PprDebug guide) (ppr PprDebug expr)
 333         pp_det other                = ppStr "???"
 334
 335     ------------
 336     my_trace =  if opt_ReportWhyUnfoldingsDisallowed
 337                 then trace
 338                 else \ msg stuff -> stuff
 339
 340     (unfolding_creation_threshold, explicit_creation_threshold)
 341       = case opt_UnfoldingCreationThreshold of
 342           Nothing -> (uNFOLDING_CREATION_THRESHOLD, False)
 343           Just xx -> (xx, True)
 344
 345     unfold_use_threshold
 346       = case opt_UnfoldingUseThreshold of
 347           Nothing -> uNFOLDING_USE_THRESHOLD
 348           Just xx -> xx
 349
 350     unfold_override_threshold
 351       = case opt_UnfoldingOverrideThreshold of
 352           Nothing -> uNFOLDING_OVERRIDE_THRESHOLD
 353           Just xx -> xx
 354
 355     con_discount_weight = uNFOLDING_CON_DISCOUNT_WEIGHT
 356
 357     calci inline_env (Rec pairs)
 358       = foldl (calc True{-recursive-}) inline_env pairs
 359
 360     calci inline_env bind@(NonRec binder rhs)
 361       = calc False{-not recursive-} inline_env (binder, rhs)
 362
 363     ---------------------------------------
 364
 365     calc is_recursive inline_env (binder, rhs)
 366       | not (toplevelishId binder)
 367       = --pprTrace "giving up on not top-level:" (ppr PprDebug binder)
 368         ignominious_defeat
 369
 370       | rhs_mentions_an_unmentionable
 371       || (not explicit_INLINE_requested
 372           && (rhs_looks_like_a_caf || guidance_says_don't || guidance_size_too_big))
 373       = let
 374             my_my_trace
 375               = if explicit_INLINE_requested
 376                 && not (isWrapperId binder) -- these always claim to be INLINEd
 377                 && not have_inlining_already
 378                 then trace                  -- we'd better have a look...
 379                 else my_trace
 380
 381             which = if scc_s_OK then " (late):" else " (early):"
 382         in
 383         my_my_trace ("unfolding disallowed for"++which++(ppShow 80 (ppr PprDebug binder))) (
 384         ignominious_defeat
 385         )
 386
 387       | rhs `isWrapperFor` binder
 388         -- Don't add an explicit "unfolding"; let the worker/wrapper
 389         -- stuff do its thing.  INLINE things don't get w/w'd, so
 390         -- they will be OK.
 391       = ignominious_defeat
 392
 393 #if ! OMIT_DEFORESTER
 394         -- For the deforester: bypass the barbed wire for recursive
 395         -- functions that want to be inlined and are tagged deforestable
 396         -- by the user, allowing these things to be communicated
 397         -- across module boundaries.
 398
 399       | is_recursive &&
 400         explicit_INLINE_requested &&
 401         deforestable binder &&
 402         scc_s_OK                        -- hack, only get them in
 403                                         -- calc_inlinings2
 404       = glorious_success UnfoldAlways
 405 #endif
 406
 407       | is_recursive && not rhs_looks_like_a_data_val
 408         -- The only recursive defns we are prepared to tolerate at the
 409         -- moment is top-level very-obviously-a-data-value ones.
 410         -- We *need* these for dictionaries to be exported!
 411       = --pprTrace "giving up on rec:" (ppr PprDebug binder)
 412         ignominious_defeat
 413
 414         -- Not really interested unless it's exported, but doing it
 415         -- this way (not worrying about export-ness) gets us all the
 416         -- workers/specs, etc., too; which we will need for generating
 417         -- interfaces.  We are also not interested if this binder is
 418         -- in the environment we already have (perhaps from a previous
 419         -- run of calcInlinings -- "earlier" is presumed to mean
 420         -- "better").
 421
 422       | explicit_INLINE_requested
 423       = glorious_success UnfoldAlways
 424
 425       | otherwise
 426       = glorious_success guidance
 427
 428       where
 429         guidance
 430           = calcUnfoldingGuidance scc_s_OK max_out_threshold rhs
 431           where
 432             max_out_threshold = if explicit_INLINE_requested
 433                                 then 100000 -- you asked for it, you got it
 434                                 else unfolding_creation_threshold
 435
 436         guidance_size
 437           = case guidance of
 438               UnfoldAlways                -> 0 -- *extremely* small
 439               EssentialUnfolding          -> 0 -- ditto
 440               UnfoldIfGoodArgs _ _ _ size -> size
 441
 442         guidance_says_don't = case guidance of { UnfoldNever -> True; _ -> False }
 443
 444         guidance_size_too_big
 445             -- Does the guidance suggest that this unfolding will
 446             -- be of no use *no matter* the arguments given to it?
 447             -- Could be more sophisticated...
 448           = case guidance of
 449               UnfoldAlways       -> False
 450               EssentialUnfolding -> False
 451               UnfoldIfGoodArgs _ no_val_args arg_info_vec size
 452
 453                 -> if explicit_creation_threshold then
 454                       False     -- user set threshold; don't second-guess...
 455
 456                    else if no_val_args == 0 && rhs_looks_like_a_data_val then
 457                       False     -- we'd like a top-level data constr to be
 458                                 -- visible even if it is never unfolded
 459                    else
 460                       let
 461                           cost
 462                             = leastItCouldCost con_discount_weight size no_val_args
 463                                 arg_info_vec rhs_arg_tys
 464                       in
 465 --                    (if (unfold_use_threshold < cost) then (pprTrace "cost:" (ppInt cost)) else \x->x ) (
 466                       unfold_use_threshold < cost
 467 --                    )
 468
 469
 470         rhs_looks_like_a_caf = not (manifestlyWHNF rhs)
 471
 472         rhs_looks_like_a_data_val
 473           = case (collectBinders rhs) of
 474               (_, _, [], Con _ _) -> True
 475               other               -> False
 476
 477         rhs_arg_tys
 478           = case (collectBinders rhs) of
 479               (_, _, val_binders, _) -> map idType val_binders
 480
 481         (mentioned_ids, _, _, mentions_litlit)
 482           = mentionedInUnfolding (\x -> x) rhs
 483
 484         rhs_mentions_an_unmentionable
 485           = foldBag (||) unfoldingUnfriendlyId False mentioned_ids
 486             || mentions_litlit
 487             -- ToDo: probably need to chk tycons/classes...
 488
 489         mentions_no_other_ids = isEmptyBag mentioned_ids
 490
 491         explicit_INLINE_requested
 492             -- did it come from a user {-# INLINE ... #-}?
 493             -- (Warning: must avoid including wrappers.)
 494           = idWantsToBeINLINEd binder
 495             && not (rhs `isWrapperFor` binder)
 496
 497         have_inlining_already = maybeToBool (lookupIdEnv inline_env binder)
 498
 499         ignominious_defeat = inline_env  -- just give back what we got
 500
 501         {-
 502             "glorious_success" is ours if we've found a suitable unfolding.
 503
 504             But we check for a couple of fine points.
 505
 506             (1) If this Id already has an inlining in the inline_env,
 507                 we don't automatically take it -- the earlier one is
 508                 "likely" to be better.
 509
 510                 But if the new one doesn't mention any other global
 511                 Ids, and it's pretty small (< UnfoldingOverrideThreshold),
 512                 then we take the chance that the new one *is* better.
 513
 514             (2) If we have an Id w/ a worker/wrapper split (with
 515                 an unfolding for the wrapper), we tend to want to keep
 516                 it -- and *nuke* any inlining that we conjured up
 517                 earlier.
 518
 519                 But, again, if this unfolding doesn't mention any
 520                 other global Ids (and small enough), then it is
 521                 probably better than the worker/wrappery, so we take
 522                 it.
 523         -}
 524         glorious_success guidance
 525           = let
 526                 new_env = addOneToIdEnv inline_env binder (mkUnfolding guidance rhs)
 527
 528                 foldr_building = opt_FoldrBuildOn
 529             in
 530             if (not have_inlining_already) then
 531                 -- Not in env: we take it no matter what
 532                 -- NB: we could check for worker/wrapper-ness,
 533                 -- but the truth is we probably haven't run
 534                 -- the strictness analyser yet.
 535                 new_env
 536
 537             else if explicit_INLINE_requested then
 538                 -- If it was a user INLINE, then we know it's already
 539                 -- in the inline_env; we stick with what we already
 540                 -- have.
 541                 --pprTrace "giving up on INLINE:" (ppr PprDebug binder)
 542                 ignominious_defeat
 543
 544             else if isWrapperId binder then
 545                 -- It's in the env, but we have since worker-wrapperised;
 546                 -- we either take this new one (because it's so good),
 547                 -- or we *undo* the one in the inline_env, so the
 548                 -- wrapper-inlining will take over.
 549
 550                 if mentions_no_other_ids {- *** && size <= unfold_override_threshold -} then
 551                     new_env
 552                 else
 553                     delOneFromIdEnv inline_env binder
 554
 555             else
 556                 -- It's in the env, nothing to do w/ worker wrapper;
 557                 -- we'll take it if it is better.
 558
 559                 if not foldr_building   -- ANDY hates us... (see below)
 560                 && mentions_no_other_ids
 561                 && guidance_size <= unfold_override_threshold then
 562                     new_env
 563                 else
 564                     --pprTrace "giving up on final hurdle:" (ppCat [ppr PprDebug binder, ppInt guidance_size, ppInt unfold_override_threshold])
 565                     ignominious_defeat -- and at the last hurdle, too!
 566 \end{code}
 567
 568 ANDY, on the hatred of the check above; why obliterate it?  Consider
 569
 570  head xs = foldr (\ x _ -> x) (_|_) xs
 571
 572 This then is exported via a pragma. However,
 573 *if* you include the extra code above, you will
 574 export the non-foldr/build version.