ghc/compiler/main/HscMain.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-2000
   3 %
   4 \section[GHC_Main]{Main driver for Glasgow Haskell compiler}
   5
   6 \begin{code}
   7 module HscMain ( hscMain ) where
   8
   9 #include "HsVersions.h"
  10
  11 import IO               ( hPutStr, stderr )
  12 import HsSyn
  13
  14 import RdrHsSyn         ( RdrNameHsModule )
  15 import FastString       ( unpackFS )
  16 import StringBuffer     ( hGetStringBuffer )
  17 import Parser           ( parse )
  18 import Lex              ( PState(..), ParseResult(..) )
  19 import SrcLoc           ( mkSrcLoc )
  20
  21 import Rename           ( renameModule )
  22
  23 import PrelInfo         ( wiredInThings )
  24 import PrelRules        ( builtinRules )
  25 import MkIface          ( writeIface )
  26 import TcModule         ( TcResults(..), typecheckModule )
  27 import Desugar          ( deSugar )
  28 import SimplCore        ( core2core )
  29 import OccurAnal        ( occurAnalyseBinds )
  30 import CoreUtils        ( coreBindsSize )
  31 import CoreTidy         ( tidyCorePgm )
  32 import CoreToStg        ( topCoreBindsToStg )
  33 import StgSyn           ( collectFinalStgBinders )
  34 import SimplStg         ( stg2stg )
  35 import CodeGen          ( codeGen )
  36 import CodeOutput       ( codeOutput )
  37
  38 import Module           ( ModuleName, moduleNameUserString )
  39 import CmdLineOpts
  40 import ErrUtils         ( ghcExit, doIfSet, dumpIfSet )
  41 import UniqSupply       ( mkSplitUniqSupply )
  42
  43 import Outputable
  44 import Char             ( isSpace )
  45 import StgInterp        ( runStgI )
  46 import HscStats         ( ppSourceStats )
  47 \end{code}
  48
  49
  50 %************************************************************************
  51 %*                                                                      *
  52 \subsection{The main compiler pipeline}
  53 %*                                                                      *
  54 %************************************************************************
  55
  56 \begin{code}
  57 data HscResult
  58    = HscOK   ModDetails              -- new details (HomeSymbolTable additions)
  59              (Maybe ModIface)        -- new iface (if any compilation was done)
  60              (Maybe String)          -- generated stub_h filename (in /tmp)
  61              (Maybe String)          -- generated stub_c filename (in /tmp)
  62              (Maybe [UnlinkedIBind]) -- interpreted code, if any
  63              PersistentCompilerState -- updated PCS
  64              (Bag WarnMsg)              -- warnings
  65
  66    | HscErrs PersistentCompilerState -- updated PCS
  67              (Bag ErrMsg)               -- errors
  68              (Bag WarnMsg)             -- warnings
  69
  70 hscMain
  71   :: DynFlags
  72   -> ModSummary       -- summary, including source filename
  73   -> Maybe ModIFace   -- old interface, if available
  74   -> String           -- file in which to put the output (.s, .hc, .java etc.)
  75   -> HomeSymbolTable            -- for home module ModDetails
  76   -> PersistentCompilerState    -- IN: persistent compiler state
  77   -> IO HscResult
  78
  79 hscMain dflags core_cmds stg_cmds summary maybe_old_iface
  80         output_filename mod_details pcs1
  81  = do
  82       source_unchanged :: Bool -- extracted from summary?
  83
  84       (pcs2, check_errs, (recomp_reqd, maybe_checked_iface))
  85          <- checkOldIface dflags finder hit hst pcs1 mod source_unchanged
  86                           maybe_old_iface
  87
  88       -- test check_errs and give up if a problem happened
  89       what_next = if recomp_reqd then hscRecomp else hscNoRecomp
  90
  91       return $
  92          what_next dflags core_cmds stg_cmds summary hit hst
  93                    pcs2 maybe_checked_iface
  94
  95 hscNoRecomp = panic "hscNoRecomp"
  96
  97 hscRecomp dflags core_cmds stg_cmds summary hit hst pcs maybe_old_iface
  98  = do
  99       -- parsed :: RdrNameHsModule
 100       parsed <- parseModule summary
 101       -- check for parse errors
 102
 103       (pcs_rn, maybe_rn_result)
 104          <- renameModule dflags finder hit hst pcs mod parsed
 105
 106       -- check maybe_rn_result for failure
 107
 108       (new_iface, rn_hs_decls) = unJust maybe_rn_result
 109
 110       maybe_tc_result
 111          <- typecheckModule dflags mod pcs hst hit pit rn_hs_decls
 112
 113       -- check maybe_tc_result for failure
 114       let tc_result = unJust maybe_tc_result
 115       let tc_pcs = tc_pcs tc_result
 116       let tc_env = tc_env tc_result
 117       let tc_binds = tc_binds tc_result
 118       let local_tycons = tc_tycons tc_result
 119       let local_classes = tc_classes tc_result
 120
 121       -- desugar, simplify and tidy, to create the unfoldings
 122       -- why is this IO-typed?
 123       (tidy_binds, orphan_rules, fe_binders, h_code, c_code)   -- return modDetails?
 124          <- dsThenSimplThenTidy dflags mod tc_result rule_base ds_uniqs
 125
 126       -- convert to Stg; needed for binders
 127       (stg_binds, cost_centre_info, top_level_ids)
 128          <- myCoreToStg c2s_uniqs st_uniqs this_mod tidy_binds
 129
 130       -- cook up a new ModDetails now we (finally) have all the bits
 131       let new_details = completeModDetails tc_env tidy_binds top_level_ids orphan_rules
 132
 133       -- and possibly create a new ModIface
 134       let maybe_final_iface = completeIface maybe_old_iface new_iface new_details
 135
 136       -- do the rest of code generation/emission
 137       -- this is obviously nonsensical: FIX
 138       (unlinkeds, stub_h_filename, stub_c_filename)
 139          <- restOfCodeGeneration this_mod imported_modules cost_centre_info
 140                                  fe_binders local_tycons local_classes stg_binds
 141
 142       -- and the answer is ...
 143       return (HscOK new_details maybe_final_iface stub_h_filename stub_c_filename
 144                     unlinkeds tc_pcs (unionBags rn_warns tc_warns))
 145
 146
 147 restOfCodeGeneration this_mod imported_modules cost_centre_info
 148                      fe_binders local_tycons local_classes stg_binds
 149  = do --------------------------  Code generation -------------------------------
 150       show_pass "CodeGen"
 151       -- _scc_     "CodeGen"
 152       abstractC <- codeGen this_mod imported_modules
 153                            cost_centre_info fe_binders
 154                            local_tycons local_classes stg_binds
 155
 156       --------------------------  Code output -------------------------------
 157       show_pass "CodeOutput"
 158       -- _scc_     "CodeOutput"
 159       (maybe_stub_h_name, maybe_stub_c_name)
 160          <- codeOutput this_mod local_tycons local_classes
 161                        occ_anal_tidy_binds stg_binds2
 162                        c_code h_code abstractC ncg_uniqs
 163
 164       -- this is obviously nonsensical: FIX
 165       return (maybe_stub_h_name, maybe_stub_c_name, [])
 166
 167
 168 dsThenSimplThenTidy dflags mod tc_result rule_base ds_uniqs
 169  = do --------------------------  Desugaring ----------------
 170       -- _scc_     "DeSugar"
 171       (desugared, rules, h_code, c_code, fe_binders)
 172          <- deSugar this_mod ds_uniqs tc_results
 173
 174       --------------------------  Main Core-language transformations ----------------
 175       -- _scc_     "Core2Core"
 176       (simplified, orphan_rules)  <- core2core core_cmds desugared rules
 177
 178       -- Do the final tidy-up
 179       (tidy_binds, tidy_orphan_rules)
 180          <- tidyCorePgm this_mod simplified orphan_rules
 181
 182       return (tidy_binds, tidy_orphan_rules, fe_binders, h_code, c_code)
 183
 184
 185
 186 myCoreToStg c2s_uniqs st_uniqs this_mod tidy_binds
 187  = do let occ_anal_tidy_binds = occurAnalyseBinds tidy_binds
 188
 189       () <- coreBindsSize occ_anal_tidy_binds `seq` return ()
 190       -- TEMP: the above call zaps some space usage allocated by the
 191       -- simplifier, which for reasons I don't understand, persists
 192       -- thoroughout code generation
 193
 194       show_pass "Core2Stg"
 195       -- _scc_     "Core2Stg"
 196       let stg_binds   = topCoreBindsToStg c2s_uniqs occ_anal_tidy_binds
 197
 198       show_pass "Stg2Stg"
 199       -- _scc_     "Stg2Stg"
 200       (stg_binds2, cost_centre_info) <- stg2stg stg_cmds this_mod st_uniqs stg_binds
 201       let final_ids = collectFinalStgBinders (map fst stg_binds2)
 202
 203       return (stg_binds2, cost_centre_info, final_ids)
 204
 205 #if 0
 206 -- BEGIN old stuff
 207         --------------------------  Reader  ----------------
 208     show_pass "Parser"  >>
 209     _scc_     "Parser"
 210
 211     let src_filename -- name of the preprocessed source file
 212        = case ms_ppsource summary of
 213             Just (filename, fingerprint) -> filename
 214             Nothing -> pprPanic "hscMain:summary is not of a source module"
 215                                 (ppr summary)
 216
 217     buf <- hGetStringBuffer True{-expand tabs-} src_filename
 218
 219     let glaexts | dopt Opt_GlasgowExts dflags = 1#
 220                 | otherwise                   = 0#
 221
 222     case parse buf PState{ bol = 0#, atbol = 1#,
 223                            context = [], glasgow_exts = glaexts,
 224                            loc = mkSrcLoc src_filename 1 } of {
 225
 226         PFailed err -> return (HscErrs pcs (unitBag err) emptyBag)
 227
 228         POk _ rdr_module@(HsModule mod_name _ _ _ _ _ _) ->
 229
 230     dumpIfSet (dopt_D_dump_parsed flags) "Parser" (ppr rdr_module) >>
 231
 232     dumpIfSet (dopt_D_source_stats flags) "Source Statistics"
 233         (ppSourceStats False rdr_module)                >>
 234
 235     -- UniqueSupplies for later use (these are the only lower case uniques)
 236     mkSplitUniqSupply 'd'       >>= \ ds_uniqs  -> -- desugarer
 237     mkSplitUniqSupply 'r'       >>= \ ru_uniqs  -> -- rules
 238     mkSplitUniqSupply 'c'       >>= \ c2s_uniqs -> -- core-to-stg
 239     mkSplitUniqSupply 'g'       >>= \ st_uniqs  -> -- stg-to-stg passes
 240     mkSplitUniqSupply 'n'       >>= \ ncg_uniqs -> -- native-code generator
 241
 242         --------------------------  Rename  ----------------
 243     show_pass "Renamer"                         >>
 244     _scc_     "Renamer"
 245
 246     renameModule dflags finder pcs hst rdr_module
 247                                                 >>= \ (pcs_rn, maybe_rn_stuff) ->
 248     case maybe_rn_stuff of {
 249         Nothing ->      -- Hurrah!  Renamer reckons that there's no need to
 250                         -- go any further
 251                         reportCompile mod_name "Compilation NOT required!" >>
 252                         return ();
 253
 254         Just (this_mod, rn_mod,
 255               old_iface, new_iface,
 256               rn_name_supply, fixity_env,
 257               imported_modules) ->
 258                         -- Oh well, we've got to recompile for real
 259
 260
 261         --------------------------  Typechecking ----------------
 262     show_pass "TypeCheck"                               >>
 263     _scc_     "TypeCheck"
 264     typecheckModule dflags mod pcs hst hit pit rn_mod
 265     --                tc_uniqs rn_name_supply
 266     --              fixity_env rn_mod
 267                                                 >>= \ maybe_tc_stuff ->
 268     case maybe_tc_stuff of {
 269         Nothing -> ghcExit 1;   -- Type checker failed
 270
 271         Just (tc_results@(TcResults {tc_tycons  = local_tycons,
 272                                      tc_classes = local_classes,
 273                                      tc_insts   = inst_info })) ->
 274
 275
 276         --------------------------  Desugaring ----------------
 277     _scc_     "DeSugar"
 278     deSugar this_mod ds_uniqs tc_results        >>= \ (desugared, rules, h_code, c_code, fe_binders) ->
 279
 280
 281         --------------------------  Main Core-language transformations ----------------
 282     _scc_     "Core2Core"
 283     core2core core_cmds desugared rules         >>= \ (simplified, orphan_rules) ->
 284
 285         -- Do the final tidy-up
 286     tidyCorePgm this_mod
 287                 simplified orphan_rules         >>= \ (tidy_binds, tidy_orphan_rules) ->
 288
 289         -- Run the occurrence analyser one last time, so that
 290         -- dead binders get dead-binder info.  This is exploited by
 291         -- code generators to avoid spitting out redundant bindings.
 292         -- The occurrence-zapping in Simplify.simplCaseBinder means
 293         -- that the Simplifier nukes useful dead-var stuff especially
 294         -- in case patterns.
 295     let occ_anal_tidy_binds = occurAnalyseBinds tidy_binds in
 296
 297     coreBindsSize occ_anal_tidy_binds `seq`
 298 --      TEMP: the above call zaps some space usage allocated by the
 299 --      simplifier, which for reasons I don't understand, persists
 300 --      thoroughout code generation
 301
 302
 303
 304         --------------------------  Convert to STG code -------------------------------
 305     show_pass "Core2Stg"                        >>
 306     _scc_     "Core2Stg"
 307     let
 308         stg_binds   = topCoreBindsToStg c2s_uniqs occ_anal_tidy_binds
 309     in
 310
 311         --------------------------  Simplify STG code -------------------------------
 312     show_pass "Stg2Stg"                          >>
 313     _scc_     "Stg2Stg"
 314     stg2stg stg_cmds this_mod st_uniqs stg_binds >>= \ (stg_binds2, cost_centre_info) ->
 315
 316 #ifdef GHCI
 317     runStgI local_tycons local_classes
 318                          (map fst stg_binds2)    >>= \ i_result ->
 319     putStr ("\nANSWER = " ++ show i_result ++ "\n\n")
 320     >>
 321
 322 #else
 323         --------------------------  Interface file -------------------------------
 324         -- Dump instance decls and type signatures into the interface file
 325     _scc_     "Interface"
 326     let
 327         final_ids = collectFinalStgBinders (map fst stg_binds2)
 328     in
 329     writeIface this_mod old_iface new_iface
 330                local_tycons local_classes inst_info
 331                final_ids occ_anal_tidy_binds tidy_orphan_rules          >>
 332
 333
 334         --------------------------  Code generation -------------------------------
 335     show_pass "CodeGen"                         >>
 336     _scc_     "CodeGen"
 337     codeGen this_mod imported_modules
 338             cost_centre_info
 339             fe_binders
 340             local_tycons local_classes
 341             stg_binds2                          >>= \ abstractC ->
 342
 343
 344         --------------------------  Code output -------------------------------
 345     show_pass "CodeOutput"                              >>
 346     _scc_     "CodeOutput"
 347     codeOutput this_mod local_tycons local_classes
 348                occ_anal_tidy_binds stg_binds2
 349                c_code h_code abstractC
 350                ncg_uniqs                                >>
 351
 352
 353         --------------------------  Final report -------------------------------
 354     reportCompile mod_name (showSDoc (ppSourceStats True rdr_module)) >>
 355
 356 #endif
 357
 358
 359     ghcExit 0
 360     } }
 361   where
 362     -------------------------------------------------------------
 363     -- ****** help functions:
 364
 365     show_pass
 366       = if opt_D_show_passes
 367         then \ what -> hPutStr stderr ("*** "++what++":\n")
 368         else \ what -> return ()
 369 -- END old stuff
 370 #endif
 371 \end{code}
 372
 373
 374 %************************************************************************
 375 %*                                                                      *
 376 \subsection{Initial persistent state}
 377 %*                                                                      *
 378 %************************************************************************
 379
 380 \begin{code}
 381 initPersistentCompilerState :: IO PersistentCompilerState
 382 initPersistentCompilerState
 383 <<<<<<< HscMain.lhs
 384   = do prs <- initPersistentRenamerState
 385        return (
 386         PCS { pcs_PST   = initPackageDetails,
 387               pcs_insts = emptyInstEnv,
 388               pcs_rules = emptyRuleEnv,
 389               pcs_PRS   = initPersistentRenamerState
 390             }
 391         )
 392 =======
 393   = PCS { pcs_PST   = initPackageDetails,
 394           pcs_insts = emptyInstEnv,
 395           pcs_rules = initRules,
 396           pcs_PRS   = initPersistentRenamerState }
 397 >>>>>>> 1.12
 398
 399 initPackageDetails :: PackageSymbolTable
 400 initPackageDetails = extendTypeEnv emptyModuleEnv wiredInThings
 401
 402 initPersistentRenamerState :: IO PersistentRenamerState
 403   = do ns <- mkSplitUniqSupply 'r'
 404        return (
 405         PRS { prsOrig  = Orig { origNames  = initOrigNames,
 406                                origIParam = emptyFM },
 407               prsDecls = emptyNameEnv,
 408               prsInsts = emptyBag,
 409               prsRules = emptyBag,
 410               prsNS    = ns
 411             }
 412         )
 413
 414 initOrigNames :: FiniteMap (ModuleName,OccName) Name
 415 initOrigNames = grab knownKeyNames `plusFM` grab (map getName wiredInThings)
 416               where
 417                 grab names   = foldl add emptyFM names
 418                 add env name = addToFM env (moduleName (nameModule name), nameOccName name) name
 419
 420
 421 initRules :: RuleEnv
 422 initRules = foldl add emptyVarEnv builtinRules
 423           where
 424             add env (name,rule) = extendNameEnv_C add1 env name [rule]
 425             add1 rules _        = rule : rules
 426 \end{code}
 427
 428
 429
 430 \begin{code}
 431 writeIface this_mod old_iface new_iface
 432            local_tycons local_classes inst_info
 433            final_ids tidy_binds tidy_orphan_rules
 434   =
 435     if isNothing opt_HiDir && isNothing opt_HiFile
 436         then return ()  -- not producing any .hi file
 437         else
 438
 439     let
 440         hi_suf = case opt_HiSuf of { Nothing -> "hi"; Just suf -> suf }
 441         filename = case opt_HiFile of {
 442                         Just f  -> f;
 443                         Nothing ->
 444                    case opt_HiDir of {
 445                         Just dir -> dir ++ '/':moduleUserString this_mod
 446                                         ++ '.':hi_suf;
 447                         Nothing  -> panic "writeIface"
 448                 }}
 449     in
 450
 451     do maybe_final_iface <- checkIface old_iface full_new_iface
 452        case maybe_final_iface of {
 453           Nothing -> when opt_D_dump_rn_trace $
 454                      putStrLn "Interface file unchanged" ;  -- No need to update .hi file
 455
 456           Just final_iface ->
 457
 458        do  let mod_vers_unchanged = case old_iface of
 459                                       Just iface -> pi_vers iface == pi_vers final_iface
 460                                       Nothing -> False
 461            when (mod_vers_unchanged && opt_D_dump_rn_trace) $
 462                 putStrLn "Module version unchanged, but usages differ; hence need new hi file"
 463
 464            if_hdl <- openFile filename WriteMode
 465            printForIface if_hdl (pprIface final_iface)
 466            hClose if_hdl
 467     }
 468   where
 469     full_new_iface = completeIface new_iface local_tycons local_classes
 470                                              inst_info final_ids tidy_binds
 471                                              tidy_orphan_rules
 472 \end{code}
 473
 474
 475 %************************************************************************
 476 %*                                                                      *
 477 \subsection{Printing the interface}
 478 %*                                                                      *
 479 %************************************************************************
 480
 481 \begin{code}
 482 pprIface (ParsedIface { pi_mod = mod, pi_vers = mod_vers, pi_orphan = orphan,
 483                         pi_usages = usages, pi_exports = exports,
 484                         pi_fixity = (fix_vers, fixities),
 485                         pi_insts = insts, pi_decls = decls,
 486                         pi_rules = (rule_vers, rules), pi_deprecs = deprecs })
 487  = vcat [ ptext SLIT("__interface")
 488                 <+> doubleQuotes (ptext opt_InPackage)
 489                 <+> ppr mod <+> ppr mod_vers <+> pp_sub_vers
 490                 <+> (if orphan then char '!' else empty)
 491                 <+> int opt_HiVersion
 492                 <+> ptext SLIT("where")
 493         , vcat (map pprExport exports)
 494         , vcat (map pprUsage usages)
 495         , pprFixities fixities
 496         , vcat [ppr i <+> semi | i <- insts]
 497         , vcat [ppr_vers v <+> ppr d <> semi | (v,d) <- decls]
 498         , pprRules rules
 499         , pprDeprecs deprecs
 500         ]
 501   where
 502     ppr_vers v | v == initialVersion = empty
 503                | otherwise           = int v
 504     pp_sub_vers
 505         | fix_vers == initialVersion && rule_vers == initialVersion = empty
 506         | otherwise = brackets (ppr fix_vers <+> ppr rule_vers)
 507 \end{code}
 508
 509 When printing export lists, we print like this:
 510         Avail   f               f
 511         AvailTC C [C, x, y]     C(x,y)
 512         AvailTC C [x, y]        C!(x,y)         -- Exporting x, y but not C
 513
 514 \begin{code}
 515 pprExport :: ExportItem -> SDoc
 516 pprExport (mod, items)
 517  = hsep [ ptext SLIT("__export "), ppr mod, hsep (map upp_avail items) ] <> semi
 518   where
 519     upp_avail :: RdrAvailInfo -> SDoc
 520     upp_avail (Avail name)      = pprOccName name
 521     upp_avail (AvailTC name []) = empty
 522     upp_avail (AvailTC name ns) = hcat [pprOccName name, bang, upp_export ns']
 523                                 where
 524                                   bang | name `elem` ns = empty
 525                                        | otherwise      = char '|'
 526                                   ns' = filter (/= name) ns
 527
 528     upp_export []    = empty
 529     upp_export names = braces (hsep (map pprOccName names))
 530 \end{code}
 531
 532
 533 \begin{code}
 534 pprUsage :: ImportVersion OccName -> SDoc
 535 pprUsage (m, has_orphans, is_boot, whats_imported)
 536   = hsep [ptext SLIT("import"), pprModuleName m,
 537           pp_orphan, pp_boot,
 538           upp_import_versions whats_imported
 539     ] <> semi
 540   where
 541     pp_orphan | has_orphans = char '!'
 542               | otherwise   = empty
 543     pp_boot   | is_boot     = char '@'
 544               | otherwise   = empty
 545
 546         -- Importing the whole module is indicated by an empty list
 547     upp_import_versions NothingAtAll   = empty
 548     upp_import_versions (Everything v) = dcolon <+> int v
 549     upp_import_versions (Specifically vm vf vr nvs)
 550       = dcolon <+> int vm <+> int vf <+> int vr <+> hsep [ ppr n <+> int v | (n,v) <- nvs ]
 551 \end{code}
 552
 553
 554 \begin{code}
 555 pprFixities []    = empty
 556 pprFixities fixes = hsep (map ppr fixes) <> semi
 557
 558 pprRules []    = empty
 559 pprRules rules = hsep [ptext SLIT("{-## __R"), hsep (map ppr rules), ptext SLIT("##-}")]
 560
 561 pprDeprecs []   = empty
 562 pprDeprecs deps = hsep [ ptext SLIT("{-## __D"), guts, ptext SLIT("##-}")]
 563                 where
 564                   guts = hsep [ ppr ie <+> doubleQuotes (ppr txt) <> semi
 565                               | Deprecation ie txt _ <- deps ]
 566 \end{code}
 567
 568