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