import GHC.ByteCode.InfoTable

 import GHC.ByteCode.Types

 import GHCi.RemoteTypes

 import GHC.Runtime.Heap.Layout ( fromStgWord, StgWord )

 import GHC.Types.Name

 import GHC.Types.Unique.DSet

 import GHC.Types.SptEntry

 import GHC.Types.Unique.FM

 import GHC.Utils.Outputable

 import GHC.Utils.Panic

 import GHC.Cmm.CallConv        ( allArgRegsCover )

 import GHC.Platform

 import GHC.Platform.Profile

 import Control.Monad

 import qualified Control.Monad.Trans.State.Strict as MTL

 #endif

 import Foreign hiding (shiftL, shiftR)

 import Data.Char  (ord)

 import Data.Maybe (fromMaybe)

 import GHC.Float (castFloatToWord32, castDoubleToWord64)

 -- Top level assembler fn.

 assembleBCOs

   -> FlatBag (ProtoBCO Name)

   -> [TyCon]

   -> Maybe ModBreaks

   -> [SptEntry]

   -> IO CompiledByteCode

   -- TODO: the profile should be bundled with the interpreter: the rts ways are

   -- fixed for an interpreter

   bcos    <- mapM (assembleBCO (profilePlatform profile)) proto_bcos

   return CompiledByteCode

     , bc_strs = top_strs

     , bc_breaks = modbreaks

     , bc_spt_entries = spt_entries

 -- memory for them, and bake the resulting addresses into the instruction stream

 -- in the form of BCONPtrWord arguments.

 --

 --

 -- Note that, as with top-level string literal bindings, this memory is never

 -- freed, so it just leaks if the BCO is unloaded. See Note [Generating code for

 -- top-level string literal bindings] in GHC.StgToByteCode for some discussion

 -- about why.

 --

 data RunAsmReader = RunAsmReader { isn_array :: {-# UNPACK #-} !(Array.IOUArray Int Word16)

                                   , ptr_array :: {-# UNPACK #-} !(SmallMutableArrayIO BCOPtr)

   ENTER                    -> emit_ bci_ENTER []

   RETURN rep               -> emit_ (return_non_tuple rep) []

   RETURN_TUPLE             -> emit_ bci_RETURN_T []

                                  emit_ bci_CCALL [wOp off, Op np, SmallOp i]

   PRIMCALL                 -> emit_ bci_PRIMCALL []

   BRK_FUN arr tick_mod tick_mod_id tickx info_mod info_mod_id infox cc ->

                               do p1 <- ptr (BCOPtrBreakArray arr)

                                  np <- addr cc

                                  emit_ bci_BRK_FUN [ Op p1

                                                   , Op tick_addr, Op info_addr

 import GHC.Platform

 import GHC.Platform.Profile

 import GHC.Types.Name       ( Name, getName )

 import GHC.Types.RepType

 import GHC.Core.DataCon     ( DataCon, dataConRepArgTys, dataConIdentity )

 -}

 -- Make info tables for the data decls in this module

  where

   mkITbl tc

     | dcs `lengthIs` n -- paranoia; this is an assertion.

        where

           dcs = tyConDataCons tc

           n   = tyConFamilySize tc

   mkITbl _ = panic "mkITbl"

 -- Assumes constructors are numbered from zero, not one

   -- TODO: the profile should be bundled with the interpreter: the rts ways are

   -- fixed for an interpreter

                     | arg <- dataConRepArgTys dcon

                     , prim_rep <- typePrimRep (scaledThing arg) ]

          platform = profilePlatform profile

          constants = platformConstants platform

          tables_next_to_code = platformTablesNextToCode platform

 import GHC.ByteCode.Types

 import GHCi.RemoteTypes

 import GHC.StgToCmm.Layout     ( ArgRep(..) )

 import GHC.Utils.Outputable

 import GHC.Types.Name

         protoBCOBitmapSize :: Word,

         protoBCOArity      :: Int,

         -- what the BCO came from, for debugging only

    }

 -- | A local block label (e.g. identifying a case alternative).

    -- For doing calls to C (via glue code generated by libffi)

    | CCALL            !WordOff  -- stack frame size

                       !Word16   -- flags.

                                 --

                                 -- 0x1: call is interruptible

    -- Breakpoints

    | BRK_FUN          (ForeignRef BreakArray)

                       !Word16                -- breakpoint tick index

                       !Word16                -- breakpoint info index

                       (RemotePtr CostCentre)

                  , protoBCOBitmap     = bitmap

                  , protoBCOBitmapSize = bsize

                  , protoBCOArity      = arity

       = (text "ProtoBCO" <+> ppr name <> char '#' <> int arity

         $$ nest 3 (case origin of

                       Left alts ->

                         vcat (zipWith (<+>) (char '{' : repeat (char ';'))

    ppr (TESTEQ_P  i lab)     = text "TESTEQ_P" <+> ppr i <+> text "__" <> ppr lab

    ppr CASEFAIL              = text "CASEFAIL"

    ppr (JMP lab)             = text "JMP"      <+> ppr lab

                                                 <+> text "marshal code at"

                                                <+> (case flags of

                                                       0x1 -> text "(interruptible)"

                                                       0x2 -> text "(unsafe)"

 {-# LANGUAGE MultiParamTypeClasses #-}

 {-# LANGUAGE OverloadedStrings     #-}

 {-# LANGUAGE DataKinds             #-}

 {-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}

 --

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

   BCONPtrAddr nm -> do

     Ptr a# <- lookupAddr interp pkgs_loaded (addr_env le) nm

     return (W# (int2Word# (addr2Int# a#)))

 lookupStaticPtr :: Interp -> FastString -> IO (Ptr ())

 lookupStaticPtr interp addr_of_label_string = do

 import GHC.Types.SptEntry

 import GHC.Types.SrcLoc

 import GHCi.BreakArray

 import GHCi.RemoteTypes

 import GHCi.FFI

 import Control.DeepSeq

 import GHC.Stack.CCS

 import GHC.Cmm.Expr ( GlobalRegSet, emptyRegSet, regSetToList )

 import GHC.Iface.Syntax

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

 -- Compiled Byte Code

   { bc_bcos   :: FlatBag UnlinkedBCO

     -- ^ Bunch of interpretable bindings

     -- ^ Mapping from DataCons to their info tables

     -- ^ top-level strings (heap allocated)

   , bc_breaks :: Maybe ModBreaks

     -- BCOs. See Note [Grand plan for static forms] in

     -- "GHC.Iface.Tidy.StaticPtrTable".

   }

 instance Outputable CompiledByteCode where

   ppr CompiledByteCode{..} = ppr $ elemsFlatBag bc_bcos

 seqCompiledByteCode :: CompiledByteCode -> ()

 seqCompiledByteCode CompiledByteCode{..} =

   rnf bc_bcos `seq`

   rnf (fmap seqModBreaks bc_breaks)

 newtype ByteOff = ByteOff Int

   -- | A reference to a top-level string literal; see

   -- Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode.

   | BCONPtrAddr  !Name

   -- Also see Note [Allocating string literals] in GHC.ByteCode.Asm.

   | BCONPtrStr   !ByteString

 instance NFData BCONPtr where

   rnf x = x `seq` ()

         -- ^ Array pointing to cost centre for each breakpoint

    , modBreaks_breakInfo :: IntMap CgBreakInfo

         -- ^ info about each breakpoint from the bytecode generator

         -- ^ info about the module in which we are setting the breakpoint

         -- ^ The 'UnitId' of the 'ModuleName'

    }

    , modBreaks_decls = array (0,-1) []

    , modBreaks_ccs = array (0,-1) []

    , modBreaks_breakInfo = IntMap.empty

    }

 {-

     breakArray <- GHCi.newBreakArray interp count

     ccs <- mkCCSArray interp mod count entries

     let

            locsTicks  = listArray (0,count-1) [ tick_loc  t | t <- entries ]

            varsTicks  = listArray (0,count-1) [ tick_ids  t | t <- entries ]

                        , modBreaks_vars   = varsTicks

                        , modBreaks_decls  = declsTicks

                        , modBreaks_ccs    = ccs

                        }

 mkCCSArray

 import GHC.Runtime.Interpreter

 import GHCi.RemoteTypes

 import GHC.Iface.Load

 import GHC.ByteCode.Linker

 import GHC.ByteCode.Asm

 -- Standard libraries

 import Control.Monad

 import qualified Data.Set as Set

 import Data.Char (isSpace)

 import qualified Data.Foldable as Foldable

         else do

           -- Link the expression itself

           let le  = linker_env pls

           -- Link the necessary packages and linkables

           new_bindings <- linkSomeBCOs interp (pkgs_loaded pls) le2 cbcs

             le1 = linker_env pls

         names_and_refs <- linkSomeBCOs interp (pkgs_loaded pls) le2 cbcs

 makeForeignNamedHValueRefs interp bindings =

   mapM (\(n, hvref) -> (n,) <$> mkFinalizedHValue interp hvref) bindings

 {- **********************************************************************

                 Unload some object modules

 maybePutStrLn :: Logger -> String -> IO ()

 maybePutStrLn logger s = maybePutSDoc logger (text s <> text "\n")

   , mkCostCentres

   , costCentreStackInfo

   , newBreakArray

   , storeBreakpoint

   , breakpointStatus

   , getBreakpointVar

   breakArray <- interpCmd interp (NewBreakArray size)

   mkFinalizedHValue interp breakArray

 storeBreakpoint :: Interp -> ForeignRef BreakArray -> Int -> Int -> IO ()

 storeBreakpoint interp ref ix cnt = do                               -- #19157

   withForeignRef ref $ \breakarray ->

 import GHC.Data.FlatBag as FlatBag

 import GHC.Data.OrdList

 import GHC.Data.Maybe

 import GHC.Types.Tickish

 import GHC.Types.SptEntry

 import Data.Array

 import Data.Coerce (coerce)

 #if MIN_VERSION_rts(1,0,3)

 import qualified Data.ByteString.Char8 as BS

 #endif

                 bnd <- binds

                 case bnd of

                   StgTopLifted bnd      -> [Right bnd]

             flattenBind (StgNonRec b e) = [(b,e)]

             flattenBind (StgRec bs)     = bs

         (BcM_State{..}, proto_bcos) <-

            runBc hsc_env this_mod mb_modBreaks $ do

              let flattened_binds = concatMap flattenBind (reverse lifted_binds)

              FlatBag.fromList (fromIntegral $ length flattened_binds) <$> mapM schemeTopBind flattened_binds

         putDumpFileMaybe logger Opt_D_dump_BCOs

            "Proto-BCOs" FormatByteCode

            (vcat (intersperse (char ' ') (map ppr $ elemsFlatBag proto_bcos)))

         let mod_breaks = case modBreaks of

              Nothing -> Nothing

              Just mb -> Just mb{ modBreaks_breakInfo = breakInfo }

         -- Squash space leaks in the CompiledByteCode.  This is really

         -- important, because when loading a set of modules into GHCi

   where dflags  = hsc_dflags hsc_env

         logger  = hsc_logger hsc_env

         profile = targetProfile dflags

 {- Note [Generating code for top-level string literal bindings]

 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

 As described in Note [Compilation plan for top-level string literals]

 we deal with them:

   1. Top-level string literal bindings are separated from the rest of

   2. When we encounter a reference to a top-level string literal, we

      generate a PUSH_ADDR pseudo-instruction, which is assembled to

    -> WordOff   -- ^ bitmap size

    -> [StgWord] -- ^ bitmap

    -> Bool      -- ^ True <=> is a return point, rather than a function

    -> ProtoBCO Name

    = ProtoBCO {

         protoBCOName = nm,

         protoBCOInstrs = maybe_add_bco_name $ maybe_add_stack_check peep_d,

         protoBCOBitmap = bitmap,

         protoBCOBitmapSize = fromIntegral bitmap_size,

         protoBCOArity = arity,

       }

      where

 #if MIN_VERSION_rts(1,0,3)

         -- by just re-using the single top-level definition.  So

         -- for the worker itself, we must allocate it directly.

     -- ioToBc (putStrLn $ "top level BCO")

                        (getName id) (toOL [PACK data_con 0, RETURN P])

                        (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-})

          bitmap = mkBitmap platform bits

      body_code <- schemeER_wrk sum_szsb_args p_init body

                  arity bitmap_size bitmap False{-not alts-})

 -- | Introduce break instructions for ticked expressions.

   where

     check_mod_ptr mb

       | mod_ptr <- modBreaks_module mb

       = Just mb

       | otherwise

       = Nothing

              -- otherwise use RETURN_TUPLE with a tuple descriptor

              nv_reps -> do

                let (call_info, args_offsets) = layoutNativeCall profile NativeTupleReturn 0 id nv_reps

                return $ PUSH_UBX (mkNativeCallInfoLit platform call_info) 1 `consOL`

                         PUSH_BCO tuple_bco `consOL`

                         unitOL RETURN_TUPLE

      scrut_code <- schemeE (d + ret_frame_size_b + save_ccs_size_b)

                            (d + ret_frame_size_b + save_ccs_size_b)

                            p scrut

      if ubx_tuple_frame

                        `consOL` scrut_code)

        else let scrut_rep = case non_void_arg_reps of

                   []    -> V

                   [rep] -> rep

                   _     -> panic "schemeE(StgCase).push_alts"

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

  -}

 tupleBCO platform args_info args =

   mkProtoBCO platform Nothing invented_name body_code (Left [])

              0{-no arity-} bitmap_size bitmap False{-is alts-}

     body_code = mkSlideW 0 1          -- pop frame header

                 `snocOL` RETURN_TUPLE -- and add it again

 primCallBCO platform args_info args =

   mkProtoBCO platform Nothing invented_name body_code (Left [])

              0{-no arity-} bitmap_size bitmap False{-is alts-}

                                           massert (off == dd + szb)

                                           go (dd + szb) (push:pushes) cs

      push_args <- go d [] shifted_args_offsets

      return $ mconcat push_args `appOL`

               (push_target `consOL`

                push_info `consOL`

      let ffires = primRepToFFIType platform r_rep

          ffiargs = map (primRepToFFIType platform) a_reps

      let

          -- do the call

            where flags = case safety of

                            PlaySafe          -> 0x0

                            PlayInterruptible -> 0x1

         { bcm_hsc_env :: HscEnv

         , thisModule  :: Module          -- current module (for breakpoints)

         , nextlabel   :: Word32          -- for generating local labels

         , modBreaks   :: Maybe ModBreaks -- info about breakpoints

         , breakInfo   :: IntMap CgBreakInfo -- ^ Info at breakpoint occurrence.