{-# LANGUAGE RecordWildCards #-}

-- | This module manages storing the various GHC option flags in a modules
-- interface file as part of the recompilation checking infrastructure.
module FlagChecker (
        fingerprintDynFlags
      , fingerprintOptFlags
      , fingerprintHpcFlags
    ) where

import GhcPrelude

import Binary
import BinIface ()
import DynFlags
import HscTypes
import Module
import Name
import Fingerprint
import BinFingerprint
-- import Outputable

import qualified EnumSet
import System.FilePath (normalise)

-- | Produce a fingerprint of a @DynFlags@ value. We only base
-- the finger print on important fields in @DynFlags@ so that
-- the recompilation checker can use this fingerprint.
--
-- NB: The 'Module' parameter is the 'Module' recorded by the
-- *interface* file, not the actual 'Module' according to our
-- 'DynFlags'.
fingerprintDynFlags :: DynFlags -> Module
                    -> (BinHandle -> Name -> IO ())
                    -> IO Fingerprint

fingerprintDynFlags dflags@DynFlags{..} this_mod nameio =
    let mainis   = if mainModIs == this_mod then Just mainFunIs else Nothing
                      -- see #5878
        -- pkgopts  = (thisPackage dflags, sort $ packageFlags dflags)
        safeHs   = setSafeMode safeHaskell
        -- oflags   = sort $ filter filterOFlags $ flags dflags

        -- *all* the extension flags and the language
        lang = (fmap fromEnum language,
                map fromEnum $ EnumSet.toList extensionFlags)

        -- -I, -D and -U flags affect CPP
        cpp = ( map normalise $ flattenIncludes includePaths
            -- normalise: eliminate spurious differences due to "./foo" vs "foo"
              , picPOpts dflags
              , opt_P_signature dflags)
            -- See Note [Repeated -optP hashing]

        -- Note [path flags and recompilation]
        paths = [ hcSuf ]

        -- -fprof-auto etc.
        prof = if gopt Opt_SccProfilingOn dflags then fromEnum profAuto else 0

        flags = (mainis, safeHs, lang, cpp, paths, prof)

    in -- pprTrace "flags" (ppr flags) $
       computeFingerprint nameio flags

-- Fingerprint the optimisation info. We keep this separate from the rest of
-- the flags because GHCi users (especially) may wish to ignore changes in
-- optimisation level or optimisation flags so as to use as many pre-existing
-- object files as they can.
-- See Note [Ignoring some flag changes]
fingerprintOptFlags :: DynFlags
                      -> (BinHandle -> Name -> IO ())
                      -> IO Fingerprint
fingerprintOptFlags DynFlags{..} nameio =
      let
        -- See https://ghc.haskell.org/trac/ghc/ticket/10923
        -- We used to fingerprint the optimisation level, but as Joachim
        -- Breitner pointed out in comment 9 on that ticket, it's better
        -- to ignore that and just look at the individual optimisation flags.
        opt_flags = map fromEnum $ filter (`EnumSet.member` optimisationFlags)
                                          (EnumSet.toList generalFlags)

      in computeFingerprint nameio opt_flags

-- Fingerprint the HPC info. We keep this separate from the rest of
-- the flags because GHCi users (especially) may wish to use an object
-- file compiled for HPC when not actually using HPC.
-- See Note [Ignoring some flag changes]
fingerprintHpcFlags :: DynFlags
                      -> (BinHandle -> Name -> IO ())
                      -> IO Fingerprint
fingerprintHpcFlags dflags@DynFlags{..} nameio =
      let
        -- -fhpc, see https://ghc.haskell.org/trac/ghc/ticket/11798
        -- hpcDir is output-only, so we should recompile if it changes
        hpc = if gopt Opt_Hpc dflags then Just hpcDir else Nothing

      in computeFingerprint nameio hpc

{- Note [path flags and recompilation]

There are several flags that we deliberately omit from the
recompilation check; here we explain why.

-osuf, -odir, -hisuf, -hidir
  If GHC decides that it does not need to recompile, then
  it must have found an up-to-date .hi file and .o file.
  There is no point recording these flags - the user must
  have passed the correct ones.  Indeed, the user may
  have compiled the source file in one-shot mode using
  -o to specify the .o file, and then loaded it in GHCi
  using -odir.

-stubdir
  We omit this one because it is automatically set by -outputdir, and
  we don't want changes in -outputdir to automatically trigger
  recompilation.  This could be wrong, but only in very rare cases.

-i (importPaths)
  For the same reason as -osuf etc. above: if GHC decides not to
  recompile, then it must have already checked all the .hi files on
  which the current module depends, so it must have found them
  successfully.  It is occasionally useful to be able to cd to a
  different directory and use -i flags to enable GHC to find the .hi
  files; we don't want this to force recompilation.

The only path-related flag left is -hcsuf.
-}

{- Note [Ignoring some flag changes]
   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Normally, --make tries to reuse only compilation products that are
the same as those that would have been produced compiling from
scratch. Sometimes, however, users would like to be more aggressive
about recompilation avoidance. This is particularly likely when
developing using GHCi (see #13604). Currently, we allow users to
ignore optimisation changes using -fignore-optim-changes, and to
ignore HPC option changes using -fignore-hpc-changes. If there's a
demand for it, we could also allow changes to -fprof-auto-* flags
(although we can't allow -prof flags to differ). The key thing about
these options is that we can still successfully link a library or
executable when some of its components differ in these ways.

The way we accomplish this is to leave the optimization and HPC
options out of the flag hash, hashing them separately.
-}

{- Note [Repeated -optP hashing]
   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

We invoke fingerprintDynFlags for each compiled module to include
the hash of relevant DynFlags in the resulting interface file.
-optP (preprocessor) flags are part of that hash.
-optP flags can come from multiple places:

  1. -optP flags directly passed on command line.
  2. -optP flags implied by other flags. Eg. -DPROFILING implied by -prof.
  3. -optP flags added with {-# OPTIONS -optP-D__F__ #-} in a file.

When compiling many modules at once with many -optP command line arguments
the work of hashing -optP flags would be repeated. This can get expensive
and as noted on #14697 it can take 7% of time and 14% of allocations on
a real codebase.

The obvious solution is to cache the hash of -optP flags per GHC invocation.
However, one has to be careful there, as the flags that were added in 3. way
have to be accounted for.

The current strategy is as follows:

  1. Lazily compute the hash of sOpt_p in sOpt_P_fingerprint whenever sOpt_p
     is modified. This serves dual purpose. It ensures correctness for when
     we add per file -optP flags and lets us save work for when we don't.
  2. When computing the fingerprint in fingerprintDynFlags use the cached
     value *and* fingerprint the additional implied (see 2. above) -optP flags.
     This is relatively cheap and saves the headache of fingerprinting all
     the -optP flags and tracking all the places that could invalidate the
     cache.
-}


-- (c) The University of Glasgow 2002-2006

{-# LANGUAGE CPP, RankNTypes, BangPatterns #-}

module IfaceEnv (
        newGlobalBinder, newInteractiveBinder,
        externaliseName,
        lookupIfaceTop,
        lookupOrig, lookupOrigIO, lookupOrigNameCache, extendNameCache,
        newIfaceName, newIfaceNames,
        extendIfaceIdEnv, extendIfaceTyVarEnv,
        tcIfaceLclId, tcIfaceTyVar, lookupIfaceVar,
        lookupIfaceTyVar, extendIfaceEnvs,
        setNameModule,

        ifaceExportNames,

        -- Name-cache stuff
        allocateGlobalBinder, updNameCacheTc,
        mkNameCacheUpdater, NameCacheUpdater(..),
   ) where

#include "HsVersions.h"

import GhcPrelude

import TcRnMonad
import HscTypes
import Type
import Var
import Name
import Avail
import Module
import FastString
import FastStringEnv
import IfaceType
import NameCache
import UniqSupply
import SrcLoc

import Outputable
import Data.List     ( partition )

{-
*********************************************************
*                                                      *
        Allocating new Names in the Name Cache
*                                                      *
*********************************************************

See Also: Note [The Name Cache] in NameCache
-}

newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name
-- Used for source code and interface files, to make the
-- Name for a thing, given its Module and OccName
-- See Note [The Name Cache]
--
-- The cache may already already have a binding for this thing,
-- because we may have seen an occurrence before, but now is the
-- moment when we know its Module and SrcLoc in their full glory

newGlobalBinder mod occ loc
  = do { name <- updNameCacheTc mod occ $ \name_cache ->
                 allocateGlobalBinder name_cache mod occ loc
       ; traceIf (text "newGlobalBinder" <+>
                  (vcat [ ppr mod <+> ppr occ <+> ppr loc, ppr name]))
       ; return name }

newInteractiveBinder :: HscEnv -> OccName -> SrcSpan -> IO Name
-- Works in the IO monad, and gets the Module
-- from the interactive context
newInteractiveBinder hsc_env occ loc
 = do { let mod = icInteractiveModule (hsc_IC hsc_env)
       ; updNameCacheIO hsc_env mod occ $ \name_cache ->
         allocateGlobalBinder name_cache mod occ loc }

allocateGlobalBinder
  :: NameCache
  -> Module -> OccName -> SrcSpan
  -> (NameCache, Name)
-- See Note [The Name Cache]
allocateGlobalBinder name_supply mod occ loc
  = case lookupOrigNameCache (nsNames name_supply) mod occ of
        -- A hit in the cache!  We are at the binding site of the name.
        -- This is the moment when we know the SrcLoc
        -- of the Name, so we set this field in the Name we return.
        --
        -- Then (bogus) multiple bindings of the same Name
        -- get different SrcLocs can can be reported as such.
        --
        -- Possible other reason: it might be in the cache because we
        --      encountered an occurrence before the binding site for an
        --      implicitly-imported Name.  Perhaps the current SrcLoc is
        --      better... but not really: it'll still just say 'imported'
        --
        -- IMPORTANT: Don't mess with wired-in names.
        --            Their wired-in-ness is in their NameSort
        --            and their Module is correct.

        Just name | isWiredInName name
                  -> (name_supply, name)
                  | otherwise
                  -> (new_name_supply, name')
                  where
                    uniq            = nameUnique name
                    name'           = mkExternalName uniq mod occ loc
                                      -- name' is like name, but with the right SrcSpan
                    new_cache       = extendNameCache (nsNames name_supply) mod occ name'
                    new_name_supply = name_supply {nsNames = new_cache}

        -- Miss in the cache!
        -- Build a completely new Name, and put it in the cache
        _ -> (new_name_supply, name)
                  where
                    (uniq, us')     = takeUniqFromSupply (nsUniqs name_supply)
                    name            = mkExternalName uniq mod occ loc
                    new_cache       = extendNameCache (nsNames name_supply) mod occ name
                    new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache}

ifaceExportNames :: [IfaceExport] -> TcRnIf gbl lcl [AvailInfo]
ifaceExportNames exports = return exports

-- | A function that atomically updates the name cache given a modifier
-- function.  The second result of the modifier function will be the result
-- of the IO action.
newtype NameCacheUpdater
      = NCU { updateNameCache :: forall c. (NameCache -> (NameCache, c)) -> IO c }

mkNameCacheUpdater :: TcRnIf a b NameCacheUpdater
mkNameCacheUpdater = do { hsc_env <- getTopEnv
                        ; let !ncRef = hsc_NC hsc_env
                        ; return (NCU (updNameCache ncRef)) }

updNameCacheTc :: Module -> OccName -> (NameCache -> (NameCache, c))
               -> TcRnIf a b c
updNameCacheTc mod occ upd_fn = do {
    hsc_env <- getTopEnv
  ; liftIO $ updNameCacheIO hsc_env mod occ upd_fn }

updNameCacheIO ::  HscEnv -> Module -> OccName
               -> (NameCache -> (NameCache, c))
               -> IO c
updNameCacheIO hsc_env mod occ upd_fn = do {

    -- First ensure that mod and occ are evaluated
    -- If not, chaos can ensue:
    --      we read the name-cache
    --      then pull on mod (say)
    --      which does some stuff that modifies the name cache
    -- This did happen, with tycon_mod in TcIface.tcIfaceAlt (DataAlt..)

    mod `seq` occ `seq` return ()
  ; updNameCache (hsc_NC hsc_env) upd_fn }

{-
************************************************************************
*                                                                      *
                Name cache access
*                                                                      *
************************************************************************
-}

-- | Look up the 'Name' for a given 'Module' and 'OccName'.
-- Consider alternatively using 'lookupIfaceTop' if you're in the 'IfL' monad
-- and 'Module' is simply that of the 'ModIface' you are typechecking.
lookupOrig :: Module -> OccName -> TcRnIf a b Name
lookupOrig mod occ
  = do  { traceIf (text "lookup_orig" <+> ppr mod <+> ppr occ)

        ; updNameCacheTc mod occ $ lookupNameCache mod occ }

lookupOrigIO :: HscEnv -> Module -> OccName -> IO Name
lookupOrigIO hsc_env mod occ
  = updNameCacheIO hsc_env mod occ $ lookupNameCache mod occ

lookupNameCache :: Module -> OccName -> NameCache -> (NameCache, Name)
-- Lookup up the (Module,OccName) in the NameCache
-- If you find it, return it; if not, allocate a fresh original name and extend
-- the NameCache.
-- Reason: this may the first occurrence of (say) Foo.bar we have encountered.
-- If we need to explore its value we will load Foo.hi; but meanwhile all we
-- need is a Name for it.
lookupNameCache mod occ name_cache =
  case lookupOrigNameCache (nsNames name_cache) mod occ of {
    Just name -> (name_cache, name);
    Nothing   ->
        case takeUniqFromSupply (nsUniqs name_cache) of {
          (uniq, us) ->
              let
                name      = mkExternalName uniq mod occ noSrcSpan
                new_cache = extendNameCache (nsNames name_cache) mod occ name
              in (name_cache{ nsUniqs = us, nsNames = new_cache }, name) }}

externaliseName :: Module -> Name -> TcRnIf m n Name
-- Take an Internal Name and make it an External one,
-- with the same unique
externaliseName mod name
  = do { let occ = nameOccName name
             loc = nameSrcSpan name
             uniq = nameUnique name
       ; occ `seq` return ()  -- c.f. seq in newGlobalBinder
       ; updNameCacheTc mod occ $ \ ns ->
         let name' = mkExternalName uniq mod occ loc
             ns'   = ns { nsNames = extendNameCache (nsNames ns) mod occ name' }
         in (ns', name') }

-- | Set the 'Module' of a 'Name'.
setNameModule :: Maybe Module -> Name -> TcRnIf m n Name
setNameModule Nothing n = return n
setNameModule (Just m) n =
    newGlobalBinder m (nameOccName n) (nameSrcSpan n)

{-
************************************************************************
*                                                                      *
                Type variables and local Ids
*                                                                      *
************************************************************************
-}

tcIfaceLclId :: FastString -> IfL Id
tcIfaceLclId occ
  = do  { lcl <- getLclEnv
        ; case (lookupFsEnv (if_id_env lcl) occ) of
            Just ty_var -> return ty_var
            Nothing     -> failIfM (text "Iface id out of scope: " <+> ppr occ)
        }

extendIfaceIdEnv :: [Id] -> IfL a -> IfL a
extendIfaceIdEnv ids thing_inside
  = do  { env <- getLclEnv
        ; let { id_env' = extendFsEnvList (if_id_env env) pairs
              ; pairs   = [(occNameFS (getOccName id), id) | id <- ids] }
        ; setLclEnv (env { if_id_env = id_env' }) thing_inside }

tcIfaceTyVar :: FastString -> IfL TyVar
tcIfaceTyVar occ
  = do  { lcl <- getLclEnv
        ; case (lookupFsEnv (if_tv_env lcl) occ) of
            Just ty_var -> return ty_var
            Nothing     -> failIfM (text "Iface type variable out of scope: " <+> ppr occ)
        }

lookupIfaceTyVar :: IfaceTvBndr -> IfL (Maybe TyVar)
lookupIfaceTyVar (occ, _)
  = do  { lcl <- getLclEnv
        ; return (lookupFsEnv (if_tv_env lcl) occ) }

lookupIfaceVar :: IfaceBndr -> IfL (Maybe TyCoVar)
lookupIfaceVar (IfaceIdBndr (occ, _))
  = do  { lcl <- getLclEnv
        ; return (lookupFsEnv (if_id_env lcl) occ) }
lookupIfaceVar (IfaceTvBndr (occ, _))
  = do  { lcl <- getLclEnv
        ; return (lookupFsEnv (if_tv_env lcl) occ) }

extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a
extendIfaceTyVarEnv tyvars thing_inside
  = do  { env <- getLclEnv
        ; let { tv_env' = extendFsEnvList (if_tv_env env) pairs
              ; pairs   = [(occNameFS (getOccName tv), tv) | tv <- tyvars] }
        ; setLclEnv (env { if_tv_env = tv_env' }) thing_inside }

extendIfaceEnvs :: [TyCoVar] -> IfL a -> IfL a
extendIfaceEnvs tcvs thing_inside
  = extendIfaceTyVarEnv tvs $
    extendIfaceIdEnv    cvs $
    thing_inside
  where
    (tvs, cvs) = partition isTyVar tcvs

{-
************************************************************************
*                                                                      *
                Getting from RdrNames to Names
*                                                                      *
************************************************************************
-}

-- | Look up a top-level name from the current Iface module
lookupIfaceTop :: OccName -> IfL Name
lookupIfaceTop occ
  = do  { env <- getLclEnv; lookupOrig (if_mod env) occ }

newIfaceName :: OccName -> IfL Name
newIfaceName occ
  = do  { uniq <- newUnique
        ; return $! mkInternalName uniq occ noSrcSpan }

newIfaceNames :: [OccName] -> IfL [Name]
newIfaceNames occs
  = do  { uniqs <- newUniqueSupply
        ; return [ mkInternalName uniq occ noSrcSpan
                 | (occ,uniq) <- occs `zip` uniqsFromSupply uniqs] }