-- * Flags and settings

         DynFlags(..), GeneralFlag(..), Severity(..), Backend, gopt,

         GhcMode(..), GhcLink(..),

         parseDynamicFlags, parseTargetFiles,

         getSessionDynFlags,

 -- bad for performance, so I increased the limit to allow it to unbox

 -- consistently.

 {-

 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998

   = -- Analyse the RHS and /then/ the body

     let -- Analyse the rhs first, generating rhs_uds

         !(rhs_uds_s, bndr', rhs') = occAnalNonRecRhs env lvl ire mb_join bndr rhs

                                            -- Note [Occurrence analysis for join points]

         -- Now analyse the body, adding the join point

 -------------------

 -- UsageDetails API

 andUDs = combineUsageDetailsWith andLocalOcc

 orUDs  = combineUsageDetailsWith orLocalOcc

 combineUsageDetailsWith :: (LocalOcc -> LocalOcc -> LocalOcc)

                         -> UsageDetails -> UsageDetails -> UsageDetails

 {-# INLINE combineUsageDetailsWith #-}

 combineUsageDetailsWith plus_occ_info

     uds1@(UD { ud_env = env1, ud_z_many = z_many1, ud_z_in_lam = z_in_lam1, ud_z_tail = z_tail1 })

     uds2@(UD { ud_env = env2, ud_z_many = z_many2, ud_z_in_lam = z_in_lam2, ud_z_tail = z_tail2 })

   | isEmptyVarEnv env1 = uds2

   | isEmptyVarEnv env2 = uds1

   | otherwise

 lookupLetOccInfo :: UsageDetails -> Id -> OccInfo

 -- Don't use locally-generated occ_info for exported (visible-elsewhere)

 {-# OPTIONS_HADDOCK not-home #-}

 {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}

 -----------------------------------------------------------------------------

    , llvmBackend

    , jsBackend

    , viaCBackend

    , interpreterBackend

    , noBackend

    , allBackends

   show = backendDescription

     :: Backend

 -- | The native code generator.

 -- (foreign primops).

 --

 -- See "GHC.StgToByteCode"

 -- | A dummy back end that generates no code.

 --

 backendDescription (Named LLVM)        = "LLVM"

 backendDescription (Named ViaC)        = "compiling via C"

 backendDescription (Named JavaScript)  = "compiling to JavaScript"

 backendDescription (Named NoBackend)   = "no code generated"

 -- | This flag tells the compiler driver whether the back

 backendWritesFiles (Named LLVM)        = True

 backendWritesFiles (Named ViaC)        = True

 backendWritesFiles (Named JavaScript)  = True

 backendWritesFiles (Named NoBackend)   = False

 -- | When the back end does write files, this value tells

 backendPipelineOutput (Named LLVM) = Persistent

 backendPipelineOutput (Named ViaC) = Persistent

 backendPipelineOutput (Named JavaScript)  = Persistent

 backendPipelineOutput (Named NoBackend)   = NoOutputFile

 -- | This flag tells the driver whether the back end can

 backendCanReuseLoadedCode (Named LLVM)        = False

 backendCanReuseLoadedCode (Named ViaC)        = False

 backendCanReuseLoadedCode (Named JavaScript)  = False

 backendCanReuseLoadedCode (Named NoBackend)   = False

 -- | It is is true of every back end except @-fno-code@

 backendGeneratesCode (Named LLVM)        = True

 backendGeneratesCode (Named ViaC)        = True

 backendGeneratesCode (Named JavaScript)  = True

 backendGeneratesCode (Named NoBackend)   = False

 backendGeneratesCodeForHsBoot :: Backend -> Bool

 backendGeneratesCodeForHsBoot (Named LLVM)        = True

 backendGeneratesCodeForHsBoot (Named ViaC)        = True

 backendGeneratesCodeForHsBoot (Named JavaScript)  = True

 backendGeneratesCodeForHsBoot (Named NoBackend)   = False

 -- | When set, this flag turns on interface writing for

 backendSupportsInterfaceWriting (Named LLVM)        = True

 backendSupportsInterfaceWriting (Named ViaC)        = True

 backendSupportsInterfaceWriting (Named JavaScript)  = True

 backendSupportsInterfaceWriting (Named NoBackend)   = False

 -- | When preparing code for this back end, the type

 backendRespectsSpecialise (Named LLVM)        = True

 backendRespectsSpecialise (Named ViaC)        = True

 backendRespectsSpecialise (Named JavaScript)  = True

 backendRespectsSpecialise (Named NoBackend)   = False

 -- | This back end wants the `mi_top_env` field of a

 backendWantsGlobalBindings (Named ViaC)        = False

 backendWantsGlobalBindings (Named JavaScript)  = False

 backendWantsGlobalBindings (Named NoBackend)   = False

 -- | The back end targets a technology that implements

 -- `switch` natively.  (For example, LLVM or C.) Therefore

 backendHasNativeSwitch (Named LLVM)        = True

 backendHasNativeSwitch (Named ViaC)        = True

 backendHasNativeSwitch (Named JavaScript)  = True

 backendHasNativeSwitch (Named NoBackend)   = False

 -- | As noted in the documentation for

 backendPrimitiveImplementation (Named LLVM)        = LlvmPrimitives

 backendPrimitiveImplementation (Named JavaScript)  = JSPrimitives

 backendPrimitiveImplementation (Named ViaC)        = GenericPrimitives

 backendPrimitiveImplementation (Named NoBackend)   = GenericPrimitives

 -- | When this value is `IsValid`, the back end is

 backendSimdValidity (Named LLVM)        = IsValid

 backendSimdValidity (Named ViaC)        = NotValid $ unlines ["SIMD vector instructions require using the NCG or the LLVM backend."]

 backendSimdValidity (Named JavaScript)  = NotValid $ unlines ["SIMD vector instructions require using the NCG or the LLVM backend."]

 backendSimdValidity (Named NoBackend)   = NotValid $ unlines ["SIMD vector instructions require using the NCG or the LLVM backend."]

 -- | This flag says whether the back end supports large

 backendSupportsEmbeddedBlobs (Named LLVM)        = False

 backendSupportsEmbeddedBlobs (Named ViaC)        = False

 backendSupportsEmbeddedBlobs (Named JavaScript)  = False

 backendSupportsEmbeddedBlobs (Named NoBackend)   = False

 -- | This flag tells the compiler driver that the back end

 backendNeedsPlatformNcgSupport (Named LLVM)        = False

 backendNeedsPlatformNcgSupport (Named ViaC)        = False

 backendNeedsPlatformNcgSupport (Named JavaScript)  = False

 backendNeedsPlatformNcgSupport (Named NoBackend)   = False

 -- | This flag is set if the back end can generate code

 backendSupportsUnsplitProcPoints (Named LLVM)        = False

 backendSupportsUnsplitProcPoints (Named ViaC)        = False

 backendSupportsUnsplitProcPoints (Named JavaScript)  = False

 backendSupportsUnsplitProcPoints (Named NoBackend)   = False

 -- | This flag guides the driver in resolving issues about

 backendSwappableWithViaC (Named LLVM)        = True

 backendSwappableWithViaC (Named ViaC)        = False

 backendSwappableWithViaC (Named JavaScript)  = False

 backendSwappableWithViaC (Named NoBackend)   = False

 -- | This flag is true if the back end works *only* with

 backendUnregisterisedAbiOnly (Named LLVM)        = False

 backendUnregisterisedAbiOnly (Named ViaC)        = True

 backendUnregisterisedAbiOnly (Named JavaScript)  = False

 backendUnregisterisedAbiOnly (Named NoBackend)   = False

 -- | This flag is set if the back end generates C code in

 backendGeneratesHc (Named LLVM)        = False

 backendGeneratesHc (Named ViaC)        = True

 backendGeneratesHc (Named JavaScript)  = False

 backendGeneratesHc (Named NoBackend)   = False

 -- | This flag says whether SPT (static pointer table)

 backendSptIsDynamic (Named LLVM)        = False

 backendSptIsDynamic (Named ViaC)        = False

 backendSptIsDynamic (Named JavaScript)  = False

 backendSptIsDynamic (Named NoBackend)   = False

 -- | If this flag is unset, then the driver ignores the flag @-fbreak-points@,

   Named LLVM        -> False

   Named ViaC        -> False

   Named JavaScript  -> False

   Named NoBackend   -> False

 -- | If this flag is set, then the driver forces the

 backendForcesOptimization0 (Named LLVM)        = False

 backendForcesOptimization0 (Named ViaC)        = False

 backendForcesOptimization0 (Named JavaScript)  = False

 backendForcesOptimization0 (Named NoBackend)   = False

 -- | I don't understand exactly how this works.  But if

 backendNeedsFullWays (Named LLVM)        = False

 backendNeedsFullWays (Named ViaC)        = False

 backendNeedsFullWays (Named JavaScript)  = False

 backendNeedsFullWays (Named NoBackend)   = False

 -- | This flag is also special for the interpreter: if a

 backendSpecialModuleSource (Named LLVM)        = const Nothing

 backendSpecialModuleSource (Named ViaC)        = const Nothing

 backendSpecialModuleSource (Named JavaScript)  = const Nothing

 backendSpecialModuleSource (Named NoBackend)   = const (Just "nothing")

 -- | This flag says whether the back end supports Haskell

 backendSupportsHpc (Named LLVM)        = True

 backendSupportsHpc (Named ViaC)        = True

 backendSupportsHpc (Named JavaScript)  = False

 backendSupportsHpc (Named NoBackend)   = True

 -- | This flag says whether the back end supports foreign

 backendSupportsCImport (Named LLVM)        = True

 backendSupportsCImport (Named ViaC)        = True

 backendSupportsCImport (Named JavaScript)  = True

 backendSupportsCImport (Named NoBackend)   = True

 -- | This flag says whether the back end supports foreign

 backendSupportsCExport (Named LLVM)        = True

 backendSupportsCExport (Named ViaC)        = True

 backendSupportsCExport (Named JavaScript)  = True

 backendSupportsCExport (Named NoBackend)   = True

 -- | When using this back end, it may be necessary or

 backendCDefs (Named LLVM)        = LlvmCDefs

 backendCDefs (Named ViaC)        = NoCDefs

 backendCDefs (Named JavaScript)  = NoCDefs

 backendCDefs (Named NoBackend)   = NoCDefs

 -- | This (defunctionalized) function generates code and

 backendCodeOutput (Named LLVM)        = LlvmCodeOutput

 backendCodeOutput (Named ViaC)        = ViaCCodeOutput

 backendCodeOutput (Named JavaScript)  = JSCodeOutput

 backendCodeOutput (Named NoBackend)   = panic "backendCodeOutput: noBackend"

 backendUseJSLinker :: Backend -> Bool

 backendUseJSLinker (Named LLVM)        = False

 backendUseJSLinker (Named ViaC)        = False

 backendUseJSLinker (Named JavaScript)  = True

 backendUseJSLinker (Named NoBackend)   = False

 -- | This (defunctionalized) function tells the compiler

 backendPostHscPipeline (Named LLVM) = LlvmPostHscPipeline

 backendPostHscPipeline (Named ViaC) = ViaCPostHscPipeline

 backendPostHscPipeline (Named JavaScript)  = JSPostHscPipeline

 backendPostHscPipeline (Named NoBackend) = NoPostHscPipeline

 -- | Somewhere in the compiler driver, when compiling

 backendNormalSuccessorPhase (Named LLVM) = LlvmOpt

 backendNormalSuccessorPhase (Named ViaC) = HCc

 backendNormalSuccessorPhase (Named JavaScript)  = StopLn

 backendNormalSuccessorPhase (Named NoBackend)   = StopLn

 -- | Name of the back end, if any.  Used to migrate legacy

 backendName (Named LLVM) = LLVM

 backendName (Named ViaC) = ViaC

 backendName (Named JavaScript)  = JavaScript

 backendName (Named NoBackend)   = NoBackend

               , llvmBackend

               , viaCBackend

               , jsBackend

               , noBackend

               ]

    | LLVM          -- ^ Names the LLVM backend.

    | ViaC          -- ^ Names the Via-C backend.

    | JavaScript    -- ^ Names the JS backend.

    | NoBackend     -- ^ Names the `-fno-code` backend.

  deriving (Eq, Show)

                    else (,) <$> (new_temp_file (hiSuf_ dflags) (dynHiSuf_ dflags))

                             <*> (new_temp_file (objectSuf_ dflags) (dynObjectSuf_ dflags))

                let new_dflags = case enable_spec of

                                   EnableObject   -> dflags { backend = defaultBackendOf ms }

                                   EnableByteCodeAndObject -> (gopt_set dflags Opt_ByteCodeAndObjectCode) { backend = defaultBackendOf ms}

                let ms' = ms

          -- was set), force it to generate byte-code. This is NOT transitive and

          -- only applies to direct targets.

          | loadAsByteCode

            )

          | otherwise

                   d { ghcLink=NoLink }) >> setBackend noBackend))

   , make_ord_flag defFlag "fbyte-code"

       (noArgM $ \dflags -> do

         pure $ flip gopt_unset Opt_ByteCodeAndObjectCode (gopt_set dflags Opt_ByteCode))

   , make_ord_flag defFlag "fobject-code"     $ noArgM $ \dflags -> do

       setBackend $ platformDefaultBackend (targetPlatform dflags)

         delListFromUFM,

         delListFromUFM_Directly,

         plusUFM,

         plusUFM_C,

         plusUFM_CD,

         plusUFM_CD2,

         mergeUFM,

 delFromUFM_Directly :: UniqFM key elt -> Unique -> UniqFM key elt

 delFromUFM_Directly (UFM m) u = UFM (M.delete (getKey u) m)

 plusUFM :: UniqFM key elt -> UniqFM key elt -> UniqFM key elt

 plusUFM (UFM x) (UFM y) = UFM (M.union y x)

      -- Note (M.union y x), with arguments flipped

      -- M.union is left-biased, plusUFM should be right-biased.

 plusUFM_C :: (elt -> elt -> elt) -> UniqFM key elt -> UniqFM key elt -> UniqFM key elt

 plusUFM_C f (UFM x) (UFM y) = UFM (M.unionWith f x y)

 -- | `plusUFM_CD f m1 d1 m2 d2` merges the maps using `f` as the

 -- combinding function and `d1` resp. `d2` as the default value if

 -- there is no entry in `m1` reps. `m2`. The domain is the union of

         elemVarEnv, disjointVarEnv, anyVarEnv,

         extendVarEnv, extendVarEnv_C, extendVarEnv_Acc,

         extendVarEnvList,

         plusVarEnvList, alterVarEnv,

         delVarEnvList, delVarEnv,

         minusVarEnv,

 extendVarEnv_C    :: (a->a->a) -> VarEnv a -> Var -> a -> VarEnv a

 extendVarEnv_Acc  :: (a->b->b) -> (a->b) -> VarEnv b -> Var -> a -> VarEnv b

 plusVarEnv        :: VarEnv a -> VarEnv a -> VarEnv a

 plusVarEnvList    :: [VarEnv a] -> VarEnv a

 extendVarEnvList  :: VarEnv a -> [(Var, a)] -> VarEnv a

 varEnvDomain      :: VarEnv elt -> UnVarSet

 delVarEnv         :: VarEnv a -> Var -> VarEnv a

 minusVarEnv       :: VarEnv a -> VarEnv b -> VarEnv a

 plusVarEnv_C      :: (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a

 plusVarEnv_CD     :: (a -> a -> a) -> VarEnv a -> a -> VarEnv a -> a -> VarEnv a

 plusMaybeVarEnv_C :: (a -> a -> Maybe a) -> VarEnv a -> VarEnv a -> VarEnv a

 mapVarEnv         :: (a -> b) -> VarEnv a -> VarEnv b

 extendVarEnv_Acc = addToUFM_Acc

 extendVarEnvList = addListToUFM

 plusVarEnv_C     = plusUFM_C

 plusVarEnv_CD    = plusUFM_CD

 plusMaybeVarEnv_C = plusMaybeUFM_C

 delVarEnvList    = delListFromUFM

 delVarEnv        = delFromUFM

 minusVarEnv      = minusUFM

 plusVarEnv       = plusUFM

 plusVarEnvList   = plusUFMList

 -- lookupVarEnv is very hot (in part due to being called by substTyVar),

 -- if it's not inlined than the mere allocation of the Just constructor causes

 +-----------------+------------------------+

 | ``ViaC``        | ``viaCBackend``        |

 +-----------------+------------------------+

 +-----------------+------------------------+

 | ``NoBackend``   | ``noBackend``          |

 +-----------------+------------------------+

   let dflt_backend = backend dflags0

       (mode, bcknd, link)

          = case postLoadMode of

                DoMake          -> (CompManager, dflt_backend, LinkBinary)

                DoBackpack      -> (CompManager, dflt_backend, LinkBinary)

                DoMkDependHS    -> (MkDepend,    dflt_backend, LinkBinary)

         # Do we have interpreter support?

         self.have_interp = False

         # Are we cross-compiling?

         self.cross = False

         # Does the RTS linker only support loading shared libraries?

         self.interp_force_dyn = False

 # -----

 def valid_way( way: WayName ) -> bool:

         return config.have_RTS_linker

     return True

 def extra_ways( ways: List[WayName] ):

                      when(fast(), skip), only_ways(['threaded2']),

                      fragile(16604),

                      run_timeout_multiplier(2)],

       -- begin initialize

       df0 <- GHC.getSessionDynFlags

       let df1 = df0{GHC.ghcMode    = GHC.CompManager,

                     GHC.ghcLink    = GHC.LinkInMemory,

                     GHC.verbosity  = 0}

       _ <- GHC.setSessionDynFlags df1

       logger <- getLogger

       (dflags1, _leftover, _warns) <- parseDynamicFlags logger dflags0 flags

       let dflags2 = dflags1 {

             , ghcLink   = LinkInMemory

             , verbosity = 1

             }

  = do { [libdir] <- getArgs

       ; runGhc (Just libdir) $ do

            flags <- getSessionDynFlags

            target <- guessTarget "T8639_api_a.hs" Nothing Nothing

            setTargets [target]

            load LoadAllTargets

     prn "target nothing: ok"

     dflags <- getSessionDynFlags

     ok <- load LoadAllTargets

     when (failed ok) $ error "Couldn't load A.hs in interpreted mode"

     prn "target interpreted: ok"

         let dflags1 =

               dflags0

                 { ghcMode = CompManager,

                   ghcLink = LinkInMemory

                 }

         logger <- getLogger

   where ghc action libdir = GHC.runGhc (Just libdir) (init >> action)

         init = do df <- GHC.getSessionDynFlags

                   GHC.setSessionDynFlags df{GHC.ghcMode    = GHC.CompManager,

                                             GHC.ghcLink    = GHC.LinkInMemory,

                                             GHC.verbosity  = 0}

      [ extra_files(['Obj.hs', 'ByteCode.hs', 'Types.hs', 'Common.hs-incl']),

        req_interp,

        req_bco,

      ],

      compile_and_run,

      ['']

      [ extra_files(['Obj.hs', 'ByteCode.hs', 'Common.hs-incl']),

        req_interp,

        req_bco,

      ],

      compile_and_run,

      ['']

      [ extra_files(['Obj.hs', 'ByteCode.hs', 'Types.hs', 'Common.hs-incl']),

        req_interp,

        req_bco,

      ],

      compile_and_run,

      ['']