Merge remote-tracking branch 'origin/master' into type-nats
[ghc.git] / compiler / main / HscMain.hs
1 -------------------------------------------------------------------------------
2 --
3 -- | Main API for compiling plain Haskell source code.
4 --
5 -- This module implements compilation of a Haskell source. It is
6 -- /not/ concerned with preprocessing of source files; this is handled
7 -- in "DriverPipeline".
8 --
9 -- There are various entry points depending on what mode we're in:
10 -- "batch" mode (@--make@), "one-shot" mode (@-c@, @-S@ etc.), and
11 -- "interactive" mode (GHCi). There are also entry points for
12 -- individual passes: parsing, typechecking/renaming, desugaring, and
13 -- simplification.
14 --
15 -- All the functions here take an 'HscEnv' as a parameter, but none of
16 -- them return a new one: 'HscEnv' is treated as an immutable value
17 -- from here on in (although it has mutable components, for the
18 -- caches).
19 --
20 -- Warning messages are dealt with consistently throughout this API:
21 -- during compilation warnings are collected, and before any function
22 -- in @HscMain@ returns, the warnings are either printed, or turned
23 -- into a real compialtion error if the @-Werror@ flag is enabled.
24 --
25 -- (c) The GRASP/AQUA Project, Glasgow University, 1993-2000
26 --
27 -------------------------------------------------------------------------------
28
29 module HscMain
30 (
31 -- * Making an HscEnv
32 newHscEnv
33
34 -- * Compiling complete source files
35 , Compiler
36 , HscStatus' (..)
37 , InteractiveStatus, HscStatus
38 , hscCompileOneShot
39 , hscCompileBatch
40 , hscCompileNothing
41 , hscCompileInteractive
42 , hscCompileCmmFile
43 , hscCompileCore
44
45 -- * Running passes separately
46 , hscParse
47 , hscTypecheckRename
48 , hscDesugar
49 , makeSimpleIface
50 , makeSimpleDetails
51 , hscSimplify -- ToDo, shouldn't really export this
52
53 -- ** Backends
54 , hscOneShotBackendOnly
55 , hscBatchBackendOnly
56 , hscNothingBackendOnly
57 , hscInteractiveBackendOnly
58
59 -- * Support for interactive evaluation
60 , hscParseIdentifier
61 , hscTcRcLookupName
62 , hscTcRnGetInfo
63 , hscCheckSafe
64 #ifdef GHCI
65 , hscGetModuleInterface
66 , hscRnImportDecls
67 , hscTcRnLookupRdrName
68 , hscStmt, hscStmtWithLocation
69 , hscDecls, hscDeclsWithLocation
70 , hscTcExpr, hscImport, hscKcType
71 , hscCompileCoreExpr
72 #endif
73 ) where
74
75 #ifdef GHCI
76 import ByteCodeGen ( byteCodeGen, coreExprToBCOs )
77 import Linker
78 import CoreTidy ( tidyExpr )
79 import Type ( Type )
80 import PrelNames
81 import {- Kind parts of -} Type ( Kind )
82 import CoreLint ( lintUnfolding )
83 import DsMeta ( templateHaskellNames )
84 import VarSet
85 import VarEnv ( emptyTidyEnv )
86 import Panic
87
88 import GHC.Exts
89 #endif
90
91 import Id
92 import Module
93 import Packages
94 import RdrName
95 import HsSyn
96 import CoreSyn
97 import StringBuffer
98 import Parser
99 import Lexer
100 import SrcLoc
101 import TcRnDriver
102 import TcIface ( typecheckIface )
103 import TcRnMonad
104 import IfaceEnv ( initNameCache )
105 import LoadIface ( ifaceStats, initExternalPackageState )
106 import PrelInfo
107 import MkIface
108 import Desugar
109 import SimplCore
110 import TidyPgm
111 import CorePrep
112 import CoreToStg ( coreToStg )
113 import qualified StgCmm ( codeGen )
114 import StgSyn
115 import CostCentre
116 import ProfInit
117 import TyCon
118 import Name
119 import SimplStg ( stg2stg )
120 import CodeGen ( codeGen )
121 import OldCmm as Old ( CmmGroup )
122 import PprCmm ( pprCmms )
123 import CmmParse ( parseCmmFile )
124 import CmmBuildInfoTables
125 import CmmPipeline
126 import CmmInfo
127 import OptimizationFuel ( initOptFuelState )
128 import CmmCvt
129 import CodeOutput
130 import NameEnv ( emptyNameEnv )
131 import NameSet ( emptyNameSet )
132 import InstEnv
133 import FamInstEnv
134 import Fingerprint ( Fingerprint )
135
136 import DynFlags
137 import ErrUtils
138 import UniqSupply ( mkSplitUniqSupply )
139
140 import Outputable
141 import HscStats ( ppSourceStats )
142 import HscTypes
143 import MkExternalCore ( emitExternalCore )
144 import FastString
145 import UniqFM ( emptyUFM )
146 import UniqSupply ( initUs_ )
147 import Bag
148 import Exception
149
150 import Data.List
151 import Control.Monad
152 import Data.Maybe
153 import Data.IORef
154 import System.FilePath as FilePath
155 import System.Directory
156
157 #include "HsVersions.h"
158
159
160 {- **********************************************************************
161 %* *
162 Initialisation
163 %* *
164 %********************************************************************* -}
165
166 newHscEnv :: DynFlags -> IO HscEnv
167 newHscEnv dflags = do
168 eps_var <- newIORef initExternalPackageState
169 us <- mkSplitUniqSupply 'r'
170 nc_var <- newIORef (initNameCache us knownKeyNames)
171 fc_var <- newIORef emptyUFM
172 mlc_var <- newIORef emptyModuleEnv
173 optFuel <- initOptFuelState
174 safe_var <- newIORef True
175 return HscEnv { hsc_dflags = dflags,
176 hsc_targets = [],
177 hsc_mod_graph = [],
178 hsc_IC = emptyInteractiveContext dflags,
179 hsc_HPT = emptyHomePackageTable,
180 hsc_EPS = eps_var,
181 hsc_NC = nc_var,
182 hsc_FC = fc_var,
183 hsc_MLC = mlc_var,
184 hsc_OptFuel = optFuel,
185 hsc_type_env_var = Nothing,
186 hsc_safeInf = safe_var }
187
188
189 knownKeyNames :: [Name] -- Put here to avoid loops involving DsMeta,
190 knownKeyNames = -- where templateHaskellNames are defined
191 map getName wiredInThings
192 ++ basicKnownKeyNames
193 #ifdef GHCI
194 ++ templateHaskellNames
195 #endif
196
197 -- -----------------------------------------------------------------------------
198 -- The Hsc monad: Passing an enviornment and warning state
199
200 newtype Hsc a = Hsc (HscEnv -> WarningMessages -> IO (a, WarningMessages))
201
202 instance Monad Hsc where
203 return a = Hsc $ \_ w -> return (a, w)
204 Hsc m >>= k = Hsc $ \e w -> do (a, w1) <- m e w
205 case k a of
206 Hsc k' -> k' e w1
207
208 instance MonadIO Hsc where
209 liftIO io = Hsc $ \_ w -> do a <- io; return (a, w)
210
211 instance Functor Hsc where
212 fmap f m = m >>= \a -> return $ f a
213
214 runHsc :: HscEnv -> Hsc a -> IO a
215 runHsc hsc_env (Hsc hsc) = do
216 (a, w) <- hsc hsc_env emptyBag
217 printOrThrowWarnings (hsc_dflags hsc_env) w
218 return a
219
220 -- A variant of runHsc that switches in the DynFlags from the
221 -- InteractiveContext before running the Hsc computation.
222 --
223 runInteractiveHsc :: HscEnv -> Hsc a -> IO a
224 runInteractiveHsc hsc_env =
225 runHsc (hsc_env { hsc_dflags = ic_dflags (hsc_IC hsc_env) })
226
227 getWarnings :: Hsc WarningMessages
228 getWarnings = Hsc $ \_ w -> return (w, w)
229
230 clearWarnings :: Hsc ()
231 clearWarnings = Hsc $ \_ _ -> return ((), emptyBag)
232
233 logWarnings :: WarningMessages -> Hsc ()
234 logWarnings w = Hsc $ \_ w0 -> return ((), w0 `unionBags` w)
235
236 getHscEnv :: Hsc HscEnv
237 getHscEnv = Hsc $ \e w -> return (e, w)
238
239 instance HasDynFlags Hsc where
240 getDynFlags = Hsc $ \e w -> return (hsc_dflags e, w)
241
242 handleWarnings :: Hsc ()
243 handleWarnings = do
244 dflags <- getDynFlags
245 w <- getWarnings
246 liftIO $ printOrThrowWarnings dflags w
247 clearWarnings
248
249 -- | log warning in the monad, and if there are errors then
250 -- throw a SourceError exception.
251 logWarningsReportErrors :: Messages -> Hsc ()
252 logWarningsReportErrors (warns,errs) = do
253 logWarnings warns
254 when (not $ isEmptyBag errs) $ throwErrors errs
255
256 -- | Throw some errors.
257 throwErrors :: ErrorMessages -> Hsc a
258 throwErrors = liftIO . throwIO . mkSrcErr
259
260 -- | Deal with errors and warnings returned by a compilation step
261 --
262 -- In order to reduce dependencies to other parts of the compiler, functions
263 -- outside the "main" parts of GHC return warnings and errors as a parameter
264 -- and signal success via by wrapping the result in a 'Maybe' type. This
265 -- function logs the returned warnings and propagates errors as exceptions
266 -- (of type 'SourceError').
267 --
268 -- This function assumes the following invariants:
269 --
270 -- 1. If the second result indicates success (is of the form 'Just x'),
271 -- there must be no error messages in the first result.
272 --
273 -- 2. If there are no error messages, but the second result indicates failure
274 -- there should be warnings in the first result. That is, if the action
275 -- failed, it must have been due to the warnings (i.e., @-Werror@).
276 ioMsgMaybe :: IO (Messages, Maybe a) -> Hsc a
277 ioMsgMaybe ioA = do
278 ((warns,errs), mb_r) <- liftIO ioA
279 logWarnings warns
280 case mb_r of
281 Nothing -> throwErrors errs
282 Just r -> ASSERT( isEmptyBag errs ) return r
283
284 -- | like ioMsgMaybe, except that we ignore error messages and return
285 -- 'Nothing' instead.
286 ioMsgMaybe' :: IO (Messages, Maybe a) -> Hsc (Maybe a)
287 ioMsgMaybe' ioA = do
288 ((warns,_errs), mb_r) <- liftIO $ ioA
289 logWarnings warns
290 return mb_r
291
292 -- -----------------------------------------------------------------------------
293 -- | Lookup things in the compiler's environment
294
295 #ifdef GHCI
296 hscTcRnLookupRdrName :: HscEnv -> RdrName -> IO [Name]
297 hscTcRnLookupRdrName hsc_env0 rdr_name = runInteractiveHsc hsc_env0 $ do
298 hsc_env <- getHscEnv
299 ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name
300 #endif
301
302 hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing)
303 hscTcRcLookupName hsc_env0 name = runInteractiveHsc hsc_env0 $ do
304 hsc_env <- getHscEnv
305 ioMsgMaybe' $ tcRnLookupName hsc_env name
306 -- ignore errors: the only error we're likely to get is
307 -- "name not found", and the Maybe in the return type
308 -- is used to indicate that.
309
310 hscTcRnGetInfo :: HscEnv -> Name -> IO (Maybe (TyThing, Fixity, [ClsInst]))
311 hscTcRnGetInfo hsc_env0 name = runInteractiveHsc hsc_env0 $ do
312 hsc_env <- getHscEnv
313 ioMsgMaybe' $ tcRnGetInfo hsc_env name
314
315 #ifdef GHCI
316 hscGetModuleInterface :: HscEnv -> Module -> IO ModIface
317 hscGetModuleInterface hsc_env0 mod = runInteractiveHsc hsc_env0 $ do
318 hsc_env <- getHscEnv
319 ioMsgMaybe $ getModuleInterface hsc_env mod
320
321 -- -----------------------------------------------------------------------------
322 -- | Rename some import declarations
323 hscRnImportDecls :: HscEnv -> [LImportDecl RdrName] -> IO GlobalRdrEnv
324 hscRnImportDecls hsc_env0 import_decls = runInteractiveHsc hsc_env0 $ do
325 hsc_env <- getHscEnv
326 ioMsgMaybe $ tcRnImportDecls hsc_env import_decls
327 #endif
328
329 -- -----------------------------------------------------------------------------
330 -- | parse a file, returning the abstract syntax
331
332 hscParse :: HscEnv -> ModSummary -> IO HsParsedModule
333 hscParse hsc_env mod_summary = runHsc hsc_env $ hscParse' mod_summary
334
335 -- internal version, that doesn't fail due to -Werror
336 hscParse' :: ModSummary -> Hsc HsParsedModule
337 hscParse' mod_summary = do
338 dflags <- getDynFlags
339 let src_filename = ms_hspp_file mod_summary
340 maybe_src_buf = ms_hspp_buf mod_summary
341
342 -------------------------- Parser ----------------
343 liftIO $ showPass dflags "Parser"
344 {-# SCC "Parser" #-} do
345
346 -- sometimes we already have the buffer in memory, perhaps
347 -- because we needed to parse the imports out of it, or get the
348 -- module name.
349 buf <- case maybe_src_buf of
350 Just b -> return b
351 Nothing -> liftIO $ hGetStringBuffer src_filename
352
353 let loc = mkRealSrcLoc (mkFastString src_filename) 1 1
354
355 case unP parseModule (mkPState dflags buf loc) of
356 PFailed span err ->
357 liftIO $ throwOneError (mkPlainErrMsg span err)
358
359 POk pst rdr_module -> do
360 logWarningsReportErrors (getMessages pst)
361 liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" $
362 ppr rdr_module
363 liftIO $ dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" $
364 ppSourceStats False rdr_module
365
366 -- To get the list of extra source files, we take the list
367 -- that the parser gave us,
368 -- - eliminate files beginning with '<'. gcc likes to use
369 -- pseudo-filenames like "<built-in>" and "<command-line>"
370 -- - normalise them (elimiante differences between ./f and f)
371 -- - filter out the preprocessed source file
372 -- - filter out anything beginning with tmpdir
373 -- - remove duplicates
374 -- - filter out the .hs/.lhs source filename if we have one
375 --
376 let n_hspp = FilePath.normalise src_filename
377 srcs0 = nub $ filter (not . (tmpDir dflags `isPrefixOf`))
378 $ filter (not . (== n_hspp))
379 $ map FilePath.normalise
380 $ filter (not . (== '<') . head)
381 $ map unpackFS
382 $ srcfiles pst
383 srcs1 = case ml_hs_file (ms_location mod_summary) of
384 Just f -> filter (/= FilePath.normalise f) srcs0
385 Nothing -> srcs0
386
387 -- sometimes we see source files from earlier
388 -- preprocessing stages that cannot be found, so just
389 -- filter them out:
390 srcs2 <- liftIO $ filterM doesFileExist srcs1
391
392 return HsParsedModule {
393 hpm_module = rdr_module,
394 hpm_src_files = srcs2
395 }
396
397 -- XXX: should this really be a Maybe X? Check under which circumstances this
398 -- can become a Nothing and decide whether this should instead throw an
399 -- exception/signal an error.
400 type RenamedStuff =
401 (Maybe (HsGroup Name, [LImportDecl Name], Maybe [LIE Name],
402 Maybe LHsDocString))
403
404 -- | Rename and typecheck a module, additionally returning the renamed syntax
405 hscTypecheckRename :: HscEnv -> ModSummary -> HsParsedModule
406 -> IO (TcGblEnv, RenamedStuff)
407 hscTypecheckRename hsc_env mod_summary rdr_module = runHsc hsc_env $ do
408 tc_result <- {-# SCC "Typecheck-Rename" #-}
409 ioMsgMaybe $
410 tcRnModule hsc_env (ms_hsc_src mod_summary)
411 True rdr_module
412
413 -- This 'do' is in the Maybe monad!
414 let rn_info = do decl <- tcg_rn_decls tc_result
415 let imports = tcg_rn_imports tc_result
416 exports = tcg_rn_exports tc_result
417 doc_hdr = tcg_doc_hdr tc_result
418 return (decl,imports,exports,doc_hdr)
419
420 return (tc_result, rn_info)
421
422 -- | Convert a typechecked module to Core
423 hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts
424 hscDesugar hsc_env mod_summary tc_result =
425 runHsc hsc_env $ hscDesugar' (ms_location mod_summary) tc_result
426
427 hscDesugar' :: ModLocation -> TcGblEnv -> Hsc ModGuts
428 hscDesugar' mod_location tc_result = do
429 hsc_env <- getHscEnv
430 r <- ioMsgMaybe $
431 {-# SCC "deSugar" #-}
432 deSugar hsc_env mod_location tc_result
433
434 -- always check -Werror after desugaring, this is the last opportunity for
435 -- warnings to arise before the backend.
436 handleWarnings
437 return r
438
439 -- | Make a 'ModIface' from the results of typechecking. Used when
440 -- not optimising, and the interface doesn't need to contain any
441 -- unfoldings or other cross-module optimisation info.
442 -- ToDo: the old interface is only needed to get the version numbers,
443 -- we should use fingerprint versions instead.
444 makeSimpleIface :: HscEnv -> Maybe ModIface -> TcGblEnv -> ModDetails
445 -> IO (ModIface,Bool)
446 makeSimpleIface hsc_env maybe_old_iface tc_result details =
447 runHsc hsc_env $ ioMsgMaybe $
448 mkIfaceTc hsc_env (fmap mi_iface_hash maybe_old_iface) details tc_result
449
450 -- | Make a 'ModDetails' from the results of typechecking. Used when
451 -- typechecking only, as opposed to full compilation.
452 makeSimpleDetails :: HscEnv -> TcGblEnv -> IO ModDetails
453 makeSimpleDetails hsc_env tc_result = mkBootModDetailsTc hsc_env tc_result
454
455
456 {- **********************************************************************
457 %* *
458 The main compiler pipeline
459 %* *
460 %********************************************************************* -}
461
462 {-
463 --------------------------------
464 The compilation proper
465 --------------------------------
466
467 It's the task of the compilation proper to compile Haskell, hs-boot and core
468 files to either byte-code, hard-code (C, asm, LLVM, ect) or to nothing at all
469 (the module is still parsed and type-checked. This feature is mostly used by
470 IDE's and the likes). Compilation can happen in either 'one-shot', 'batch',
471 'nothing', or 'interactive' mode. 'One-shot' mode targets hard-code, 'batch'
472 mode targets hard-code, 'nothing' mode targets nothing and 'interactive' mode
473 targets byte-code.
474
475 The modes are kept separate because of their different types and meanings:
476
477 * In 'one-shot' mode, we're only compiling a single file and can therefore
478 discard the new ModIface and ModDetails. This is also the reason it only
479 targets hard-code; compiling to byte-code or nothing doesn't make sense when
480 we discard the result.
481
482 * 'Batch' mode is like 'one-shot' except that we keep the resulting ModIface
483 and ModDetails. 'Batch' mode doesn't target byte-code since that require us to
484 return the newly compiled byte-code.
485
486 * 'Nothing' mode has exactly the same type as 'batch' mode but they're still
487 kept separate. This is because compiling to nothing is fairly special: We
488 don't output any interface files, we don't run the simplifier and we don't
489 generate any code.
490
491 * 'Interactive' mode is similar to 'batch' mode except that we return the
492 compiled byte-code together with the ModIface and ModDetails.
493
494 Trying to compile a hs-boot file to byte-code will result in a run-time error.
495 This is the only thing that isn't caught by the type-system.
496 -}
497
498
499 -- | Status of a compilation to hard-code or nothing.
500 data HscStatus' a
501 = HscNoRecomp
502 | HscRecomp
503 (Maybe FilePath) -- Has stub files. This is a hack. We can't compile
504 -- C files here since it's done in DriverPipeline.
505 -- For now we just return True if we want the caller
506 -- to compile them for us.
507 a
508
509 -- This is a bit ugly. Since we use a typeclass below and would like to avoid
510 -- functional dependencies, we have to parameterise the typeclass over the
511 -- result type. Therefore we need to artificially distinguish some types. We do
512 -- this by adding type tags which will simply be ignored by the caller.
513 type HscStatus = HscStatus' ()
514 type InteractiveStatus = HscStatus' (Maybe (CompiledByteCode, ModBreaks))
515 -- INVARIANT: result is @Nothing@ <=> input was a boot file
516
517 type OneShotResult = HscStatus
518 type BatchResult = (HscStatus, ModIface, ModDetails)
519 type NothingResult = (HscStatus, ModIface, ModDetails)
520 type InteractiveResult = (InteractiveStatus, ModIface, ModDetails)
521
522 -- ToDo: The old interface and module index are only using in 'batch' and
523 -- 'interactive' mode. They should be removed from 'oneshot' mode.
524 type Compiler result = HscEnv
525 -> ModSummary
526 -> SourceModified
527 -> Maybe ModIface -- Old interface, if available
528 -> Maybe (Int,Int) -- Just (i,n) <=> module i of n (for msgs)
529 -> IO result
530
531 data HsCompiler a = HsCompiler {
532 -- | Called when no recompilation is necessary.
533 hscNoRecomp :: ModIface
534 -> Hsc a,
535
536 -- | Called to recompile the module.
537 hscRecompile :: ModSummary -> Maybe Fingerprint
538 -> Hsc a,
539
540 hscBackend :: TcGblEnv -> ModSummary -> Maybe Fingerprint
541 -> Hsc a,
542
543 -- | Code generation for Boot modules.
544 hscGenBootOutput :: TcGblEnv -> ModSummary -> Maybe Fingerprint
545 -> Hsc a,
546
547 -- | Code generation for normal modules.
548 hscGenOutput :: ModGuts -> ModSummary -> Maybe Fingerprint
549 -> Hsc a
550 }
551
552 genericHscCompile :: HsCompiler a
553 -> (HscEnv -> Maybe (Int,Int) -> RecompileRequired -> ModSummary -> IO ())
554 -> HscEnv -> ModSummary -> SourceModified
555 -> Maybe ModIface -> Maybe (Int, Int)
556 -> IO a
557 genericHscCompile compiler hscMessage hsc_env
558 mod_summary source_modified
559 mb_old_iface0 mb_mod_index
560 = do
561 (recomp_reqd, mb_checked_iface)
562 <- {-# SCC "checkOldIface" #-}
563 checkOldIface hsc_env mod_summary
564 source_modified mb_old_iface0
565 -- save the interface that comes back from checkOldIface.
566 -- In one-shot mode we don't have the old iface until this
567 -- point, when checkOldIface reads it from the disk.
568 let mb_old_hash = fmap mi_iface_hash mb_checked_iface
569
570 let skip iface = do
571 hscMessage hsc_env mb_mod_index UpToDate mod_summary
572 runHsc hsc_env $ hscNoRecomp compiler iface
573
574 compile reason = do
575 hscMessage hsc_env mb_mod_index reason mod_summary
576 runHsc hsc_env $ hscRecompile compiler mod_summary mb_old_hash
577
578 stable = case source_modified of
579 SourceUnmodifiedAndStable -> True
580 _ -> False
581
582 -- If the module used TH splices when it was last compiled,
583 -- then the recompilation check is not accurate enough (#481)
584 -- and we must ignore it. However, if the module is stable
585 -- (none of the modules it depends on, directly or indirectly,
586 -- changed), then we *can* skip recompilation. This is why
587 -- the SourceModified type contains SourceUnmodifiedAndStable,
588 -- and it's pretty important: otherwise ghc --make would
589 -- always recompile TH modules, even if nothing at all has
590 -- changed. Stability is just the same check that make is
591 -- doing for us in one-shot mode.
592
593 case mb_checked_iface of
594 Just iface | not (recompileRequired recomp_reqd) ->
595 if mi_used_th iface && not stable
596 then compile RecompForcedByTH
597 else skip iface
598 _otherwise ->
599 compile recomp_reqd
600
601 hscCheckRecompBackend :: HsCompiler a -> TcGblEnv -> Compiler a
602 hscCheckRecompBackend compiler tc_result hsc_env mod_summary
603 source_modified mb_old_iface _m_of_n
604 = do
605 (recomp_reqd, mb_checked_iface)
606 <- {-# SCC "checkOldIface" #-}
607 checkOldIface hsc_env mod_summary
608 source_modified mb_old_iface
609
610 let mb_old_hash = fmap mi_iface_hash mb_checked_iface
611 case mb_checked_iface of
612 Just iface | not (recompileRequired recomp_reqd)
613 -> runHsc hsc_env $
614 hscNoRecomp compiler
615 iface{ mi_globals = Just (tcg_rdr_env tc_result) }
616 _otherwise
617 -> runHsc hsc_env $
618 hscBackend compiler tc_result mod_summary mb_old_hash
619
620 genericHscRecompile :: HsCompiler a
621 -> ModSummary -> Maybe Fingerprint
622 -> Hsc a
623 genericHscRecompile compiler mod_summary mb_old_hash
624 | ExtCoreFile <- ms_hsc_src mod_summary =
625 panic "GHC does not currently support reading External Core files"
626 | otherwise = do
627 tc_result <- hscFileFrontEnd mod_summary
628 hscBackend compiler tc_result mod_summary mb_old_hash
629
630 genericHscBackend :: HsCompiler a
631 -> TcGblEnv -> ModSummary -> Maybe Fingerprint
632 -> Hsc a
633 genericHscBackend compiler tc_result mod_summary mb_old_hash
634 | HsBootFile <- ms_hsc_src mod_summary =
635 hscGenBootOutput compiler tc_result mod_summary mb_old_hash
636 | otherwise = do
637 guts <- hscDesugar' (ms_location mod_summary) tc_result
638 hscGenOutput compiler guts mod_summary mb_old_hash
639
640 compilerBackend :: HsCompiler a -> TcGblEnv -> Compiler a
641 compilerBackend comp tcg hsc_env ms' _ _mb_old_iface _ =
642 runHsc hsc_env $ hscBackend comp tcg ms' Nothing
643
644 --------------------------------------------------------------
645 -- Compilers
646 --------------------------------------------------------------
647
648 hscOneShotCompiler :: HsCompiler OneShotResult
649 hscOneShotCompiler = HsCompiler {
650
651 hscNoRecomp = \_old_iface -> do
652 hsc_env <- getHscEnv
653 liftIO $ dumpIfaceStats hsc_env
654 return HscNoRecomp
655
656 , hscRecompile = genericHscRecompile hscOneShotCompiler
657
658 , hscBackend = \tc_result mod_summary mb_old_hash -> do
659 dflags <- getDynFlags
660 case hscTarget dflags of
661 HscNothing -> return (HscRecomp Nothing ())
662 _otherw -> genericHscBackend hscOneShotCompiler
663 tc_result mod_summary mb_old_hash
664
665 , hscGenBootOutput = \tc_result mod_summary mb_old_iface -> do
666 (iface, changed, _) <- hscSimpleIface tc_result mb_old_iface
667 hscWriteIface iface changed mod_summary
668 return (HscRecomp Nothing ())
669
670 , hscGenOutput = \guts0 mod_summary mb_old_iface -> do
671 guts <- hscSimplify' guts0
672 (iface, changed, _details, cgguts) <- hscNormalIface guts mb_old_iface
673 hscWriteIface iface changed mod_summary
674 hasStub <- hscGenHardCode cgguts mod_summary
675 return (HscRecomp hasStub ())
676 }
677
678 -- Compile Haskell, boot and extCore in OneShot mode.
679 hscCompileOneShot :: Compiler OneShotResult
680 hscCompileOneShot hsc_env mod_summary src_changed mb_old_iface mb_i_of_n
681 = do
682 -- One-shot mode needs a knot-tying mutable variable for interface
683 -- files. See TcRnTypes.TcGblEnv.tcg_type_env_var.
684 type_env_var <- newIORef emptyNameEnv
685 let mod = ms_mod mod_summary
686 hsc_env' = hsc_env{ hsc_type_env_var = Just (mod, type_env_var) }
687
688 genericHscCompile hscOneShotCompiler
689 oneShotMsg hsc_env' mod_summary src_changed
690 mb_old_iface mb_i_of_n
691
692 hscOneShotBackendOnly :: TcGblEnv -> Compiler OneShotResult
693 hscOneShotBackendOnly = compilerBackend hscOneShotCompiler
694
695 --------------------------------------------------------------
696
697 hscBatchCompiler :: HsCompiler BatchResult
698 hscBatchCompiler = HsCompiler {
699
700 hscNoRecomp = \iface -> do
701 details <- genModDetails iface
702 return (HscNoRecomp, iface, details)
703
704 , hscRecompile = genericHscRecompile hscBatchCompiler
705
706 , hscBackend = genericHscBackend hscBatchCompiler
707
708 , hscGenBootOutput = \tc_result mod_summary mb_old_iface -> do
709 (iface, changed, details) <- hscSimpleIface tc_result mb_old_iface
710 hscWriteIface iface changed mod_summary
711 return (HscRecomp Nothing (), iface, details)
712
713 , hscGenOutput = \guts0 mod_summary mb_old_iface -> do
714 guts <- hscSimplify' guts0
715 (iface, changed, details, cgguts) <- hscNormalIface guts mb_old_iface
716 hscWriteIface iface changed mod_summary
717 hasStub <- hscGenHardCode cgguts mod_summary
718 return (HscRecomp hasStub (), iface, details)
719 }
720
721 -- | Compile Haskell, boot and extCore in batch mode.
722 hscCompileBatch :: Compiler (HscStatus, ModIface, ModDetails)
723 hscCompileBatch = genericHscCompile hscBatchCompiler batchMsg
724
725 hscBatchBackendOnly :: TcGblEnv -> Compiler BatchResult
726 hscBatchBackendOnly = hscCheckRecompBackend hscBatchCompiler
727
728 --------------------------------------------------------------
729
730 hscInteractiveCompiler :: HsCompiler InteractiveResult
731 hscInteractiveCompiler = HsCompiler {
732 hscNoRecomp = \iface -> do
733 details <- genModDetails iface
734 return (HscNoRecomp, iface, details)
735
736 , hscRecompile = genericHscRecompile hscInteractiveCompiler
737
738 , hscBackend = genericHscBackend hscInteractiveCompiler
739
740 , hscGenBootOutput = \tc_result _mod_summary mb_old_iface -> do
741 (iface, _changed, details) <- hscSimpleIface tc_result mb_old_iface
742 return (HscRecomp Nothing Nothing, iface, details)
743
744 , hscGenOutput = \guts0 mod_summary mb_old_iface -> do
745 guts <- hscSimplify' guts0
746 (iface, _changed, details, cgguts) <- hscNormalIface guts mb_old_iface
747 hscInteractive (iface, details, cgguts) mod_summary
748 }
749
750 -- Compile Haskell, extCore to bytecode.
751 hscCompileInteractive :: Compiler (InteractiveStatus, ModIface, ModDetails)
752 hscCompileInteractive = genericHscCompile hscInteractiveCompiler batchMsg
753
754 hscInteractiveBackendOnly :: TcGblEnv -> Compiler InteractiveResult
755 hscInteractiveBackendOnly = compilerBackend hscInteractiveCompiler
756
757 --------------------------------------------------------------
758
759 hscNothingCompiler :: HsCompiler NothingResult
760 hscNothingCompiler = HsCompiler {
761 hscNoRecomp = \iface -> do
762 details <- genModDetails iface
763 return (HscNoRecomp, iface, details)
764
765 , hscRecompile = genericHscRecompile hscNothingCompiler
766
767 , hscBackend = \tc_result _mod_summary mb_old_iface -> do
768 handleWarnings
769 (iface, _changed, details) <- hscSimpleIface tc_result mb_old_iface
770 return (HscRecomp Nothing (), iface, details)
771
772 , hscGenBootOutput = \_ _ _ ->
773 panic "hscCompileNothing: hscGenBootOutput should not be called"
774
775 , hscGenOutput = \_ _ _ ->
776 panic "hscCompileNothing: hscGenOutput should not be called"
777 }
778
779 -- Type-check Haskell and .hs-boot only (no external core)
780 hscCompileNothing :: Compiler (HscStatus, ModIface, ModDetails)
781 hscCompileNothing = genericHscCompile hscNothingCompiler batchMsg
782
783 hscNothingBackendOnly :: TcGblEnv -> Compiler NothingResult
784 hscNothingBackendOnly = compilerBackend hscNothingCompiler
785
786 --------------------------------------------------------------
787 -- NoRecomp handlers
788 --------------------------------------------------------------
789
790 genModDetails :: ModIface -> Hsc ModDetails
791 genModDetails old_iface
792 = do
793 hsc_env <- getHscEnv
794 new_details <- {-# SCC "tcRnIface" #-}
795 liftIO $ initIfaceCheck hsc_env (typecheckIface old_iface)
796 liftIO $ dumpIfaceStats hsc_env
797 return new_details
798
799 --------------------------------------------------------------
800 -- Progress displayers.
801 --------------------------------------------------------------
802
803 oneShotMsg :: HscEnv -> Maybe (Int,Int) -> RecompileRequired -> ModSummary
804 -> IO ()
805 oneShotMsg hsc_env _mb_mod_index recomp _mod_summary =
806 case recomp of
807 UpToDate ->
808 compilationProgressMsg (hsc_dflags hsc_env) $
809 "compilation IS NOT required"
810 _other ->
811 return ()
812
813 batchMsg :: HscEnv -> Maybe (Int,Int) -> RecompileRequired -> ModSummary
814 -> IO ()
815 batchMsg hsc_env mb_mod_index recomp mod_summary =
816 case recomp of
817 MustCompile -> showMsg "Compiling " ""
818 UpToDate
819 | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg "Skipping " ""
820 | otherwise -> return ()
821 RecompBecause reason -> showMsg "Compiling " (" [" ++ reason ++ "]")
822 RecompForcedByTH -> showMsg "Compiling " " [TH]"
823 where
824 showMsg msg reason =
825 compilationProgressMsg (hsc_dflags hsc_env) $
826 (showModuleIndex mb_mod_index ++
827 msg ++ showModMsg (hscTarget (hsc_dflags hsc_env))
828 (recompileRequired recomp) mod_summary)
829 ++ reason
830
831 --------------------------------------------------------------
832 -- FrontEnds
833 --------------------------------------------------------------
834
835 hscFileFrontEnd :: ModSummary -> Hsc TcGblEnv
836 hscFileFrontEnd mod_summary = do
837 hpm <- hscParse' mod_summary
838 hsc_env <- getHscEnv
839 dflags <- getDynFlags
840 tcg_env <-
841 {-# SCC "Typecheck-Rename" #-}
842 ioMsgMaybe $
843 tcRnModule hsc_env (ms_hsc_src mod_summary) False hpm
844 tcSafeOK <- liftIO $ readIORef (tcg_safeInfer tcg_env)
845
846 -- end of the Safe Haskell line, how to respond to user?
847 if not (safeHaskellOn dflags) || (safeInferOn dflags && not tcSafeOK)
848
849 -- if safe haskell off or safe infer failed, wipe trust
850 then wipeTrust tcg_env emptyBag
851
852 -- module safe, throw warning if needed
853 else do
854 tcg_env' <- hscCheckSafeImports tcg_env
855 safe <- liftIO $ hscGetSafeInf hsc_env
856 when (safe && wopt Opt_WarnSafe dflags)
857 (logWarnings $ unitBag $
858 mkPlainWarnMsg (warnSafeOnLoc dflags) $ errSafe tcg_env')
859 return tcg_env'
860 where
861 pprMod t = ppr $ moduleName $ tcg_mod t
862 errSafe t = quotes (pprMod t) <+> text "has been infered as safe!"
863
864 --------------------------------------------------------------
865 -- Safe Haskell
866 --------------------------------------------------------------
867
868 -- Note [Safe Haskell Trust Check]
869 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
870 -- Safe Haskell checks that an import is trusted according to the following
871 -- rules for an import of module M that resides in Package P:
872 --
873 -- * If M is recorded as Safe and all its trust dependencies are OK
874 -- then M is considered safe.
875 -- * If M is recorded as Trustworthy and P is considered trusted and
876 -- all M's trust dependencies are OK then M is considered safe.
877 --
878 -- By trust dependencies we mean that the check is transitive. So if
879 -- a module M that is Safe relies on a module N that is trustworthy,
880 -- importing module M will first check (according to the second case)
881 -- that N is trusted before checking M is trusted.
882 --
883 -- This is a minimal description, so please refer to the user guide
884 -- for more details. The user guide is also considered the authoritative
885 -- source in this matter, not the comments or code.
886
887
888 -- Note [Safe Haskell Inference]
889 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
890 -- Safe Haskell does Safe inference on modules that don't have any specific
891 -- safe haskell mode flag. The basic aproach to this is:
892 -- * When deciding if we need to do a Safe language check, treat
893 -- an unmarked module as having -XSafe mode specified.
894 -- * For checks, don't throw errors but return them to the caller.
895 -- * Caller checks if there are errors:
896 -- * For modules explicitly marked -XSafe, we throw the errors.
897 -- * For unmarked modules (inference mode), we drop the errors
898 -- and mark the module as being Unsafe.
899
900
901 -- | Check that the safe imports of the module being compiled are valid.
902 -- If not we either issue a compilation error if the module is explicitly
903 -- using Safe Haskell, or mark the module as unsafe if we're in safe
904 -- inference mode.
905 hscCheckSafeImports :: TcGblEnv -> Hsc TcGblEnv
906 hscCheckSafeImports tcg_env = do
907 dflags <- getDynFlags
908 tcg_env' <- checkSafeImports dflags tcg_env
909 case safeLanguageOn dflags of
910 True -> do
911 -- we nuke user written RULES in -XSafe
912 logWarnings $ warns (tcg_rules tcg_env')
913 return tcg_env' { tcg_rules = [] }
914 False
915 -- user defined RULES, so not safe or already unsafe
916 | safeInferOn dflags && not (null $ tcg_rules tcg_env') ||
917 safeHaskell dflags == Sf_None
918 -> wipeTrust tcg_env' $ warns (tcg_rules tcg_env')
919
920 -- trustworthy OR safe infered with no RULES
921 | otherwise
922 -> return tcg_env'
923
924 where
925 warns rules = listToBag $ map warnRules rules
926 warnRules (L loc (HsRule n _ _ _ _ _ _)) =
927 mkPlainWarnMsg loc $
928 text "Rule \"" <> ftext n <> text "\" ignored" $+$
929 text "User defined rules are disabled under Safe Haskell"
930
931 -- | Validate that safe imported modules are actually safe. For modules in the
932 -- HomePackage (the package the module we are compiling in resides) this just
933 -- involves checking its trust type is 'Safe' or 'Trustworthy'. For modules
934 -- that reside in another package we also must check that the external pacakge
935 -- is trusted. See the Note [Safe Haskell Trust Check] above for more
936 -- information.
937 --
938 -- The code for this is quite tricky as the whole algorithm is done in a few
939 -- distinct phases in different parts of the code base. See
940 -- RnNames.rnImportDecl for where package trust dependencies for a module are
941 -- collected and unioned. Specifically see the Note [RnNames . Tracking Trust
942 -- Transitively] and the Note [RnNames . Trust Own Package].
943 checkSafeImports :: DynFlags -> TcGblEnv -> Hsc TcGblEnv
944 checkSafeImports dflags tcg_env
945 = do
946 -- We want to use the warning state specifically for detecting if safe
947 -- inference has failed, so store and clear any existing warnings.
948 oldErrs <- getWarnings
949 clearWarnings
950
951 imps <- mapM condense imports'
952 pkgs <- mapM checkSafe imps
953
954 -- grab any safe haskell specific errors and restore old warnings
955 errs <- getWarnings
956 clearWarnings
957 logWarnings oldErrs
958
959 -- See the Note [Safe Haskell Inference]
960 case (not $ isEmptyBag errs) of
961
962 -- We have errors!
963 True ->
964 -- did we fail safe inference or fail -XSafe?
965 case safeInferOn dflags of
966 True -> wipeTrust tcg_env errs
967 False -> liftIO . throwIO . mkSrcErr $ errs
968
969 -- All good matey!
970 False -> do
971 when (packageTrustOn dflags) $ checkPkgTrust dflags pkg_reqs
972 -- add in trusted package requirements for this module
973 let new_trust = emptyImportAvails { imp_trust_pkgs = catMaybes pkgs }
974 return tcg_env { tcg_imports = imp_info `plusImportAvails` new_trust }
975
976 where
977 imp_info = tcg_imports tcg_env -- ImportAvails
978 imports = imp_mods imp_info -- ImportedMods
979 imports' = moduleEnvToList imports -- (Module, [ImportedModsVal])
980 pkg_reqs = imp_trust_pkgs imp_info -- [PackageId]
981
982 condense :: (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, IsSafeImport)
983 condense (_, []) = panic "HscMain.condense: Pattern match failure!"
984 condense (m, x:xs) = do (_,_,l,s) <- foldlM cond' x xs
985 -- we turn all imports into safe ones when
986 -- inference mode is on.
987 let s' = if safeInferOn dflags then True else s
988 return (m, l, s')
989
990 -- ImportedModsVal = (ModuleName, Bool, SrcSpan, IsSafeImport)
991 cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal
992 cond' v1@(m1,_,l1,s1) (_,_,_,s2)
993 | s1 /= s2
994 = throwErrors $ unitBag $ mkPlainErrMsg l1
995 (text "Module" <+> ppr m1 <+>
996 (text $ "is imported both as a safe and unsafe import!"))
997 | otherwise
998 = return v1
999
1000 -- easier interface to work with
1001 checkSafe (_, _, False) = return Nothing
1002 checkSafe (m, l, True ) = fst `fmap` hscCheckSafe' dflags m l
1003
1004 -- | Check that a module is safe to import.
1005 --
1006 -- We return True to indicate the import is safe and False otherwise
1007 -- although in the False case an exception may be thrown first.
1008 hscCheckSafe :: HscEnv -> Module -> SrcSpan -> IO Bool
1009 hscCheckSafe hsc_env m l = runHsc hsc_env $ do
1010 dflags <- getDynFlags
1011 pkgs <- snd `fmap` hscCheckSafe' dflags m l
1012 when (packageTrustOn dflags) $ checkPkgTrust dflags pkgs
1013 errs <- getWarnings
1014 return $ isEmptyBag errs
1015
1016 hscCheckSafe' :: DynFlags -> Module -> SrcSpan -> Hsc (Maybe PackageId, [PackageId])
1017 hscCheckSafe' dflags m l = do
1018 (tw, pkgs) <- isModSafe m l
1019 case tw of
1020 False -> return (Nothing, pkgs)
1021 True | isHomePkg m -> return (Nothing, pkgs)
1022 | otherwise -> return (Just $ modulePackageId m, pkgs)
1023 where
1024 -- Is a module trusted? If not, throw or log errors depending on the type.
1025 -- Return (regardless of trusted or not) if the trust type requires the
1026 -- modules own package be trusted and a list of other packages required to
1027 -- be trusted (these later ones haven't been checked)
1028 isModSafe :: Module -> SrcSpan -> Hsc (Bool, [PackageId])
1029 isModSafe m l = do
1030 iface <- lookup' m
1031 case iface of
1032 -- can't load iface to check trust!
1033 Nothing -> throwErrors $ unitBag $ mkPlainErrMsg l
1034 $ text "Can't load the interface file for" <+> ppr m <>
1035 text ", to check that it can be safely imported"
1036
1037 -- got iface, check trust
1038 Just iface' -> do
1039 let trust = getSafeMode $ mi_trust iface'
1040 trust_own_pkg = mi_trust_pkg iface'
1041 -- check module is trusted
1042 safeM = trust `elem` [Sf_SafeInfered, Sf_Safe, Sf_Trustworthy]
1043 -- check package is trusted
1044 safeP = packageTrusted trust trust_own_pkg m
1045 -- pkg trust reqs
1046 pkgRs = map fst $ filter snd $ dep_pkgs $ mi_deps iface'
1047 case (safeM, safeP) of
1048 -- General errors we throw but Safe errors we log
1049 (True, True ) -> return (trust == Sf_Trustworthy, pkgRs)
1050 (True, False) -> liftIO . throwIO $ pkgTrustErr
1051 (False, _ ) -> logWarnings modTrustErr >>
1052 return (trust == Sf_Trustworthy, pkgRs)
1053
1054 where
1055 pkgTrustErr = mkSrcErr $ unitBag $ mkPlainErrMsg l $ ppr m
1056 <+> text "can't be safely imported!" <+> text "The package ("
1057 <> ppr (modulePackageId m)
1058 <> text ") the module resides in isn't trusted."
1059 modTrustErr = unitBag $ mkPlainErrMsg l $ ppr m
1060 <+> text "can't be safely imported!"
1061 <+> text "The module itself isn't safe."
1062
1063 -- | Check the package a module resides in is trusted. Safe compiled
1064 -- modules are trusted without requiring that their package is trusted. For
1065 -- trustworthy modules, modules in the home package are trusted but
1066 -- otherwise we check the package trust flag.
1067 packageTrusted :: SafeHaskellMode -> Bool -> Module -> Bool
1068 packageTrusted _ _ _
1069 | not (packageTrustOn dflags) = True
1070 packageTrusted Sf_Safe False _ = True
1071 packageTrusted Sf_SafeInfered False _ = True
1072 packageTrusted _ _ m
1073 | isHomePkg m = True
1074 | otherwise = trusted $ getPackageDetails (pkgState dflags)
1075 (modulePackageId m)
1076
1077 lookup' :: Module -> Hsc (Maybe ModIface)
1078 lookup' m = do
1079 hsc_env <- getHscEnv
1080 hsc_eps <- liftIO $ hscEPS hsc_env
1081 let pkgIfaceT = eps_PIT hsc_eps
1082 homePkgT = hsc_HPT hsc_env
1083 iface = lookupIfaceByModule dflags homePkgT pkgIfaceT m
1084 #ifdef GHCI
1085 -- the 'lookupIfaceByModule' method will always fail when calling from GHCi
1086 -- as the compiler hasn't filled in the various module tables
1087 -- so we need to call 'getModuleInterface' to load from disk
1088 iface' <- case iface of
1089 Just _ -> return iface
1090 Nothing -> snd `fmap` (liftIO $ getModuleInterface hsc_env m)
1091 return iface'
1092 #else
1093 return iface
1094 #endif
1095
1096
1097 isHomePkg :: Module -> Bool
1098 isHomePkg m
1099 | thisPackage dflags == modulePackageId m = True
1100 | otherwise = False
1101
1102 -- | Check the list of packages are trusted.
1103 checkPkgTrust :: DynFlags -> [PackageId] -> Hsc ()
1104 checkPkgTrust dflags pkgs =
1105 case errors of
1106 [] -> return ()
1107 _ -> (liftIO . throwIO . mkSrcErr . listToBag) errors
1108 where
1109 errors = catMaybes $ map go pkgs
1110 go pkg
1111 | trusted $ getPackageDetails (pkgState dflags) pkg
1112 = Nothing
1113 | otherwise
1114 = Just $ mkPlainErrMsg noSrcSpan
1115 $ text "The package (" <> ppr pkg <> text ") is required"
1116 <> text " to be trusted but it isn't!"
1117
1118 -- | Set module to unsafe and wipe trust information.
1119 --
1120 -- Make sure to call this method to set a module to infered unsafe,
1121 -- it should be a central and single failure method.
1122 wipeTrust :: TcGblEnv -> WarningMessages -> Hsc TcGblEnv
1123 wipeTrust tcg_env whyUnsafe = do
1124 env <- getHscEnv
1125 dflags <- getDynFlags
1126
1127 when (wopt Opt_WarnUnsafe dflags)
1128 (logWarnings $ unitBag $
1129 mkPlainWarnMsg (warnUnsafeOnLoc dflags) whyUnsafe')
1130
1131 liftIO $ hscSetSafeInf env False
1132 return $ tcg_env { tcg_imports = wiped_trust }
1133
1134 where
1135 wiped_trust = (tcg_imports tcg_env) { imp_trust_pkgs = [] }
1136 pprMod = ppr $ moduleName $ tcg_mod tcg_env
1137 whyUnsafe' = vcat [ quotes pprMod <+> text "has been infered as unsafe!"
1138 , text "Reason:"
1139 , nest 4 (vcat $ pprErrMsgBag whyUnsafe) ]
1140
1141
1142 --------------------------------------------------------------
1143 -- Simplifiers
1144 --------------------------------------------------------------
1145
1146 hscSimplify :: HscEnv -> ModGuts -> IO ModGuts
1147 hscSimplify hsc_env modguts = runHsc hsc_env $ hscSimplify' modguts
1148
1149 hscSimplify' :: ModGuts -> Hsc ModGuts
1150 hscSimplify' ds_result = do
1151 hsc_env <- getHscEnv
1152 {-# SCC "Core2Core" #-}
1153 liftIO $ core2core hsc_env ds_result
1154
1155 --------------------------------------------------------------
1156 -- Interface generators
1157 --------------------------------------------------------------
1158
1159 hscSimpleIface :: TcGblEnv
1160 -> Maybe Fingerprint
1161 -> Hsc (ModIface, Bool, ModDetails)
1162 hscSimpleIface tc_result mb_old_iface = do
1163 hsc_env <- getHscEnv
1164 details <- liftIO $ mkBootModDetailsTc hsc_env tc_result
1165 (new_iface, no_change)
1166 <- {-# SCC "MkFinalIface" #-}
1167 ioMsgMaybe $
1168 mkIfaceTc hsc_env mb_old_iface details tc_result
1169 -- And the answer is ...
1170 liftIO $ dumpIfaceStats hsc_env
1171 return (new_iface, no_change, details)
1172
1173 hscNormalIface :: ModGuts
1174 -> Maybe Fingerprint
1175 -> Hsc (ModIface, Bool, ModDetails, CgGuts)
1176 hscNormalIface simpl_result mb_old_iface = do
1177 hsc_env <- getHscEnv
1178 (cg_guts, details) <- {-# SCC "CoreTidy" #-}
1179 liftIO $ tidyProgram hsc_env simpl_result
1180
1181 -- BUILD THE NEW ModIface and ModDetails
1182 -- and emit external core if necessary
1183 -- This has to happen *after* code gen so that the back-end
1184 -- info has been set. Not yet clear if it matters waiting
1185 -- until after code output
1186 (new_iface, no_change)
1187 <- {-# SCC "MkFinalIface" #-}
1188 ioMsgMaybe $
1189 mkIface hsc_env mb_old_iface details simpl_result
1190
1191 -- Emit external core
1192 -- This should definitely be here and not after CorePrep,
1193 -- because CorePrep produces unqualified constructor wrapper declarations,
1194 -- so its output isn't valid External Core (without some preprocessing).
1195 liftIO $ emitExternalCore (hsc_dflags hsc_env) cg_guts
1196 liftIO $ dumpIfaceStats hsc_env
1197
1198 -- Return the prepared code.
1199 return (new_iface, no_change, details, cg_guts)
1200
1201 --------------------------------------------------------------
1202 -- BackEnd combinators
1203 --------------------------------------------------------------
1204
1205 hscWriteIface :: ModIface -> Bool -> ModSummary -> Hsc ()
1206 hscWriteIface iface no_change mod_summary = do
1207 dflags <- getDynFlags
1208 unless no_change $
1209 {-# SCC "writeIface" #-}
1210 liftIO $ writeIfaceFile dflags (ms_location mod_summary) iface
1211
1212 -- | Compile to hard-code.
1213 hscGenHardCode :: CgGuts -> ModSummary
1214 -> Hsc (Maybe FilePath) -- ^ @Just f@ <=> _stub.c is f
1215 hscGenHardCode cgguts mod_summary = do
1216 hsc_env <- getHscEnv
1217 liftIO $ do
1218 let CgGuts{ -- This is the last use of the ModGuts in a compilation.
1219 -- From now on, we just use the bits we need.
1220 cg_module = this_mod,
1221 cg_binds = core_binds,
1222 cg_tycons = tycons,
1223 cg_foreign = foreign_stubs0,
1224 cg_dep_pkgs = dependencies,
1225 cg_hpc_info = hpc_info } = cgguts
1226 dflags = hsc_dflags hsc_env
1227 platform = targetPlatform dflags
1228 location = ms_location mod_summary
1229 data_tycons = filter isDataTyCon tycons
1230 -- cg_tycons includes newtypes, for the benefit of External Core,
1231 -- but we don't generate any code for newtypes
1232
1233 -------------------
1234 -- PREPARE FOR CODE GENERATION
1235 -- Do saturation and convert to A-normal form
1236 prepd_binds <- {-# SCC "CorePrep" #-}
1237 corePrepPgm dflags core_binds data_tycons ;
1238 ----------------- Convert to STG ------------------
1239 (stg_binds, cost_centre_info)
1240 <- {-# SCC "CoreToStg" #-}
1241 myCoreToStg dflags this_mod prepd_binds
1242
1243 let prof_init = profilingInitCode platform this_mod cost_centre_info
1244 foreign_stubs = foreign_stubs0 `appendStubC` prof_init
1245
1246 ------------------ Code generation ------------------
1247
1248 cmms <- if dopt Opt_TryNewCodeGen dflags
1249 then {-# SCC "NewCodeGen" #-}
1250 tryNewCodeGen hsc_env this_mod data_tycons
1251 cost_centre_info
1252 stg_binds hpc_info
1253 else {-# SCC "CodeGen" #-}
1254 codeGen dflags this_mod data_tycons
1255 cost_centre_info
1256 stg_binds hpc_info
1257
1258 ------------------ Code output -----------------------
1259 rawcmms <- {-# SCC "cmmToRawCmm" #-}
1260 cmmToRawCmm platform cmms
1261 dumpIfSet_dyn dflags Opt_D_dump_raw_cmm "Raw Cmm" (pprPlatform platform rawcmms)
1262 (_stub_h_exists, stub_c_exists)
1263 <- {-# SCC "codeOutput" #-}
1264 codeOutput dflags this_mod location foreign_stubs
1265 dependencies rawcmms
1266 return stub_c_exists
1267
1268 hscInteractive :: (ModIface, ModDetails, CgGuts)
1269 -> ModSummary
1270 -> Hsc (InteractiveStatus, ModIface, ModDetails)
1271 #ifdef GHCI
1272 hscInteractive (iface, details, cgguts) mod_summary = do
1273 dflags <- getDynFlags
1274 let CgGuts{ -- This is the last use of the ModGuts in a compilation.
1275 -- From now on, we just use the bits we need.
1276 cg_module = this_mod,
1277 cg_binds = core_binds,
1278 cg_tycons = tycons,
1279 cg_foreign = foreign_stubs,
1280 cg_modBreaks = mod_breaks } = cgguts
1281
1282 location = ms_location mod_summary
1283 data_tycons = filter isDataTyCon tycons
1284 -- cg_tycons includes newtypes, for the benefit of External Core,
1285 -- but we don't generate any code for newtypes
1286
1287 -------------------
1288 -- PREPARE FOR CODE GENERATION
1289 -- Do saturation and convert to A-normal form
1290 prepd_binds <- {-# SCC "CorePrep" #-}
1291 liftIO $ corePrepPgm dflags core_binds data_tycons ;
1292 ----------------- Generate byte code ------------------
1293 comp_bc <- liftIO $ byteCodeGen dflags this_mod prepd_binds
1294 data_tycons mod_breaks
1295 ------------------ Create f-x-dynamic C-side stuff ---
1296 (_istub_h_exists, istub_c_exists)
1297 <- liftIO $ outputForeignStubs dflags this_mod
1298 location foreign_stubs
1299 return (HscRecomp istub_c_exists (Just (comp_bc, mod_breaks))
1300 , iface, details)
1301 #else
1302 hscInteractive _ _ = panic "GHC not compiled with interpreter"
1303 #endif
1304
1305 ------------------------------
1306
1307 hscCompileCmmFile :: HscEnv -> FilePath -> IO ()
1308 hscCompileCmmFile hsc_env filename = runHsc hsc_env $ do
1309 let dflags = hsc_dflags hsc_env
1310 cmm <- ioMsgMaybe $ parseCmmFile dflags filename
1311 liftIO $ do
1312 rawCmms <- cmmToRawCmm (targetPlatform dflags) [cmm]
1313 _ <- codeOutput dflags no_mod no_loc NoStubs [] rawCmms
1314 return ()
1315 where
1316 no_mod = panic "hscCmmFile: no_mod"
1317 no_loc = ModLocation{ ml_hs_file = Just filename,
1318 ml_hi_file = panic "hscCmmFile: no hi file",
1319 ml_obj_file = panic "hscCmmFile: no obj file" }
1320
1321 -------------------- Stuff for new code gen ---------------------
1322
1323 tryNewCodeGen :: HscEnv -> Module -> [TyCon]
1324 -> CollectedCCs
1325 -> [(StgBinding,[(Id,[Id])])]
1326 -> HpcInfo
1327 -> IO [Old.CmmGroup]
1328 tryNewCodeGen hsc_env this_mod data_tycons
1329 cost_centre_info stg_binds hpc_info = do
1330 let dflags = hsc_dflags hsc_env
1331 platform = targetPlatform dflags
1332 prog <- StgCmm.codeGen dflags this_mod data_tycons
1333 cost_centre_info stg_binds hpc_info
1334 dumpIfSet_dyn dflags Opt_D_dump_cmmz "Cmm produced by new codegen"
1335 (pprCmms platform prog)
1336
1337 -- We are building a single SRT for the entire module, so
1338 -- we must thread it through all the procedures as we cps-convert them.
1339 us <- mkSplitUniqSupply 'S'
1340 let initTopSRT = initUs_ us emptySRT
1341 (topSRT, prog) <- foldM (cmmPipeline hsc_env) (initTopSRT, []) prog
1342
1343 let prog' = map cmmOfZgraph (srtToData topSRT : prog)
1344 dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" (pprPlatform platform prog')
1345 return prog'
1346
1347 myCoreToStg :: DynFlags -> Module -> CoreProgram
1348 -> IO ( [(StgBinding,[(Id,[Id])])] -- output program
1349 , CollectedCCs) -- cost centre info (declared and used)
1350 myCoreToStg dflags this_mod prepd_binds = do
1351 stg_binds
1352 <- {-# SCC "Core2Stg" #-}
1353 coreToStg dflags prepd_binds
1354
1355 (stg_binds2, cost_centre_info)
1356 <- {-# SCC "Stg2Stg" #-}
1357 stg2stg dflags this_mod stg_binds
1358
1359 return (stg_binds2, cost_centre_info)
1360
1361
1362 {- **********************************************************************
1363 %* *
1364 \subsection{Compiling a do-statement}
1365 %* *
1366 %********************************************************************* -}
1367
1368 {-
1369 When the UnlinkedBCOExpr is linked you get an HValue of type *IO [HValue]* When
1370 you run it you get a list of HValues that should be the same length as the list
1371 of names; add them to the ClosureEnv.
1372
1373 A naked expression returns a singleton Name [it]. The stmt is lifted into the
1374 IO monad as explained in Note [Interactively-bound Ids in GHCi] in TcRnDriver
1375 -}
1376
1377 #ifdef GHCI
1378 -- | Compile a stmt all the way to an HValue, but don't run it
1379 --
1380 -- We return Nothing to indicate an empty statement (or comment only), not a
1381 -- parse error.
1382 hscStmt :: HscEnv -> String -> IO (Maybe ([Id], IO [HValue]))
1383 hscStmt hsc_env stmt = hscStmtWithLocation hsc_env stmt "<interactive>" 1
1384
1385 -- | Compile a stmt all the way to an HValue, but don't run it
1386 --
1387 -- We return Nothing to indicate an empty statement (or comment only), not a
1388 -- parse error.
1389 hscStmtWithLocation :: HscEnv
1390 -> String -- ^ The statement
1391 -> String -- ^ The source
1392 -> Int -- ^ Starting line
1393 -> IO (Maybe ([Id], IO [HValue]))
1394 hscStmtWithLocation hsc_env0 stmt source linenumber =
1395 runInteractiveHsc hsc_env0 $ do
1396 hsc_env <- getHscEnv
1397 maybe_stmt <- hscParseStmtWithLocation source linenumber stmt
1398 case maybe_stmt of
1399 Nothing -> return Nothing
1400
1401 Just parsed_stmt -> do
1402 let icntxt = hsc_IC hsc_env
1403 rdr_env = ic_rn_gbl_env icntxt
1404 type_env = mkTypeEnvWithImplicits (ic_tythings icntxt)
1405 src_span = srcLocSpan interactiveSrcLoc
1406
1407 -- Rename and typecheck it
1408 -- Here we lift the stmt into the IO monad, see Note
1409 -- [Interactively-bound Ids in GHCi] in TcRnDriver
1410 (ids, tc_expr) <- ioMsgMaybe $ tcRnStmt hsc_env icntxt parsed_stmt
1411
1412 -- Desugar it
1413 ds_expr <- ioMsgMaybe $
1414 deSugarExpr hsc_env iNTERACTIVE rdr_env type_env tc_expr
1415 handleWarnings
1416
1417 -- Then code-gen, and link it
1418 hsc_env <- getHscEnv
1419 hval <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr
1420 let hval_io = unsafeCoerce# hval :: IO [HValue]
1421
1422 return $ Just (ids, hval_io)
1423
1424 -- | Compile a decls
1425 hscDecls :: HscEnv
1426 -> String -- ^ The statement
1427 -> IO ([TyThing], InteractiveContext)
1428 hscDecls hsc_env str = hscDeclsWithLocation hsc_env str "<interactive>" 1
1429
1430 -- | Compile a decls
1431 hscDeclsWithLocation :: HscEnv
1432 -> String -- ^ The statement
1433 -> String -- ^ The source
1434 -> Int -- ^ Starting line
1435 -> IO ([TyThing], InteractiveContext)
1436 hscDeclsWithLocation hsc_env0 str source linenumber =
1437 runInteractiveHsc hsc_env0 $ do
1438 hsc_env <- getHscEnv
1439 L _ (HsModule{ hsmodDecls = decls }) <-
1440 hscParseThingWithLocation source linenumber parseModule str
1441
1442 {- Rename and typecheck it -}
1443 let icontext = hsc_IC hsc_env
1444 tc_gblenv <- ioMsgMaybe $ tcRnDeclsi hsc_env icontext decls
1445
1446 {- Grab the new instances -}
1447 -- We grab the whole environment because of the overlapping that may have
1448 -- been done. See the notes at the definition of InteractiveContext
1449 -- (ic_instances) for more details.
1450 let finsts = tcg_fam_insts tc_gblenv
1451 insts = tcg_insts tc_gblenv
1452
1453 {- Desugar it -}
1454 -- We use a basically null location for iNTERACTIVE
1455 let iNTERACTIVELoc = ModLocation{ ml_hs_file = Nothing,
1456 ml_hi_file = undefined,
1457 ml_obj_file = undefined}
1458 ds_result <- hscDesugar' iNTERACTIVELoc tc_gblenv
1459
1460 {- Simplify -}
1461 simpl_mg <- liftIO $ hscSimplify hsc_env ds_result
1462
1463 {- Tidy -}
1464 (tidy_cg, _mod_details) <- liftIO $ tidyProgram hsc_env simpl_mg
1465
1466 let dflags = hsc_dflags hsc_env
1467 !CgGuts{ cg_module = this_mod,
1468 cg_binds = core_binds,
1469 cg_tycons = tycons,
1470 cg_modBreaks = mod_breaks } = tidy_cg
1471 data_tycons = filter isDataTyCon tycons
1472
1473 {- Prepare For Code Generation -}
1474 -- Do saturation and convert to A-normal form
1475 prepd_binds <- {-# SCC "CorePrep" #-}
1476 liftIO $ corePrepPgm dflags core_binds data_tycons
1477
1478 {- Generate byte code -}
1479 cbc <- liftIO $ byteCodeGen dflags this_mod
1480 prepd_binds data_tycons mod_breaks
1481
1482 let src_span = srcLocSpan interactiveSrcLoc
1483 hsc_env <- getHscEnv
1484 liftIO $ linkDecls hsc_env src_span cbc
1485
1486 let tcs = filter (not . isImplicitTyCon) $ (mg_tcs simpl_mg)
1487
1488 ext_vars = filter (isExternalName . idName) $
1489 bindersOfBinds core_binds
1490
1491 (sys_vars, user_vars) = partition is_sys_var ext_vars
1492 is_sys_var id = isDFunId id
1493 || isRecordSelector id
1494 || isJust (isClassOpId_maybe id)
1495 -- we only need to keep around the external bindings
1496 -- (as decided by TidyPgm), since those are the only ones
1497 -- that might be referenced elsewhere.
1498
1499 tythings = map AnId user_vars
1500 ++ map ATyCon tcs
1501
1502 let ictxt1 = extendInteractiveContext icontext tythings
1503 ictxt = ictxt1 { ic_sys_vars = sys_vars ++ ic_sys_vars ictxt1,
1504 ic_instances = (insts, finsts) }
1505
1506 return (tythings, ictxt)
1507
1508 hscImport :: HscEnv -> String -> IO (ImportDecl RdrName)
1509 hscImport hsc_env str = runInteractiveHsc hsc_env $ do
1510 (L _ (HsModule{hsmodImports=is})) <-
1511 hscParseThing parseModule str
1512 case is of
1513 [i] -> return (unLoc i)
1514 _ -> liftIO $ throwOneError $
1515 mkPlainErrMsg noSrcSpan $
1516 ptext (sLit "parse error in import declaration")
1517
1518 -- | Typecheck an expression (but don't run it)
1519 hscTcExpr :: HscEnv
1520 -> String -- ^ The expression
1521 -> IO Type
1522 hscTcExpr hsc_env0 expr = runInteractiveHsc hsc_env0 $ do
1523 hsc_env <- getHscEnv
1524 maybe_stmt <- hscParseStmt expr
1525 case maybe_stmt of
1526 Just (L _ (ExprStmt expr _ _ _)) ->
1527 ioMsgMaybe $ tcRnExpr hsc_env (hsc_IC hsc_env) expr
1528 _ ->
1529 throwErrors $ unitBag $ mkPlainErrMsg noSrcSpan
1530 (text "not an expression:" <+> quotes (text expr))
1531
1532 -- | Find the kind of a type
1533 hscKcType
1534 :: HscEnv
1535 -> Bool -- ^ Normalise the type
1536 -> String -- ^ The type as a string
1537 -> IO (Type, Kind) -- ^ Resulting type (possibly normalised) and kind
1538 hscKcType hsc_env0 normalise str = runInteractiveHsc hsc_env0 $ do
1539 hsc_env <- getHscEnv
1540 ty <- hscParseType str
1541 ioMsgMaybe $ tcRnType hsc_env (hsc_IC hsc_env) normalise ty
1542
1543 hscParseStmt :: String -> Hsc (Maybe (LStmt RdrName))
1544 hscParseStmt = hscParseThing parseStmt
1545
1546 hscParseStmtWithLocation :: String -> Int -> String
1547 -> Hsc (Maybe (LStmt RdrName))
1548 hscParseStmtWithLocation source linenumber stmt =
1549 hscParseThingWithLocation source linenumber parseStmt stmt
1550
1551 hscParseType :: String -> Hsc (LHsType RdrName)
1552 hscParseType = hscParseThing parseType
1553 #endif
1554
1555 hscParseIdentifier :: HscEnv -> String -> IO (Located RdrName)
1556 hscParseIdentifier hsc_env str =
1557 runInteractiveHsc hsc_env $ hscParseThing parseIdentifier str
1558
1559 hscParseThing :: (Outputable thing) => Lexer.P thing -> String -> Hsc thing
1560 hscParseThing = hscParseThingWithLocation "<interactive>" 1
1561
1562 hscParseThingWithLocation :: (Outputable thing) => String -> Int
1563 -> Lexer.P thing -> String -> Hsc thing
1564 hscParseThingWithLocation source linenumber parser str
1565 = {-# SCC "Parser" #-} do
1566 dflags <- getDynFlags
1567 liftIO $ showPass dflags "Parser"
1568
1569 let buf = stringToStringBuffer str
1570 loc = mkRealSrcLoc (fsLit source) linenumber 1
1571
1572 case unP parser (mkPState dflags buf loc) of
1573 PFailed span err -> do
1574 let msg = mkPlainErrMsg span err
1575 throwErrors $ unitBag msg
1576
1577 POk pst thing -> do
1578 logWarningsReportErrors (getMessages pst)
1579 liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing)
1580 return thing
1581
1582 hscCompileCore :: HscEnv -> Bool -> ModSummary -> CoreProgram -> IO ()
1583 hscCompileCore hsc_env simplify mod_summary binds = runHsc hsc_env $ do
1584 guts <- maybe_simplify (mkModGuts (ms_mod mod_summary) binds)
1585 (iface, changed, _details, cgguts) <- hscNormalIface guts Nothing
1586 hscWriteIface iface changed mod_summary
1587 _ <- hscGenHardCode cgguts mod_summary
1588 return ()
1589
1590 where
1591 maybe_simplify mod_guts | simplify = hscSimplify' mod_guts
1592 | otherwise = return mod_guts
1593
1594 -- Makes a "vanilla" ModGuts.
1595 mkModGuts :: Module -> CoreProgram -> ModGuts
1596 mkModGuts mod binds =
1597 ModGuts {
1598 mg_module = mod,
1599 mg_boot = False,
1600 mg_exports = [],
1601 mg_deps = noDependencies,
1602 mg_dir_imps = emptyModuleEnv,
1603 mg_used_names = emptyNameSet,
1604 mg_used_th = False,
1605 mg_rdr_env = emptyGlobalRdrEnv,
1606 mg_fix_env = emptyFixityEnv,
1607 mg_tcs = [],
1608 mg_insts = [],
1609 mg_fam_insts = [],
1610 mg_rules = [],
1611 mg_vect_decls = [],
1612 mg_binds = binds,
1613 mg_foreign = NoStubs,
1614 mg_warns = NoWarnings,
1615 mg_anns = [],
1616 mg_hpc_info = emptyHpcInfo False,
1617 mg_modBreaks = emptyModBreaks,
1618 mg_vect_info = noVectInfo,
1619 mg_inst_env = emptyInstEnv,
1620 mg_fam_inst_env = emptyFamInstEnv,
1621 mg_trust_pkg = False,
1622 mg_dependent_files = []
1623 }
1624
1625
1626 {- **********************************************************************
1627 %* *
1628 Desugar, simplify, convert to bytecode, and link an expression
1629 %* *
1630 %********************************************************************* -}
1631
1632 #ifdef GHCI
1633 hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO HValue
1634 hscCompileCoreExpr hsc_env srcspan ds_expr
1635 | rtsIsProfiled
1636 = throwIO (InstallationError "You can't call hscCompileCoreExpr in a profiled compiler")
1637 -- Otherwise you get a seg-fault when you run it
1638
1639 | otherwise = do
1640 let dflags = hsc_dflags hsc_env
1641 let lint_on = dopt Opt_DoCoreLinting dflags
1642
1643 {- Simplify it -}
1644 simpl_expr <- simplifyExpr dflags ds_expr
1645
1646 {- Tidy it (temporary, until coreSat does cloning) -}
1647 let tidy_expr = tidyExpr emptyTidyEnv simpl_expr
1648
1649 {- Prepare for codegen -}
1650 prepd_expr <- corePrepExpr dflags tidy_expr
1651
1652 {- Lint if necessary -}
1653 -- ToDo: improve SrcLoc
1654 when lint_on $
1655 let ictxt = hsc_IC hsc_env
1656 te = mkTypeEnvWithImplicits (ic_tythings ictxt ++ map AnId (ic_sys_vars ictxt))
1657 tyvars = varSetElems $ tyThingsTyVars $ typeEnvElts $ te
1658 vars = typeEnvIds te
1659 in case lintUnfolding noSrcLoc (tyvars ++ vars) prepd_expr of
1660 Just err -> pprPanic "hscCompileCoreExpr" err
1661 Nothing -> return ()
1662
1663 {- Convert to BCOs -}
1664 bcos <- coreExprToBCOs dflags iNTERACTIVE prepd_expr
1665
1666 {- link it -}
1667 hval <- linkExpr hsc_env srcspan bcos
1668
1669 return hval
1670 #endif
1671
1672
1673 {- **********************************************************************
1674 %* *
1675 Statistics on reading interfaces
1676 %* *
1677 %********************************************************************* -}
1678
1679 dumpIfaceStats :: HscEnv -> IO ()
1680 dumpIfaceStats hsc_env = do
1681 eps <- readIORef (hsc_EPS hsc_env)
1682 dumpIfSet (dump_if_trace || dump_rn_stats)
1683 "Interface statistics"
1684 (ifaceStats eps)
1685 where
1686 dflags = hsc_dflags hsc_env
1687 dump_rn_stats = dopt Opt_D_dump_rn_stats dflags
1688 dump_if_trace = dopt Opt_D_dump_if_trace dflags
1689
1690
1691 {- **********************************************************************
1692 %* *
1693 Progress Messages: Module i of n
1694 %* *
1695 %********************************************************************* -}
1696
1697 showModuleIndex :: Maybe (Int, Int) -> String
1698 showModuleIndex Nothing = ""
1699 showModuleIndex (Just (i,n)) = "[" ++ padded ++ " of " ++ n_str ++ "] "
1700 where
1701 n_str = show n
1702 i_str = show i
1703 padded = replicate (length n_str - length i_str) ' ' ++ i_str
1704