Implement fat interfaces, which can resume compilation. (#10871)

This commit implements fat interfaces files, which are like normal interface
files except that they can be typechecked into a ModGuts instead of a
ModDetails, and then properly simplified and code generated.  In effect, fat
interface files define an IR that has been renamed and typechecked, but not
compiled.

There are a few ways to use this:

    - -fwrite-fat-interface causes GHC to write out the fat interface
      file during compilation.  Use it with -fno-code to just parse,
      typecheck, and desugar, and halt compilation.

    - One-shot compilation can take an fat interface file as an input, and
      finish compilation.  NB: you must ensure that the import path does
      NOT include the directory that contains the fat interface files,
      or GHC will work strangely.

    - We also support --make compilation of a set of fat interface files,
      but you have to pass the -ffrom-fat-interface so that finder
      looks for hi files rather than hs files to compile.

In both "compile fat interface" scenarios, it's highly recommended you
set a distinct --outputdir, so as to not clobber the existing fat interface
files.

There are a large number of bits and bobs, but here are the highlights:

    - To make it easier to test, we've implemented a debugging only
      mode -fvia-fat-interface, which takes the output of the desugarer
      and sucks it through a fat interface, before continuing compilation.
      This is useful for catching bugs in the serialization process.
      There's a new testing way 'viafat' which applies this flag; there
      are a few tests which unconditionally test this way and you can
      run the entire test suite this way using WAY=viafat.

    - We taught MkIface how to serialize SpecInfos.

    - New IfaceDecl, an IfaceBinding, which is similar to an IfaceId;
      however, we can have IfaceBindings for local, unexported names,
      we save a different set of IdInfo, and finally there is always
      an unfolding present 'idRhs'.

    - There's a hack to deal with the root main name main::Main.main,
      which needs to be serialized (since we will code gen it.)

    - Computation of usage info has been pushed up to the desugarer,
      so that we don't need to serialize the components of this. A
      number of fields are consequently dropped from ModGuts.

TODO:

    - Documentation

    - Fat interface files have NO useful fingerprints. This is suboptimal:
      we'd like to have recompilation avoidance apply to fat interface
      compilation in addition to the normal compilation.

    - The family instance environment is not properly initialized when compiling
      fat interface files, which could result in loss of specialization
      opportunities.

Signed-off-by: Edward Z. Yang <[email protected]>

Test Plan: validate

Reviewers: simonpj, austin, hvr, goldfire, bgamari

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D1318

compiler/basicTypes/IdInfo.hs

@@ -206,6 +206,16 @@ pprIdDetails other     = brackets (pp other)
 -- Most of the 'IdInfo' gives information about the value, or definition, of
 -- the 'Id', independent of its usage. Exceptions to this
 -- are 'demandInfo', 'occInfo', 'oneShotInfo' and 'callArityInfo'.
+--
+-- Some 'IdInfo' is calculated while we are simplifying or tidying a program,
+-- but there are a few cases where 'IdInfo' comes from the user program,
+-- so it is well worth making sure we hold onto it.  Specifically:
+--
+--  1. 'RuleInfo', which may be non-empty for local IDs.  When we tidy,
+--  we'll collect these into the global rules for a module.
+--
+--  2. 'InlinePragma', which records what the user wrote, so we don't want to
+--  lose that.
 data IdInfo
   = IdInfo {
         arityInfo       :: !ArityInfo,          -- ^ 'Id' arity

compiler/basicTypes/Var.hs

@@ -54,6 +54,9 @@ module Var (
         isGlobalId, isExportedId,
         mustHaveLocalBinding,
 
+        -- ** For fat interface files...
+        IdScope(..), ExportFlag(..), idScope,
+
         -- ** Constructing 'TyVar's
         mkTyVar, mkTcTyVar, mkKindVar,
 

compiler/coreSyn/CoreLint.hs

@@ -234,6 +234,9 @@ coreDumpFlag CoreDoVectorisation      = Just Opt_D_dump_vect
 coreDumpFlag CoreDesugar              = Just Opt_D_dump_ds
 coreDumpFlag CoreDesugarOpt           = Just Opt_D_dump_ds
 coreDumpFlag CoreTidy                 = Just Opt_D_dump_simpl
+-- TODO: make a separate flag?
+coreDumpFlag CoreTidyGuts             = Just Opt_D_dump_simpl
+coreDumpFlag CoreLoadGuts             = Just Opt_D_dump_simpl
 coreDumpFlag CorePrep                 = Just Opt_D_dump_prep
 
 coreDumpFlag CoreDoPrintCore          = Nothing
@@ -1616,7 +1619,7 @@ lookupIdInScope id
                 Nothing -> do { addErrL out_of_scope
                               ; return id } }
   where
-    out_of_scope = pprBndr LetBind id <+> ptext (sLit "is out of scope")
+    out_of_scope = pprBndr LetBind id <+> ptext (sLit "is out of scope") <+> ppr id
 
 
 oneTupleDataConId :: Id -- Should not happen

compiler/coreSyn/CoreTidy.hs

@@ -9,7 +9,7 @@ The code for *top-level* bindings is in TidyPgm.
 
 {-# LANGUAGE CPP #-}
 module CoreTidy (
-        tidyExpr, tidyVarOcc, tidyRule, tidyRules, tidyUnfolding
+        tidyExpr, tidyVarOcc, tidyRule, tidyRules, tidyUnfolding, tidyBndrs
     ) where
 
 #include "HsVersions.h"

compiler/deSugar/DsMonad.hs

@@ -231,7 +231,8 @@ mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
          -> IORef Messages -> IORef [(Fingerprint, (Id, CoreExpr))]
          -> (DsGblEnv, DsLclEnv)
 mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var static_binds_var
-  = let if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) }
+  = let if_genv = IfGblEnv { if_load_fat_interface = Nothing
+                           , if_rec_types = Just (mod, return type_env) }
         if_lenv = mkIfLclEnv mod (ptext (sLit "GHC error in desugarer lookup in") <+> ppr mod)
         gbl_env = DsGblEnv { ds_mod     = mod
                            , ds_fam_inst_env = fam_inst_env

compiler/iface/BuildTyCl.hs

@@ -211,22 +211,22 @@ buildPatSyn :: Name -> Bool
 buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder
             (univ_tvs, req_theta) (ex_tvs, prov_theta) arg_tys
             pat_ty field_labels
-  = ASSERT((and [ univ_tvs == univ_tvs'
-                , ex_tvs == ex_tvs'
-                , pat_ty `eqType` pat_ty'
-                , prov_theta `eqTypes` prov_theta'
-                , req_theta `eqTypes` req_theta'
-                , arg_tys `eqTypes` arg_tys'
+  = ASSERT((and [ univ_tvs == univ_tvs2
+                , ex_tvs == ex_tvs2
+                , pat_ty `eqType` pat_ty2
+                , prov_theta `eqTypes` prov_theta2
+                , req_theta `eqTypes` req_theta2
+                , arg_tys `eqTypes` arg_tys2
                 ]))
     mkPatSyn src_name declared_infix
              (univ_tvs, req_theta) (ex_tvs, prov_theta)
              arg_tys pat_ty
              matcher builder field_labels
   where
-    ((_:univ_tvs'), req_theta', tau) = tcSplitSigmaTy $ idType matcher_id
-    ([pat_ty', cont_sigma, _], _) = tcSplitFunTys tau
-    (ex_tvs', prov_theta', cont_tau) = tcSplitSigmaTy cont_sigma
-    (arg_tys', _) = tcSplitFunTys cont_tau
+    ((_:univ_tvs2), req_theta2, tau) = tcSplitSigmaTy $ idType matcher_id
+    ([pat_ty2, cont_sigma, _], _) = tcSplitFunTys tau
+    (ex_tvs2, prov_theta2, cont_tau) = tcSplitSigmaTy cont_sigma
+    (arg_tys2, _) = tcSplitFunTys cont_tau
 
 -- ------------------------------------------------------
 

compiler/iface/IfaceSyn.hs

@@ -19,6 +19,7 @@ module IfaceSyn (
         IfaceSrcBang(..), SrcUnpackedness(..), SrcStrictness(..),
         IfaceAxBranch(..),
         IfaceTyConParent(..),
+        IfaceIdScope(..), -- fat interface
 
         -- Misc
         ifaceDeclImplicitBndrs, visibleIfConDecls,
@@ -89,11 +90,35 @@ type IfaceTopBndr = OccName
   -- drop it when serialising and add it back in when deserialising.
 
 data IfaceDecl
+  -- An IfaceId describes a regular, exportable thing with a type
+  -- (and maybe some extra information.)  IfaceIds only occur in
+  -- regular interface files.
   = IfaceId { ifName      :: IfaceTopBndr,
               ifType      :: IfaceType,
               ifIdDetails :: IfaceIdDetails,
               ifIdInfo    :: IfaceIdInfo }
 
+  -- An IfaceBinding is like an IfaceId, but two extra pieces of
+  -- information: a right-hand side (which can be parsed into a
+  -- CoreBinding) and an exposed flags (which indicates whether
+  -- or not it is MANDATORY that this binding be exposed, or if
+  -- it may or may not be exposed depending on whether or not
+  -- it is in mi_exports).  IfaceBindings only occur in fat interface
+  -- files.
+  | IfaceBinding { ifName      :: IfaceTopBndr,
+                   -- NB: This is a HACK to recognize if a main 'ifName'
+                   -- is actually a root main, in which case we must
+                   -- give it a different name.  A better strategy is
+                   -- to just not inject these bindings in until later,
+                   -- but this is a bit annoying to do.
+                   ifRootMain  :: Bool,
+                   ifType      :: IfaceType,
+                   ifIdScope   :: IfaceIdScope,
+                   ifIdDetails :: IfaceIdDetails,
+                   ifIdInfo    :: IfaceIdInfo,
+                   ifRhs       :: IfaceExpr
+                 }
+
   | IfaceData { ifName       :: IfaceTopBndr,        -- Type constructor
                 ifCType      :: Maybe CType,    -- C type for CAPI FFI
                 ifTyVars     :: [IfaceTvBndr],  -- Type variables
@@ -158,6 +183,12 @@ data IfaceDecl
                   ifFieldLabels   :: [FieldLabel] }
 
 
+-- IdScope
+data IfaceIdScope
+  = IfLocalId
+  | IfExportedLocalId
+  deriving (Eq)
+
 data IfaceTyConParent
   = IfNoParent
   | IfDataInstance IfExtName
@@ -680,6 +711,18 @@ pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype,
             | otherwise = Outputable.empty
 
 
+pprIfaceDecl ss (IfaceBinding { ifName = var, ifRootMain = is_root_main, ifType = ty,
+                                ifIdDetails = details, ifIdInfo = info,
+                                ifIdScope = _scope, ifRhs = rhs })
+  = vcat [ hang (bndr_doc <+> dcolon)
+              2 (pprIfaceSigmaType ty)
+         -- , ppShowIface ss (ppr scope) TODO
+         , ppShowIface ss (ppr details)
+         , ppShowIface ss (ppr info)
+         , ppShowIface ss (ppr rhs) ]
+  where bndr_doc | is_root_main = text "main::Main.main"
+                 | otherwise    = pprPrefixIfDeclBndr ss var
+
 pprIfaceDecl ss (IfaceClass { ifATs = ats, ifSigs = sigs, ifRec = isrec
                             , ifCtxt   = context, ifName  = clas
                             , ifTyVars = tyvars,  ifRoles = roles
@@ -1114,6 +1157,11 @@ freeNamesIfDecl (IfaceId _s t d i) =
   freeNamesIfType t &&&
   freeNamesIfIdInfo i &&&
   freeNamesIfIdDetails d
+freeNamesIfDecl d@IfaceBinding{} =
+  freeNamesIfType (ifType d) &&&
+  freeNamesIfIdInfo (ifIdInfo d) &&&
+  freeNamesIfIdDetails (ifIdDetails d) &&&
+  freeNamesIfExpr (ifRhs d)
 freeNamesIfDecl d@IfaceData{} =
   freeNamesIfTvBndrs (ifTyVars d) &&&
   freeNamesIfaceTyConParent (ifParent d) &&&
@@ -1450,6 +1498,17 @@ instance Binary IfaceDecl where
         put_ bh a10
         put_ bh a11
 
+    put_ bh (IfaceBinding name rootMain ty scope details idinfo rhs) = do
+        if not rootMain
+            then putByte bh 8
+            else putByte bh 9
+        put_ bh (occNameFS name)
+        put_ bh ty
+        put_ bh scope
+        put_ bh details
+        put_ bh idinfo
+        put_ bh rhs
+
     get bh = do
         h <- getByte bh
         case h of
@@ -1517,8 +1576,34 @@ instance Binary IfaceDecl where
                     a11 <- get bh
                     occ <- return $! mkDataOccFS a1
                     return (IfacePatSyn occ a2 a3 a4 a5 a6 a7 a8 a9 a10 a11)
+            8 -> do name    <- get bh
+                    ty      <- get bh
+                    scope   <- get bh
+                    details <- get bh
+                    idinfo  <- get bh
+                    rhs     <- get bh
+                    occ <- return $! mkVarOccFS name
+                    return (IfaceBinding occ False ty scope details idinfo rhs)
+            9 -> do name    <- get bh
+                    ty      <- get bh
+                    scope   <- get bh
+                    details <- get bh
+                    idinfo  <- get bh
+                    rhs     <- get bh
+                    occ <- return $! mkVarOccFS name
+                    return (IfaceBinding occ True ty scope details idinfo rhs)
+
             _ -> panic (unwords ["Unknown IfaceDecl tag:", show h])
 
+instance Binary IfaceIdScope where
+    put_ bh IfLocalId = putByte bh 0
+    put_ bh IfExportedLocalId = putByte bh 1
+
+    get bh = do { h <- getByte bh
+                ; return $ case h of
+                    0 -> IfLocalId
+                    _ -> IfExportedLocalId }
+
 instance Binary IfaceFamTyConFlav where
     put_ bh IfaceDataFamilyTyCon              = putByte bh 0
     put_ bh IfaceOpenSynFamilyTyCon           = putByte bh 1

compiler/iface/LoadIface.hs

@@ -22,6 +22,7 @@ module LoadIface (
         loadInterface, loadWiredInHomeIface,
         loadSysInterface, loadUserInterface, loadPluginInterface,
         findAndReadIface, readIface,    -- Used when reading the module's old interface
+        readAnyIface,
         loadDecls,      -- Should move to TcIface and be renamed
         initExternalPackageState,
 
@@ -555,7 +556,10 @@ loadDecl :: Bool                    -- Don't load pragmas into the decl pool
 loadDecl ignore_prags (_version, decl)
   = do  {       -- Populate the name cache with final versions of all
                 -- the names associated with the decl
-          main_name      <- lookupIfaceTop (ifName decl)
+          main_name      <-
+            case decl of
+              IfaceBinding { ifRootMain = True } -> return rootMainName
+              _ -> lookupIfaceTop (ifName decl)
 
         -- Typecheck the thing, lazily
         -- NB. Firstly, the laziness is there in case we never need the
@@ -708,7 +712,7 @@ findAndReadIface doc_str mod hi_boot_file
 
                        -- Found file, so read it
                        let file_path = addBootSuffix_maybe hi_boot_file
-                                                           (ml_hi_file loc)
+                                     $ ml_hi_file loc
 
                        -- See Note [Home module load error]
                        if thisPackage dflags == moduleUnitId mod &&
@@ -760,18 +764,29 @@ readIface :: Module -> FilePath
         -- Succeeded iface <=> successfully found and parsed
 
 readIface wanted_mod file_path
-  = do  { res <- tryMostM $
-                 readBinIface CheckHiWay QuietBinIFaceReading file_path
+  = do  { res <- readAnyIface file_path
         ; case res of
-            Right iface
-                | wanted_mod == actual_mod -> return (Succeeded iface)
-                | otherwise                -> return (Failed err)
+            Succeeded iface
+                | wanted_mod /= actual_mod -> return (Failed err)
                 where
                   actual_mod = mi_module iface
                   err = hiModuleNameMismatchWarn wanted_mod actual_mod
+            _ -> return res
+        }
+
+-- @readIface@ requires us to state up-front what 'Module' the interface
+-- file we're reading is; if it doesn't match what is stored in the file,
+-- we error.  For fat interfaces, we will in general not know what 'Module'
+-- the interface is for (since it may have been user-provided); this function
+-- skips that check.
+readAnyIface :: FilePath -> TcRnIf gbl lcl (MaybeErr MsgDoc ModIface)
+readAnyIface file_path
+  = do res <- tryMostM $
+                 readBinIface CheckHiWay QuietBinIFaceReading file_path
+       case res of
+         Right iface -> return (Succeeded iface)
+         Left exn    -> return (Failed (text (showException exn)))
 
-            Left exn    -> return (Failed (text (showException exn)))
-    }
 
 {-
 *********************************************************