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           ( PprStyle(..), ppShow, ppAboves, ppAppendFile
  45                           IF_ATTACK_PRAGMAS(COMMA ppAbove)
  46                         )
  47 #ifdef USE_NEW_READER
  48 import ReadPrefix2      ( rdModule )
  49 #else
  50 import {-hide from mkdependHS-}
  51         ReadPrefix      ( rdModule )
  52 #endif
  53 import Rename           -- renameModule ...
  54 import SimplCore        -- core2core
  55 import SimplStg         ( stg2stg )
  56 --ANDY: import SimplHaskell
  57 import StgSyn           ( pprPlainStgBinding, StgBinding, StgRhs, CostCentre,
  58                           StgBinderInfo, PlainStgProgram(..), PlainStgBinding(..)
  59                         )
  60 import TCE              ( rngTCE, {- UNUSED: printTypeInfoForPop,-} TCE(..)
  61                           IF_ATTACK_PRAGMAS(COMMA eltsUFM)
  62                         )
  63 import Typecheck        -- typecheckModule ...
  64 import SplitUniq
  65 import Unique           -- lots of UniqueSupplies, etc.
  66 import Util
  67
  68 #if ! OMIT_NATIVE_CODEGEN
  69 import AsmCodeGen       ( dumpRealAsm
  70 # if __GLASGOW_HASKELL__
  71                           , writeRealAsm
  72 # endif
  73                         )
  74 #endif
  75
  76 #ifdef USE_SEMANTIQUE_STRANAL
  77 import ProgEnv          ( ProgEnv(..), TreeProgEnv(..), createProgEnv )
  78 import StrAnal          ( ppShowStrAnal, OAT )
  79 #endif
  80 #ifdef DPH
  81 import PodizeCore       ( podizeCore , PodWarning)
  82 import AbsCTopApal      ( nuAbsCToApal )
  83 import NextUsed         ( pprTopNextUsedC, getTopLevelNexts, AbsCNextUsed,
  84                           TopAbsCNextUsed(..) , MagicId)
  85
  86 #endif {- Data Parallel Haskell -}
  87 \end{code}
  88
  89 \begin{code}
  90 #ifndef __GLASGOW_HASKELL__
  91 main :: Dialogue
  92
  93 main = mainIOtoDialogue main_io
  94
  95 main_io :: MainIO ()
  96 main_io
  97 #else
  98 mainPrimIO
  99 #endif
 100   = BSCC("mainIO")
 101     BSCC("rdInput") readMn stdin ESCC   `thenMn` \ input_pgm ->
 102     getArgsMn                           `thenMn` \ raw_cmd_line ->
 103     classifyOpts raw_cmd_line           `thenMn` \ cmd_line_info ->
 104     BSCC("doPasses")
 105     doIt cmd_line_info input_pgm
 106     ESCC ESCC
 107 \end{code}
 108
 109 \begin{code}
 110 doIt :: CmdLineInfo -> String -> MainIO ()
 111 #ifndef DPH
 112 doIt (switch_lookup_fn, core_cmds, stg_cmds) input_pgm
 113 #else
 114 doIt (switch_lookup_fn, core_cmds, podize_cmds, pcore_cmds, stg_cmds) input_pgm
 115 #endif {- Data Parallel Haskell -}
 116   --
 117   -- Help functions and boring global variables (e.g., printing style)
 118   -- are figured out first; the "business end" follows, in the
 119   -- body of the let.
 120   --
 121   = let
 122         -- ****** help functions:
 123
 124         switch_is_on switch = switchIsOn switch_lookup_fn switch
 125             -- essentially, converts SwBool answer to Bool
 126
 127         string_switch_is_on switch
 128           = maybeToBool (stringSwitchSet switch_lookup_fn switch)
 129
 130         doOutput switch io_action
 131           = BSCC("doOutput")
 132             case (stringSwitchSet switch_lookup_fn switch) of
 133               Nothing    -> returnMn ()
 134               Just fname ->
 135                 fopen fname "a+"        `thenMn` \ file ->
 136                 if (file == ``NULL'') then
 137                     error ("doOutput: failed to open:"++fname)
 138                 else
 139                     io_action file              `thenMn` \ () ->
 140                     fclose file                 `thenMn` \ status ->
 141                     if status == 0
 142                     then returnMn ()
 143                     else error ("doOutput: closed failed: "{-++show status++" "-}++fname)
 144             ESCC
 145
 146         doDump switch hdr string
 147           = BSCC("doDump")
 148             if (switch_is_on switch)
 149             then writeMn stderr hdr             `thenMn_`
 150                  writeMn stderr ('\n': string)  `thenMn_`
 151                  writeMn stderr "\n"
 152             else returnMn ()
 153             ESCC
 154
 155         -- ****** printing styles and column width:
 156
 157         pprCols = (80 :: Int) -- could make configurable
 158
 159         (pprStyle, pprErrorsStyle)
 160           = if      switch_is_on PprStyle_All   then
 161                     (PprShowAll, PprShowAll)
 162             else if switch_is_on PprStyle_Debug then
 163                     (PprDebug, PprDebug)
 164             else if switch_is_on PprStyle_User  then
 165                     (PprForUser, PprForUser)
 166             else -- defaults...
 167                     (PprDebug, PprForUser)
 168
 169         pp_show p = ppShow {-WAS:pprCols-}10000{-random-} p
 170     in
 171     -- non-tuple-ish bindings...
 172
 173         -- ****** possibly fiddle builtin namespaces:
 174
 175     BIND (BSCC("builtinEnv")
 176           builtinNameInfo switch_is_on {-switch looker-upper-}
 177           ESCC
 178          )
 179       _TO_ (init_val_lookup_fn, init_tc_lookup_fn) ->
 180
 181     -- **********************************************
 182     -- Welcome to the business end of the main module
 183     -- of the Glorious Glasgow Haskell compiler!
 184     -- **********************************************
 185 #ifndef DPH
 186     doDump Verbose "Glasgow Haskell Compiler, version 0.26" "" `thenMn_`
 187 #else
 188     doDump Verbose "Data Parallel Haskell Compiler, version 0.06 (Glasgow 0.26)" ""
 189         `thenMn_`
 190 #endif {- Data Parallel Haskell -}
 191
 192     -- ******* READER
 193 #ifdef USE_NEW_READER
 194     BSCC("rdModule")
 195     rdModule
 196     ESCC
 197         `thenMn` \ (mod_name, export_list_fns, absyn_tree) ->
 198
 199     BIND (\x -> x) _TO_ bar_foo ->
 200     -- so BINDs and BENDs add up...
 201 #else
 202     BIND BSCC("rdModule")
 203          rdModule input_pgm
 204          ESCC
 205     _TO_ (mod_name, export_list_fns, absyn_tree) ->
 206 #endif
 207     let
 208         -- reader things used (much?) later
 209         ds_mod_name = mod_name
 210         if_mod_name = mod_name
 211         co_mod_name = mod_name
 212         st_mod_name = mod_name
 213         cc_mod_name = mod_name
 214         -- also: export_list_fns
 215     in
 216     doDump D_dump_rif2hs "Parsed, Haskellised:"
 217                          (pp_show (ppr pprStyle absyn_tree)) `thenMn_`
 218
 219     -- UniqueSupplies for later use
 220     getSplitUniqSupplyMn 'r'    `thenMn` \ rn_uniqs ->  -- renamer
 221     getSplitUniqSupplyMn 't'    `thenMn` \ tc_uniqs ->  -- typechecker
 222     getSplitUniqSupplyMn 'd'    `thenMn` \ ds_uniqs ->  -- desugarer
 223     getSplitUniqSupplyMn 's'    `thenMn` \ sm_uniqs ->  -- core-to-core simplifier
 224     getSplitUniqSupplyMn 'C'    `thenMn` \ c2s_uniqs -> -- core-to-stg
 225     getSplitUniqSupplyMn 'T'    `thenMn` \ st_uniqs ->  -- stg-to-stg passes
 226     getSplitUniqSupplyMn 'F'    `thenMn` \ fl_uniqs ->  -- absC flattener
 227     getSplitUniqSupplyMn 'P'    `thenMn` \ prof_uniqs -> -- profiling tidy-upper
 228     getSplitUniqSupplyMn 'L'    `thenMn` \ pre_ncg_uniqs -> -- native-code generator
 229     let
 230         ncg_uniqs = {-mkUniqueSupplyGrimily-} pre_ncg_uniqs
 231     in
 232     -- ******* RENAMER
 233     BIND BSCC("Renamer")
 234          renameModule switch_is_on
 235                       (init_val_lookup_fn, init_tc_lookup_fn)
 236                       absyn_tree
 237                       rn_uniqs
 238          ESCC
 239     _TO_ (mod4, import_names, final_name_funs, rn_errs_bag) ->
 240     let
 241         -- renamer things used (much?) later
 242         cc_import_names = import_names
 243     in
 244
 245     doDump D_dump_rn4 "Renamer-pass4:"
 246                         (pp_show (ppr pprStyle mod4))   `thenMn_`
 247
 248     if (not (isEmptyBag rn_errs_bag)) then
 249         -- Stop right here
 250         writeMn stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle rn_errs_bag))
 251         `thenMn_` writeMn stderr "\n"
 252         `thenMn_` exitMn 1
 253
 254     else -- No renaming errors, carry on with...
 255
 256     -- ******* TYPECHECKER
 257     BIND (case BSCC("TypeChecker")
 258                typecheckModule switch_is_on tc_uniqs final_name_funs mod4
 259                ESCC
 260           of
 261             Succeeded stuff
 262                 -> (emptyBag, stuff)
 263             Failed tc_errs_bag
 264                 -> (tc_errs_bag,
 265                     panic "main: tickled tc_results even though there were errors"))
 266
 267     _TO_ (tc_errs_bag, tc_results) ->
 268
 269     let
 270         ppr_b :: (Inst, TypecheckedExpr) -> Pretty
 271         ppr_b (i,e) = ppr pprStyle (VarMonoBind (mkInstId i) e)
 272     in
 273     if (not (isEmptyBag tc_errs_bag)) then
 274         -- Must stop *before* trying to dump tc output, because
 275         -- if it fails it does not give you any useful stuff back!
 276         writeMn stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle tc_errs_bag))
 277         `thenMn_` writeMn stderr "\n"
 278         `thenMn_` exitMn 1
 279
 280     else ( -- No typechecking errors either -- so, go for broke!
 281
 282     BIND tc_results
 283     _TO_  (typechecked_quad@(class_binds, inst_binds, val_binds, const_binds),
 284            interface_stuff@(_,_,_,_,_),  -- @-pat just for strictness...
 285            tycon_specs, {-UNUSED:big_env,-} this_mod_env, ddump_deriv) ->
 286     let
 287 --      big_tce  = getE_TCE big_env
 288 --      big_elts = rngTCE big_tce
 289
 290         this_mod_tce  = getE_TCE this_mod_env
 291         this_mod_elts = rngTCE this_mod_tce
 292
 293         local_tycons = [tc | tc <- this_mod_elts,
 294                                    isLocallyDefined tc, -- from this module only
 295                                    isDataTyCon tc ]     -- algebraic types only
 296     in
 297 --    pprTrace "Envs:" (ppAboves [
 298 --      ppr pprStyle if_global_ids,
 299 --      ppr pprStyle if_tce,
 300 --      ppr pprStyle if_ce,
 301 --      ppr pprStyle this_mod_env,
 302 --      ppr pprStyle big_env
 303 --      ]) (
 304
 305     doDump D_dump_tc "Typechecked:"
 306                       (pp_show
 307                         (ppAboves [ppr pprStyle class_binds,
 308                                    ppr pprStyle inst_binds,
 309                                    ppAboves (map ppr_b const_binds),
 310                                    ppr pprStyle val_binds]))    `thenMn_`
 311
 312     doDump D_dump_deriv   "Derived instances:"
 313                           (pp_show (ddump_deriv pprStyle))      `thenMn_`
 314
 315 --NOT REALLY USED:
 316 --  doDump D_dump_type_info "" (pp_show (printTypeInfoForPop big_tce)) `thenMn_`
 317     -- ******* DESUGARER
 318     let
 319         (desugared,ds_warnings)
 320           = BSCC("DeSugarer")
 321             deSugar ds_uniqs switch_lookup_fn ds_mod_name typechecked_quad
 322             ESCC
 323     in
 324     (if isEmptyBag ds_warnings then
 325         returnMn ()
 326      else
 327         writeMn stderr (ppShow pprCols (pprDsWarnings pprErrorsStyle ds_warnings))
 328         `thenMn_` writeMn stderr "\n"
 329     ) `thenMn_`
 330
 331     doDump D_dump_ds "Desugared:" (pp_show (ppAboves
 332                         (map (pprPlainCoreBinding pprStyle) desugared)))   `thenMn_`
 333
 334     -- ******* CORE-TO-CORE SIMPLIFICATION (NB: I/O op)
 335     core2core core_cmds switch_lookup_fn co_mod_name pprStyle
 336               sm_uniqs local_tycons tycon_specs desugared
 337                 `thenMn` \ (simplified, inlinings_env,
 338                             SpecData _ _ _ gen_tycons all_tycon_specs
 339                                      spec_errs spec_warn spec_tyerrs) ->
 340
 341     doDump D_dump_simpl "Simplified:" (pp_show (ppAboves
 342                         (map (pprPlainCoreBinding pprStyle) simplified)))   `thenMn_`
 343
 344 -- ANDY:
 345 --  doDump D_dump_core_passes_info "(Haskell) Simplified:"
 346 --                      (coreToHaskell simplified)                          `thenMn_`
 347
 348 #ifdef DPH
 349     -- ******* PODIZE (VECTORIZE) THE CORE PROGRAM
 350     let
 351         (warn,podized) = BSCC("PodizeCore")
 352                          podizeCore podize_cmds switch_is_on
 353                                     uniqSupply_p simplified
 354                          ESCC
 355     in
 356     (if (not (null warn))
 357      then writeMn stderr "\n"                                               `thenMn_`
 358           writeMn stderr (ppShow pprCols (ppAboves
 359                     (map (\w -> pprPodizedWarning w pprErrorsStyle) warn))) `thenMn_`
 360           writeMn stderr "\n"
 361      else returnMn ())                                                      `thenMn_`
 362
 363     doDump D_dump_pod   "Podization:" (pp_show (ppAboves
 364                      (map (pprPlainCoreBinding pprStyle) podized)))         `thenMn_`
 365
 366     -- ******** CORE-TO-CORE SIMPLIFICATION OF PODIZED PROGRAM
 367     let
 368         psimplified = BSCC("PodizeCore2Core")
 369                       core2core pcore_cmds switch_is_on pprStyle
 370                                 uniqSupply_S podized
 371                       ESCC
 372     in
 373     doDump D_dump_psimpl "Par Simplified:" (pp_show (ppAboves
 374                         (map (pprPlainCoreBinding pprStyle) psimplified)))  `thenMn_`
 375
 376 #endif {- Data Parallel Haskell -}
 377
 378 #ifdef USE_SEMANTIQUE_STRANAL
 379     -- ******* SEMANTIQUE STRICTNESS ANALYSER
 380     doDump D_dump_stranal_sem "Strictness:" (ppShowStrAnal simplified big_env) `thenMn_`
 381 #endif
 382
 383     -- ******* STG-TO-STG SIMPLIFICATION
 384     let
 385 #ifndef DPH
 386         stg_binds   = BSCC("Core2Stg")
 387                       topCoreBindsToStg c2s_uniqs simplified
 388                       ESCC
 389 #else
 390         stg_binds   = BSCC("Core2Stg")
 391                       topCoreBindsToStg c2s_uniqs psimplified
 392                       ESCC
 393 #endif {- Data Parallel Haskell -}
 394     in
 395
 396     stg2stg stg_cmds switch_lookup_fn st_mod_name pprStyle st_uniqs stg_binds
 397                         `thenMn` \ (stg_binds2, cost_centre_info) ->
 398
 399     doDump D_dump_stg "STG syntax:" (pp_show (ppAboves
 400                       (map (pprPlainStgBinding pprStyle) stg_binds2)))  `thenMn_`
 401
 402     -- ******* INTERFACE GENERATION (needs STG output)
 403 {-  let
 404         mod_name = "_TestName_"
 405         export_list_fns = (\ x -> False, \ x -> False)
 406         inlinings_env = nullIdEnv
 407         fixities = []
 408         if_global_ids = []
 409         if_ce = nullCE
 410         if_tce = nullTCE
 411         if_inst_info = emptyBag
 412     in
 413 -}  let
 414         mod_interface
 415           = BSCC("MkInterface")
 416             mkInterface switch_is_on if_mod_name export_list_fns
 417                         inlinings_env all_tycon_specs
 418                         interface_stuff
 419                         stg_binds2
 420             ESCC
 421     in
 422     doOutput ProduceHi BSCC("PrintInterface")
 423                        ( \ file ->
 424                          ppAppendFile file 1000{-pprCols-} mod_interface )
 425                        ESCC                                             `thenMn_`
 426
 427     -- ******* "ABSTRACT", THEN "FLAT", THEN *REAL* C!
 428     let
 429         abstractC      = BSCC("CodeGen")
 430                          codeGen cc_mod_name     -- module name for CC labelling
 431                                  cost_centre_info
 432                                  cc_import_names -- import names for CC registering
 433                                  switch_lookup_fn
 434                                  gen_tycons      -- type constructors generated locally
 435                                  all_tycon_specs -- tycon specialisations
 436                                  stg_binds2
 437                          ESCC
 438
 439         flat_abstractC = BSCC("FlattenAbsC")
 440                          flattenAbsC fl_uniqs abstractC
 441                          ESCC
 442     in
 443     doDump D_dump_absC  "Abstract C:" (dumpRealC switch_is_on abstractC)   `thenMn_`
 444
 445     doDump D_dump_flatC "Flat Abstract C:" (dumpRealC switch_is_on flat_abstractC) `thenMn_`
 446
 447     -- You can have C (c_output) or assembly-language (ncg_output),
 448     -- but not both.  [Allowing for both gives a space leak on
 449     -- flat_abstractC.  WDP 94/10]
 450     let
 451         (flat_absC_c, flat_absC_ncg) =
 452            case (string_switch_is_on ProduceC || switch_is_on D_dump_realC,
 453                  string_switch_is_on ProduceS || switch_is_on D_dump_asm) of
 454              (True,  False) -> (flat_abstractC, AbsCNop)
 455              (False, True)  -> (AbsCNop, flat_abstractC)
 456              (False, False) -> (AbsCNop, AbsCNop)
 457              (True,  True)  -> error "ERROR: Can't do both .hc and .s at the same time"
 458
 459         c_output_d = BSCC("PrintRealC")
 460                      dumpRealC switch_is_on flat_absC_c
 461                      ESCC
 462
 463 #ifdef __GLASGOW_HASKELL__
 464         c_output_w = BSCC("PrintRealC")
 465                      (\ f -> writeRealC switch_is_on f flat_absC_c)
 466                      ESCC
 467 #else
 468         c_output_w = c_output_d
 469 #endif
 470
 471 #if OMIT_NATIVE_CODEGEN
 472         ncg_output_d
 473           = error "*** GHC not built with a native-code generator ***"
 474         ncg_output_w = ncg_output_d
 475 #else
 476         ncg_output_d = BSCC("nativeCode")
 477                      dumpRealAsm switch_lookup_fn flat_absC_ncg ncg_uniqs
 478                      ESCC
 479
 480 #ifdef __GLASGOW_HASKELL__
 481         ncg_output_w = BSCC("nativeCode")
 482                      (\ f -> writeRealAsm switch_lookup_fn f flat_absC_ncg ncg_uniqs)
 483                      ESCC
 484 #else
 485         ncg_output_w = ncg_output_d
 486 #endif
 487 #endif
 488     in
 489     doDump D_dump_asm "" ncg_output_d `thenMn_`
 490     doOutput ProduceS    ncg_output_w `thenMn_`
 491
 492 #ifndef DPH
 493     -- ********* GHC Finished !!!!
 494     doDump D_dump_realC "" c_output_d `thenMn_`
 495     doOutput ProduceC      c_output_w `thenMn_`
 496
 497 #else
 498     -- ********* DPH needs native code generator, nearly finished.....
 499     let
 500         next_used_flatC = getTopLevelNexts flat_abstractC []
 501         apal_module     = nuAbsCToApal uniqSupply_L mod_name next_used_flatC
 502     in
 503     doDump D_dump_nextC "Next Used annotated C:" (ppShow pprCols
 504                                 (pprTopNextUsedC next_used_flatC))          `thenMn_`
 505     doOutput ProduceC   ("! /* DAP assembler (APAL): */\n"++apal_module)    `thenMn_`
 506
 507 #endif {- Data Parallel Haskell -}
 508     exitMn 0
 509     {-)-} BEND ) BEND BEND BEND BEND
 510 \end{code}