Main.hs 92.1 KB
Newer Older
Hécate Moonlight's avatar
Hécate Moonlight committed
1 2
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
3
{-# LANGUAGE NondecreasingIndentation #-}
Hécate Moonlight's avatar
Hécate Moonlight committed
4

Simon Marlow's avatar
Simon Marlow committed
5
{-# OPTIONS_GHC -fprof-auto-top #-}
6

dterei's avatar
dterei committed
7 8
-------------------------------------------------------------------------------
--
9
-- | Main API for compiling plain Haskell source code.
10
--
dterei's avatar
dterei committed
11
-- This module implements compilation of a Haskell source. It is
12
-- /not/ concerned with preprocessing of source files; this is handled
13
-- in "GHC.Driver.Pipeline"
14 15 16
--
-- There are various entry points depending on what mode we're in:
-- "batch" mode (@--make@), "one-shot" mode (@-c@, @-S@ etc.), and
dterei's avatar
dterei committed
17
-- "interactive" mode (GHCi). There are also entry points for
18 19 20 21 22 23 24 25
-- individual passes: parsing, typechecking/renaming, desugaring, and
-- simplification.
--
-- All the functions here take an 'HscEnv' as a parameter, but none of
-- them return a new one: 'HscEnv' is treated as an immutable value
-- from here on in (although it has mutable components, for the
-- caches).
--
26 27 28 29 30
-- We use the Hsc monad to deal with warning messages consistently:
-- specifically, while executing within an Hsc monad, warnings are
-- collected. When a Hsc monad returns to an IO monad, the
-- warnings are printed, or compilation aborts if the @-Werror@
-- flag is enabled.
31
--
dterei's avatar
dterei committed
32 33 34 35
-- (c) The GRASP/AQUA Project, Glasgow University, 1993-2000
--
-------------------------------------------------------------------------------

Sylvain Henry's avatar
Sylvain Henry committed
36
module GHC.Driver.Main
dterei's avatar
dterei committed
37
    (
38 39 40 41
    -- * Making an HscEnv
      newHscEnv

    -- * Compiling complete source files
42 43
    , Messager, batchMsg
    , HscStatus (..)
44
    , hscIncrementalCompile
45
    , initModDetails
46
    , hscMaybeWriteIface
47 48
    , hscCompileCmmFile

49 50 51
    , hscGenHardCode
    , hscInteractive

52
    -- * Running passes separately
Thomas Schilling's avatar
Thomas Schilling committed
53 54 55
    , hscParse
    , hscTypecheckRename
    , hscDesugar
Simon Marlow's avatar
Simon Marlow committed
56
    , makeSimpleDetails
57 58
    , hscSimplify -- ToDo, shouldn't really export this

59 60 61 62
    -- * Safe Haskell
    , hscCheckSafe
    , hscGetSafe

63 64 65 66
    -- * Support for interactive evaluation
    , hscParseIdentifier
    , hscTcRcLookupName
    , hscTcRnGetInfo
dterei's avatar
dterei committed
67
    , hscIsGHCiMonad
68
    , hscGetModuleInterface
69
    , hscRnImportDecls
70
    , hscTcRnLookupRdrName
71 72
    , hscStmt, hscParseStmtWithLocation, hscStmtWithLocation, hscParsedStmt
    , hscDecls, hscParseDeclsWithLocation, hscDeclsWithLocation, hscParsedDecls
73
    , hscTcExpr, TcRnExprMode(..), hscImport, hscKcType
74
    , hscParseExpr
xldenis's avatar
xldenis committed
75
    , hscParseType
76
    , hscCompileCoreExpr
77 78
    -- * Low-level exports for hooks
    , hscCompileCoreExpr'
Edsko de Vries's avatar
Edsko de Vries committed
79
      -- We want to make sure that we export enough to be able to redefine
80
      -- hsc_typecheck in client code
Sylvain Henry's avatar
Sylvain Henry committed
81
    , hscParse', hscSimplify', hscDesugar', tcRnModule', doCodeGen
Edsko de Vries's avatar
Edsko de Vries committed
82
    , getHscEnv
83
    , hscSimpleIface'
84
    , oneShotMsg
85
    , dumpIfaceStats
Edward Z. Yang's avatar
Edward Z. Yang committed
86 87
    , ioMsgMaybe
    , showModuleIndex
88
    , hscAddSptEntries
89
    ) where
90

91
import GHC.Prelude
92

Sylvain Henry's avatar
Sylvain Henry committed
93 94 95 96
import GHC.Driver.Plugins
import GHC.Driver.Session
import GHC.Driver.Backend
import GHC.Driver.Env
97
import GHC.Driver.Errors
Sylvain Henry's avatar
Sylvain Henry committed
98 99 100 101 102
import GHC.Driver.CodeOutput
import GHC.Driver.Config
import GHC.Driver.Hooks

import GHC.Runtime.Context
Sylvain Henry's avatar
Sylvain Henry committed
103
import GHC.Runtime.Interpreter ( addSptEntry, hscInterp )
Sylvain Henry's avatar
Sylvain Henry committed
104
import GHC.Runtime.Loader      ( initializePlugins )
Sylvain Henry's avatar
Sylvain Henry committed
105
import GHCi.RemoteTypes        ( ForeignHValue )
Sylvain Henry's avatar
Sylvain Henry committed
106 107
import GHC.ByteCode.Types

108 109 110
import GHC.Linker.Loader
import GHC.Linker.Types

Sylvain Henry's avatar
Sylvain Henry committed
111 112 113 114 115 116
import GHC.Hs
import GHC.Hs.Dump
import GHC.Hs.Stats         ( ppSourceStats )

import GHC.HsToCore

117
import GHC.StgToByteCode    ( byteCodeGen, stgExprToBCOs )
Sylvain Henry's avatar
Sylvain Henry committed
118 119 120

import GHC.IfaceToCore  ( typecheckIface )

121
import GHC.Iface.Load   ( ifaceStats, writeIface )
Sylvain Henry's avatar
Sylvain Henry committed
122 123 124 125 126
import GHC.Iface.Make
import GHC.Iface.Recomp
import GHC.Iface.Tidy
import GHC.Iface.Ext.Ast    ( mkHieFile )
import GHC.Iface.Ext.Types  ( getAsts, hie_asts, hie_module )
Sylvain Henry's avatar
Sylvain Henry committed
127
import GHC.Iface.Ext.Binary ( readHieFile, writeHieFile , hie_file_result)
Sylvain Henry's avatar
Sylvain Henry committed
128 129 130
import GHC.Iface.Ext.Debug  ( diffFile, validateScopes )

import GHC.Core
Sylvain Henry's avatar
Sylvain Henry committed
131
import GHC.Core.Tidy           ( tidyExpr )
Sylvain Henry's avatar
Sylvain Henry committed
132
import GHC.Core.Type           ( Type, Kind )
Sylvain Henry's avatar
Sylvain Henry committed
133
import GHC.Core.Lint           ( lintInteractiveExpr )
134 135
import GHC.Core.Multiplicity
import GHC.Core.Utils          ( exprType )
Sylvain Henry's avatar
Sylvain Henry committed
136
import GHC.Core.ConLike
Sylvain Henry's avatar
Sylvain Henry committed
137 138 139 140 141 142 143
import GHC.Core.Opt.Pipeline
import GHC.Core.TyCon
import GHC.Core.InstEnv
import GHC.Core.FamInstEnv

import GHC.CoreToStg.Prep
import GHC.CoreToStg    ( coreToStg )
144

145 146
import GHC.Parser.Errors
import GHC.Parser.Errors.Ppr
Sylvain Henry's avatar
Sylvain Henry committed
147 148
import GHC.Parser
import GHC.Parser.Lexer as Lexer
Sylvain Henry's avatar
Sylvain Henry committed
149

Sylvain Henry's avatar
Sylvain Henry committed
150 151 152
import GHC.Tc.Module
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.Zonk    ( ZonkFlexi (DefaultFlexi) )
Sylvain Henry's avatar
Sylvain Henry committed
153

Sylvain Henry's avatar
Sylvain Henry committed
154 155 156
import GHC.Stg.Syntax
import GHC.Stg.FVs      ( annTopBindingsFreeVars )
import GHC.Stg.Pipeline ( stg2stg )
Sylvain Henry's avatar
Sylvain Henry committed
157 158 159

import GHC.Builtin.Utils
import GHC.Builtin.Names
160
import GHC.Builtin.Uniques ( mkPseudoUniqueE )
Sylvain Henry's avatar
Sylvain Henry committed
161

162
import qualified GHC.StgToCmm as StgToCmm ( codeGen )
Sylvain Henry's avatar
Sylvain Henry committed
163 164
import GHC.StgToCmm.Types (CgInfos (..), ModuleLFInfos)

165
import GHC.Cmm
166
import GHC.Cmm.Parser       ( parseCmmFile )
167 168 169
import GHC.Cmm.Info.Build
import GHC.Cmm.Pipeline
import GHC.Cmm.Info
170

Sylvain Henry's avatar
Sylvain Henry committed
171
import GHC.Unit
Sylvain Henry's avatar
Sylvain Henry committed
172
import GHC.Unit.Env
Sylvain Henry's avatar
Sylvain Henry committed
173
import GHC.Unit.Finder
Sylvain Henry's avatar
Sylvain Henry committed
174 175 176 177 178 179 180 181 182 183 184
import GHC.Unit.External
import GHC.Unit.State
import GHC.Unit.Module.ModDetails
import GHC.Unit.Module.ModGuts
import GHC.Unit.Module.ModIface
import GHC.Unit.Module.ModSummary
import GHC.Unit.Module.Graph
import GHC.Unit.Module.Imported
import GHC.Unit.Module.Deps
import GHC.Unit.Module.Status
import GHC.Unit.Home.ModInfo
185

Sylvain Henry's avatar
Sylvain Henry committed
186 187 188 189 190
import GHC.Types.Id
import GHC.Types.SourceError
import GHC.Types.SafeHaskell
import GHC.Types.ForeignStubs
import GHC.Types.Var.Env       ( emptyTidyEnv )
191
import GHC.Types.Error
Sylvain Henry's avatar
Sylvain Henry committed
192 193
import GHC.Types.Fixity.Env
import GHC.Types.CostCentre
194
import GHC.Types.IPE
Sylvain Henry's avatar
Sylvain Henry committed
195 196 197
import GHC.Types.SourceFile
import GHC.Types.SrcLoc
import GHC.Types.Name
Sylvain Henry's avatar
Sylvain Henry committed
198
import GHC.Types.Name.Env
Sylvain Henry's avatar
Sylvain Henry committed
199 200 201 202 203 204 205 206 207 208 209 210
import GHC.Types.Name.Cache ( initNameCache )
import GHC.Types.Name.Reader
import GHC.Types.Name.Ppr
import GHC.Types.TyThing
import GHC.Types.HpcInfo

import GHC.Utils.Fingerprint ( Fingerprint )
import GHC.Utils.Panic
import GHC.Utils.Error
import GHC.Utils.Outputable
import GHC.Utils.Exception
import GHC.Utils.Misc
Sylvain Henry's avatar
Sylvain Henry committed
211
import GHC.Utils.Logger
212
import GHC.Utils.TmpFs
Sylvain Henry's avatar
Sylvain Henry committed
213

214 215
import GHC.Data.FastString
import GHC.Data.Bag
Sylvain Henry's avatar
Sylvain Henry committed
216
import GHC.Data.StringBuffer
217 218
import qualified GHC.Data.Stream as Stream
import GHC.Data.Stream (Stream)
219

Sylvain Henry's avatar
Sylvain Henry committed
220
import Data.Data hiding (Fixity, TyCon)
221
import Data.Maybe       ( fromJust )
222
import Data.List        ( nub, isPrefixOf, partition )
Simon Marlow's avatar
Simon Marlow committed
223 224
import Control.Monad
import Data.IORef
225
import System.FilePath as FilePath
226
import System.Directory
227
import System.IO (fixIO)
228 229
import qualified Data.Set as S
import Data.Set (Set)
230
import Data.Functor
231
import Control.DeepSeq (force)
232
import Data.Bifunctor (first, bimap)
dterei's avatar
dterei committed
233

Thomas Schilling's avatar
Thomas Schilling committed
234
#include "HsVersions.h"
235

236

dterei's avatar
dterei committed
237 238 239 240 241
{- **********************************************************************
%*                                                                      *
                Initialisation
%*                                                                      *
%********************************************************************* -}
242

243
newHscEnv :: DynFlags -> IO HscEnv
244
newHscEnv dflags = do
245
    nc_var  <- initNameCache 'r' knownKeyNames
Sylvain Henry's avatar
Sylvain Henry committed
246
    fc_var  <- initFinderCache
Sylvain Henry's avatar
Sylvain Henry committed
247
    logger  <- initLogger
248
    tmpfs   <- initTmpFs
Sylvain Henry's avatar
Sylvain Henry committed
249
    unit_env <- initUnitEnv (ghcNameVersion dflags) (targetPlatform dflags)
250
    return HscEnv {  hsc_dflags         = dflags
Sylvain Henry's avatar
Sylvain Henry committed
251
                  ,  hsc_logger         = logger
252 253 254 255 256 257 258
                  ,  hsc_targets        = []
                  ,  hsc_mod_graph      = emptyMG
                  ,  hsc_IC             = emptyInteractiveContext dflags
                  ,  hsc_NC             = nc_var
                  ,  hsc_FC             = fc_var
                  ,  hsc_type_env_var   = Nothing
                  ,  hsc_interp         = Nothing
Sylvain Henry's avatar
Sylvain Henry committed
259
                  ,  hsc_unit_env       = unit_env
260 261
                  ,  hsc_plugins        = []
                  ,  hsc_static_plugins = []
Sylvain Henry's avatar
Sylvain Henry committed
262
                  ,  hsc_hooks          = emptyHooks
263
                  ,  hsc_tmpfs          = tmpfs
264
                  }
Thomas Schilling's avatar
Thomas Schilling committed
265

266
-- -----------------------------------------------------------------------------
267

268
getWarnings :: Hsc WarningMessages
dterei's avatar
dterei committed
269
getWarnings = Hsc $ \_ w -> return (w, w)
270 271

clearWarnings :: Hsc ()
dterei's avatar
dterei committed
272
clearWarnings = Hsc $ \_ _ -> return ((), emptyBag)
273

274 275
logDiagnostics :: Bag (MsgEnvelope DiagnosticMessage) -> Hsc ()
logDiagnostics w = Hsc $ \_ w0 -> return ((), w0 `unionBags` w)
276 277

getHscEnv :: Hsc HscEnv
dterei's avatar
dterei committed
278
getHscEnv = Hsc $ \e w -> return (e, w)
279 280 281

handleWarnings :: Hsc ()
handleWarnings = do
dterei's avatar
dterei committed
282
    dflags <- getDynFlags
Sylvain Henry's avatar
Sylvain Henry committed
283
    logger <- getLogger
dterei's avatar
dterei committed
284
    w <- getWarnings
285
    liftIO $ printOrThrowDiagnostics logger dflags w
dterei's avatar
dterei committed
286
    clearWarnings
287 288 289

-- | log warning in the monad, and if there are errors then
-- throw a SourceError exception.
290
logWarningsReportErrors :: (Bag PsWarning, Bag PsError) -> Hsc ()
291
logWarningsReportErrors (warnings,errors) = do
292 293 294
    dflags <- getDynFlags
    let warns = fmap (mkParserWarn dflags) warnings
        errs  = fmap mkParserErr errors
295
    logDiagnostics warns
dterei's avatar
dterei committed
296
    when (not $ isEmptyBag errs) $ throwErrors errs
297

298 299
-- | Log warnings and throw errors, assuming the messages
-- contain at least one error (e.g. coming from PFailed)
300
handleWarningsThrowErrors :: (Bag PsWarning, Bag PsError) -> Hsc a
301
handleWarningsThrowErrors (warnings, errors) = do
302
    dflags <- getDynFlags
303 304 305
    let warns = fmap (mkParserWarn dflags) warnings
        errs  = fmap mkParserErr           errors
    logDiagnostics warns
Sylvain Henry's avatar
Sylvain Henry committed
306
    logger <- getLogger
307
    let (wWarns, wErrs) = partitionMessageBag warns
Sylvain Henry's avatar
Sylvain Henry committed
308
    liftIO $ printBagOfErrors logger dflags wWarns
309
    throwErrors (unionBags errs wErrs)
310 311 312 313 314

-- | Deal with errors and warnings returned by a compilation step
--
-- In order to reduce dependencies to other parts of the compiler, functions
-- outside the "main" parts of GHC return warnings and errors as a parameter
dterei's avatar
dterei committed
315
-- and signal success via by wrapping the result in a 'Maybe' type. This
316 317 318 319 320 321 322 323 324
-- function logs the returned warnings and propagates errors as exceptions
-- (of type 'SourceError').
--
-- This function assumes the following invariants:
--
--  1. If the second result indicates success (is of the form 'Just x'),
--     there must be no error messages in the first result.
--
--  2. If there are no error messages, but the second result indicates failure
dterei's avatar
dterei committed
325
--     there should be warnings in the first result. That is, if the action
326
--     failed, it must have been due to the warnings (i.e., @-Werror@).
327
ioMsgMaybe :: IO (Messages DiagnosticMessage, Maybe a) -> Hsc a
328
ioMsgMaybe ioA = do
329 330
    (msgs, mb_r) <- liftIO ioA
    let (warns, errs) = partitionMessages msgs
331
    logDiagnostics warns
dterei's avatar
dterei committed
332 333 334
    case mb_r of
        Nothing -> throwErrors errs
        Just r  -> ASSERT( isEmptyBag errs ) return r
335 336 337

-- | like ioMsgMaybe, except that we ignore error messages and return
-- 'Nothing' instead.
338
ioMsgMaybe' :: IO (Messages DiagnosticMessage, Maybe a) -> Hsc (Maybe a)
339
ioMsgMaybe' ioA = do
340
    (msgs, mb_r) <- liftIO $ ioA
341
    logDiagnostics (getWarningMessages msgs)
dterei's avatar
dterei committed
342
    return mb_r
343 344 345 346

-- -----------------------------------------------------------------------------
-- | Lookup things in the compiler's environment

Alan Zimmerman's avatar
Alan Zimmerman committed
347
hscTcRnLookupRdrName :: HscEnv -> LocatedN RdrName -> IO [Name]
348 349
hscTcRnLookupRdrName hsc_env0 rdr_name
  = runInteractiveHsc hsc_env0 $
350 351
    do { hsc_env <- getHscEnv
       ; ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name }
352 353

hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing)
354 355 356
hscTcRcLookupName hsc_env0 name = runInteractiveHsc hsc_env0 $ do
  hsc_env <- getHscEnv
  ioMsgMaybe' $ tcRnLookupName hsc_env name
dterei's avatar
dterei committed
357 358 359
      -- ignore errors: the only error we're likely to get is
      -- "name not found", and the Maybe in the return type
      -- is used to indicate that.
360

361 362
hscTcRnGetInfo :: HscEnv -> Name
               -> IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
363 364 365 366
hscTcRnGetInfo hsc_env0 name
  = runInteractiveHsc hsc_env0 $
    do { hsc_env <- getHscEnv
       ; ioMsgMaybe' $ tcRnGetInfo hsc_env name }
367

dterei's avatar
dterei committed
368
hscIsGHCiMonad :: HscEnv -> String -> IO Name
Edsko de Vries's avatar
Edsko de Vries committed
369
hscIsGHCiMonad hsc_env name
370
  = runHsc hsc_env $ ioMsgMaybe $ isGHCiMonad hsc_env name
dterei's avatar
dterei committed
371

372
hscGetModuleInterface :: HscEnv -> Module -> IO ModIface
373 374 375
hscGetModuleInterface hsc_env0 mod = runInteractiveHsc hsc_env0 $ do
  hsc_env <- getHscEnv
  ioMsgMaybe $ getModuleInterface hsc_env mod
376 377 378

-- -----------------------------------------------------------------------------
-- | Rename some import declarations
379
hscRnImportDecls :: HscEnv -> [LImportDecl GhcPs] -> IO GlobalRdrEnv
380 381 382
hscRnImportDecls hsc_env0 import_decls = runInteractiveHsc hsc_env0 $ do
  hsc_env <- getHscEnv
  ioMsgMaybe $ tcRnImportDecls hsc_env import_decls
383

384
-- -----------------------------------------------------------------------------
Simon Marlow's avatar
Simon Marlow committed
385
-- | parse a file, returning the abstract syntax
386

387
hscParse :: HscEnv -> ModSummary -> IO HsParsedModule
388 389 390
hscParse hsc_env mod_summary = runHsc hsc_env $ hscParse' mod_summary

-- internal version, that doesn't fail due to -Werror
391
hscParse' :: ModSummary -> Hsc HsParsedModule
Edward Z. Yang's avatar
Edward Z. Yang committed
392 393
hscParse' mod_summary
 | Just r <- ms_parsed_mod mod_summary = return r
Sylvain Henry's avatar
Sylvain Henry committed
394
 | otherwise = do
dterei's avatar
dterei committed
395
    dflags <- getDynFlags
Sylvain Henry's avatar
Sylvain Henry committed
396 397 398 399
    logger <- getLogger
    {-# SCC "Parser" #-} withTiming logger dflags
                (text "Parser"<+>brackets (ppr $ ms_mod mod_summary))
                (const ()) $ do
dterei's avatar
dterei committed
400 401
    let src_filename  = ms_hspp_file mod_summary
        maybe_src_buf = ms_hspp_buf  mod_summary
402

dterei's avatar
dterei committed
403
    --------------------------  Parser  ----------------
404 405 406
    -- sometimes we already have the buffer in memory, perhaps
    -- because we needed to parse the imports out of it, or get the
    -- module name.
dterei's avatar
dterei committed
407 408 409
    buf <- case maybe_src_buf of
               Just b  -> return b
               Nothing -> liftIO $ hGetStringBuffer src_filename
410

dterei's avatar
dterei committed
411
    let loc = mkRealSrcLoc (mkFastString src_filename) 1 1
Edward Z. Yang's avatar
Edward Z. Yang committed
412 413 414
    let parseMod | HsigFile == ms_hsc_src mod_summary
                 = parseSignature
                 | otherwise = parseModule
415

416
    case unP parseMod (initParserState (initParserOpts dflags) buf loc) of
417
        PFailed pst ->
418
            handleWarningsThrowErrors (getMessages pst)
dterei's avatar
dterei committed
419
        POk pst rdr_module -> do
420
            let (warns, errs) = bimap (fmap (mkParserWarn dflags)) (fmap mkParserErr) (getMessages pst)
421
            logDiagnostics warns
Sylvain Henry's avatar
Sylvain Henry committed
422
            liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_parsed "Parser"
Sylvain Henry's avatar
Sylvain Henry committed
423
                        FormatHaskell (ppr rdr_module)
Sylvain Henry's avatar
Sylvain Henry committed
424
            liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_parsed_ast "Parser AST"
Alan Zimmerman's avatar
Alan Zimmerman committed
425
                        FormatHaskell (showAstData NoBlankSrcSpan
Alan Zimmerman's avatar
Alan Zimmerman committed
426
                                                   NoBlankEpAnnotations
Alan Zimmerman's avatar
Alan Zimmerman committed
427
                                                   rdr_module)
Sylvain Henry's avatar
Sylvain Henry committed
428
            liftIO $ dumpIfSet_dyn logger dflags Opt_D_source_stats "Source Statistics"
Sylvain Henry's avatar
Sylvain Henry committed
429
                        FormatText (ppSourceStats False rdr_module)
430
            when (not $ isEmptyBag errs) $ throwErrors errs
431 432 433 434 435

            -- To get the list of extra source files, we take the list
            -- that the parser gave us,
            --   - eliminate files beginning with '<'.  gcc likes to use
            --     pseudo-filenames like "<built-in>" and "<command-line>"
Gabor Greif's avatar
Gabor Greif committed
436
            --   - normalise them (eliminate differences between ./f and f)
437 438 439 440 441 442 443 444 445
            --   - filter out the preprocessed source file
            --   - filter out anything beginning with tmpdir
            --   - remove duplicates
            --   - filter out the .hs/.lhs source filename if we have one
            --
            let n_hspp  = FilePath.normalise src_filename
                srcs0 = nub $ filter (not . (tmpDir dflags `isPrefixOf`))
                            $ filter (not . (== n_hspp))
                            $ map FilePath.normalise
Gabor Greif's avatar
Gabor Greif committed
446
                            $ filter (not . isPrefixOf "<")
447 448 449 450 451 452
                            $ map unpackFS
                            $ srcfiles pst
                srcs1 = case ml_hs_file (ms_location mod_summary) of
                          Just f  -> filter (/= FilePath.normalise f) srcs0
                          Nothing -> srcs0

453 454 455 456 457
            -- sometimes we see source files from earlier
            -- preprocessing stages that cannot be found, so just
            -- filter them out:
            srcs2 <- liftIO $ filterM doesFileExist srcs1

458
            let res = HsParsedModule {
459
                      hpm_module    = rdr_module,
460
                      hpm_src_files = srcs2
461
                   }
Simon Marlow's avatar
Simon Marlow committed
462

463 464 465
            -- apply parse transformation of plugins
            let applyPluginAction p opts
                  = parsedResultAction p opts mod_summary
466 467
            hsc_env <- getHscEnv
            withPlugins hsc_env applyPluginAction res
468

Simon Marlow's avatar
Simon Marlow committed
469

470 471
-- -----------------------------------------------------------------------------
-- | If the renamed source has been kept, extract it. Dump it if requested.
Alec Theriault's avatar
Alec Theriault committed
472 473
extract_renamed_stuff :: ModSummary -> TcGblEnv -> Hsc RenamedStuff
extract_renamed_stuff mod_summary tc_result = do
474
    let rn_info = getRenamedStuff tc_result
Thomas Schilling's avatar
Thomas Schilling committed
475

476
    dflags <- getDynFlags
Sylvain Henry's avatar
Sylvain Henry committed
477 478
    logger <- getLogger
    liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_rn_ast "Renamer"
Alan Zimmerman's avatar
Alan Zimmerman committed
479
                FormatHaskell (showAstData NoBlankSrcSpan NoBlankEpAnnotations rn_info)
480

Alec Theriault's avatar
Alec Theriault committed
481 482
    -- Create HIE files
    when (gopt Opt_WriteHie dflags) $ do
483 484 485
        -- I assume this fromJust is safe because `-fwrite-hie-file`
        -- enables the option which keeps the renamed source.
        hieFile <- mkHieFile mod_summary tc_result (fromJust rn_info)
Alec Theriault's avatar
Alec Theriault committed
486 487
        let out_file = ml_hie_file $ ms_location mod_summary
        liftIO $ writeHieFile out_file hieFile
Sylvain Henry's avatar
Sylvain Henry committed
488
        liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_hie "HIE AST" FormatHaskell (ppr $ hie_asts hieFile)
Alec Theriault's avatar
Alec Theriault committed
489 490 491 492 493 494

        -- Validate HIE files
        when (gopt Opt_ValidateHie dflags) $ do
            hs_env <- Hsc $ \e w -> return (e, w)
            liftIO $ do
              -- Validate Scopes
495
              case validateScopes (hie_module hieFile) $ getAsts $ hie_asts hieFile of
Sylvain Henry's avatar
Sylvain Henry committed
496
                  [] -> putMsg logger dflags $ text "Got valid scopes"
Alec Theriault's avatar
Alec Theriault committed
497
                  xs -> do
Sylvain Henry's avatar
Sylvain Henry committed
498 499
                    putMsg logger dflags $ text "Got invalid scopes"
                    mapM_ (putMsg logger dflags) xs
Alec Theriault's avatar
Alec Theriault committed
500
              -- Roundtrip testing
Sylvain Henry's avatar
Sylvain Henry committed
501
              file' <- readHieFile (hsc_NC hs_env) out_file
502
              case diffFile hieFile (hie_file_result file') of
Alec Theriault's avatar
Alec Theriault committed
503
                [] ->
Sylvain Henry's avatar
Sylvain Henry committed
504
                  putMsg logger dflags $ text "Got no roundtrip errors"
Alec Theriault's avatar
Alec Theriault committed
505
                xs -> do
Sylvain Henry's avatar
Sylvain Henry committed
506 507
                  putMsg logger dflags $ text "Got roundtrip errors"
                  mapM_ (putMsg logger (dopt_set dflags Opt_D_ppr_debug)) xs
Alec Theriault's avatar
Alec Theriault committed
508
    return rn_info
Simon Marlow's avatar
Simon Marlow committed
509

510 511 512 513 514

-- -----------------------------------------------------------------------------
-- | Rename and typecheck a module, additionally returning the renamed syntax
hscTypecheckRename :: HscEnv -> ModSummary -> HsParsedModule
                   -> IO (TcGblEnv, RenamedStuff)
515 516
hscTypecheckRename hsc_env mod_summary rdr_module = runHsc hsc_env $
    hsc_typecheck True mod_summary (Just rdr_module)
517 518


519
-- | A bunch of logic piled around @tcRnModule'@, concerning a) backpack
520 521 522
-- b) concerning dumping rename info and hie files. It would be nice to further
-- separate this stuff out, probably in conjunction better separating renaming
-- and type checking (#17781).
Alec Theriault's avatar
Alec Theriault committed
523
hsc_typecheck :: Bool -- ^ Keep renamed source?
524
              -> ModSummary -> Maybe HsParsedModule
525
              -> Hsc (TcGblEnv, RenamedStuff)
Alec Theriault's avatar
Alec Theriault committed
526
hsc_typecheck keep_rn mod_summary mb_rdr_module = do
Edward Z. Yang's avatar
Edward Z. Yang committed
527 528 529
    hsc_env <- getHscEnv
    let hsc_src = ms_hsc_src mod_summary
        dflags = hsc_dflags hsc_env
530
        home_unit = hsc_home_unit hsc_env
Edward Z. Yang's avatar
Edward Z. Yang committed
531
        outer_mod = ms_mod mod_summary
532
        mod_name = moduleName outer_mod
Sylvain Henry's avatar
Sylvain Henry committed
533 534
        outer_mod' = mkHomeModule home_unit mod_name
        inner_mod = homeModuleNameInstantiation home_unit mod_name
Edward Z. Yang's avatar
Edward Z. Yang committed
535 536
        src_filename  = ms_hspp_file mod_summary
        real_loc = realSrcLocSpan $ mkRealSrcLoc (mkFastString src_filename) 1 1
Alec Theriault's avatar
Alec Theriault committed
537
        keep_rn' = gopt Opt_WriteHie dflags || keep_rn
Sylvain Henry's avatar
Sylvain Henry committed
538
    MASSERT( isHomeModule home_unit outer_mod )
539
    tc_result <- if hsc_src == HsigFile && not (isHoleModule inner_mod)
540
        then ioMsgMaybe $ tcRnInstantiateSignature hsc_env outer_mod' real_loc
Edward Z. Yang's avatar
Edward Z. Yang committed
541 542 543 544
        else
         do hpm <- case mb_rdr_module of
                    Just hpm -> return hpm
                    Nothing -> hscParse' mod_summary
Alec Theriault's avatar
Alec Theriault committed
545
            tc_result0 <- tcRnModule' mod_summary keep_rn' hpm
Edward Z. Yang's avatar
Edward Z. Yang committed
546 547 548
            if hsc_src == HsigFile
                then do (iface, _, _) <- liftIO $ hscSimpleIface hsc_env tc_result0 Nothing
                        ioMsgMaybe $
549
                            tcRnMergeSignatures hsc_env hpm tc_result0 iface
Edward Z. Yang's avatar
Edward Z. Yang committed
550
                else return tc_result0
551 552 553 554
    -- TODO are we extracting anything when we merely instantiate a signature?
    -- If not, try to move this into the "else" case above.
    rn_info <- extract_renamed_stuff mod_summary tc_result
    return (tc_result, rn_info)
Edward Z. Yang's avatar
Edward Z. Yang committed
555

556
-- wrapper around tcRnModule to handle safe haskell extras
557
tcRnModule' :: ModSummary -> Bool -> HsParsedModule
558
            -> Hsc TcGblEnv
559 560
tcRnModule' sum save_rn_syntax mod = do
    hsc_env <- getHscEnv
561 562
    dflags   <- getDynFlags

563
    let reason = WarningWithFlag Opt_WarnMissingSafeHaskellMode
564 565 566
    -- -Wmissing-safe-haskell-mode
    when (not (safeHaskellModeEnabled dflags)
          && wopt Opt_WarnMissingSafeHaskellMode dflags) $
567
        logDiagnostics $ unitBag $
568
        mkPlainMsgEnvelope dflags reason (getLoc (hpm_module mod)) $
569 570
        warnMissingSafeHaskellMode

571 572
    tcg_res <- {-# SCC "Typecheck-Rename" #-}
               ioMsgMaybe $
573
                   tcRnModule hsc_env sum
574
                     save_rn_syntax mod
575

576 577 578
    -- See Note [Safe Haskell Overlapping Instances Implementation]
    -- although this is used for more than just that failure case.
    (tcSafeOK, whyUnsafe) <- liftIO $ readIORef (tcg_safeInfer tcg_res)
579
    let allSafeOK = safeInferred dflags && tcSafeOK
580

581
    -- end of the safe haskell line, how to respond to user?
582 583 584 585 586 587 588 589 590
    if not (safeHaskellOn dflags)
         || (safeInferOn dflags && not allSafeOK)
      -- if safe Haskell off or safe infer failed, mark unsafe
      then markUnsafeInfer tcg_res whyUnsafe

      -- module (could be) safe, throw warning if needed
      else do
          tcg_res' <- hscCheckSafeImports tcg_res
          safe <- liftIO $ fst <$> readIORef (tcg_safeInfer tcg_res')
591
          when safe $
592 593 594
            case wopt Opt_WarnSafe dflags of
              True
                | safeHaskell dflags == Sf_Safe -> return ()
595
                | otherwise -> (logDiagnostics $ unitBag $
596
                       mkPlainMsgEnvelope dflags (WarningWithFlag Opt_WarnSafe)
597
                                          (warnSafeOnLoc dflags) $
598 599 600
                       errSafe tcg_res')
              False | safeHaskell dflags == Sf_Trustworthy &&
                      wopt Opt_WarnTrustworthySafe dflags ->
601
                      (logDiagnostics $ unitBag $
602
                       mkPlainMsgEnvelope dflags (WarningWithFlag Opt_WarnTrustworthySafe)
603
                                          (trustworthyOnLoc dflags) $
604 605 606
                       errTwthySafe tcg_res')
              False -> return ()
          return tcg_res'
607 608
  where
    pprMod t  = ppr $ moduleName $ tcg_mod t
609
    errSafe t = quotes (pprMod t) <+> text "has been inferred as safe!"
610 611
    errTwthySafe t = quotes (pprMod t)
      <+> text "is marked as Trustworthy but has been inferred as safe!"
612 613
    warnMissingSafeHaskellMode = ppr (moduleName (ms_mod sum))
      <+> text "is missing Safe Haskell mode"
614

Simon Marlow's avatar
Simon Marlow committed
615
-- | Convert a typechecked module to Core
616
hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts
617
hscDesugar hsc_env mod_summary tc_result =
Ian Lynagh's avatar
Ian Lynagh committed
618
    runHsc hsc_env $ hscDesugar' (ms_location mod_summary) tc_result
619

Ian Lynagh's avatar
Ian Lynagh committed
620 621
hscDesugar' :: ModLocation -> TcGblEnv -> Hsc ModGuts
hscDesugar' mod_location tc_result = do
dterei's avatar
dterei committed
622
    hsc_env <- getHscEnv
Simon Marlow's avatar
Simon Marlow committed
623 624
    r <- ioMsgMaybe $
      {-# SCC "deSugar" #-}
Ian Lynagh's avatar
Ian Lynagh committed
625
      deSugar hsc_env mod_location tc_result
626

dterei's avatar
dterei committed
627 628 629 630
    -- always check -Werror after desugaring, this is the last opportunity for
    -- warnings to arise before the backend.
    handleWarnings
    return r
Simon Marlow's avatar
Simon Marlow committed
631

dterei's avatar
dterei committed
632
-- | Make a 'ModDetails' from the results of typechecking. Used when
Simon Marlow's avatar
Simon Marlow committed
633
-- typechecking only, as opposed to full compilation.
634 635
makeSimpleDetails :: HscEnv -> TcGblEnv -> IO ModDetails
makeSimpleDetails hsc_env tc_result = mkBootModDetailsTc hsc_env tc_result
Simon Marlow's avatar
Simon Marlow committed
636

637

dterei's avatar
dterei committed
638 639 640 641 642 643 644
{- **********************************************************************
%*                                                                      *
                The main compiler pipeline
%*                                                                      *
%********************************************************************* -}

{-
645 646 647 648
                   --------------------------------
                        The compilation proper
                   --------------------------------

dterei's avatar
dterei committed
649
It's the task of the compilation proper to compile Haskell, hs-boot and core
Gabor Greif's avatar
Gabor Greif committed
650
files to either byte-code, hard-code (C, asm, LLVM, etc.) or to nothing at all
dterei's avatar
dterei committed
651 652 653 654
(the module is still parsed and type-checked. This feature is mostly used by
IDE's and the likes). Compilation can happen in either 'one-shot', 'batch',
'nothing', or 'interactive' mode. 'One-shot' mode targets hard-code, 'batch'
mode targets hard-code, 'nothing' mode targets nothing and 'interactive' mode
655
targets byte-code.
dterei's avatar
dterei committed
656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680

The modes are kept separate because of their different types and meanings:

 * In 'one-shot' mode, we're only compiling a single file and can therefore
 discard the new ModIface and ModDetails. This is also the reason it only
 targets hard-code; compiling to byte-code or nothing doesn't make sense when
 we discard the result.

 * 'Batch' mode is like 'one-shot' except that we keep the resulting ModIface
 and ModDetails. 'Batch' mode doesn't target byte-code since that require us to
 return the newly compiled byte-code.

 * 'Nothing' mode has exactly the same type as 'batch' mode but they're still
 kept separate. This is because compiling to nothing is fairly special: We
 don't output any interface files, we don't run the simplifier and we don't
 generate any code.

 * 'Interactive' mode is similar to 'batch' mode except that we return the
 compiled byte-code together with the ModIface and ModDetails.

Trying to compile a hs-boot file to byte-code will result in a run-time error.
This is the only thing that isn't caught by the type-system.
-}


681
type Messager = HscEnv -> (Int,Int) -> RecompileRequired -> ModuleGraphNode -> IO ()
682

683 684 685 686 687 688 689 690 691 692 693 694 695 696 697
-- | This function runs GHC's frontend with recompilation
-- avoidance. Specifically, it checks if recompilation is needed,
-- and if it is, it parses and typechecks the input module.
-- It does not write out the results of typechecking (See
-- compileOne and hscIncrementalCompile).
hscIncrementalFrontend :: Bool -- always do basic recompilation check?
                       -> Maybe TcGblEnv
                       -> Maybe Messager
                       -> ModSummary
                       -> SourceModified
                       -> Maybe ModIface  -- Old interface, if available
                       -> (Int,Int)       -- (i,n) = module i of n (for msgs)
                       -> Hsc (Either ModIface (FrontendResult, Maybe Fingerprint))

hscIncrementalFrontend
Simon Marlow's avatar
Simon Marlow committed
698
  always_do_basic_recompilation_check m_tc_result
699
  mHscMessage mod_summary source_modified mb_old_iface mod_index
700
    = do
701
    hsc_env <- getHscEnv
702 703

    let msg what = case mHscMessage of
704 705 706
          -- We use extendModSummaryNoDeps because extra backpack deps are only needed for batch mode
          Just hscMessage -> hscMessage hsc_env mod_index what (ModuleNode (extendModSummaryNoDeps mod_summary))
          Nothing -> return ()
dterei's avatar
dterei committed
707

708
        skip iface = do
709
            liftIO $ msg UpToDate
710
            return $ Left iface
dterei's avatar
dterei committed
711

712
        compile mb_old_hash reason = do
713
            liftIO $ msg reason
Sylvain Henry's avatar
Sylvain Henry committed
714 715 716
            tc_result <- case hscFrontendHook (hsc_hooks hsc_env) of
              Nothing -> FrontendTypecheck . fst <$> hsc_typecheck False mod_summary Nothing
              Just h  -> h mod_summary
John Ericson's avatar
John Ericson committed
717
            return $ Right (tc_result, mb_old_hash)
dterei's avatar
dterei committed
718 719 720 721

        stable = case source_modified of
                     SourceUnmodifiedAndStable -> True
                     _                         -> False
722

723 724 725
    case m_tc_result of
         Just tc_result
          | not always_do_basic_recompilation_check ->
726
             return $ Right (FrontendTypecheck tc_result, Nothing)
727 728 729
         _ -> do
            (recomp_reqd, mb_checked_iface)
                <- {-# SCC "checkOldIface" #-}
730
                   liftIO $ checkOldIface hsc_env mod_summary
731 732 733 734
                                source_modified mb_old_iface
            -- save the interface that comes back from checkOldIface.
            -- In one-shot mode we don't have the old iface until this
            -- point, when checkOldIface reads it from the disk.
735
            let mb_old_hash = fmap (mi_iface_hash . mi_final_exts) mb_checked_iface
736 737 738

            case mb_checked_iface of
                Just iface | not (recompileRequired recomp_reqd) ->
Simon Marlow's avatar
Simon Marlow committed
739 740 741 742 743 744 745 746 747 748 749 750 751
                    -- If the module used TH splices when it was last
                    -- compiled, then the recompilation check is not
                    -- accurate enough (#481) and we must ignore
                    -- it.  However, if the module is stable (none of
                    -- the modules it depends on, directly or
                    -- indirectly, changed), then we *can* skip
                    -- recompilation. This is why the SourceModified
                    -- type contains SourceUnmodifiedAndStable, and
                    -- it's pretty important: otherwise ghc --make
                    -- would always recompile TH modules, even if
                    -- nothing at all has changed. Stability is just
                    -- the same check that make is doing for us in
                    -- one-shot mode.
752 753 754 755 756 757 758 759 760 761
                    case m_tc_result of
                    Nothing
                     | mi_used_th iface && not stable ->
                        compile mb_old_hash (RecompBecause "TH")
                    _ ->
                        skip iface
                _ ->
                    case m_tc_result of
                    Nothing -> compile mb_old_hash recomp_reqd
                    Just tc_result ->
762
                        return $ Right (FrontendTypecheck tc_result, mb_old_hash)
763

764 765 766 767
--------------------------------------------------------------
-- Compilers
--------------------------------------------------------------

768 769 770 771 772
-- | Used by both OneShot and batch mode. Runs the pipeline HsSyn and Core parts
-- of the pipeline.
-- We return a interface if we already had an old one around and recompilation
-- was not needed. Otherwise it will be created during later passes when we
-- run the compilation pipeline.
773 774 775 776 777 778 779 780
hscIncrementalCompile :: Bool
                      -> Maybe TcGblEnv
                      -> Maybe Messager
                      -> HscEnv
                      -> ModSummary
                      -> SourceModified
                      -> Maybe ModIface
                      -> (Int,Int)
781
                      -> IO (HscStatus, HscEnv)
782 783
hscIncrementalCompile always_do_basic_recompilation_check m_tc_result
    mHscMessage hsc_env' mod_summary source_modified mb_old_iface mod_index
784
  = do
785
    hsc_env'' <- initializePlugins hsc_env'
Matthew Pickering's avatar
Matthew Pickering committed
786

dterei's avatar
dterei committed
787
    -- One-shot mode needs a knot-tying mutable variable for interface
Sylvain Henry's avatar
Sylvain Henry committed
788
    -- files. See GHC.Tc.Utils.TcGblEnv.tcg_type_env_var.
789
    -- See also Note [hsc_type_env_var hack]
dterei's avatar
dterei committed
790 791
    type_env_var <- newIORef emptyNameEnv
    let mod = ms_mod mod_summary
Matthew Pickering's avatar
Matthew Pickering committed
792 793
        hsc_env | isOneShot (ghcMode (hsc_dflags hsc_env''))
                = hsc_env'' { hsc_type_env_var = Just (mod, type_env_var) }
794
                | otherwise
Matthew Pickering's avatar
Matthew Pickering committed
795
                = hsc_env''
796

797 798 799 800 801 802 803 804
    -- NB: enter Hsc monad here so that we don't bail out early with
    -- -Werror on typechecker warnings; we also want to run the desugarer
    -- to get those warnings too. (But we'll always exit at that point
    -- because the desugarer runs ioMsgMaybe.)
    runHsc hsc_env $ do
    e <- hscIncrementalFrontend always_do_basic_recompilation_check m_tc_result mHscMessage
            mod_summary source_modified mb_old_iface mod_index
    case e of
805 806
        -- We didn't need to do any typechecking; the old interface
        -- file on disk was good enough.
807
        Left iface -> do
808
            details <- liftIO $ initModDetails hsc_env mod_summary iface
809
            return (HscUpToDate iface details, hsc_env')
810 811 812 813
        -- We finished type checking.  (mb_old_hash is the hash of
        -- the interface that existed on disk; it's possible we had
        -- to retypecheck but the resulting interface is exactly
        -- the same.)
814
        Right (FrontendTypecheck tc_result, mb_old_hash) -> do
815
            status <- finish mod_summary tc_result mb_old_hash
816
            return (status, hsc_env)
817

818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869