never executed always true always false
    1 
    2 {-# LANGUAGE FlexibleInstances #-}
    3 {-# LANGUAGE NondecreasingIndentation #-}
    4 {-# LANGUAGE OverloadedStrings #-}
    5 {-# LANGUAGE TypeFamilies #-}
    6 
    7 
    8 -- | This is the driver for the 'ghc --backpack' mode, which
    9 -- is a reimplementation of the "package manager" bits of
   10 -- Backpack directly in GHC.  The basic method of operation
   11 -- is to compile packages and then directly insert them into
   12 -- GHC's in memory database.
   13 --
   14 -- The compilation products of this mode aren't really suitable
   15 -- for Cabal, because GHC makes up component IDs for the things
   16 -- it builds and doesn't serialize out the database contents.
   17 -- But it's still handy for constructing tests.
   18 
   19 module GHC.Driver.Backpack (doBackpack) where
   20 
   21 import GHC.Prelude
   22 
   23 -- In a separate module because it hooks into the parser.
   24 import GHC.Driver.Backpack.Syntax
   25 import GHC.Driver.Config.Finder (initFinderOpts)
   26 import GHC.Driver.Config.Parser (initParserOpts)
   27 import GHC.Driver.Config.Diagnostic
   28 import GHC.Driver.Monad
   29 import GHC.Driver.Session
   30 import GHC.Driver.Ppr
   31 import GHC.Driver.Main
   32 import GHC.Driver.Make
   33 import GHC.Driver.Env
   34 import GHC.Driver.Errors
   35 import GHC.Driver.Errors.Types
   36 
   37 import GHC.Parser
   38 import GHC.Parser.Header
   39 import GHC.Parser.Lexer
   40 import GHC.Parser.Annotation
   41 
   42 import GHC.Rename.Names
   43 
   44 import GHC hiding (Failed, Succeeded)
   45 import GHC.Tc.Utils.Monad
   46 import GHC.Iface.Recomp
   47 import GHC.Builtin.Names
   48 
   49 import GHC.Types.SrcLoc
   50 import GHC.Types.SourceError
   51 import GHC.Types.SourceFile
   52 import GHC.Types.Unique.FM
   53 import GHC.Types.Unique.DFM
   54 import GHC.Types.Unique.DSet
   55 
   56 import GHC.Utils.Outputable
   57 import GHC.Utils.Fingerprint
   58 import GHC.Utils.Misc
   59 import GHC.Utils.Panic
   60 import GHC.Utils.Error
   61 import GHC.Utils.Logger
   62 
   63 import GHC.Unit
   64 import GHC.Unit.Env
   65 import GHC.Unit.External
   66 import GHC.Unit.Finder
   67 import GHC.Unit.Module.Graph
   68 import GHC.Unit.Module.ModSummary
   69 import GHC.Unit.Home.ModInfo
   70 
   71 import GHC.Linker.Types
   72 
   73 import qualified GHC.LanguageExtensions as LangExt
   74 
   75 import GHC.Data.Maybe
   76 import GHC.Data.StringBuffer
   77 import GHC.Data.FastString
   78 import qualified GHC.Data.EnumSet as EnumSet
   79 import qualified GHC.Data.ShortText as ST
   80 
   81 import Data.List ( partition )
   82 import System.Exit
   83 import Control.Monad
   84 import System.FilePath
   85 import Data.Version
   86 
   87 -- for the unification
   88 import Data.IORef
   89 import Data.Map (Map)
   90 import qualified Data.Map as Map
   91 import qualified Data.Set as Set
   92 
   93 -- | Entry point to compile a Backpack file.
   94 doBackpack :: [FilePath] -> Ghc ()
   95 doBackpack [src_filename] = do
   96     -- Apply options from file to dflags
   97     dflags0 <- getDynFlags
   98     let dflags1 = dflags0
   99     let parser_opts1 = initParserOpts dflags1
  100     src_opts <- liftIO $ getOptionsFromFile parser_opts1 src_filename
  101     (dflags, unhandled_flags, warns) <- liftIO $ parseDynamicFilePragma dflags1 src_opts
  102     modifySession (hscSetFlags dflags)
  103     logger <- getLogger -- Get the logger after having set the session flags,
  104                         -- so that logger options are correctly set.
  105                         -- Not doing so caused #20396.
  106     -- Cribbed from: preprocessFile / GHC.Driver.Pipeline
  107     liftIO $ checkProcessArgsResult unhandled_flags
  108     liftIO $ handleFlagWarnings logger (initDiagOpts dflags) warns
  109     -- TODO: Preprocessing not implemented
  110 
  111     buf <- liftIO $ hGetStringBuffer src_filename
  112     let loc = mkRealSrcLoc (mkFastString src_filename) 1 1 -- TODO: not great
  113     case unP parseBackpack (initParserState (initParserOpts dflags) buf loc) of
  114         PFailed pst -> throwErrors (GhcPsMessage <$> getPsErrorMessages pst)
  115         POk _ pkgname_bkp -> do
  116             -- OK, so we have an LHsUnit PackageName, but we want an
  117             -- LHsUnit HsComponentId.  So let's rename it.
  118             hsc_env <- getSession
  119             let bkp = renameHsUnits (hsc_units hsc_env) (bkpPackageNameMap pkgname_bkp) pkgname_bkp
  120             initBkpM src_filename bkp $
  121                 forM_ (zip [1..] bkp) $ \(i, lunit) -> do
  122                     let comp_name = unLoc (hsunitName (unLoc lunit))
  123                     msgTopPackage (i,length bkp) comp_name
  124                     innerBkpM $ do
  125                         let (cid, insts) = computeUnitId lunit
  126                         if null insts
  127                             then if cid == UnitId (fsLit "main")
  128                                     then compileExe lunit
  129                                     else compileUnit cid []
  130                             else typecheckUnit cid insts
  131 doBackpack _ =
  132     throwGhcException (CmdLineError "--backpack can only process a single file")
  133 
  134 computeUnitId :: LHsUnit HsComponentId -> (UnitId, [(ModuleName, Module)])
  135 computeUnitId (L _ unit) = (cid, [ (r, mkHoleModule r) | r <- reqs ])
  136   where
  137     cid = hsComponentId (unLoc (hsunitName unit))
  138     reqs = uniqDSetToList (unionManyUniqDSets (map (get_reqs . unLoc) (hsunitBody unit)))
  139     get_reqs (DeclD HsigFile (L _ modname) _) = unitUniqDSet modname
  140     get_reqs (DeclD HsSrcFile _ _) = emptyUniqDSet
  141     get_reqs (DeclD HsBootFile _ _) = emptyUniqDSet
  142     get_reqs (IncludeD (IncludeDecl (L _ hsuid) _ _)) =
  143         unitFreeModuleHoles (convertHsComponentId hsuid)
  144 
  145 -- | Tiny enum for all types of Backpack operations we may do.
  146 data SessionType
  147     -- | A compilation operation which will result in a
  148     -- runnable executable being produced.
  149     = ExeSession
  150     -- | A type-checking operation which produces only
  151     -- interface files, no object files.
  152     | TcSession
  153     -- | A compilation operation which produces both
  154     -- interface files and object files.
  155     | CompSession
  156     deriving (Eq)
  157 
  158 -- | Create a temporary Session to do some sort of type checking or
  159 -- compilation.
  160 withBkpSession :: UnitId
  161                -> [(ModuleName, Module)]
  162                -> [(Unit, ModRenaming)]
  163                -> SessionType   -- what kind of session are we doing
  164                -> BkpM a        -- actual action to run
  165                -> BkpM a
  166 withBkpSession cid insts deps session_type do_this = do
  167     dflags <- getDynFlags
  168     let cid_fs = unitFS cid
  169         is_primary = False
  170         uid_str = unpackFS (mkInstantiatedUnitHash cid insts)
  171         cid_str = unpackFS cid_fs
  172         -- There are multiple units in a single Backpack file, so we
  173         -- need to separate out the results in those cases.  Right now,
  174         -- we follow this hierarchy:
  175         --      $outputdir/$compid          --> typecheck results
  176         --      $outputdir/$compid/$unitid  --> compile results
  177         key_base p | Just f <- p dflags = f
  178                    | otherwise          = "."
  179         sub_comp p | is_primary = p
  180                    | otherwise = p </> cid_str
  181         outdir p | CompSession <- session_type
  182                  -- Special case when package is definite
  183                  , not (null insts) = sub_comp (key_base p) </> uid_str
  184                  | otherwise = sub_comp (key_base p)
  185 
  186         mk_temp_env hsc_env = hscUpdateFlags (\dflags -> mk_temp_dflags (hsc_units hsc_env) dflags) hsc_env
  187         mk_temp_dflags unit_state dflags = dflags
  188             { backend = case session_type of
  189                             TcSession -> NoBackend
  190                             _         -> backend dflags
  191             , ghcLink = case session_type of
  192                             TcSession -> NoLink
  193                             _         -> ghcLink dflags
  194             , homeUnitInstantiations_ = insts
  195                                      -- if we don't have any instantiation, don't
  196                                      -- fill `homeUnitInstanceOfId` as it makes no
  197                                      -- sense (we're not instantiating anything)
  198             , homeUnitInstanceOf_   = if null insts then Nothing else Just cid
  199             , homeUnitId_ = case session_type of
  200                 TcSession -> newUnitId cid Nothing
  201                 -- No hash passed if no instances
  202                 _ | null insts -> newUnitId cid Nothing
  203                   | otherwise  -> newUnitId cid (Just (mkInstantiatedUnitHash cid insts))
  204 
  205 
  206             -- If we're type-checking an indefinite package, we want to
  207             -- turn on interface writing.  However, if the user also
  208             -- explicitly passed in `-fno-code`, we DON'T want to write
  209             -- interfaces unless the user also asked for `-fwrite-interface`.
  210             -- See Note [-fno-code mode]
  211             , generalFlags = case session_type of
  212                 -- Make sure to write interfaces when we are type-checking
  213                 -- indefinite packages.
  214                 TcSession
  215                   | backend dflags /= NoBackend
  216                   -> EnumSet.insert Opt_WriteInterface (generalFlags dflags)
  217                 _ -> generalFlags dflags
  218 
  219             -- Setup all of the output directories according to our hierarchy
  220             , objectDir   = Just (outdir objectDir)
  221             , hiDir       = Just (outdir hiDir)
  222             , stubDir     = Just (outdir stubDir)
  223             -- Unset output-file for non exe builds
  224             , outputFile_ = case session_type of
  225                 ExeSession -> outputFile_ dflags
  226                 _          -> Nothing
  227             , dynOutputFile_ = case session_type of
  228                 ExeSession -> dynOutputFile_ dflags
  229                 _          -> Nothing
  230             -- Clear the import path so we don't accidentally grab anything
  231             , importPaths = []
  232             -- Synthesize the flags
  233             , packageFlags = packageFlags dflags ++ map (\(uid0, rn) ->
  234               let uid = unwireUnit unit_state
  235                         $ improveUnit unit_state
  236                         $ renameHoleUnit unit_state (listToUFM insts) uid0
  237               in ExposePackage
  238                 (showSDoc dflags
  239                     (text "-unit-id" <+> ppr uid <+> ppr rn))
  240                 (UnitIdArg uid) rn) deps
  241             }
  242     withTempSession mk_temp_env $ do
  243       dflags <- getSessionDynFlags
  244       -- pprTrace "flags" (ppr insts <> ppr deps) $ return ()
  245       setSessionDynFlags dflags -- calls initUnits
  246       do_this
  247 
  248 withBkpExeSession :: [(Unit, ModRenaming)] -> BkpM a -> BkpM a
  249 withBkpExeSession deps do_this =
  250     withBkpSession (UnitId (fsLit "main")) [] deps ExeSession do_this
  251 
  252 getSource :: UnitId -> BkpM (LHsUnit HsComponentId)
  253 getSource cid = do
  254     bkp_env <- getBkpEnv
  255     case Map.lookup cid (bkp_table bkp_env) of
  256         Nothing -> pprPanic "missing needed dependency" (ppr cid)
  257         Just lunit -> return lunit
  258 
  259 typecheckUnit :: UnitId -> [(ModuleName, Module)] -> BkpM ()
  260 typecheckUnit cid insts = do
  261     lunit <- getSource cid
  262     buildUnit TcSession cid insts lunit
  263 
  264 compileUnit :: UnitId -> [(ModuleName, Module)] -> BkpM ()
  265 compileUnit cid insts = do
  266     -- Let everyone know we're building this unit
  267     msgUnitId (mkVirtUnit cid insts)
  268     lunit <- getSource cid
  269     buildUnit CompSession cid insts lunit
  270 
  271 -- | Compute the dependencies with instantiations of a syntactic
  272 -- HsUnit; e.g., wherever you see @dependency p[A=<A>]@ in a
  273 -- unit file, return the 'Unit' corresponding to @p[A=<A>]@.
  274 -- The @include_sigs@ parameter controls whether or not we also
  275 -- include @dependency signature@ declarations in this calculation.
  276 --
  277 -- Invariant: this NEVER returns UnitId.
  278 hsunitDeps :: Bool {- include sigs -} -> HsUnit HsComponentId -> [(Unit, ModRenaming)]
  279 hsunitDeps include_sigs unit = concatMap get_dep (hsunitBody unit)
  280   where
  281     get_dep (L _ (IncludeD (IncludeDecl (L _ hsuid) mb_lrn is_sig)))
  282         | include_sigs || not is_sig = [(convertHsComponentId hsuid, go mb_lrn)]
  283         | otherwise = []
  284       where
  285         go Nothing = ModRenaming True []
  286         go (Just lrns) = ModRenaming False (map convRn lrns)
  287           where
  288             convRn (L _ (Renaming (L _ from) Nothing))         = (from, from)
  289             convRn (L _ (Renaming (L _ from) (Just (L _ to)))) = (from, to)
  290     get_dep _ = []
  291 
  292 buildUnit :: SessionType -> UnitId -> [(ModuleName, Module)] -> LHsUnit HsComponentId -> BkpM ()
  293 buildUnit session cid insts lunit = do
  294     -- NB: include signature dependencies ONLY when typechecking.
  295     -- If we're compiling, it's not necessary to recursively
  296     -- compile a signature since it isn't going to produce
  297     -- any object files.
  298     let deps_w_rns = hsunitDeps (session == TcSession) (unLoc lunit)
  299         raw_deps = map fst deps_w_rns
  300     hsc_env <- getSession
  301     -- The compilation dependencies are just the appropriately filled
  302     -- in unit IDs which must be compiled before we can compile.
  303     let hsubst = listToUFM insts
  304         deps0 = map (renameHoleUnit (hsc_units hsc_env) hsubst) raw_deps
  305 
  306     -- Build dependencies OR make sure they make sense. BUT NOTE,
  307     -- we can only check the ones that are fully filled; the rest
  308     -- we have to defer until we've typechecked our local signature.
  309     -- TODO: work this into GHC.Driver.Make!!
  310     forM_ (zip [1..] deps0) $ \(i, dep) ->
  311         case session of
  312             TcSession -> return ()
  313             _ -> compileInclude (length deps0) (i, dep)
  314 
  315     -- IMPROVE IT
  316     let deps = map (improveUnit (hsc_units hsc_env)) deps0
  317 
  318     mb_old_eps <- case session of
  319                     TcSession -> fmap Just getEpsGhc
  320                     _ -> return Nothing
  321 
  322     conf <- withBkpSession cid insts deps_w_rns session $ do
  323 
  324         dflags <- getDynFlags
  325         mod_graph <- hsunitModuleGraph (unLoc lunit)
  326 
  327         msg <- mkBackpackMsg
  328         (ok, _) <- load' [] LoadAllTargets (Just msg) mod_graph
  329         when (failed ok) (liftIO $ exitWith (ExitFailure 1))
  330 
  331         let hi_dir = expectJust (panic "hiDir Backpack") $ hiDir dflags
  332             export_mod ms = (ms_mod_name ms, ms_mod ms)
  333             -- Export everything!
  334             mods = [ export_mod ms | ms <- mgModSummaries mod_graph
  335                                    , ms_hsc_src ms == HsSrcFile ]
  336 
  337         -- Compile relevant only
  338         hsc_env <- getSession
  339         let home_mod_infos = eltsUDFM (hsc_HPT hsc_env)
  340             linkables = map (expectJust "bkp link" . hm_linkable)
  341                       . filter ((==HsSrcFile) . mi_hsc_src . hm_iface)
  342                       $ home_mod_infos
  343             getOfiles LM{ linkableUnlinked = us } = map nameOfObject (filter isObject us)
  344             obj_files = concatMap getOfiles linkables
  345             state     = hsc_units hsc_env
  346 
  347         let compat_fs = unitIdFS cid
  348             compat_pn = PackageName compat_fs
  349             unit_id   = homeUnitId (hsc_home_unit hsc_env)
  350 
  351         return GenericUnitInfo {
  352             -- Stub data
  353             unitAbiHash = "",
  354             unitPackageId = PackageId compat_fs,
  355             unitPackageName = compat_pn,
  356             unitPackageVersion = makeVersion [],
  357             unitId = unit_id,
  358             unitComponentName = Nothing,
  359             unitInstanceOf = cid,
  360             unitInstantiations = insts,
  361             -- Slight inefficiency here haha
  362             unitExposedModules = map (\(m,n) -> (m,Just n)) mods,
  363             unitHiddenModules = [], -- TODO: doc only
  364             unitDepends = case session of
  365                         -- Technically, we should state that we depend
  366                         -- on all the indefinite libraries we used to
  367                         -- typecheck this.  However, this field isn't
  368                         -- really used for anything, so we leave it
  369                         -- blank for now.
  370                         TcSession -> []
  371                         _ -> map (toUnitId . unwireUnit state)
  372                                 $ deps ++ [ moduleUnit mod
  373                                           | (_, mod) <- insts
  374                                           , not (isHoleModule mod) ],
  375             unitAbiDepends = [],
  376             unitLinkerOptions = case session of
  377                                  TcSession -> []
  378                                  _ -> map ST.pack $ obj_files,
  379             unitImportDirs = [ ST.pack $ hi_dir ],
  380             unitIsExposed = False,
  381             unitIsIndefinite = case session of
  382                                  TcSession -> True
  383                                  _ -> False,
  384             -- nope
  385             unitLibraries = [],
  386             unitExtDepLibsSys = [],
  387             unitExtDepLibsGhc = [],
  388             unitLibraryDynDirs = [],
  389             unitLibraryDirs = [],
  390             unitExtDepFrameworks = [],
  391             unitExtDepFrameworkDirs = [],
  392             unitCcOptions = [],
  393             unitIncludes = [],
  394             unitIncludeDirs = [],
  395             unitHaddockInterfaces = [],
  396             unitHaddockHTMLs = [],
  397             unitIsTrusted = False
  398             }
  399 
  400 
  401     addUnit conf
  402     case mb_old_eps of
  403         Just old_eps -> updateEpsGhc_ (const old_eps)
  404         _ -> return ()
  405 
  406 compileExe :: LHsUnit HsComponentId -> BkpM ()
  407 compileExe lunit = do
  408     msgUnitId mainUnit
  409     let deps_w_rns = hsunitDeps False (unLoc lunit)
  410         deps = map fst deps_w_rns
  411         -- no renaming necessary
  412     forM_ (zip [1..] deps) $ \(i, dep) ->
  413         compileInclude (length deps) (i, dep)
  414     withBkpExeSession deps_w_rns $ do
  415         mod_graph <- hsunitModuleGraph (unLoc lunit)
  416         msg <- mkBackpackMsg
  417         (ok, _) <- load' [] LoadAllTargets (Just msg) mod_graph
  418         when (failed ok) (liftIO $ exitWith (ExitFailure 1))
  419 
  420 -- | Register a new virtual unit database containing a single unit
  421 addUnit :: GhcMonad m => UnitInfo -> m ()
  422 addUnit u = do
  423     hsc_env <- getSession
  424     logger <- getLogger
  425     let dflags0 = hsc_dflags hsc_env
  426     let old_unit_env = hsc_unit_env hsc_env
  427     newdbs <- case ue_unit_dbs old_unit_env of
  428         Nothing  -> panic "addUnit: called too early"
  429         Just dbs ->
  430          let newdb = UnitDatabase
  431                { unitDatabasePath  = "(in memory " ++ showSDoc dflags0 (ppr (unitId u)) ++ ")"
  432                , unitDatabaseUnits = [u]
  433                }
  434          in return (dbs ++ [newdb]) -- added at the end because ordering matters
  435     (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 (Just newdbs)
  436 
  437     -- update platform constants
  438     dflags <- liftIO $ updatePlatformConstants dflags0 mconstants
  439 
  440     let unit_env = UnitEnv
  441           { ue_platform  = targetPlatform dflags
  442           , ue_namever   = ghcNameVersion dflags
  443           , ue_home_unit = Just home_unit
  444           , ue_hpt       = ue_hpt old_unit_env
  445           , ue_eps       = ue_eps old_unit_env
  446           , ue_units     = unit_state
  447           , ue_unit_dbs  = Just dbs
  448           }
  449     setSession $ hscSetFlags dflags $ hsc_env { hsc_unit_env = unit_env }
  450 
  451 compileInclude :: Int -> (Int, Unit) -> BkpM ()
  452 compileInclude n (i, uid) = do
  453     hsc_env <- getSession
  454     let pkgs = hsc_units hsc_env
  455     msgInclude (i, n) uid
  456     -- Check if we've compiled it already
  457     case uid of
  458       HoleUnit   -> return ()
  459       RealUnit _ -> return ()
  460       VirtUnit i -> case lookupUnit pkgs uid of
  461         Nothing -> innerBkpM $ compileUnit (instUnitInstanceOf i) (instUnitInsts i)
  462         Just _  -> return ()
  463 
  464 -- ----------------------------------------------------------------------------
  465 -- Backpack monad
  466 
  467 -- | Backpack monad is a 'GhcMonad' which also maintains a little extra state
  468 -- beyond the 'Session', c.f. 'BkpEnv'.
  469 type BkpM = IOEnv BkpEnv
  470 
  471 -- | Backpack environment.  NB: this has a 'Session' and not an 'HscEnv',
  472 -- because we are going to update the 'HscEnv' as we go.
  473 data BkpEnv
  474     = BkpEnv {
  475         -- | The session
  476         bkp_session :: Session,
  477         -- | The filename of the bkp file we're compiling
  478         bkp_filename :: FilePath,
  479         -- | Table of source units which we know how to compile
  480         bkp_table :: Map UnitId (LHsUnit HsComponentId),
  481         -- | When a package we are compiling includes another package
  482         -- which has not been compiled, we bump the level and compile
  483         -- that.
  484         bkp_level :: Int
  485     }
  486 
  487 -- Blah, to get rid of the default instance for IOEnv
  488 -- TODO: just make a proper new monad for BkpM, rather than use IOEnv
  489 instance {-# OVERLAPPING #-} HasDynFlags BkpM where
  490     getDynFlags = fmap hsc_dflags getSession
  491 instance {-# OVERLAPPING #-} HasLogger BkpM where
  492     getLogger = fmap hsc_logger getSession
  493 
  494 
  495 instance GhcMonad BkpM where
  496     getSession = do
  497         Session s <- fmap bkp_session getEnv
  498         readMutVar s
  499     setSession hsc_env = do
  500         Session s <- fmap bkp_session getEnv
  501         writeMutVar s hsc_env
  502 
  503 -- | Get the current 'BkpEnv'.
  504 getBkpEnv :: BkpM BkpEnv
  505 getBkpEnv = getEnv
  506 
  507 -- | Get the nesting level, when recursively compiling modules.
  508 getBkpLevel :: BkpM Int
  509 getBkpLevel = bkp_level `fmap` getBkpEnv
  510 
  511 -- | Run a 'BkpM' computation, with the nesting level bumped one.
  512 innerBkpM :: BkpM a -> BkpM a
  513 innerBkpM do_this =
  514     -- NB: withTempSession mutates, so we don't have to worry
  515     -- about bkp_session being stale.
  516     updEnv (\env -> env { bkp_level = bkp_level env + 1 }) do_this
  517 
  518 -- | Update the EPS from a 'GhcMonad'. TODO move to appropriate library spot.
  519 updateEpsGhc_ :: GhcMonad m => (ExternalPackageState -> ExternalPackageState) -> m ()
  520 updateEpsGhc_ f = do
  521     hsc_env <- getSession
  522     liftIO $ atomicModifyIORef' (euc_eps (ue_eps (hsc_unit_env hsc_env))) (\x -> (f x, ()))
  523 
  524 -- | Get the EPS from a 'GhcMonad'.
  525 getEpsGhc :: GhcMonad m => m ExternalPackageState
  526 getEpsGhc = do
  527     hsc_env <- getSession
  528     liftIO $ hscEPS hsc_env
  529 
  530 -- | Run 'BkpM' in 'Ghc'.
  531 initBkpM :: FilePath -> [LHsUnit HsComponentId] -> BkpM a -> Ghc a
  532 initBkpM file bkp m =
  533   reifyGhc $ \session -> do
  534     let env = BkpEnv {
  535         bkp_session = session,
  536         bkp_table = Map.fromList [(hsComponentId (unLoc (hsunitName (unLoc u))), u) | u <- bkp],
  537         bkp_filename = file,
  538         bkp_level = 0
  539       }
  540     runIOEnv env m
  541 
  542 -- ----------------------------------------------------------------------------
  543 -- Messaging
  544 
  545 -- | Print a compilation progress message, but with indentation according
  546 -- to @level@ (for nested compilation).
  547 backpackProgressMsg :: Int -> Logger -> SDoc -> IO ()
  548 backpackProgressMsg level logger msg =
  549     compilationProgressMsg logger $ text (replicate (level * 2) ' ') -- TODO: use GHC.Utils.Ppr.RStr
  550                                     <> msg
  551 
  552 -- | Creates a 'Messager' for Backpack compilation; this is basically
  553 -- a carbon copy of 'batchMsg' but calling 'backpackProgressMsg', which
  554 -- handles indentation.
  555 mkBackpackMsg :: BkpM Messager
  556 mkBackpackMsg = do
  557     level <- getBkpLevel
  558     return $ \hsc_env mod_index recomp node ->
  559       let dflags = hsc_dflags hsc_env
  560           logger = hsc_logger hsc_env
  561           state = hsc_units hsc_env
  562           showMsg msg reason =
  563             backpackProgressMsg level logger $ pprWithUnitState state $
  564                 showModuleIndex mod_index <>
  565                 msg <> showModMsg dflags (recompileRequired recomp) node
  566                     <> reason
  567       in case node of
  568         InstantiationNode _ ->
  569           case recomp of
  570             MustCompile -> showMsg (text "Instantiating ") empty
  571             UpToDate
  572               | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg (text "Skipping  ") empty
  573               | otherwise -> return ()
  574             RecompBecause reason -> showMsg (text "Instantiating ")
  575                                             (text " [" <> pprWithUnitState state (ppr reason) <> text "]")
  576         ModuleNode _ ->
  577           case recomp of
  578             MustCompile -> showMsg (text "Compiling ") empty
  579             UpToDate
  580               | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg (text "Skipping  ") empty
  581               | otherwise -> return ()
  582             RecompBecause reason -> showMsg (text "Compiling ")
  583                                             (text " [" <> pprWithUnitState state (ppr reason) <> text "]")
  584 
  585 -- | 'PprStyle' for Backpack messages; here we usually want the module to
  586 -- be qualified (so we can tell how it was instantiated.) But we try not
  587 -- to qualify packages so we can use simple names for them.
  588 backpackStyle :: PprStyle
  589 backpackStyle =
  590     mkUserStyle
  591         (QueryQualify neverQualifyNames
  592                       alwaysQualifyModules
  593                       neverQualifyPackages) AllTheWay
  594 
  595 -- | Message when we initially process a Backpack unit.
  596 msgTopPackage :: (Int,Int) -> HsComponentId -> BkpM ()
  597 msgTopPackage (i,n) (HsComponentId (PackageName fs_pn) _) = do
  598     logger <- getLogger
  599     level <- getBkpLevel
  600     liftIO . backpackProgressMsg level logger
  601         $ showModuleIndex (i, n) <> text "Processing " <> ftext fs_pn
  602 
  603 -- | Message when we instantiate a Backpack unit.
  604 msgUnitId :: Unit -> BkpM ()
  605 msgUnitId pk = do
  606     logger <- getLogger
  607     hsc_env <- getSession
  608     level <- getBkpLevel
  609     let state = hsc_units hsc_env
  610     liftIO . backpackProgressMsg level logger
  611         $ pprWithUnitState state
  612         $ text "Instantiating "
  613            <> withPprStyle backpackStyle (ppr pk)
  614 
  615 -- | Message when we include a Backpack unit.
  616 msgInclude :: (Int,Int) -> Unit -> BkpM ()
  617 msgInclude (i,n) uid = do
  618     logger <- getLogger
  619     hsc_env <- getSession
  620     level <- getBkpLevel
  621     let state = hsc_units hsc_env
  622     liftIO . backpackProgressMsg level logger
  623         $ pprWithUnitState state
  624         $ showModuleIndex (i, n) <> text "Including "
  625             <> withPprStyle backpackStyle (ppr uid)
  626 
  627 -- ----------------------------------------------------------------------------
  628 -- Conversion from PackageName to HsComponentId
  629 
  630 type PackageNameMap a = UniqFM PackageName a
  631 
  632 -- For now, something really simple, since we're not actually going
  633 -- to use this for anything
  634 unitDefines :: LHsUnit PackageName -> (PackageName, HsComponentId)
  635 unitDefines (L _ HsUnit{ hsunitName = L _ pn@(PackageName fs) })
  636     = (pn, HsComponentId pn (UnitId fs))
  637 
  638 bkpPackageNameMap :: [LHsUnit PackageName] -> PackageNameMap HsComponentId
  639 bkpPackageNameMap units = listToUFM (map unitDefines units)
  640 
  641 renameHsUnits :: UnitState -> PackageNameMap HsComponentId -> [LHsUnit PackageName] -> [LHsUnit HsComponentId]
  642 renameHsUnits pkgstate m units = map (fmap renameHsUnit) units
  643   where
  644 
  645     renamePackageName :: PackageName -> HsComponentId
  646     renamePackageName pn =
  647         case lookupUFM m pn of
  648             Nothing ->
  649                 case lookupPackageName pkgstate pn of
  650                     Nothing -> error "no package name"
  651                     Just cid -> HsComponentId pn cid
  652             Just hscid -> hscid
  653 
  654     renameHsUnit :: HsUnit PackageName -> HsUnit HsComponentId
  655     renameHsUnit u =
  656         HsUnit {
  657             hsunitName = fmap renamePackageName (hsunitName u),
  658             hsunitBody = map (fmap renameHsUnitDecl) (hsunitBody u)
  659         }
  660 
  661     renameHsUnitDecl :: HsUnitDecl PackageName -> HsUnitDecl HsComponentId
  662     renameHsUnitDecl (DeclD a b c) = DeclD a b c
  663     renameHsUnitDecl (IncludeD idecl) =
  664         IncludeD IncludeDecl {
  665             idUnitId = fmap renameHsUnitId (idUnitId idecl),
  666             idModRenaming = idModRenaming idecl,
  667             idSignatureInclude = idSignatureInclude idecl
  668         }
  669 
  670     renameHsUnitId :: HsUnitId PackageName -> HsUnitId HsComponentId
  671     renameHsUnitId (HsUnitId ln subst)
  672         = HsUnitId (fmap renamePackageName ln) (map (fmap renameHsModuleSubst) subst)
  673 
  674     renameHsModuleSubst :: HsModuleSubst PackageName -> HsModuleSubst HsComponentId
  675     renameHsModuleSubst (lk, lm)
  676         = (lk, fmap renameHsModuleId lm)
  677 
  678     renameHsModuleId :: HsModuleId PackageName -> HsModuleId HsComponentId
  679     renameHsModuleId (HsModuleVar lm) = HsModuleVar lm
  680     renameHsModuleId (HsModuleId luid lm) = HsModuleId (fmap renameHsUnitId luid) lm
  681 
  682 convertHsComponentId :: HsUnitId HsComponentId -> Unit
  683 convertHsComponentId (HsUnitId (L _ hscid) subst)
  684     = mkVirtUnit (hsComponentId hscid) (map (convertHsModuleSubst . unLoc) subst)
  685 
  686 convertHsModuleSubst :: HsModuleSubst HsComponentId -> (ModuleName, Module)
  687 convertHsModuleSubst (L _ modname, L _ m) = (modname, convertHsModuleId m)
  688 
  689 convertHsModuleId :: HsModuleId HsComponentId -> Module
  690 convertHsModuleId (HsModuleVar (L _ modname)) = mkHoleModule modname
  691 convertHsModuleId (HsModuleId (L _ hsuid) (L _ modname)) = mkModule (convertHsComponentId hsuid) modname
  692 
  693 
  694 
  695 {-
  696 ************************************************************************
  697 *                                                                      *
  698                         Module graph construction
  699 *                                                                      *
  700 ************************************************************************
  701 -}
  702 
  703 -- | This is our version of GHC.Driver.Make.downsweep, but with a few modifications:
  704 --
  705 --  1. Every module is required to be mentioned, so we don't do any funny
  706 --     business with targets or recursively grabbing dependencies.  (We
  707 --     could support this in principle).
  708 --  2. We support inline modules, whose summary we have to synthesize ourself.
  709 --
  710 -- We don't bother trying to support GHC.Driver.Make for now, it's more trouble
  711 -- than it's worth for inline modules.
  712 hsunitModuleGraph :: HsUnit HsComponentId -> BkpM ModuleGraph
  713 hsunitModuleGraph unit = do
  714     hsc_env <- getSession
  715 
  716     let decls = hsunitBody unit
  717         pn = hsPackageName (unLoc (hsunitName unit))
  718         home_unit = hsc_home_unit hsc_env
  719 
  720     --  1. Create a HsSrcFile/HsigFile summary for every
  721     --  explicitly mentioned module/signature.
  722     let get_decl (L _ (DeclD hsc_src lmodname mb_hsmod)) =
  723           Just `fmap` summariseDecl pn hsc_src lmodname mb_hsmod
  724         get_decl _ = return Nothing
  725     nodes <- catMaybes `fmap` mapM get_decl decls
  726 
  727     --  2. For each hole which does not already have an hsig file,
  728     --  create an "empty" hsig file to induce compilation for the
  729     --  requirement.
  730     let hsig_set = Set.fromList
  731           [ ms_mod_name ms
  732           | ExtendedModSummary { emsModSummary = ms } <- nodes
  733           , ms_hsc_src ms == HsigFile
  734           ]
  735     req_nodes <- fmap catMaybes . forM (homeUnitInstantiations home_unit) $ \(mod_name, _) ->
  736         if Set.member mod_name hsig_set
  737             then return Nothing
  738             else fmap (Just . extendModSummaryNoDeps) $ summariseRequirement pn mod_name
  739             -- Using extendModSummaryNoDeps here is okay because we're making a leaf node
  740             -- representing a signature that can't depend on any other unit.
  741 
  742     let graph_nodes = (ModuleNode <$> (nodes ++ req_nodes)) ++ (instantiationNodes (hsc_units hsc_env))
  743         key_nodes = map mkNodeKey graph_nodes
  744     -- This error message is not very good but .bkp mode is just for testing so
  745     -- better to be direct rather than pretty.
  746     when
  747       (length key_nodes /= length (ordNub key_nodes))
  748       (pprPanic "Duplicate nodes keys in backpack file" (ppr key_nodes))
  749 
  750     -- 3. Return the kaboodle
  751     return $ mkModuleGraph' $ graph_nodes
  752 
  753 
  754 summariseRequirement :: PackageName -> ModuleName -> BkpM ModSummary
  755 summariseRequirement pn mod_name = do
  756     hsc_env <- getSession
  757     let dflags = hsc_dflags hsc_env
  758     let home_unit = hsc_home_unit hsc_env
  759     let fopts = initFinderOpts dflags
  760 
  761     let PackageName pn_fs = pn
  762     let location = mkHomeModLocation2 fopts mod_name
  763                     (unpackFS pn_fs </> moduleNameSlashes mod_name) "hsig"
  764 
  765     env <- getBkpEnv
  766     src_hash <- liftIO $ getFileHash (bkp_filename env)
  767     hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)
  768     hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location)
  769     let loc = srcLocSpan (mkSrcLoc (mkFastString (bkp_filename env)) 1 1)
  770 
  771     let fc = hsc_FC hsc_env
  772     mod <- liftIO $ addHomeModuleToFinder fc home_unit mod_name location
  773 
  774     extra_sig_imports <- liftIO $ findExtraSigImports hsc_env HsigFile mod_name
  775 
  776     return ModSummary {
  777         ms_mod = mod,
  778         ms_hsc_src = HsigFile,
  779         ms_location = location,
  780         ms_hs_hash = src_hash,
  781         ms_obj_date = Nothing,
  782         ms_dyn_obj_date = Nothing,
  783         ms_iface_date = hi_timestamp,
  784         ms_hie_date = hie_timestamp,
  785         ms_srcimps = [],
  786         ms_textual_imps = ((,) NoPkgQual . noLoc) <$> extra_sig_imports,
  787         ms_ghc_prim_import = False,
  788         ms_parsed_mod = Just (HsParsedModule {
  789                 hpm_module = L loc (HsModule {
  790                         hsmodAnn = noAnn,
  791                         hsmodLayout = NoLayoutInfo,
  792                         hsmodName = Just (L (noAnnSrcSpan loc) mod_name),
  793                         hsmodExports = Nothing,
  794                         hsmodImports = [],
  795                         hsmodDecls = [],
  796                         hsmodDeprecMessage = Nothing,
  797                         hsmodHaddockModHeader = Nothing
  798                     }),
  799                 hpm_src_files = []
  800             }),
  801         ms_hspp_file = "", -- none, it came inline
  802         ms_hspp_opts = dflags,
  803         ms_hspp_buf = Nothing
  804         }
  805 
  806 summariseDecl :: PackageName
  807               -> HscSource
  808               -> Located ModuleName
  809               -> Maybe (Located HsModule)
  810               -> BkpM ExtendedModSummary
  811 summariseDecl pn hsc_src (L _ modname) (Just hsmod) = hsModuleToModSummary pn hsc_src modname hsmod
  812 summariseDecl _pn hsc_src lmodname@(L loc modname) Nothing
  813     = do hsc_env <- getSession
  814          -- TODO: this looks for modules in the wrong place
  815          r <- liftIO $ summariseModule hsc_env
  816                          emptyModNodeMap -- GHC API recomp not supported
  817                          (hscSourceToIsBoot hsc_src)
  818                          lmodname
  819                          Nothing -- GHC API buffer support not supported
  820                          [] -- No exclusions
  821          case r of
  822             Nothing -> throwOneError $ fmap GhcDriverMessage
  823                                      $ mkPlainErrorMsgEnvelope loc (DriverBackpackModuleNotFound modname)
  824             Just (Left err) -> throwErrors (fmap GhcDriverMessage err)
  825             Just (Right summary) -> return summary
  826 
  827 -- | Up until now, GHC has assumed a single compilation target per source file.
  828 -- Backpack files with inline modules break this model, since a single file
  829 -- may generate multiple output files.  How do we decide to name these files?
  830 -- Should there only be one output file? This function our current heuristic,
  831 -- which is we make a "fake" module and use that.
  832 hsModuleToModSummary :: PackageName
  833                      -> HscSource
  834                      -> ModuleName
  835                      -> Located HsModule
  836                      -> BkpM ExtendedModSummary
  837 hsModuleToModSummary pn hsc_src modname
  838                      hsmod = do
  839     let imps = hsmodImports (unLoc hsmod)
  840         loc  = getLoc hsmod
  841     hsc_env <- getSession
  842     -- Sort of the same deal as in GHC.Driver.Pipeline's getLocation
  843     -- Use the PACKAGE NAME to find the location
  844     let PackageName unit_fs = pn
  845         dflags = hsc_dflags hsc_env
  846         fopts = initFinderOpts dflags
  847     -- Unfortunately, we have to define a "fake" location in
  848     -- order to appease the various code which uses the file
  849     -- name to figure out where to put, e.g. object files.
  850     -- To add insult to injury, we don't even actually use
  851     -- these filenames to figure out where the hi files go.
  852     -- A travesty!
  853     let location0 = mkHomeModLocation2 fopts modname
  854                              (unpackFS unit_fs </>
  855                               moduleNameSlashes modname)
  856                               (case hsc_src of
  857                                 HsigFile -> "hsig"
  858                                 HsBootFile -> "hs-boot"
  859                                 HsSrcFile -> "hs")
  860     -- DANGEROUS: bootifying can POISON the module finder cache
  861     let location = case hsc_src of
  862                         HsBootFile -> addBootSuffixLocnOut location0
  863                         _ -> location0
  864     -- This duplicates a pile of logic in GHC.Driver.Make
  865     hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)
  866     hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location)
  867 
  868     -- Also copied from 'getImports'
  869     let (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource . unLoc) imps
  870 
  871              -- GHC.Prim doesn't exist physically, so don't go looking for it.
  872         (ordinary_imps, ghc_prim_import)
  873           = partition ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc)
  874               ord_idecls
  875 
  876         implicit_prelude = xopt LangExt.ImplicitPrelude dflags
  877         implicit_imports = mkPrelImports modname loc
  878                                          implicit_prelude imps
  879 
  880         rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env)
  881         convImport (L _ i) = (rn_pkg_qual (ideclPkgQual i), reLoc $ ideclName i)
  882 
  883     extra_sig_imports <- liftIO $ findExtraSigImports hsc_env hsc_src modname
  884 
  885     let normal_imports = map convImport (implicit_imports ++ ordinary_imps)
  886     (implicit_sigs, inst_deps) <- liftIO $ implicitRequirementsShallow hsc_env normal_imports
  887 
  888     -- So that Finder can find it, even though it doesn't exist...
  889     this_mod <- liftIO $ do
  890       let home_unit = hsc_home_unit hsc_env
  891       let fc        = hsc_FC hsc_env
  892       addHomeModuleToFinder fc home_unit modname location
  893     return $ ExtendedModSummary
  894       { emsModSummary =
  895           ModSummary {
  896             ms_mod = this_mod,
  897             ms_hsc_src = hsc_src,
  898             ms_location = location,
  899             ms_hspp_file = (case hiDir dflags of
  900                             Nothing -> ""
  901                             Just d -> d) </> ".." </> moduleNameSlashes modname <.> "hi",
  902             ms_hspp_opts = dflags,
  903             ms_hspp_buf = Nothing,
  904             ms_srcimps = map convImport src_idecls,
  905             ms_ghc_prim_import = not (null ghc_prim_import),
  906             ms_textual_imps = normal_imports
  907                            -- We have to do something special here:
  908                            -- due to merging, requirements may end up with
  909                            -- extra imports
  910                            ++ ((,) NoPkgQual . noLoc <$> extra_sig_imports)
  911                            ++ ((,) NoPkgQual . noLoc <$> implicit_sigs),
  912             -- This is our hack to get the parse tree to the right spot
  913             ms_parsed_mod = Just (HsParsedModule {
  914                     hpm_module = hsmod,
  915                     hpm_src_files = [] -- TODO if we preprocessed it
  916                 }),
  917             -- Source hash = fingerprint0, so the recompilation tests do not recompile
  918             -- too much. In future, if necessary then could get the hash by just hashing the
  919             -- relevant part of the .bkp file.
  920             ms_hs_hash = fingerprint0,
  921             ms_obj_date = Nothing, -- TODO do this, but problem: hi_timestamp is BOGUS
  922             ms_dyn_obj_date = Nothing, -- TODO do this, but problem: hi_timestamp is BOGUS
  923             ms_iface_date = hi_timestamp,
  924             ms_hie_date = hie_timestamp
  925           }
  926       , emsInstantiatedUnits = inst_deps
  927       }
  928 
  929 -- | Create a new, externally provided hashed unit id from
  930 -- a hash.
  931 newUnitId :: UnitId -> Maybe FastString -> UnitId
  932 newUnitId uid mhash = case mhash of
  933    Nothing   -> uid
  934    Just hash -> UnitId (unitIdFS uid `appendFS` mkFastString "+" `appendFS` hash)