ghc/compiler/main/Main.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
   3 %
   4 \section[GHC_Main]{Main driver for Glasgow Haskell compiler}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module Main (
  10 #ifdef __GLASGOW_HASKELL__
  11         mainPrimIO
  12 #else
  13         main
  14 #endif
  15     ) where
  16
  17 import MainMonad
  18 import CmdLineOpts
  19
  20 import AbsCSyn
  21 import AbsPrel          ( builtinNameInfo )
  22 import AbsSyn
  23 import AbsUniType       ( isDataTyCon, TauType(..), UniType, TyVar, TyCon, Class )
  24 import Bag              ( emptyBag, isEmptyBag, Bag )
  25 import CE               ( CE(..), UniqFM )
  26 import CodeGen          ( codeGen )
  27 import CoreToStg        ( topCoreBindsToStg )
  28 import Desugar          ( deSugar )
  29 import DsMonad          ( DsMatchContext, DsMatchKind, pprDsWarnings )
  30 import E                ( getE_TCE, E, GVE(..) )
  31                                 -- most of above needed by mkInterface
  32 #ifndef DPH
  33 import Errors           ( pprBagOfErrors, Error(..) )
  34 #else
  35 import Errors           ( pprBagOfErrors, pprPodizedWarning, Error(..) )
  36 #endif {- Data Parallel Haskell -}
  37 import Id               ( mkInstId, Id, Inst )
  38 import Maybes           ( maybeToBool, Maybe(..), MaybeErr(..) )
  39 import MkIface          ( mkInterface )
  40 import Outputable
  41 import PlainCore        ( CoreExpr, CoreBinding, pprPlainCoreBinding,
  42                           PlainCoreProgram(..), PlainCoreBinding(..)
  43                         )
  44 import Pretty
  45
  46 #ifdef USE_NEW_READER
  47 import ReadPrefix2      ( rdModule )
  48 #else
  49 import {-hide from mkdependHS-}
  50         ReadPrefix      ( rdModule )
  51 #endif
  52 import Rename           -- renameModule ...
  53 import SimplCore        -- core2core
  54 import SimplStg         ( stg2stg )
  55 --ANDY: import SimplHaskell
  56 import StgSyn           ( pprPlainStgBinding, StgBinding, StgRhs, CostCentre,
  57                           StgBinderInfo, PlainStgProgram(..), PlainStgBinding(..)
  58                         )
  59 import TCE              ( rngTCE, {- UNUSED: printTypeInfoForPop,-} TCE(..)
  60                           IF_ATTACK_PRAGMAS(COMMA eltsUFM)
  61                         )
  62 import Typecheck        -- typecheckModule ...
  63 import SplitUniq
  64 import Unique           -- lots of UniqueSupplies, etc.
  65 import Util
  66
  67 #if ! OMIT_NATIVE_CODEGEN
  68 import AsmCodeGen       ( dumpRealAsm
  69 # if __GLASGOW_HASKELL__
  70                           , writeRealAsm
  71 # endif
  72                         )
  73 #endif
  74
  75 #ifdef USE_SEMANTIQUE_STRANAL
  76 import ProgEnv          ( ProgEnv(..), TreeProgEnv(..), createProgEnv )
  77 import StrAnal          ( ppShowStrAnal, OAT )
  78 #endif
  79 #ifdef DPH
  80 import PodizeCore       ( podizeCore , PodWarning)
  81 import AbsCTopApal      ( nuAbsCToApal )
  82 import NextUsed         ( pprTopNextUsedC, getTopLevelNexts, AbsCNextUsed,
  83                           TopAbsCNextUsed(..) , MagicId)
  84
  85 #endif {- Data Parallel Haskell -}
  86 \end{code}
  87
  88 \begin{code}
  89 #ifndef __GLASGOW_HASKELL__
  90 main :: Dialogue
  91
  92 main = mainIOtoDialogue main_io
  93
  94 main_io :: MainIO ()
  95 main_io
  96 #else
  97 mainPrimIO
  98 #endif
  99   = BSCC("mainIO")
 100     BSCC("rdInput") readMn stdin ESCC   `thenMn` \ input_pgm ->
 101     getArgsMn                           `thenMn` \ raw_cmd_line ->
 102     classifyOpts raw_cmd_line           `thenMn` \ cmd_line_info ->
 103     BSCC("doPasses")
 104     doIt cmd_line_info input_pgm
 105     ESCC ESCC
 106 \end{code}
 107
 108 \begin{code}
 109 doIt :: CmdLineInfo -> String -> MainIO ()
 110 #ifndef DPH
 111 doIt (switch_lookup_fn, core_cmds, stg_cmds) input_pgm
 112 #else
 113 doIt (switch_lookup_fn, core_cmds, podize_cmds, pcore_cmds, stg_cmds) input_pgm
 114 #endif {- Data Parallel Haskell -}
 115   --
 116   -- Help functions and boring global variables (e.g., printing style)
 117   -- are figured out first; the "business end" follows, in the
 118   -- body of the let.
 119   --
 120   = let
 121         -- ****** help functions:
 122
 123         switch_is_on switch = switchIsOn switch_lookup_fn switch
 124
 125         string_switch_is_on switch
 126           = maybeToBool (stringSwitchSet switch_lookup_fn switch)
 127
 128         show_pass
 129           = if switch_is_on D_show_passes
 130             then \ what -> writeMn stderr ("*** "++what++":\n")
 131             else \ what -> returnMn ()
 132
 133         doOutput switch io_action
 134           = BSCC("doOutput")
 135             case (stringSwitchSet switch_lookup_fn switch) of
 136               Nothing    -> returnMn ()
 137               Just fname ->
 138                 fopen fname "a+"        `thenMn` \ file ->
 139                 if (file == ``NULL'') then
 140                     error ("doOutput: failed to open:"++fname)
 141                 else
 142                     io_action file              `thenMn` \ () ->
 143                     fclose file                 `thenMn` \ status ->
 144                     if status == 0
 145                     then returnMn ()
 146                     else error ("doOutput: closed failed: "{-++show status++" "-}++fname)
 147             ESCC
 148
 149         doDump switch hdr string
 150           = BSCC("doDump")
 151             if (switch_is_on switch)
 152             then writeMn stderr hdr             `thenMn_`
 153                  writeMn stderr ('\n': string)  `thenMn_`
 154                  writeMn stderr "\n"
 155             else returnMn ()
 156             ESCC
 157
 158         -- ****** printing styles and column width:
 159
 160         pprCols = (80 :: Int) -- could make configurable
 161
 162         (pprStyle, pprErrorsStyle)
 163           = if      switch_is_on PprStyle_All   then
 164                     (PprShowAll, PprShowAll)
 165             else if switch_is_on PprStyle_Debug then
 166                     (PprDebug, PprDebug)
 167             else if switch_is_on PprStyle_User  then
 168                     (PprForUser, PprForUser)
 169             else -- defaults...
 170                     (PprDebug, PprForUser)
 171
 172         pp_show p = ppShow {-WAS:pprCols-}10000{-random-} p
 173     in
 174     -- non-tuple-ish bindings...
 175
 176         -- ****** possibly fiddle builtin namespaces:
 177
 178     BIND (BSCC("builtinEnv")
 179           builtinNameInfo switch_is_on {-switch looker-upper-}
 180           ESCC
 181          )
 182       _TO_ (init_val_lookup_fn, init_tc_lookup_fn) ->
 183
 184     -- **********************************************
 185     -- Welcome to the business end of the main module
 186     -- of the Glorious Glasgow Haskell compiler!
 187     -- **********************************************
 188 #ifndef DPH
 189     doDump Verbose "Glasgow Haskell Compiler, version 0.27" "" `thenMn_`
 190 #else
 191     doDump Verbose "Data Parallel Haskell Compiler, version 0.06 (Glasgow 0.27)" ""
 192         `thenMn_`
 193 #endif {- Data Parallel Haskell -}
 194
 195     -- ******* READER
 196     show_pass "Read" `thenMn_`
 197 #ifdef USE_NEW_READER
 198     BSCC("rdModule")
 199     rdModule
 200     ESCC
 201         `thenMn` \ (mod_name, export_list_fns, absyn_tree) ->
 202
 203     BIND (\x -> x) _TO_ bar_foo ->
 204     -- so BINDs and BENDs add up...
 205 #else
 206     BIND BSCC("rdModule")
 207          rdModule input_pgm
 208          ESCC
 209     _TO_ (mod_name, export_list_fns, absyn_tree) ->
 210 #endif
 211     let
 212         -- reader things used (much?) later
 213         ds_mod_name = mod_name
 214         if_mod_name = mod_name
 215         co_mod_name = mod_name
 216         st_mod_name = mod_name
 217         cc_mod_name = mod_name
 218         -- also: export_list_fns
 219     in
 220     doDump D_source_stats "\nSource Statistics:"
 221                          (pp_show (ppSourceStats absyn_tree)) `thenMn_`
 222
 223     doDump D_dump_rif2hs "Parsed, Haskellised:"
 224                          (pp_show (ppr pprStyle absyn_tree))  `thenMn_`
 225
 226     -- UniqueSupplies for later use
 227     getSplitUniqSupplyMn 'r'    `thenMn` \ rn_uniqs ->  -- renamer
 228     getSplitUniqSupplyMn 't'    `thenMn` \ tc_uniqs ->  -- typechecker
 229     getSplitUniqSupplyMn 'd'    `thenMn` \ ds_uniqs ->  -- desugarer
 230     getSplitUniqSupplyMn 's'    `thenMn` \ sm_uniqs ->  -- core-to-core simplifier
 231     getSplitUniqSupplyMn 'C'    `thenMn` \ c2s_uniqs -> -- core-to-stg
 232     getSplitUniqSupplyMn 'T'    `thenMn` \ st_uniqs ->  -- stg-to-stg passes
 233     getSplitUniqSupplyMn 'F'    `thenMn` \ fl_uniqs ->  -- absC flattener
 234     getSplitUniqSupplyMn 'P'    `thenMn` \ prof_uniqs -> -- profiling tidy-upper
 235     getSplitUniqSupplyMn 'L'    `thenMn` \ pre_ncg_uniqs -> -- native-code generator
 236     let
 237         ncg_uniqs = {-mkUniqueSupplyGrimily-} pre_ncg_uniqs
 238     in
 239     -- ******* RENAMER
 240     show_pass "Rename" `thenMn_`
 241     BIND BSCC("Renamer")
 242          renameModule switch_is_on
 243                       (init_val_lookup_fn, init_tc_lookup_fn)
 244                       absyn_tree
 245                       rn_uniqs
 246          ESCC
 247     _TO_ (mod4, import_names, final_name_funs, rn_errs_bag) ->
 248     let
 249         -- renamer things used (much?) later
 250         cc_import_names = import_names
 251     in
 252
 253     doDump D_dump_rn4 "Renamer-pass4:"
 254                         (pp_show (ppr pprStyle mod4))   `thenMn_`
 255
 256     if (not (isEmptyBag rn_errs_bag)) then
 257         -- Stop right here
 258         writeMn stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle rn_errs_bag))
 259         `thenMn_` writeMn stderr "\n"
 260         `thenMn_` exitMn 1
 261
 262     else -- No renaming errors, carry on with...
 263
 264     -- ******* TYPECHECKER
 265     show_pass "TypeCheck" `thenMn_`
 266     BIND (case BSCC("TypeChecker")
 267                typecheckModule switch_is_on tc_uniqs final_name_funs mod4
 268                ESCC
 269           of
 270             Succeeded stuff
 271                 -> (emptyBag, stuff)
 272             Failed tc_errs_bag
 273                 -> (tc_errs_bag,
 274                     panic "main: tickled tc_results even though there were errors"))
 275
 276     _TO_ (tc_errs_bag, tc_results) ->
 277
 278     let
 279         ppr_b :: (Inst, TypecheckedExpr) -> Pretty
 280         ppr_b (i,e) = ppr pprStyle (VarMonoBind (mkInstId i) e)
 281     in
 282     if (not (isEmptyBag tc_errs_bag)) then
 283         -- Must stop *before* trying to dump tc output, because
 284         -- if it fails it does not give you any useful stuff back!
 285         writeMn stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle tc_errs_bag))
 286         `thenMn_` writeMn stderr "\n"
 287         `thenMn_` exitMn 1
 288
 289     else ( -- No typechecking errors either -- so, go for broke!
 290
 291     BIND tc_results
 292     _TO_  (typechecked_quad@(class_binds, inst_binds, val_binds, const_binds),
 293            interface_stuff@(_,_,_,_,_),  -- @-pat just for strictness...
 294            pragma_tycon_specs, {-UNUSED:big_env,-} this_mod_env, ddump_deriv) ->
 295     let
 296 --      big_tce  = getE_TCE big_env
 297 --      big_elts = rngTCE big_tce
 298
 299         this_mod_tce  = getE_TCE this_mod_env
 300         this_mod_elts = rngTCE this_mod_tce
 301
 302         local_tycons = [tc | tc <- this_mod_elts,
 303                                    isLocallyDefined tc, -- from this module only
 304                                    isDataTyCon tc ]     -- algebraic types only
 305     in
 306 --    pprTrace "Envs:" (ppAboves [
 307 --      ppr pprStyle if_global_ids,
 308 --      ppr pprStyle if_tce,
 309 --      ppr pprStyle if_ce,
 310 --      ppr pprStyle this_mod_env,
 311 --      ppr pprStyle big_env
 312 --      ]) (
 313
 314     doDump D_dump_tc "Typechecked:"
 315                       (pp_show
 316                         (ppAboves [ppr pprStyle class_binds,
 317                                    ppr pprStyle inst_binds,
 318                                    ppAboves (map ppr_b const_binds),
 319                                    ppr pprStyle val_binds]))    `thenMn_`
 320
 321     doDump D_dump_deriv   "Derived instances:"
 322                           (pp_show (ddump_deriv pprStyle))      `thenMn_`
 323
 324 --NOT REALLY USED:
 325 --  doDump D_dump_type_info "" (pp_show (printTypeInfoForPop big_tce)) `thenMn_`
 326     -- ******* DESUGARER
 327     show_pass "DeSugar" `thenMn_`
 328     let
 329         (desugared,ds_warnings)
 330           = BSCC("DeSugarer")
 331             deSugar ds_uniqs switch_lookup_fn ds_mod_name typechecked_quad
 332             ESCC
 333     in
 334     (if isEmptyBag ds_warnings then
 335         returnMn ()
 336      else
 337         writeMn stderr (ppShow pprCols (pprDsWarnings pprErrorsStyle ds_warnings))
 338         `thenMn_` writeMn stderr "\n"
 339     ) `thenMn_`
 340
 341     doDump D_dump_ds "Desugared:" (pp_show (ppAboves
 342                         (map (pprPlainCoreBinding pprStyle) desugared)))   `thenMn_`
 343
 344     -- ******* CORE-TO-CORE SIMPLIFICATION (NB: I/O op)
 345     core2core core_cmds switch_lookup_fn co_mod_name pprStyle
 346               sm_uniqs local_tycons pragma_tycon_specs desugared
 347                 `thenMn` \ (simplified, inlinings_env,
 348                             SpecData _ _ _ gen_tycons all_tycon_specs _ _ _) ->
 349
 350     doDump D_dump_simpl "Simplified:" (pp_show (ppAboves
 351                         (map (pprPlainCoreBinding pprStyle) simplified)))   `thenMn_`
 352
 353 -- ANDY:
 354 --  doDump D_dump_core_passes_info "(Haskell) Simplified:"
 355 --                      (coreToHaskell simplified)                          `thenMn_`
 356
 357 #ifdef DPH
 358     -- ******* PODIZE (VECTORIZE) THE CORE PROGRAM
 359     let
 360         (warn,podized) = BSCC("PodizeCore")
 361                          podizeCore podize_cmds switch_is_on
 362                                     uniqSupply_p simplified
 363                          ESCC
 364     in
 365     (if (not (null warn))
 366      then writeMn stderr "\n"                                               `thenMn_`
 367           writeMn stderr (ppShow pprCols (ppAboves
 368                     (map (\w -> pprPodizedWarning w pprErrorsStyle) warn))) `thenMn_`
 369           writeMn stderr "\n"
 370      else returnMn ())                                                      `thenMn_`
 371
 372     doDump D_dump_pod   "Podization:" (pp_show (ppAboves
 373                      (map (pprPlainCoreBinding pprStyle) podized)))         `thenMn_`
 374
 375     -- ******** CORE-TO-CORE SIMPLIFICATION OF PODIZED PROGRAM
 376     let
 377         psimplified = BSCC("PodizeCore2Core")
 378                       core2core pcore_cmds switch_is_on pprStyle
 379                                 uniqSupply_S podized
 380                       ESCC
 381     in
 382     doDump D_dump_psimpl "Par Simplified:" (pp_show (ppAboves
 383                         (map (pprPlainCoreBinding pprStyle) psimplified)))  `thenMn_`
 384
 385 #endif {- Data Parallel Haskell -}
 386
 387 #ifdef USE_SEMANTIQUE_STRANAL
 388     -- ******* SEMANTIQUE STRICTNESS ANALYSER
 389     doDump D_dump_stranal_sem "Strictness:" (ppShowStrAnal simplified big_env) `thenMn_`
 390 #endif
 391
 392     -- ******* STG-TO-STG SIMPLIFICATION
 393     show_pass "Core2Stg" `thenMn_`
 394     let
 395 #ifndef DPH
 396         stg_binds   = BSCC("Core2Stg")
 397                       topCoreBindsToStg c2s_uniqs simplified
 398                       ESCC
 399 #else
 400         stg_binds   = BSCC("Core2Stg")
 401                       topCoreBindsToStg c2s_uniqs psimplified
 402                       ESCC
 403 #endif {- Data Parallel Haskell -}
 404     in
 405     show_pass "Stg2Stg" `thenMn_`
 406     stg2stg stg_cmds switch_lookup_fn st_mod_name pprStyle st_uniqs stg_binds
 407                         `thenMn` \ (stg_binds2, cost_centre_info) ->
 408
 409     doDump D_dump_stg "STG syntax:" (pp_show (ppAboves
 410                       (map (pprPlainStgBinding pprStyle) stg_binds2)))  `thenMn_`
 411
 412     -- ******* INTERFACE GENERATION (needs STG output)
 413 {-  let
 414         mod_name = "_TestName_"
 415         export_list_fns = (\ x -> False, \ x -> False)
 416         inlinings_env = nullIdEnv
 417         fixities = []
 418         if_global_ids = []
 419         if_ce = nullCE
 420         if_tce = nullTCE
 421         if_inst_info = emptyBag
 422     in
 423 -}
 424     show_pass "Interface" `thenMn_`
 425     let
 426         mod_interface
 427           = BSCC("MkInterface")
 428             mkInterface switch_is_on if_mod_name export_list_fns
 429                         inlinings_env all_tycon_specs
 430                         interface_stuff
 431                         stg_binds2
 432             ESCC
 433     in
 434     doOutput ProduceHi BSCC("PrintInterface")
 435                        ( \ file ->
 436                          ppAppendFile file 1000{-pprCols-} mod_interface )
 437                        ESCC                                             `thenMn_`
 438
 439     -- ******* "ABSTRACT", THEN "FLAT", THEN *REAL* C!
 440     show_pass "CodeGen" `thenMn_`
 441     let
 442         abstractC      = BSCC("CodeGen")
 443                          codeGen cc_mod_name     -- module name for CC labelling
 444                                  cost_centre_info
 445                                  cc_import_names -- import names for CC registering
 446                                  switch_lookup_fn
 447                                  gen_tycons      -- type constructors generated locally
 448                                  all_tycon_specs -- tycon specialisations
 449                                  stg_binds2
 450                          ESCC
 451
 452         flat_abstractC = BSCC("FlattenAbsC")
 453                          flattenAbsC fl_uniqs abstractC
 454                          ESCC
 455     in
 456     doDump D_dump_absC  "Abstract C:" (dumpRealC switch_is_on abstractC)   `thenMn_`
 457
 458     doDump D_dump_flatC "Flat Abstract C:" (dumpRealC switch_is_on flat_abstractC) `thenMn_`
 459
 460     -- You can have C (c_output) or assembly-language (ncg_output),
 461     -- but not both.  [Allowing for both gives a space leak on
 462     -- flat_abstractC.  WDP 94/10]
 463     let
 464         (flat_absC_c, flat_absC_ncg) =
 465            case (string_switch_is_on ProduceC || switch_is_on D_dump_realC,
 466                  string_switch_is_on ProduceS || switch_is_on D_dump_asm) of
 467              (True,  False) -> (flat_abstractC, AbsCNop)
 468              (False, True)  -> (AbsCNop, flat_abstractC)
 469              (False, False) -> (AbsCNop, AbsCNop)
 470              (True,  True)  -> error "ERROR: Can't do both .hc and .s at the same time"
 471
 472         c_output_d = BSCC("PrintRealC")
 473                      dumpRealC switch_is_on flat_absC_c
 474                      ESCC
 475
 476 #ifdef __GLASGOW_HASKELL__
 477         c_output_w = BSCC("PrintRealC")
 478                      (\ f -> writeRealC switch_is_on f flat_absC_c)
 479                      ESCC
 480 #else
 481         c_output_w = c_output_d
 482 #endif
 483
 484 #if OMIT_NATIVE_CODEGEN
 485         ncg_output_d
 486           = error "*** GHC not built with a native-code generator ***"
 487         ncg_output_w = ncg_output_d
 488 #else
 489         ncg_output_d = BSCC("nativeCode")
 490                      dumpRealAsm switch_lookup_fn flat_absC_ncg ncg_uniqs
 491                      ESCC
 492
 493 #ifdef __GLASGOW_HASKELL__
 494         ncg_output_w = BSCC("nativeCode")
 495                      (\ f -> writeRealAsm switch_lookup_fn f flat_absC_ncg ncg_uniqs)
 496                      ESCC
 497 #else
 498         ncg_output_w = ncg_output_d
 499 #endif
 500 #endif
 501     in
 502     doDump D_dump_asm "" ncg_output_d `thenMn_`
 503     doOutput ProduceS    ncg_output_w `thenMn_`
 504
 505 #ifndef DPH
 506     -- ********* GHC Finished !!!!
 507     doDump D_dump_realC "" c_output_d `thenMn_`
 508     doOutput ProduceC      c_output_w `thenMn_`
 509
 510 #else
 511     -- ********* DPH needs native code generator, nearly finished.....
 512     let
 513         next_used_flatC = getTopLevelNexts flat_abstractC []
 514         apal_module     = nuAbsCToApal uniqSupply_L mod_name next_used_flatC
 515     in
 516     doDump D_dump_nextC "Next Used annotated C:" (ppShow pprCols
 517                                 (pprTopNextUsedC next_used_flatC))          `thenMn_`
 518     doOutput ProduceC   ("! /* DAP assembler (APAL): */\n"++apal_module)    `thenMn_`
 519
 520 #endif {- Data Parallel Haskell -}
 521     exitMn 0
 522     {-)-} BEND ) BEND BEND BEND BEND
 523
 524
 525 ppSourceStats (Module name exports imports fixities typedecls typesigs
 526                       classdecls instdecls instsigs defdecls binds
 527                       [{-no sigs-}] src_loc)
 528  = ppAboves (map pp_val
 529                [("ExportAll        ", export_all), -- 1 if no export list
 530                 ("ExportDecls      ", export_ds),
 531                 ("ExportModules    ", export_ms),
 532                 ("ImportAll        ", import_all),
 533                 ("ImportPartial    ", import_partial),
 534                 ("  PartialDecls   ", partial_decls),
 535                 ("ImportHiding     ", import_hiding),
 536                 ("  HidingDecls    ", hiding_decls),
 537                 ("FixityDecls      ", fixity_ds),
 538                 ("DefaultDecls     ", defalut_ds),
 539                 ("TypeDecls        ", type_ds),
 540                 ("DataDecls        ", data_ds),
 541                 ("DataConstrs      ", data_constrs),
 542                 ("DataDerivings    ", data_derivs),
 543                 ("ClassDecls       ", class_ds),
 544                 ("ClassMethods     ", class_method_ds),
 545                 ("DefaultMethods   ", default_method_ds),
 546                 ("InstDecls        ", inst_ds),
 547                 ("InstMethods      ", inst_method_ds),
 548                 ("TypeSigs         ", bind_tys),
 549                 ("ValBinds         ", val_bind_ds),
 550                 ("FunBinds         ", fn_bind_ds),
 551                 ("InlineMeths      ", method_inlines),
 552                 ("InlineBinds      ", bind_inlines),
 553                 ("SpecialisedData  ", data_specs),
 554                 ("SpecialisedInsts ", inst_specs),
 555                 ("SpecialisedMeths ", method_specs),
 556                 ("SpecialisedBinds ", bind_specs)
 557                ])
 558   where
 559     pp_val (str, 0) = ppNil
 560     pp_val (str, n) = ppBesides [ppStr str, ppInt n]
 561
 562     (export_decls, export_mods) = getRawIEStrings exports
 563     type_decls = filter is_type_decl typedecls
 564     data_decls = filter is_data_decl typedecls
 565
 566     export_ds  = length export_decls
 567     export_ms  = length export_mods
 568     export_all = if export_ds == 0 && export_ms == 0 then 1 else 0
 569
 570     fixity_ds  = length fixities
 571     defalut_ds = length defdecls
 572     type_ds    = length type_decls
 573     data_ds    = length data_decls
 574     class_ds   = length classdecls
 575     inst_ds    = length instdecls
 576
 577     (val_bind_ds, fn_bind_ds, bind_tys, bind_specs, bind_inlines)
 578         = count_binds binds
 579
 580     (import_all, import_partial, partial_decls, import_hiding, hiding_decls)
 581         = foldr add5 (0,0,0,0,0) (map import_info imports)
 582     (data_constrs, data_derivs)
 583         = foldr add2 (0,0) (map data_info data_decls)
 584     (class_method_ds, default_method_ds)
 585         = foldr add2 (0,0) (map class_info classdecls)
 586     (inst_method_ds, method_specs, method_inlines)
 587         = foldr add3 (0,0,0) (map inst_info instdecls)
 588
 589     data_specs  = length (filter is_data_spec_sig typesigs)
 590     inst_specs  = length (filter is_inst_spec_sig instsigs)
 591
 592
 593     count_binds EmptyBinds        = (0,0,0,0,0)
 594     count_binds (ThenBinds b1 b2) = count_binds b1 `add5` count_binds b2
 595     count_binds (SingleBind b)    = case count_bind b of
 596                                       (vs,fs) -> (vs,fs,0,0,0)
 597     count_binds (BindWith b sigs) = case (count_bind b, count_sigs sigs) of
 598                                       ((vs,fs),(ts,_,ss,is)) -> (vs,fs,ts,ss,is)
 599
 600     count_bind EmptyBind      = (0,0)
 601     count_bind (NonRecBind b) = count_monobinds b
 602     count_bind (RecBind b)    = count_monobinds b
 603
 604     count_monobinds EmptyMonoBinds       = (0,0)
 605     count_monobinds (AndMonoBinds b1 b2) = count_monobinds b1 `add2` count_monobinds b2
 606     count_monobinds (PatMonoBind (VarPatIn n) r _) = (1,0)
 607     count_monobinds (PatMonoBind p r _)  = (0,1)
 608     count_monobinds (FunMonoBind f m _)  = (0,1)
 609
 610     count_sigs sigs = foldr add4 (0,0,0,0) (map sig_info sigs)
 611
 612     sig_info (Sig _ _ _ _)        = (1,0,0,0)
 613     sig_info (ClassOpSig _ _ _ _) = (0,1,0,0)
 614     sig_info (SpecSig _ _ _ _)    = (0,0,1,0)
 615     sig_info (InlineSig _ _ _)    = (0,0,0,1)
 616     sig_info _                    = (0,0,0,0)
 617
 618     import_info (ImportAll _ _)        = (1,0,0,0,0)
 619     import_info (ImportSome _ ds _)    = (0,1,length ds,0,0)
 620     import_info (ImportButHide _ ds _) = (0,0,0,1,length ds)
 621
 622     data_info (TyData _ _ _ constrs derivs _ _)
 623         = (length constrs, length derivs)
 624
 625     class_info (ClassDecl _ _ _ meth_sigs def_meths _ _)
 626         = case count_sigs meth_sigs of
 627             (_,classops,_,_) ->
 628                (classops, addpr (count_monobinds def_meths))
 629
 630     inst_info (InstDecl _ _ _ inst_meths _ _ _ inst_sigs _ _)
 631         = case count_sigs inst_sigs of
 632             (_,_,ss,is) ->
 633                (addpr (count_monobinds inst_meths), ss, is)
 634
 635     is_type_decl (TySynonym _ _ _ _ _)   = True
 636     is_type_decl _                       = False
 637     is_data_decl (TyData _ _ _ _ _ _ _)  = True
 638     is_data_decl _                       = False
 639     is_data_spec_sig (SpecDataSig _ _ _) = True
 640     is_data_spec_sig _                   = False
 641     is_inst_spec_sig (InstSpecSig _ _ _) = True
 642
 643     addpr (x,y) = x+y
 644     add1 x1 y1  = x1+y1
 645     add2 (x1,x2) (y1,y2) = (x1+y1,x2+y2)
 646     add3 (x1,x2,x3) (y1,y2,y3) = (x1+y1,x2+y2,x3+y3)
 647     add4 (x1,x2,x3,x4) (y1,y2,y3,y4) = (x1+y1,x2+y2,x3+y3,x4+y4)
 648     add5 (x1,x2,x3,x4,x5) (y1,y2,y3,y4,y5) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5)
 649 \end{code}
 650
 651