{-# LANGUAGE CPP                        #-}
{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards            #-}

{-# OPTIONS_GHC -fprof-auto-top #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

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

-- | GHC.StgToByteCode: Generate bytecode from STG
module GHC.StgToByteCode ( UnlinkedBCO, byteCodeGen) where

#include "HsVersions.h"

import GHC.Prelude

import GHC.Driver.Session
import GHC.Driver.Env

import GHC.ByteCode.Instr
import GHC.ByteCode.Asm
import GHC.ByteCode.Types

import GHC.Cmm.CallConv
import GHC.Cmm.Expr
import GHC.Cmm.Node
import GHC.Cmm.Utils

import GHC.Platform
import GHC.Platform.Profile

import GHC.Runtime.Interpreter
import GHCi.FFI
import GHCi.RemoteTypes
import GHC.Types.Basic
import GHC.Utils.Outputable
import GHC.Types.Name
import GHC.Types.Id.Make
import GHC.Types.Id
import GHC.Types.ForeignCall
import GHC.Core
import GHC.Types.Literal
import GHC.Builtin.PrimOps
import GHC.Core.Type
import GHC.Types.RepType
import GHC.Core.DataCon
import GHC.Core.TyCon
import GHC.Utils.Misc
import GHC.Utils.Logger
import GHC.Types.Var.Set
import GHC.Builtin.Types ( unboxedUnitTy )
import GHC.Builtin.Types.Prim
import GHC.Core.TyCo.Ppr ( pprType )
import GHC.Utils.Error
import GHC.Types.Unique
import GHC.Builtin.Uniques
import GHC.Builtin.Utils ( primOpId )
import GHC.Data.FastString
import GHC.Utils.Panic
import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, nonVoidIds )
import GHC.StgToCmm.Layout
import GHC.Runtime.Heap.Layout hiding (WordOff, ByteOff, wordsToBytes)
import GHC.Data.Bitmap
import GHC.Data.OrdList
import GHC.Data.Maybe
import GHC.Types.Var.Env
import GHC.Types.Tickish

import Data.List ( genericReplicate, genericLength, intersperse
                 , partition, scanl', sort, sortBy, zip4, zip6, nub )
import Foreign hiding (shiftL, shiftR)
import Control.Monad
import Data.Char

import GHC.Types.Unique.Supply
import GHC.Unit.Module

import Control.Exception
import Data.Array
import Data.Coerce (coerce)
import Data.ByteString (ByteString)
import Data.Map (Map)
import Data.IntMap (IntMap)
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
import qualified GHC.Data.FiniteMap as Map
import Data.Ord
import GHC.Stack.CCS
import Data.Either ( partitionEithers )

import qualified GHC.Types.CostCentre as CC
import GHC.Stg.Syntax
import GHC.Stg.FVs

-- -----------------------------------------------------------------------------
-- Generating byte code for a complete module

byteCodeGen :: HscEnv
            -> Module
            -> [StgTopBinding]
            -> [TyCon]
            -> Maybe ModBreaks
            -> IO CompiledByteCode
byteCodeGen :: HscEnv
-> Module
-> [StgTopBinding]
-> [TyCon]
-> Maybe ModBreaks
-> IO CompiledByteCode
byteCodeGen HscEnv
hsc_env Module
this_mod [StgTopBinding]
binds [TyCon]
tycs Maybe ModBreaks
mb_modBreaks
   = Logger
-> DynFlags
-> SDoc
-> (CompiledByteCode -> ())
-> IO CompiledByteCode
-> IO CompiledByteCode
forall (m :: * -> *) a.
MonadIO m =>
Logger -> DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger DynFlags
dflags
                (String -> SDoc
text String
"GHC.StgToByteCode"SDoc -> SDoc -> SDoc
<+>SDoc -> SDoc
brackets (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
this_mod))
                (() -> CompiledByteCode -> ()
forall a b. a -> b -> a
const ()) (IO CompiledByteCode -> IO CompiledByteCode)
-> IO CompiledByteCode -> IO CompiledByteCode
forall a b. (a -> b) -> a -> b
$ do
        -- Split top-level binds into strings and others.
        -- See Note [generating code for top-level string literal bindings].
        let ([(Id, ByteString)]
strings, [GenStgBinding 'Vanilla]
lifted_binds) = [Either (Id, ByteString) (GenStgBinding 'Vanilla)]
-> ([(Id, ByteString)], [GenStgBinding 'Vanilla])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either (Id, ByteString) (GenStgBinding 'Vanilla)]
 -> ([(Id, ByteString)], [GenStgBinding 'Vanilla]))
-> [Either (Id, ByteString) (GenStgBinding 'Vanilla)]
-> ([(Id, ByteString)], [GenStgBinding 'Vanilla])
forall a b. (a -> b) -> a -> b
$ do  -- list monad
                StgTopBinding
bnd <- [StgTopBinding]
binds
                case StgTopBinding
bnd of
                  StgTopLifted GenStgBinding 'Vanilla
bnd      -> [GenStgBinding 'Vanilla
-> Either (Id, ByteString) (GenStgBinding 'Vanilla)
forall a b. b -> Either a b
Right GenStgBinding 'Vanilla
bnd]
                  StgTopStringLit Id
b ByteString
str -> [(Id, ByteString)
-> Either (Id, ByteString) (GenStgBinding 'Vanilla)
forall a b. a -> Either a b
Left (Id
b, ByteString
str)]
            flattenBind :: GenStgBinding pass -> [(BinderP pass, GenStgRhs pass)]
flattenBind (StgNonRec BinderP pass
b GenStgRhs pass
e) = [(BinderP pass
b,GenStgRhs pass
e)]
            flattenBind (StgRec [(BinderP pass, GenStgRhs pass)]
bs)     = [(BinderP pass, GenStgRhs pass)]
bs
        [(Id, RemotePtr ())]
stringPtrs <- Interp -> [(Id, ByteString)] -> IO [(Id, RemotePtr ())]
allocateTopStrings Interp
interp [(Id, ByteString)]
strings

        UniqSupply
us <- Char -> IO UniqSupply
mkSplitUniqSupply Char
'y'
        (BcM_State{[FFIInfo]
Maybe ModBreaks
Word32
IntMap CgBreakInfo
Module
UniqSupply
IdEnv (RemotePtr ())
HscEnv
topStrings :: BcM_State -> IdEnv (RemotePtr ())
breakInfo :: BcM_State -> IntMap CgBreakInfo
modBreaks :: BcM_State -> Maybe ModBreaks
ffis :: BcM_State -> [FFIInfo]
nextlabel :: BcM_State -> Word32
thisModule :: BcM_State -> Module
uniqSupply :: BcM_State -> UniqSupply
bcm_hsc_env :: BcM_State -> HscEnv
topStrings :: IdEnv (RemotePtr ())
breakInfo :: IntMap CgBreakInfo
modBreaks :: Maybe ModBreaks
ffis :: [FFIInfo]
nextlabel :: Word32
thisModule :: Module
uniqSupply :: UniqSupply
bcm_hsc_env :: HscEnv
..}, [ProtoBCO Name]
proto_bcos) <-
           HscEnv
-> UniqSupply
-> Module
-> Maybe ModBreaks
-> IdEnv (RemotePtr ())
-> BcM [ProtoBCO Name]
-> IO (BcM_State, [ProtoBCO Name])
forall r.
HscEnv
-> UniqSupply
-> Module
-> Maybe ModBreaks
-> IdEnv (RemotePtr ())
-> BcM r
-> IO (BcM_State, r)
runBc HscEnv
hsc_env UniqSupply
us Module
this_mod Maybe ModBreaks
mb_modBreaks ([(Id, RemotePtr ())] -> IdEnv (RemotePtr ())
forall a. [(Id, a)] -> VarEnv a
mkVarEnv [(Id, RemotePtr ())]
stringPtrs) (BcM [ProtoBCO Name] -> IO (BcM_State, [ProtoBCO Name]))
-> BcM [ProtoBCO Name] -> IO (BcM_State, [ProtoBCO Name])
forall a b. (a -> b) -> a -> b
$ do
             [GenStgBinding 'Vanilla]
prepd_binds <- (GenStgBinding 'Vanilla -> BcM (GenStgBinding 'Vanilla))
-> [GenStgBinding 'Vanilla] -> BcM [GenStgBinding 'Vanilla]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GenStgBinding 'Vanilla -> BcM (GenStgBinding 'Vanilla)
bcPrepBind [GenStgBinding 'Vanilla]
lifted_binds
             let flattened_binds :: [(Id, CgStgRhs)]
flattened_binds =
                   (GenStgBinding 'Vanilla -> [(Id, CgStgRhs)])
-> [GenStgBinding 'Vanilla] -> [(Id, CgStgRhs)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (GenStgBinding 'CodeGen -> [(Id, CgStgRhs)]
forall {pass :: StgPass}.
GenStgBinding pass -> [(BinderP pass, GenStgRhs pass)]
flattenBind (GenStgBinding 'CodeGen -> [(Id, CgStgRhs)])
-> (GenStgBinding 'Vanilla -> GenStgBinding 'CodeGen)
-> GenStgBinding 'Vanilla
-> [(Id, CgStgRhs)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenStgBinding 'Vanilla -> GenStgBinding 'CodeGen
annBindingFreeVars) ([GenStgBinding 'Vanilla] -> [GenStgBinding 'Vanilla]
forall a. [a] -> [a]
reverse [GenStgBinding 'Vanilla]
prepd_binds)
             ((Id, CgStgRhs) -> BcM (ProtoBCO Name))
-> [(Id, CgStgRhs)] -> BcM [ProtoBCO Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Id, CgStgRhs) -> BcM (ProtoBCO Name)
schemeTopBind [(Id, CgStgRhs)]
flattened_binds

        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([FFIInfo] -> Bool
forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull [FFIInfo]
ffis)
             (String -> IO ()
forall a. String -> a
panic String
"GHC.StgToByteCode.byteCodeGen: missing final emitBc?")

        Logger
-> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn Logger
logger DynFlags
dflags DumpFlag
Opt_D_dump_BCOs
           String
"Proto-BCOs" DumpFormat
FormatByteCode
           ([SDoc] -> SDoc
vcat (SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
intersperse (Char -> SDoc
char Char
' ') ((ProtoBCO Name -> SDoc) -> [ProtoBCO Name] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map ProtoBCO Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ProtoBCO Name]
proto_bcos)))

        CompiledByteCode
cbc <- Interp
-> Profile
-> [ProtoBCO Name]
-> [TyCon]
-> [RemotePtr ()]
-> Maybe ModBreaks
-> IO CompiledByteCode
assembleBCOs Interp
interp Profile
profile [ProtoBCO Name]
proto_bcos [TyCon]
tycs (((Id, RemotePtr ()) -> RemotePtr ())
-> [(Id, RemotePtr ())] -> [RemotePtr ()]
forall a b. (a -> b) -> [a] -> [b]
map (Id, RemotePtr ()) -> RemotePtr ()
forall a b. (a, b) -> b
snd [(Id, RemotePtr ())]
stringPtrs)
          (case Maybe ModBreaks
modBreaks of
             Maybe ModBreaks
Nothing -> Maybe ModBreaks
forall a. Maybe a
Nothing
             Just ModBreaks
mb -> ModBreaks -> Maybe ModBreaks
forall a. a -> Maybe a
Just ModBreaks
mb{ modBreaks_breakInfo :: IntMap CgBreakInfo
modBreaks_breakInfo = IntMap CgBreakInfo
breakInfo })

        -- Squash space leaks in the CompiledByteCode.  This is really
        -- important, because when loading a set of modules into GHCi
        -- we don't touch the CompiledByteCode until the end when we
        -- do linking.  Forcing out the thunks here reduces space
        -- usage by more than 50% when loading a large number of
        -- modules.
        () -> IO ()
forall a. a -> IO a
evaluate (CompiledByteCode -> ()
seqCompiledByteCode CompiledByteCode
cbc)

        CompiledByteCode -> IO CompiledByteCode
forall (m :: * -> *) a. Monad m => a -> m a
return CompiledByteCode
cbc

  where dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
        logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
        interp :: Interp
interp  = HscEnv -> Interp
hscInterp HscEnv
hsc_env
        profile :: Profile
profile = DynFlags -> Profile
targetProfile DynFlags
dflags

allocateTopStrings
  :: Interp
  -> [(Id, ByteString)]
  -> IO [(Var, RemotePtr ())]
allocateTopStrings :: Interp -> [(Id, ByteString)] -> IO [(Id, RemotePtr ())]
allocateTopStrings Interp
interp [(Id, ByteString)]
topStrings = do
  let !([Id]
bndrs, [ByteString]
strings) = [(Id, ByteString)] -> ([Id], [ByteString])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Id, ByteString)]
topStrings
  [RemotePtr ()]
ptrs <- Interp -> Message [RemotePtr ()] -> IO [RemotePtr ()]
forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp (Message [RemotePtr ()] -> IO [RemotePtr ()])
-> Message [RemotePtr ()] -> IO [RemotePtr ()]
forall a b. (a -> b) -> a -> b
$ [ByteString] -> Message [RemotePtr ()]
MallocStrings [ByteString]
strings
  [(Id, RemotePtr ())] -> IO [(Id, RemotePtr ())]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Id, RemotePtr ())] -> IO [(Id, RemotePtr ())])
-> [(Id, RemotePtr ())] -> IO [(Id, RemotePtr ())]
forall a b. (a -> b) -> a -> b
$ [Id] -> [RemotePtr ()] -> [(Id, RemotePtr ())]
forall a b. [a] -> [b] -> [(a, b)]
zip [Id]
bndrs [RemotePtr ()]
ptrs

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

Here is a summary on how the byte code generator deals with top-level string
literals:

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

2. The strings are allocated via interpCmd, in allocateTopStrings

3. The mapping from binders to allocated strings (topStrings) are maintained in
   BcM and used when generating code for variable references.
-}

{-
  Prepare the STG for bytecode generation:

   - Ensure that all breakpoints are directly under
        a let-binding, introducing a new binding for
        those that aren't already.

   - Protect Not-necessarily lifted join points, see
        Note [Not-necessarily-lifted join points]

 -}

bcPrepRHS :: StgRhs -> BcM StgRhs
-- explicitly match all constructors so we get a warning if we miss any
bcPrepRHS :: StgRhs -> BcM StgRhs
bcPrepRHS (StgRhsClosure XRhsClosure 'Vanilla
fvs CostCentreStack
cc UpdateFlag
upd [BinderP 'Vanilla]
args (StgTick bp :: StgTickish
bp@Breakpoint{} GenStgExpr 'Vanilla
expr)) = do
  {- If we have a breakpoint directly under an StgRhsClosure we don't
     need to introduce a new binding for it.
   -}
  GenStgExpr 'Vanilla
expr' <- GenStgExpr 'Vanilla -> BcM (GenStgExpr 'Vanilla)
bcPrepExpr GenStgExpr 'Vanilla
expr
  StgRhs -> BcM StgRhs
forall (f :: * -> *) a. Applicative f => a -> f a
pure (XRhsClosure 'Vanilla
-> CostCentreStack
-> UpdateFlag
-> [BinderP 'Vanilla]
-> GenStgExpr 'Vanilla
-> StgRhs
forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> GenStgRhs pass
StgRhsClosure XRhsClosure 'Vanilla
fvs CostCentreStack
cc UpdateFlag
upd [BinderP 'Vanilla]
args (StgTickish -> GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
forall (pass :: StgPass).
StgTickish -> GenStgExpr pass -> GenStgExpr pass
StgTick StgTickish
bp GenStgExpr 'Vanilla
expr'))
bcPrepRHS (StgRhsClosure XRhsClosure 'Vanilla
fvs CostCentreStack
cc UpdateFlag
upd [BinderP 'Vanilla]
args GenStgExpr 'Vanilla
expr) =
  XRhsClosure 'Vanilla
-> CostCentreStack
-> UpdateFlag
-> [BinderP 'Vanilla]
-> GenStgExpr 'Vanilla
-> StgRhs
forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> GenStgRhs pass
StgRhsClosure XRhsClosure 'Vanilla
fvs CostCentreStack
cc UpdateFlag
upd [BinderP 'Vanilla]
args (GenStgExpr 'Vanilla -> StgRhs)
-> BcM (GenStgExpr 'Vanilla) -> BcM StgRhs
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenStgExpr 'Vanilla -> BcM (GenStgExpr 'Vanilla)
bcPrepExpr GenStgExpr 'Vanilla
expr
bcPrepRHS con :: StgRhs
con@StgRhsCon{} = StgRhs -> BcM StgRhs
forall (f :: * -> *) a. Applicative f => a -> f a
pure StgRhs
con

bcPrepExpr :: StgExpr -> BcM StgExpr
-- explicitly match all constructors so we get a warning if we miss any
bcPrepExpr :: GenStgExpr 'Vanilla -> BcM (GenStgExpr 'Vanilla)
bcPrepExpr (StgTick bp :: StgTickish
bp@(Breakpoint XBreakpoint 'TickishPassStg
tick_ty Int
_ [XTickishId 'TickishPassStg]
_) GenStgExpr 'Vanilla
rhs)
  | Kind -> Bool
isLiftedTypeKind (HasDebugCallStack => Kind -> Kind
Kind -> Kind
typeKind Kind
XBreakpoint 'TickishPassStg
tick_ty) = do
      Id
id <- Kind -> BcM Id
newId Kind
XBreakpoint 'TickishPassStg
tick_ty
      GenStgExpr 'Vanilla
rhs' <- GenStgExpr 'Vanilla -> BcM (GenStgExpr 'Vanilla)
bcPrepExpr GenStgExpr 'Vanilla
rhs
      let expr' :: GenStgExpr 'Vanilla
expr' = StgTickish -> GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
forall (pass :: StgPass).
StgTickish -> GenStgExpr pass -> GenStgExpr pass
StgTick StgTickish
bp GenStgExpr 'Vanilla
rhs'
          bnd :: GenStgBinding 'Vanilla
bnd = BinderP 'Vanilla -> StgRhs -> GenStgBinding 'Vanilla
forall (pass :: StgPass).
BinderP pass -> GenStgRhs pass -> GenStgBinding pass
StgNonRec Id
BinderP 'Vanilla
id (XRhsClosure 'Vanilla
-> CostCentreStack
-> UpdateFlag
-> [BinderP 'Vanilla]
-> GenStgExpr 'Vanilla
-> StgRhs
forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> GenStgRhs pass
StgRhsClosure NoExtFieldSilent
XRhsClosure 'Vanilla
noExtFieldSilent
                                            CostCentreStack
CC.dontCareCCS
                                            UpdateFlag
ReEntrant
                                            []
                                            GenStgExpr 'Vanilla
expr'
                             )
          letExp :: GenStgExpr 'Vanilla
letExp = XLet 'Vanilla
-> GenStgBinding 'Vanilla
-> GenStgExpr 'Vanilla
-> GenStgExpr 'Vanilla
forall (pass :: StgPass).
XLet pass
-> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
StgLet NoExtFieldSilent
XLet 'Vanilla
noExtFieldSilent GenStgBinding 'Vanilla
bnd (Id -> [StgArg] -> GenStgExpr 'Vanilla
forall (pass :: StgPass). Id -> [StgArg] -> GenStgExpr pass
StgApp Id
id [])
      GenStgExpr 'Vanilla -> BcM (GenStgExpr 'Vanilla)
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenStgExpr 'Vanilla
letExp
  | Bool
otherwise = do
      Id
id <- Kind -> BcM Id
newId (Kind -> Kind -> Kind
mkVisFunTyMany Kind
realWorldStatePrimTy Kind
XBreakpoint 'TickishPassStg
tick_ty)
      Id
st <- Kind -> BcM Id
newId Kind
realWorldStatePrimTy
      GenStgExpr 'Vanilla
rhs' <- GenStgExpr 'Vanilla -> BcM (GenStgExpr 'Vanilla)
bcPrepExpr GenStgExpr 'Vanilla
rhs
      let expr' :: GenStgExpr 'Vanilla
expr' = StgTickish -> GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
forall (pass :: StgPass).
StgTickish -> GenStgExpr pass -> GenStgExpr pass
StgTick StgTickish
bp GenStgExpr 'Vanilla
rhs'
          bnd :: GenStgBinding 'Vanilla
bnd = BinderP 'Vanilla -> StgRhs -> GenStgBinding 'Vanilla
forall (pass :: StgPass).
BinderP pass -> GenStgRhs pass -> GenStgBinding pass
StgNonRec Id
BinderP 'Vanilla
id (XRhsClosure 'Vanilla
-> CostCentreStack
-> UpdateFlag
-> [BinderP 'Vanilla]
-> GenStgExpr 'Vanilla
-> StgRhs
forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> GenStgRhs pass
StgRhsClosure NoExtFieldSilent
XRhsClosure 'Vanilla
noExtFieldSilent
                                            CostCentreStack
CC.dontCareCCS
                                            UpdateFlag
ReEntrant
                                            [Id
BinderP 'Vanilla
voidArgId]
                                            GenStgExpr 'Vanilla
expr'
                             )
      GenStgExpr 'Vanilla -> BcM (GenStgExpr 'Vanilla)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GenStgExpr 'Vanilla -> BcM (GenStgExpr 'Vanilla))
-> GenStgExpr 'Vanilla -> BcM (GenStgExpr 'Vanilla)
forall a b. (a -> b) -> a -> b
$ XLet 'Vanilla
-> GenStgBinding 'Vanilla
-> GenStgExpr 'Vanilla
-> GenStgExpr 'Vanilla
forall (pass :: StgPass).
XLet pass
-> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
StgLet NoExtFieldSilent
XLet 'Vanilla
noExtFieldSilent GenStgBinding 'Vanilla
bnd (Id -> [StgArg] -> GenStgExpr 'Vanilla
forall (pass :: StgPass). Id -> [StgArg] -> GenStgExpr pass
StgApp Id
id [Id -> StgArg
StgVarArg Id
st])
bcPrepExpr (StgTick StgTickish
tick GenStgExpr 'Vanilla
rhs) =
  StgTickish -> GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
forall (pass :: StgPass).
StgTickish -> GenStgExpr pass -> GenStgExpr pass
StgTick StgTickish
tick (GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
-> BcM (GenStgExpr 'Vanilla) -> BcM (GenStgExpr 'Vanilla)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenStgExpr 'Vanilla -> BcM (GenStgExpr 'Vanilla)
bcPrepExpr GenStgExpr 'Vanilla
rhs
bcPrepExpr (StgLet XLet 'Vanilla
xlet GenStgBinding 'Vanilla
bnds GenStgExpr 'Vanilla
expr) =
  XLet 'Vanilla
-> GenStgBinding 'Vanilla
-> GenStgExpr 'Vanilla
-> GenStgExpr 'Vanilla
forall (pass :: StgPass).
XLet pass
-> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
StgLet XLet 'Vanilla
xlet (GenStgBinding 'Vanilla
 -> GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
-> BcM (GenStgBinding 'Vanilla)
-> BcM (GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenStgBinding 'Vanilla -> BcM (GenStgBinding 'Vanilla)
bcPrepBind GenStgBinding 'Vanilla
bnds
              BcM (GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
-> BcM (GenStgExpr 'Vanilla) -> BcM (GenStgExpr 'Vanilla)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GenStgExpr 'Vanilla -> BcM (GenStgExpr 'Vanilla)
bcPrepExpr GenStgExpr 'Vanilla
expr
bcPrepExpr (StgLetNoEscape XLetNoEscape 'Vanilla
xlne GenStgBinding 'Vanilla
bnds GenStgExpr 'Vanilla
expr) =
  XLet 'Vanilla
-> GenStgBinding 'Vanilla
-> GenStgExpr 'Vanilla
-> GenStgExpr 'Vanilla
forall (pass :: StgPass).
XLet pass
-> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
StgLet XLet 'Vanilla
XLetNoEscape 'Vanilla
xlne (GenStgBinding 'Vanilla
 -> GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
-> BcM (GenStgBinding 'Vanilla)
-> BcM (GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenStgBinding 'Vanilla -> BcM (GenStgBinding 'Vanilla)
bcPrepBind GenStgBinding 'Vanilla
bnds
              BcM (GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
-> BcM (GenStgExpr 'Vanilla) -> BcM (GenStgExpr 'Vanilla)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GenStgExpr 'Vanilla -> BcM (GenStgExpr 'Vanilla)
bcPrepExpr GenStgExpr 'Vanilla
expr
bcPrepExpr (StgCase GenStgExpr 'Vanilla
expr BinderP 'Vanilla
bndr AltType
alt_type [GenStgAlt 'Vanilla]
alts) =
  GenStgExpr 'Vanilla
-> Id
-> AltType
-> [(AltCon, [Id], GenStgExpr 'Vanilla)]
-> GenStgExpr 'Vanilla
forall (pass :: StgPass).
GenStgExpr pass
-> BinderP pass -> AltType -> [GenStgAlt pass] -> GenStgExpr pass
StgCase (GenStgExpr 'Vanilla
 -> Id
 -> AltType
 -> [(AltCon, [Id], GenStgExpr 'Vanilla)]
 -> GenStgExpr 'Vanilla)
-> BcM (GenStgExpr 'Vanilla)
-> BcM
     (Id
      -> AltType
      -> [(AltCon, [Id], GenStgExpr 'Vanilla)]
      -> GenStgExpr 'Vanilla)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenStgExpr 'Vanilla -> BcM (GenStgExpr 'Vanilla)
bcPrepExpr GenStgExpr 'Vanilla
expr
          BcM
  (Id
   -> AltType
   -> [(AltCon, [Id], GenStgExpr 'Vanilla)]
   -> GenStgExpr 'Vanilla)
-> BcM Id
-> BcM
     (AltType
      -> [(AltCon, [Id], GenStgExpr 'Vanilla)] -> GenStgExpr 'Vanilla)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Id -> BcM Id
forall (f :: * -> *) a. Applicative f => a -> f a
pure Id
BinderP 'Vanilla
bndr
          BcM
  (AltType
   -> [(AltCon, [Id], GenStgExpr 'Vanilla)] -> GenStgExpr 'Vanilla)
-> BcM AltType
-> BcM
     ([(AltCon, [Id], GenStgExpr 'Vanilla)] -> GenStgExpr 'Vanilla)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AltType -> BcM AltType
forall (f :: * -> *) a. Applicative f => a -> f a
pure AltType
alt_type
          BcM ([(AltCon, [Id], GenStgExpr 'Vanilla)] -> GenStgExpr 'Vanilla)
-> BcM [(AltCon, [Id], GenStgExpr 'Vanilla)]
-> BcM (GenStgExpr 'Vanilla)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((AltCon, [Id], GenStgExpr 'Vanilla)
 -> BcM (AltCon, [Id], GenStgExpr 'Vanilla))
-> [(AltCon, [Id], GenStgExpr 'Vanilla)]
-> BcM [(AltCon, [Id], GenStgExpr 'Vanilla)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (AltCon, [Id], GenStgExpr 'Vanilla)
-> BcM (AltCon, [Id], GenStgExpr 'Vanilla)
GenStgAlt 'Vanilla -> BcM (GenStgAlt 'Vanilla)
bcPrepAlt [(AltCon, [Id], GenStgExpr 'Vanilla)]
[GenStgAlt 'Vanilla]
alts
bcPrepExpr lit :: GenStgExpr 'Vanilla
lit@StgLit{} = GenStgExpr 'Vanilla -> BcM (GenStgExpr 'Vanilla)
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenStgExpr 'Vanilla
lit
-- See Note [Not-necessarily-lifted join points], step 3.
bcPrepExpr (StgApp Id
x [])
  | Id -> Bool
isNNLJoinPoint Id
x = GenStgExpr 'Vanilla -> BcM (GenStgExpr 'Vanilla)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GenStgExpr 'Vanilla -> BcM (GenStgExpr 'Vanilla))
-> GenStgExpr 'Vanilla -> BcM (GenStgExpr 'Vanilla)
forall a b. (a -> b) -> a -> b
$
      Id -> [StgArg] -> GenStgExpr 'Vanilla
forall (pass :: StgPass). Id -> [StgArg] -> GenStgExpr pass
StgApp (Id -> Id
protectNNLJoinPointId Id
x) [Id -> StgArg
StgVarArg Id
voidPrimId]
bcPrepExpr app :: GenStgExpr 'Vanilla
app@StgApp{} = GenStgExpr 'Vanilla -> BcM (GenStgExpr 'Vanilla)
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenStgExpr 'Vanilla
app
bcPrepExpr app :: GenStgExpr 'Vanilla
app@StgConApp{} = GenStgExpr 'Vanilla -> BcM (GenStgExpr 'Vanilla)
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenStgExpr 'Vanilla
app
bcPrepExpr app :: GenStgExpr 'Vanilla
app@StgOpApp{} = GenStgExpr 'Vanilla -> BcM (GenStgExpr 'Vanilla)
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenStgExpr 'Vanilla
app

bcPrepAlt :: StgAlt -> BcM StgAlt
bcPrepAlt :: GenStgAlt 'Vanilla -> BcM (GenStgAlt 'Vanilla)
bcPrepAlt (AltCon
ac, [BinderP 'Vanilla]
bndrs, GenStgExpr 'Vanilla
expr) = (,,) AltCon
ac [Id]
[BinderP 'Vanilla]
bndrs (GenStgExpr 'Vanilla -> (AltCon, [Id], GenStgExpr 'Vanilla))
-> BcM (GenStgExpr 'Vanilla)
-> BcM (AltCon, [Id], GenStgExpr 'Vanilla)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenStgExpr 'Vanilla -> BcM (GenStgExpr 'Vanilla)
bcPrepExpr GenStgExpr 'Vanilla
expr

bcPrepBind :: StgBinding -> BcM StgBinding
-- explicitly match all constructors so we get a warning if we miss any
bcPrepBind :: GenStgBinding 'Vanilla -> BcM (GenStgBinding 'Vanilla)
bcPrepBind (StgNonRec BinderP 'Vanilla
bndr StgRhs
rhs) =
  let (Id
bndr', StgRhs
rhs') = (Id, StgRhs) -> (Id, StgRhs)
bcPrepSingleBind (Id
BinderP 'Vanilla
bndr, StgRhs
rhs)
  in  BinderP 'Vanilla -> StgRhs -> GenStgBinding 'Vanilla
forall (pass :: StgPass).
BinderP pass -> GenStgRhs pass -> GenStgBinding pass
StgNonRec Id
BinderP 'Vanilla
bndr' (StgRhs -> GenStgBinding 'Vanilla)
-> BcM StgRhs -> BcM (GenStgBinding 'Vanilla)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StgRhs -> BcM StgRhs
bcPrepRHS StgRhs
rhs'
bcPrepBind (StgRec [(BinderP 'Vanilla, StgRhs)]
bnds) =
  [(Id, StgRhs)] -> GenStgBinding 'Vanilla
forall (pass :: StgPass).
[(BinderP pass, GenStgRhs pass)] -> GenStgBinding pass
StgRec ([(Id, StgRhs)] -> GenStgBinding 'Vanilla)
-> BcM [(Id, StgRhs)] -> BcM (GenStgBinding 'Vanilla)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Id, StgRhs) -> BcM (Id, StgRhs))
-> [(Id, StgRhs)] -> BcM [(Id, StgRhs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((\(Id
b,StgRhs
r) -> (,) Id
b (StgRhs -> (Id, StgRhs)) -> BcM StgRhs -> BcM (Id, StgRhs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StgRhs -> BcM StgRhs
bcPrepRHS StgRhs
r) ((Id, StgRhs) -> BcM (Id, StgRhs))
-> ((Id, StgRhs) -> (Id, StgRhs))
-> (Id, StgRhs)
-> BcM (Id, StgRhs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Id, StgRhs) -> (Id, StgRhs)
bcPrepSingleBind)
                  [(Id, StgRhs)]
[(BinderP 'Vanilla, StgRhs)]
bnds

bcPrepSingleBind :: (Id, StgRhs) -> (Id, StgRhs)
-- If necessary, modify this Id and body to protect not-necessarily-lifted join points.
-- See Note [Not-necessarily-lifted join points], step 2.
bcPrepSingleBind :: (Id, StgRhs) -> (Id, StgRhs)
bcPrepSingleBind (Id
x, StgRhsClosure XRhsClosure 'Vanilla
ext CostCentreStack
cc UpdateFlag
upd_flag [BinderP 'Vanilla]
args GenStgExpr 'Vanilla
body)
  | Id -> Bool
isNNLJoinPoint Id
x
  = ( Id -> Id
protectNNLJoinPointId Id
x
    , XRhsClosure 'Vanilla
-> CostCentreStack
-> UpdateFlag
-> [BinderP 'Vanilla]
-> GenStgExpr 'Vanilla
-> StgRhs
forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> GenStgRhs pass
StgRhsClosure XRhsClosure 'Vanilla
ext CostCentreStack
cc UpdateFlag
upd_flag ([Id]
[BinderP 'Vanilla]
args [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id
voidArgId]) GenStgExpr 'Vanilla
body)
bcPrepSingleBind (Id, StgRhs)
bnd = (Id, StgRhs)
bnd

-- -----------------------------------------------------------------------------
-- Compilation schema for the bytecode generator

type BCInstrList = OrdList BCInstr

wordsToBytes :: Platform -> WordOff -> ByteOff
wordsToBytes :: Platform -> WordOff -> ByteOff
wordsToBytes Platform
platform = Int -> ByteOff
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> ByteOff) -> (WordOff -> Int) -> WordOff -> ByteOff
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int
forall a. Num a => a -> a -> a
* Platform -> Int
platformWordSizeInBytes Platform
platform) (Int -> Int) -> (WordOff -> Int) -> WordOff -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WordOff -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral

-- Used when we know we have a whole number of words
bytesToWords :: Platform -> ByteOff -> WordOff
bytesToWords :: Platform -> ByteOff -> WordOff
bytesToWords Platform
platform (ByteOff Int
bytes) =
    let (Int
q, Int
r) = Int
bytes Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`quotRem` (Platform -> Int
platformWordSizeInBytes Platform
platform)
    in if Int
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
           then Int -> WordOff
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
q
           else String -> SDoc -> WordOff
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"GHC.StgToByteCode.bytesToWords"
                         (String -> SDoc
text String
"bytes=" SDoc -> SDoc -> SDoc
<> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
bytes)

wordSize :: Platform -> ByteOff
wordSize :: Platform -> ByteOff
wordSize Platform
platform = Int -> ByteOff
ByteOff (Platform -> Int
platformWordSizeInBytes Platform
platform)

type Sequel = ByteOff -- back off to this depth before ENTER

type StackDepth = ByteOff

-- | Maps Ids to their stack depth. This allows us to avoid having to mess with
-- it after each push/pop.
type BCEnv = Map Id StackDepth -- To find vars on the stack

{-
ppBCEnv :: BCEnv -> SDoc
ppBCEnv p
   = text "begin-env"
     $$ nest 4 (vcat (map pp_one (sortBy cmp_snd (Map.toList p))))
     $$ text "end-env"
     where
        pp_one (var, ByteOff offset) = int offset <> colon <+> ppr var <+> ppr (bcIdArgReps var)
        cmp_snd x y = compare (snd x) (snd y)
-}

-- Create a BCO and do a spot of peephole optimisation on the insns
-- at the same time.
mkProtoBCO
   :: Platform
   -> name
   -> BCInstrList
   -> Either  [CgStgAlt] (CgStgRhs)
        -- ^ original expression; for debugging only
   -> Int
   -> Word16
   -> [StgWord]
   -> Bool      -- True <=> is a return point, rather than a function
   -> [FFIInfo]
   -> ProtoBCO name
mkProtoBCO :: forall name.
Platform
-> name
-> OrdList BCInstr
-> Either [CgStgAlt] CgStgRhs
-> Int
-> Word16
-> [StgWord]
-> Bool
-> [FFIInfo]
-> ProtoBCO name
mkProtoBCO Platform
platform name
nm OrdList BCInstr
instrs_ordlist Either [CgStgAlt] CgStgRhs
origin Int
arity Word16
bitmap_size [StgWord]
bitmap Bool
is_ret [FFIInfo]
ffis
   = ProtoBCO {
        protoBCOName :: name
protoBCOName = name
nm,
        protoBCOInstrs :: [BCInstr]
protoBCOInstrs = [BCInstr]
maybe_with_stack_check,
        protoBCOBitmap :: [StgWord]
protoBCOBitmap = [StgWord]
bitmap,
        protoBCOBitmapSize :: Word16
protoBCOBitmapSize = Word16
bitmap_size,
        protoBCOArity :: Int
protoBCOArity = Int
arity,
        protoBCOExpr :: Either [CgStgAlt] CgStgRhs
protoBCOExpr = Either [CgStgAlt] CgStgRhs
origin,
        protoBCOFFIs :: [FFIInfo]
protoBCOFFIs = [FFIInfo]
ffis
      }
     where
        -- Overestimate the stack usage (in words) of this BCO,
        -- and if >= iNTERP_STACK_CHECK_THRESH, add an explicit
        -- stack check.  (The interpreter always does a stack check
        -- for iNTERP_STACK_CHECK_THRESH words at the start of each
        -- BCO anyway, so we only need to add an explicit one in the
        -- (hopefully rare) cases when the (overestimated) stack use
        -- exceeds iNTERP_STACK_CHECK_THRESH.
        maybe_with_stack_check :: [BCInstr]
maybe_with_stack_check
           | Bool
is_ret Bool -> Bool -> Bool
&& Word
stack_usage Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
< Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (PlatformConstants -> Int
pc_AP_STACK_SPLIM (Platform -> PlatformConstants
platformConstants Platform
platform)) = [BCInstr]
peep_d
                -- don't do stack checks at return points,
                -- everything is aggregated up to the top BCO
                -- (which must be a function).
                -- That is, unless the stack usage is >= AP_STACK_SPLIM,
                -- see bug #1466.
           | Word
stack_usage Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
>= Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
iNTERP_STACK_CHECK_THRESH
           = Word -> BCInstr
STKCHECK Word
stack_usage BCInstr -> [BCInstr] -> [BCInstr]
forall a. a -> [a] -> [a]
: [BCInstr]
peep_d
           | Bool
otherwise
           = [BCInstr]
peep_d     -- the supposedly common case

        -- We assume that this sum doesn't wrap
        stack_usage :: Word
stack_usage = [Word] -> Word
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((BCInstr -> Word) -> [BCInstr] -> [Word]
forall a b. (a -> b) -> [a] -> [b]
map BCInstr -> Word
bciStackUse [BCInstr]
peep_d)

        -- Merge local pushes
        peep_d :: [BCInstr]
peep_d = [BCInstr] -> [BCInstr]
peep (OrdList BCInstr -> [BCInstr]
forall a. OrdList a -> [a]
fromOL OrdList BCInstr
instrs_ordlist)

        peep :: [BCInstr] -> [BCInstr]
peep (PUSH_L Word16
off1 : PUSH_L Word16
off2 : PUSH_L Word16
off3 : [BCInstr]
rest)
           = Word16 -> Word16 -> Word16 -> BCInstr
PUSH_LLL Word16
off1 (Word16
off2Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
-Word16
1) (Word16
off3Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
-Word16
2) BCInstr -> [BCInstr] -> [BCInstr]
forall a. a -> [a] -> [a]
: [BCInstr] -> [BCInstr]
peep [BCInstr]
rest
        peep (PUSH_L Word16
off1 : PUSH_L Word16
off2 : [BCInstr]
rest)
           = Word16 -> Word16 -> BCInstr
PUSH_LL Word16
off1 (Word16
off2Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
-Word16
1) BCInstr -> [BCInstr] -> [BCInstr]
forall a. a -> [a] -> [a]
: [BCInstr] -> [BCInstr]
peep [BCInstr]
rest
        peep (BCInstr
i:[BCInstr]
rest)
           = BCInstr
i BCInstr -> [BCInstr] -> [BCInstr]
forall a. a -> [a] -> [a]
: [BCInstr] -> [BCInstr]
peep [BCInstr]
rest
        peep []
           = []

argBits :: Platform -> [ArgRep] -> [Bool]
argBits :: Platform -> [ArgRep] -> [Bool]
argBits Platform
_        [] = []
argBits Platform
platform (ArgRep
rep : [ArgRep]
args)
  | ArgRep -> Bool
isFollowableArg ArgRep
rep  = Bool
False Bool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
: Platform -> [ArgRep] -> [Bool]
argBits Platform
platform [ArgRep]
args
  | Bool
otherwise = Int -> [Bool] -> [Bool]
forall a. Int -> [a] -> [a]
take (Platform -> ArgRep -> Int
argRepSizeW Platform
platform ArgRep
rep) (Bool -> [Bool]
forall a. a -> [a]
repeat Bool
True) [Bool] -> [Bool] -> [Bool]
forall a. [a] -> [a] -> [a]
++ Platform -> [ArgRep] -> [Bool]
argBits Platform
platform [ArgRep]
args

non_void :: [ArgRep] -> [ArgRep]
non_void :: [ArgRep] -> [ArgRep]
non_void = (ArgRep -> Bool) -> [ArgRep] -> [ArgRep]
forall a. (a -> Bool) -> [a] -> [a]
filter ArgRep -> Bool
nv
  where nv :: ArgRep -> Bool
nv ArgRep
V = Bool
False
        nv ArgRep
_ = Bool
True

-- -----------------------------------------------------------------------------
-- schemeTopBind

-- Compile code for the right-hand side of a top-level binding

schemeTopBind :: (Id, CgStgRhs) -> BcM (ProtoBCO Name)
schemeTopBind :: (Id, CgStgRhs) -> BcM (ProtoBCO Name)
schemeTopBind (Id
id, CgStgRhs
rhs)
  | Just DataCon
data_con <- Id -> Maybe DataCon
isDataConWorkId_maybe Id
id,
    DataCon -> Bool
isNullaryRepDataCon DataCon
data_con = do
    Platform
platform <- Profile -> Platform
profilePlatform (Profile -> Platform) -> BcM Profile -> BcM Platform
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BcM Profile
getProfile
        -- Special case for the worker of a nullary data con.
        -- It'll look like this:        Nil = /\a -> Nil a
        -- If we feed it into schemeR, we'll get
        --      Nil = Nil
        -- because mkConAppCode treats nullary constructor applications
        -- by just re-using the single top-level definition.  So
        -- for the worker itself, we must allocate it directly.
    -- ioToBc (putStrLn $ "top level BCO")
    let enter :: BCInstr
enter = if Kind -> Bool
isUnliftedTypeKind (TyCon -> Kind
tyConResKind (DataCon -> TyCon
dataConTyCon DataCon
data_con))
                then ArgRep -> BCInstr
RETURN_UNLIFTED ArgRep
P
                else BCInstr
ENTER
    ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
emitBc (Platform
-> Name
-> OrdList BCInstr
-> Either [CgStgAlt] CgStgRhs
-> Int
-> Word16
-> [StgWord]
-> Bool
-> [FFIInfo]
-> ProtoBCO Name
forall name.
Platform
-> name
-> OrdList BCInstr
-> Either [CgStgAlt] CgStgRhs
-> Int
-> Word16
-> [StgWord]
-> Bool
-> [FFIInfo]
-> ProtoBCO name
mkProtoBCO Platform
platform (Id -> Name
forall a. NamedThing a => a -> Name
getName Id
id) ([BCInstr] -> OrdList BCInstr
forall a. [a] -> OrdList a
toOL [DataCon -> Word16 -> BCInstr
PACK DataCon
data_con Word16
0, BCInstr
enter])
                       (CgStgRhs -> Either [(AltCon, [Id], GenStgExpr 'CodeGen)] CgStgRhs
forall a b. b -> Either a b
Right CgStgRhs
rhs) Int
0 Word16
0 [{-no bitmap-}] Bool
False{-not alts-})

  | Bool
otherwise
  = [Id] -> (Name, CgStgRhs) -> BcM (ProtoBCO Name)
schemeR [{- No free variables -}] (Id -> Name
forall a. NamedThing a => a -> Name
getName Id
id, CgStgRhs
rhs)


-- -----------------------------------------------------------------------------
-- schemeR

-- Compile code for a right-hand side, to give a BCO that,
-- when executed with the free variables and arguments on top of the stack,
-- will return with a pointer to the result on top of the stack, after
-- removing the free variables and arguments.
--
-- Park the resulting BCO in the monad.  Also requires the
-- name of the variable to which this value was bound,
-- so as to give the resulting BCO a name.
schemeR :: [Id]                 -- Free vars of the RHS, ordered as they
                                -- will appear in the thunk.  Empty for
                                -- top-level things, which have no free vars.
        -> (Name, CgStgRhs)
        -> BcM (ProtoBCO Name)
schemeR :: [Id] -> (Name, CgStgRhs) -> BcM (ProtoBCO Name)
schemeR [Id]
fvs (Name
nm, CgStgRhs
rhs)
   = [Id]
-> Name
-> CgStgRhs
-> ([Id], GenStgExpr 'CodeGen)
-> BcM (ProtoBCO Name)
schemeR_wrk [Id]
fvs Name
nm CgStgRhs
rhs (CgStgRhs -> ([Id], GenStgExpr 'CodeGen)
collect CgStgRhs
rhs)

-- If an expression is a lambda, return the
-- list of arguments to the lambda (in R-to-L order) and the
-- underlying expression

collect :: CgStgRhs -> ([Var], CgStgExpr)
collect :: CgStgRhs -> ([Id], GenStgExpr 'CodeGen)
collect (StgRhsClosure XRhsClosure 'CodeGen
_ CostCentreStack
_ UpdateFlag
_ [BinderP 'CodeGen]
args GenStgExpr 'CodeGen
body) = ([Id]
[BinderP 'CodeGen]
args, GenStgExpr 'CodeGen
body)
collect (StgRhsCon CostCentreStack
_cc DataCon
dc ConstructorNumber
cnum [StgTickish]
_ticks [StgArg]
args) = ([], DataCon
-> XConApp 'CodeGen -> [StgArg] -> [Kind] -> GenStgExpr 'CodeGen
forall (pass :: StgPass).
DataCon -> XConApp pass -> [StgArg] -> [Kind] -> GenStgExpr pass
StgConApp DataCon
dc ConstructorNumber
XConApp 'CodeGen
cnum [StgArg]
args [])

schemeR_wrk
    :: [Id]
    -> Name
    -> CgStgRhs            -- expression e, for debugging only
    -> ([Var], CgStgExpr)  -- result of collect on e
    -> BcM (ProtoBCO Name)
schemeR_wrk :: [Id]
-> Name
-> CgStgRhs
-> ([Id], GenStgExpr 'CodeGen)
-> BcM (ProtoBCO Name)
schemeR_wrk [Id]
fvs Name
nm CgStgRhs
original_body ([Id]
args, GenStgExpr 'CodeGen
body)
   = do
     Profile
profile <- BcM Profile
getProfile
     let
         platform :: Platform
platform  = Profile -> Platform
profilePlatform Profile
profile
         all_args :: [Id]
all_args  = [Id] -> [Id]
forall a. [a] -> [a]
reverse [Id]
args [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
fvs
         arity :: Int
arity     = [Id] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Id]
all_args
         -- all_args are the args in reverse order.  We're compiling a function
         -- \fv1..fvn x1..xn -> e
         -- i.e. the fvs come first

         -- Stack arguments always take a whole number of words, we never pack
         -- them unlike constructor fields.
         szsb_args :: [ByteOff]
szsb_args = (Id -> ByteOff) -> [Id] -> [ByteOff]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> WordOff -> ByteOff
wordsToBytes Platform
platform (WordOff -> ByteOff) -> (Id -> WordOff) -> Id -> ByteOff
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Platform -> Id -> WordOff
idSizeW Platform
platform) [Id]
all_args
         sum_szsb_args :: ByteOff
sum_szsb_args  = [ByteOff] -> ByteOff
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [ByteOff]
szsb_args
         p_init :: Map Id ByteOff
p_init    = [(Id, ByteOff)] -> Map Id ByteOff
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([Id] -> [ByteOff] -> [(Id, ByteOff)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Id]
all_args (ByteOff -> [ByteOff] -> [ByteOff]
mkStackOffsets ByteOff
0 [ByteOff]
szsb_args))

         -- make the arg bitmap
         bits :: [Bool]
bits = Platform -> [ArgRep] -> [Bool]
argBits Platform
platform ([ArgRep] -> [ArgRep]
forall a. [a] -> [a]
reverse ((Id -> ArgRep) -> [Id] -> [ArgRep]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> Id -> ArgRep
bcIdArgRep Platform
platform) [Id]
all_args))
         bitmap_size :: Word16
bitmap_size = [Bool] -> Word16
forall i a. Num i => [a] -> i
genericLength [Bool]
bits
         bitmap :: [StgWord]
bitmap = Platform -> [Bool] -> [StgWord]
mkBitmap Platform
platform [Bool]
bits
     OrdList BCInstr
body_code <- ByteOff
-> Map Id ByteOff -> GenStgExpr 'CodeGen -> BcM (OrdList BCInstr)
schemeER_wrk ByteOff
sum_szsb_args Map Id ByteOff
p_init GenStgExpr 'CodeGen
body

     ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
emitBc (Platform
-> Name
-> OrdList BCInstr
-> Either [CgStgAlt] CgStgRhs
-> Int
-> Word16
-> [StgWord]
-> Bool
-> [FFIInfo]
-> ProtoBCO Name
forall name.
Platform
-> name
-> OrdList BCInstr
-> Either [CgStgAlt] CgStgRhs
-> Int
-> Word16
-> [StgWord]
-> Bool
-> [FFIInfo]
-> ProtoBCO name
mkProtoBCO Platform
platform Name
nm OrdList BCInstr
body_code (CgStgRhs -> Either [(AltCon, [Id], GenStgExpr 'CodeGen)] CgStgRhs
forall a b. b -> Either a b
Right CgStgRhs
original_body)
                 Int
arity Word16
bitmap_size [StgWord]
bitmap Bool
False{-not alts-})

-- introduce break instructions for ticked expressions
schemeER_wrk :: StackDepth -> BCEnv -> CgStgExpr -> BcM BCInstrList
schemeER_wrk :: ByteOff
-> Map Id ByteOff -> GenStgExpr 'CodeGen -> BcM (OrdList BCInstr)
schemeER_wrk ByteOff
d Map Id ByteOff
p (StgTick (Breakpoint XBreakpoint 'TickishPassStg
tick_ty Int
tick_no [XTickishId 'TickishPassStg]
fvs) GenStgExpr 'CodeGen
rhs)
  = do  OrdList BCInstr
code <- ByteOff
-> ByteOff
-> Map Id ByteOff
-> GenStgExpr 'CodeGen
-> BcM (OrdList BCInstr)
schemeE ByteOff
d ByteOff
0 Map Id ByteOff
p GenStgExpr 'CodeGen
rhs
        Array Int (RemotePtr CostCentre)
cc_arr <- BcM (Array Int (RemotePtr CostCentre))
getCCArray
        ModuleName
this_mod <- Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (Module -> ModuleName) -> BcM Module -> BcM ModuleName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BcM Module
getCurrentModule
        Platform
platform <- Profile -> Platform
profilePlatform (Profile -> Platform) -> BcM Profile -> BcM Platform
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BcM Profile
getProfile
        let idOffSets :: [Maybe (Id, Word16)]
idOffSets = Platform
-> ByteOff -> Map Id ByteOff -> [Id] -> [Maybe (Id, Word16)]
getVarOffSets Platform
platform ByteOff
d Map Id ByteOff
p [Id]
[XTickishId 'TickishPassStg]
fvs
        let breakInfo :: CgBreakInfo
breakInfo = CgBreakInfo
                        { cgb_vars :: [Maybe (Id, Word16)]
cgb_vars = [Maybe (Id, Word16)]
idOffSets
                        , cgb_resty :: Kind
cgb_resty = Kind
XBreakpoint 'TickishPassStg
tick_ty
                        }
        Int -> CgBreakInfo -> BcM ()
newBreakInfo Int
tick_no CgBreakInfo
breakInfo
        HscEnv
hsc_env <- BcM HscEnv
getHscEnv
        let cc :: RemotePtr CostCentre
cc | Just Interp
interp <- HscEnv -> Maybe Interp
hsc_interp HscEnv
hsc_env
               , Interp -> Bool
interpreterProfiled Interp
interp
               = Array Int (RemotePtr CostCentre)
cc_arr Array Int (RemotePtr CostCentre) -> Int -> RemotePtr CostCentre
forall i e. Ix i => Array i e -> i -> e
! Int
tick_no
               | Bool
otherwise = Ptr CostCentre -> RemotePtr CostCentre
forall a. Ptr a -> RemotePtr a
toRemotePtr Ptr CostCentre
forall a. Ptr a
nullPtr
        let breakInstr :: BCInstr
breakInstr = Word16 -> Unique -> RemotePtr CostCentre -> BCInstr
BRK_FUN (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
tick_no) (ModuleName -> Unique
forall a. Uniquable a => a -> Unique
getUnique ModuleName
this_mod) RemotePtr CostCentre
cc
        OrdList BCInstr -> BcM (OrdList BCInstr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList BCInstr -> BcM (OrdList BCInstr))
-> OrdList BCInstr -> BcM (OrdList BCInstr)
forall a b. (a -> b) -> a -> b
$ BCInstr
breakInstr BCInstr -> OrdList BCInstr -> OrdList BCInstr
forall a. a -> OrdList a -> OrdList a
`consOL` OrdList BCInstr
code
schemeER_wrk ByteOff
d Map Id ByteOff
p GenStgExpr 'CodeGen
rhs = ByteOff
-> ByteOff
-> Map Id ByteOff
-> GenStgExpr 'CodeGen
-> BcM (OrdList BCInstr)
schemeE ByteOff
d ByteOff
0 Map Id ByteOff
p GenStgExpr 'CodeGen
rhs

getVarOffSets :: Platform -> StackDepth -> BCEnv -> [Id] -> [Maybe (Id, Word16)]
getVarOffSets :: Platform
-> ByteOff -> Map Id ByteOff -> [Id] -> [Maybe (Id, Word16)]
getVarOffSets Platform
platform ByteOff
depth Map Id ByteOff
env = (Id -> Maybe (Id, Word16)) -> [Id] -> [Maybe (Id, Word16)]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Maybe (Id, Word16)
getOffSet
  where
    getOffSet :: Id -> Maybe (Id, Word16)
getOffSet Id
id = case Id -> Map Id ByteOff -> Maybe ByteOff
lookupBCEnv_maybe Id
id Map Id ByteOff
env of
        Maybe ByteOff
Nothing     -> Maybe (Id, Word16)
forall a. Maybe a
Nothing
        Just ByteOff
offset ->
            -- michalt: I'm not entirely sure why we need the stack
            -- adjustment by 2 here. I initially thought that there's
            -- something off with getIdValFromApStack (the only user of this
            -- value), but it looks ok to me. My current hypothesis is that
            -- this "adjustment" is needed due to stack manipulation for
            -- BRK_FUN in Interpreter.c In any case, this is used only when
            -- we trigger a breakpoint.
            let !var_depth_ws :: Word16
var_depth_ws =
                    WordOff -> Word16
trunc16W (WordOff -> Word16) -> WordOff -> Word16
forall a b. (a -> b) -> a -> b
$ Platform -> ByteOff -> WordOff
bytesToWords Platform
platform (ByteOff
depth ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
- ByteOff
offset) WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
+ WordOff
2
            in (Id, Word16) -> Maybe (Id, Word16)
forall a. a -> Maybe a
Just (Id
id, Word16
var_depth_ws)

truncIntegral16 :: Integral a => a -> Word16
truncIntegral16 :: forall a. Integral a => a -> Word16
truncIntegral16 a
w
    | a
w a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> Word16 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16
forall a. Bounded a => a
maxBound :: Word16)
    = String -> Word16
forall a. String -> a
panic String
"stack depth overflow"
    | Bool
otherwise
    = a -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
w

trunc16B :: ByteOff -> Word16
trunc16B :: ByteOff -> Word16
trunc16B = ByteOff -> Word16
forall a. Integral a => a -> Word16
truncIntegral16

trunc16W :: WordOff -> Word16
trunc16W :: WordOff -> Word16
trunc16W = WordOff -> Word16
forall a. Integral a => a -> Word16
truncIntegral16

fvsToEnv :: BCEnv -> CgStgRhs -> [Id]
-- Takes the free variables of a right-hand side, and
-- delivers an ordered list of the local variables that will
-- be captured in the thunk for the RHS
-- The BCEnv argument tells which variables are in the local
-- environment: these are the ones that should be captured
--
-- The code that constructs the thunk, and the code that executes
-- it, have to agree about this layout

fvsToEnv :: Map Id ByteOff -> CgStgRhs -> [Id]
fvsToEnv Map Id ByteOff
p CgStgRhs
rhs =  [Id
v | Id
v <- DIdSet -> [Id]
dVarSetElems (DIdSet -> [Id]) -> DIdSet -> [Id]
forall a b. (a -> b) -> a -> b
$ CgStgRhs -> DIdSet
forall (pass :: StgPass).
(XRhsClosure pass ~ DIdSet) =>
GenStgRhs pass -> DIdSet
freeVarsOfRhs CgStgRhs
rhs,
                       Id
v Id -> Map Id ByteOff -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map Id ByteOff
p]

-- -----------------------------------------------------------------------------
-- schemeE

-- Returning an unlifted value.
-- Heave it on the stack, SLIDE, and RETURN.
returnUnliftedAtom
    :: StackDepth
    -> Sequel
    -> BCEnv
    -> StgArg
    -> BcM BCInstrList
returnUnliftedAtom :: ByteOff
-> ByteOff -> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr)
returnUnliftedAtom ByteOff
d ByteOff
s Map Id ByteOff
p StgArg
e = do
    let reps :: [PrimRep]
reps = case StgArg
e of
                 StgLitArg Literal
lit -> HasDebugCallStack => Kind -> [PrimRep]
Kind -> [PrimRep]
typePrimRepArgs (Literal -> Kind
literalType Literal
lit)
                 StgVarArg Id
i   -> Id -> [PrimRep]
bcIdPrimReps Id
i
    (OrdList BCInstr
push, ByteOff
szb) <- ByteOff
-> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr, ByteOff)
pushAtom ByteOff
d Map Id ByteOff
p StgArg
e
    OrdList BCInstr
ret <- ByteOff -> ByteOff -> ByteOff -> [PrimRep] -> BcM (OrdList BCInstr)
returnUnliftedReps ByteOff
d ByteOff
s ByteOff
szb [PrimRep]
reps
    OrdList BCInstr -> BcM (OrdList BCInstr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList BCInstr
push OrdList BCInstr -> OrdList BCInstr -> OrdList BCInstr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList BCInstr
ret)

-- return an unlifted value from the top of the stack
returnUnliftedReps
    :: StackDepth
    -> Sequel
    -> ByteOff    -- size of the thing we're returning
    -> [PrimRep]  -- representations
    -> BcM BCInstrList
returnUnliftedReps :: ByteOff -> ByteOff -> ByteOff -> [PrimRep] -> BcM (OrdList BCInstr)
returnUnliftedReps ByteOff
d ByteOff
s ByteOff
szb [PrimRep]
reps = do
    Profile
profile <- BcM Profile
getProfile
    let platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile
        non_void :: PrimRep -> Bool
non_void PrimRep
VoidRep = Bool
False
        non_void PrimRep
_ = Bool
True
    OrdList BCInstr
ret <- case (PrimRep -> Bool) -> [PrimRep] -> [PrimRep]
forall a. (a -> Bool) -> [a] -> [a]
filter PrimRep -> Bool
non_void [PrimRep]
reps of
             -- use RETURN_UBX for unary representations
             []    -> OrdList BCInstr -> BcM (OrdList BCInstr)
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstr -> OrdList BCInstr
forall a. a -> OrdList a
unitOL (BCInstr -> OrdList BCInstr) -> BCInstr -> OrdList BCInstr
forall a b. (a -> b) -> a -> b
$ ArgRep -> BCInstr
RETURN_UNLIFTED ArgRep
V)
             [PrimRep
rep] -> OrdList BCInstr -> BcM (OrdList BCInstr)
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstr -> OrdList BCInstr
forall a. a -> OrdList a
unitOL (BCInstr -> OrdList BCInstr) -> BCInstr -> OrdList BCInstr
forall a b. (a -> b) -> a -> b
$ ArgRep -> BCInstr
RETURN_UNLIFTED (Platform -> PrimRep -> ArgRep
toArgRep Platform
platform PrimRep
rep))
             -- otherwise use RETURN_TUPLE with a tuple descriptor
             [PrimRep]
nv_reps -> do
               let (TupleInfo
tuple_info, [(PrimRep, ByteOff)]
args_offsets) = Profile
-> ByteOff
-> (PrimRep -> CmmType)
-> [PrimRep]
-> (TupleInfo, [(PrimRep, ByteOff)])
forall a.
Profile
-> ByteOff -> (a -> CmmType) -> [a] -> (TupleInfo, [(a, ByteOff)])
layoutTuple Profile
profile ByteOff
0 (Platform -> PrimRep -> CmmType
primRepCmmType Platform
platform) [PrimRep]
nv_reps
                   args_ptrs :: [(Bool, ByteOff)]
args_ptrs = ((PrimRep, ByteOff) -> (Bool, ByteOff))
-> [(PrimRep, ByteOff)] -> [(Bool, ByteOff)]
forall a b. (a -> b) -> [a] -> [b]
map (\(PrimRep
rep, ByteOff
off) -> (ArgRep -> Bool
isFollowableArg (Platform -> PrimRep -> ArgRep
toArgRep Platform
platform PrimRep
rep), ByteOff
off)) [(PrimRep, ByteOff)]
args_offsets
               ProtoBCO Name
tuple_bco <- ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
emitBc (Platform
-> TupleInfo -> [(Bool, ByteOff)] -> [FFIInfo] -> ProtoBCO Name
tupleBCO Platform
platform TupleInfo
tuple_info [(Bool, ByteOff)]
args_ptrs)
               OrdList BCInstr -> BcM (OrdList BCInstr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList BCInstr -> BcM (OrdList BCInstr))
-> OrdList BCInstr -> BcM (OrdList BCInstr)
forall a b. (a -> b) -> a -> b
$ Literal -> Word16 -> BCInstr
PUSH_UBX (Platform -> TupleInfo -> Literal
mkTupleInfoLit Platform
platform TupleInfo
tuple_info) Word16
1 BCInstr -> OrdList BCInstr -> OrdList BCInstr
forall a. a -> OrdList a -> OrdList a
`consOL`
                        ProtoBCO Name -> BCInstr
PUSH_BCO ProtoBCO Name
tuple_bco BCInstr -> OrdList BCInstr -> OrdList BCInstr
forall a. a -> OrdList a -> OrdList a
`consOL`
                        BCInstr -> OrdList BCInstr
forall a. a -> OrdList a
unitOL BCInstr
RETURN_TUPLE
    OrdList BCInstr -> BcM (OrdList BCInstr)
forall (m :: * -> *) a. Monad m => a -> m a
return ( Platform -> ByteOff -> ByteOff -> OrdList BCInstr
mkSlideB Platform
platform ByteOff
szb (ByteOff
d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
- ByteOff
s) -- clear to sequel
             OrdList BCInstr -> OrdList BCInstr -> OrdList BCInstr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`  OrdList BCInstr
ret)                 -- go

-- construct and return an unboxed tuple
returnUnboxedTuple
    :: StackDepth
    -> Sequel
    -> BCEnv
    -> [StgArg]
    -> BcM BCInstrList
returnUnboxedTuple :: ByteOff
-> ByteOff -> Map Id ByteOff -> [StgArg] -> BcM (OrdList BCInstr)
returnUnboxedTuple ByteOff
d ByteOff
s Map Id ByteOff
p [StgArg]
es = do
    Profile
profile <- BcM Profile
getProfile
    let platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile
        arg_ty :: StgArg -> CmmType
arg_ty StgArg
e = Platform -> PrimRep -> CmmType
primRepCmmType Platform
platform (StgArg -> PrimRep
atomPrimRep StgArg
e)
        (TupleInfo
tuple_info, [(StgArg, ByteOff)]
tuple_components) = Profile
-> ByteOff
-> (StgArg -> CmmType)
-> [StgArg]
-> (TupleInfo, [(StgArg, ByteOff)])
forall a.
Profile
-> ByteOff -> (a -> CmmType) -> [a] -> (TupleInfo, [(a, ByteOff)])
layoutTuple Profile
profile ByteOff
d StgArg -> CmmType
arg_ty [StgArg]
es
        go :: ByteOff
-> [OrdList BCInstr]
-> [(StgArg, ByteOff)]
-> BcM [OrdList BCInstr]
go ByteOff
_   [OrdList BCInstr]
pushes [] = [OrdList BCInstr] -> BcM [OrdList BCInstr]
forall (m :: * -> *) a. Monad m => a -> m a
return ([OrdList BCInstr] -> [OrdList BCInstr]
forall a. [a] -> [a]
reverse [OrdList BCInstr]
pushes)
        go !ByteOff
dd [OrdList BCInstr]
pushes ((StgArg
a, ByteOff
off):[(StgArg, ByteOff)]
cs) = do (OrdList BCInstr
push, ByteOff
szb) <- ByteOff
-> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr, ByteOff)
pushAtom ByteOff
dd Map Id ByteOff
p StgArg
a
                                         MASSERT(off == dd + szb)
                                         ByteOff
-> [OrdList BCInstr]
-> [(StgArg, ByteOff)]
-> BcM [OrdList BCInstr]
go (ByteOff
dd ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ ByteOff
szb) (OrdList BCInstr
pushOrdList BCInstr -> [OrdList BCInstr] -> [OrdList BCInstr]
forall a. a -> [a] -> [a]
:[OrdList BCInstr]
pushes) [(StgArg, ByteOff)]
cs
    [OrdList BCInstr]
pushes <- ByteOff
-> [OrdList BCInstr]
-> [(StgArg, ByteOff)]
-> BcM [OrdList BCInstr]
go ByteOff
d [] [(StgArg, ByteOff)]
tuple_components
    OrdList BCInstr
ret <- ByteOff -> ByteOff -> ByteOff -> [PrimRep] -> BcM (OrdList BCInstr)
returnUnliftedReps ByteOff
d
                              ByteOff
s
                              (Platform -> WordOff -> ByteOff
wordsToBytes Platform
platform (WordOff -> ByteOff) -> WordOff -> ByteOff
forall a b. (a -> b) -> a -> b
$ TupleInfo -> WordOff
tupleSize TupleInfo
tuple_info)
                              ((StgArg -> PrimRep) -> [StgArg] -> [PrimRep]
forall a b. (a -> b) -> [a] -> [b]
map StgArg -> PrimRep
atomPrimRep [StgArg]
es)
    OrdList BCInstr -> BcM (OrdList BCInstr)
forall (m :: * -> *) a. Monad m => a -> m a
return ([OrdList BCInstr] -> OrdList BCInstr
forall a. Monoid a => [a] -> a
mconcat [OrdList BCInstr]
pushes OrdList BCInstr -> OrdList BCInstr -> OrdList BCInstr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList BCInstr
ret)

-- Compile code to apply the given expression to the remaining args
-- on the stack, returning a HNF.
schemeE
    :: StackDepth -> Sequel -> BCEnv -> CgStgExpr -> BcM BCInstrList
schemeE :: ByteOff
-> ByteOff
-> Map Id ByteOff
-> GenStgExpr 'CodeGen
-> BcM (OrdList BCInstr)
schemeE ByteOff
d ByteOff
s Map Id ByteOff
p (StgLit Literal
lit) = ByteOff
-> ByteOff -> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr)
returnUnliftedAtom ByteOff
d ByteOff
s Map Id ByteOff
p (Literal -> StgArg
StgLitArg Literal
lit)
schemeE ByteOff
d ByteOff
s Map Id ByteOff
p (StgApp Id
x [])
   | HasDebugCallStack => Kind -> Bool
Kind -> Bool
isUnliftedType (Id -> Kind
idType Id
x) = ByteOff
-> ByteOff -> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr)
returnUnliftedAtom ByteOff
d ByteOff
s Map Id ByteOff
p (Id -> StgArg
StgVarArg Id
x)
-- Delegate tail-calls to schemeT.
schemeE ByteOff
d ByteOff
s Map Id ByteOff
p e :: GenStgExpr 'CodeGen
e@(StgApp {}) = ByteOff
-> ByteOff
-> Map Id ByteOff
-> GenStgExpr 'CodeGen
-> BcM (OrdList BCInstr)
schemeT ByteOff
d ByteOff
s Map Id ByteOff
p GenStgExpr 'CodeGen
e
schemeE ByteOff
d ByteOff
s Map Id ByteOff
p e :: GenStgExpr 'CodeGen
e@(StgConApp {}) = ByteOff
-> ByteOff
-> Map Id ByteOff
-> GenStgExpr 'CodeGen
-> BcM (OrdList BCInstr)
schemeT ByteOff
d ByteOff
s Map Id ByteOff
p GenStgExpr 'CodeGen
e
schemeE ByteOff
d ByteOff
s Map Id ByteOff
p e :: GenStgExpr 'CodeGen
e@(StgOpApp {}) = ByteOff
-> ByteOff
-> Map Id ByteOff
-> GenStgExpr 'CodeGen
-> BcM (OrdList BCInstr)
schemeT ByteOff
d ByteOff
s Map Id ByteOff
p GenStgExpr 'CodeGen
e
schemeE ByteOff
d ByteOff
s Map Id ByteOff
p (StgLetNoEscape XLetNoEscape 'CodeGen
xlet GenStgBinding 'CodeGen
bnd GenStgExpr 'CodeGen
body)
   = ByteOff
-> ByteOff
-> Map Id ByteOff
-> GenStgExpr 'CodeGen
-> BcM (OrdList BCInstr)
schemeE ByteOff
d ByteOff
s Map Id ByteOff
p (XLet 'CodeGen
-> GenStgBinding 'CodeGen
-> GenStgExpr 'CodeGen
-> GenStgExpr 'CodeGen
forall (pass :: StgPass).
XLet pass
-> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
StgLet XLet 'CodeGen
XLetNoEscape 'CodeGen
xlet GenStgBinding 'CodeGen
bnd GenStgExpr 'CodeGen
body)
schemeE ByteOff
d ByteOff
s Map Id ByteOff
p (StgLet XLet 'CodeGen
_xlet
                      (StgNonRec BinderP 'CodeGen
x (StgRhsCon CostCentreStack
_cc DataCon
data_con ConstructorNumber
_cnum [StgTickish]
_ticks [StgArg]
args))
                      GenStgExpr 'CodeGen
body)
   = do -- Special case for a non-recursive let whose RHS is a
        -- saturated constructor application.
        -- Just allocate the constructor and carry on
        OrdList BCInstr
alloc_code <- ByteOff
-> ByteOff
-> Map Id ByteOff
-> DataCon
-> [StgArg]
-> BcM (OrdList BCInstr)
mkConAppCode ByteOff
d ByteOff
s Map Id ByteOff
p DataCon
data_con [StgArg]
args
        Platform
platform <- DynFlags -> Platform
targetPlatform (DynFlags -> Platform) -> BcM DynFlags -> BcM Platform
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BcM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
        let !d2 :: ByteOff
d2 = ByteOff
d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ Platform -> ByteOff
wordSize Platform
platform
        OrdList BCInstr
body_code <- ByteOff
-> ByteOff
-> Map Id ByteOff
-> GenStgExpr 'CodeGen
-> BcM (OrdList BCInstr)
schemeE ByteOff
d2 ByteOff
s (Id -> ByteOff -> Map Id ByteOff -> Map Id ByteOff
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Id
BinderP 'CodeGen
x ByteOff
d2 Map Id ByteOff
p) GenStgExpr 'CodeGen
body
        OrdList BCInstr -> BcM (OrdList BCInstr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList BCInstr
alloc_code OrdList BCInstr -> OrdList BCInstr -> OrdList BCInstr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList BCInstr
body_code)
-- General case for let.  Generates correct, if inefficient, code in
-- all situations.
schemeE ByteOff
d ByteOff
s Map Id ByteOff
p (StgLet XLet 'CodeGen
_ext GenStgBinding 'CodeGen
binds GenStgExpr 'CodeGen
body) = do
     Platform
platform <- DynFlags -> Platform
targetPlatform (DynFlags -> Platform) -> BcM DynFlags -> BcM Platform
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BcM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
     let ([Id]
xs,[CgStgRhs]
rhss) = case GenStgBinding 'CodeGen
binds of StgNonRec BinderP 'CodeGen
x CgStgRhs
rhs  -> ([Id
BinderP 'CodeGen
x],[CgStgRhs
rhs])
                                   StgRec [(BinderP 'CodeGen, CgStgRhs)]
xs_n_rhss -> [(Id, CgStgRhs)] -> ([Id], [CgStgRhs])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Id, CgStgRhs)]
[(BinderP 'CodeGen, CgStgRhs)]
xs_n_rhss
         n_binds :: WordOff
n_binds = [Id] -> WordOff
forall i a. Num i => [a] -> i
genericLength [Id]
xs

         fvss :: [[Id]]
fvss  = (CgStgRhs -> [Id]) -> [CgStgRhs] -> [[Id]]
forall a b. (a -> b) -> [a] -> [b]
map (Map Id ByteOff -> CgStgRhs -> [Id]
fvsToEnv Map Id ByteOff
p') [CgStgRhs]
rhss

         -- Sizes of free vars
         size_w :: Id -> Word16
size_w = WordOff -> Word16
trunc16W (WordOff -> Word16) -> (Id -> WordOff) -> Id -> Word16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Platform -> Id -> WordOff
idSizeW Platform
platform
         sizes :: [Word16]
sizes = ([Id] -> Word16) -> [[Id]] -> [Word16]
forall a b. (a -> b) -> [a] -> [b]
map (\[Id]
rhs_fvs -> [Word16] -> Word16
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((Id -> Word16) -> [Id] -> [Word16]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Word16
size_w [Id]
rhs_fvs)) [[Id]]
fvss

         -- the arity of each rhs
         arities :: [Word16]
arities = (CgStgRhs -> Word16) -> [CgStgRhs] -> [Word16]
forall a b. (a -> b) -> [a] -> [b]
map ([Id] -> Word16
forall i a. Num i => [a] -> i
genericLength ([Id] -> Word16) -> (CgStgRhs -> [Id]) -> CgStgRhs -> Word16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Id], GenStgExpr 'CodeGen) -> [Id]
forall a b. (a, b) -> a
fst (([Id], GenStgExpr 'CodeGen) -> [Id])
-> (CgStgRhs -> ([Id], GenStgExpr 'CodeGen)) -> CgStgRhs -> [Id]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CgStgRhs -> ([Id], GenStgExpr 'CodeGen)
collect) [CgStgRhs]
rhss

         -- This p', d' defn is safe because all the items being pushed
         -- are ptrs, so all have size 1 word.  d' and p' reflect the stack
         -- after the closures have been allocated in the heap (but not
         -- filled in), and pointers to them parked on the stack.
         offsets :: [ByteOff]
offsets = ByteOff -> [ByteOff] -> [ByteOff]
mkStackOffsets ByteOff
d (WordOff -> ByteOff -> [ByteOff]
forall i a. Integral i => i -> a -> [a]
genericReplicate WordOff
n_binds (Platform -> ByteOff
wordSize Platform
platform))
         p' :: Map Id ByteOff
p' = [(Id, ByteOff)] -> Map Id ByteOff -> Map Id ByteOff
forall key elt.
Ord key =>
[(key, elt)] -> Map key elt -> Map key elt
Map.insertList ([Id] -> [ByteOff] -> [(Id, ByteOff)]
forall a b. [a] -> [b] -> [(a, b)]
zipE [Id]
xs [ByteOff]
offsets) Map Id ByteOff
p
         d' :: ByteOff
d' = ByteOff
d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ Platform -> WordOff -> ByteOff
wordsToBytes Platform
platform WordOff
n_binds
         zipE :: [a] -> [b] -> [(a, b)]
zipE = String -> [a] -> [b] -> [(a, b)]
forall a b. String -> [a] -> [b] -> [(a, b)]
zipEqual String
"schemeE"

         -- ToDo: don't build thunks for things with no free variables
         build_thunk
             :: StackDepth
             -> [Id]
             -> Word16
             -> ProtoBCO Name
             -> Word16
             -> Word16
             -> BcM BCInstrList
         build_thunk :: ByteOff
-> [Id]
-> Word16
-> ProtoBCO Name
-> Word16
-> Word16
-> BcM (OrdList BCInstr)
build_thunk ByteOff
_ [] Word16
size ProtoBCO Name
bco Word16
off Word16
arity
            = OrdList BCInstr -> BcM (OrdList BCInstr)
forall (m :: * -> *) a. Monad m => a -> m a
return (ProtoBCO Name -> BCInstr
PUSH_BCO ProtoBCO Name
bco BCInstr -> OrdList BCInstr -> OrdList BCInstr
forall a. a -> OrdList a -> OrdList a
`consOL` BCInstr -> OrdList BCInstr
forall a. a -> OrdList a
unitOL (Word16 -> Word16 -> BCInstr
mkap (Word16
offWord16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
+Word16
size) Word16
size))
           where
                mkap :: Word16 -> Word16 -> BCInstr
mkap | Word16
arity Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Word16
0 = Word16 -> Word16 -> BCInstr
MKAP
                     | Bool
otherwise  = Word16 -> Word16 -> BCInstr
MKPAP
         build_thunk ByteOff
dd (Id
fv:[Id]
fvs) Word16
size ProtoBCO Name
bco Word16
off Word16
arity = do
              (OrdList BCInstr
push_code, ByteOff
pushed_szb) <- ByteOff
-> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr, ByteOff)
pushAtom ByteOff
dd Map Id ByteOff
p' (Id -> StgArg
StgVarArg Id
fv)
              OrdList BCInstr
more_push_code <-
                  ByteOff
-> [Id]
-> Word16
-> ProtoBCO Name
-> Word16
-> Word16
-> BcM (OrdList BCInstr)
build_thunk (ByteOff
dd ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ ByteOff
pushed_szb) [Id]
fvs Word16
size ProtoBCO Name
bco Word16
off Word16
arity
              OrdList BCInstr -> BcM (OrdList BCInstr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList BCInstr
push_code OrdList BCInstr -> OrdList BCInstr -> OrdList BCInstr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList BCInstr
more_push_code)

         alloc_code :: OrdList BCInstr
alloc_code = [BCInstr] -> OrdList BCInstr
forall a. [a] -> OrdList a
toOL ((Word16 -> Word16 -> BCInstr) -> [Word16] -> [Word16] -> [BCInstr]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Word16 -> Word16 -> BCInstr
mkAlloc [Word16]
sizes [Word16]
arities)
           where mkAlloc :: Word16 -> Word16 -> BCInstr
mkAlloc Word16
sz Word16
0
                    | Bool
is_tick     = Word16 -> BCInstr
ALLOC_AP_NOUPD Word16
sz
                    | Bool
otherwise   = Word16 -> BCInstr
ALLOC_AP Word16
sz
                 mkAlloc Word16
sz Word16
arity = Word16 -> Word16 -> BCInstr
ALLOC_PAP Word16
arity Word16
sz

         is_tick :: Bool
is_tick = case GenStgBinding 'CodeGen
binds of
                     StgNonRec BinderP 'CodeGen
id CgStgRhs
_ -> OccName -> FastString
occNameFS (Id -> OccName
forall a. NamedThing a => a -> OccName
getOccName Id
BinderP 'CodeGen
id) FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
== FastString
tickFS
                     GenStgBinding 'CodeGen
_other -> Bool
False

         compile_bind :: ByteOff
-> [Id]
-> a
-> CgStgRhs
-> Word16
-> Word16
-> Word16
-> BcM (OrdList BCInstr)
compile_bind ByteOff
d' [Id]
fvs a
x (CgStgRhs
rhs::CgStgRhs) Word16
size Word16
arity Word16
off = do
                ProtoBCO Name
bco <- [Id] -> (Name, CgStgRhs) -> BcM (ProtoBCO Name)
schemeR [Id]
fvs (a -> Name
forall a. NamedThing a => a -> Name
getName a
x,CgStgRhs
rhs)
                ByteOff
-> [Id]
-> Word16
-> ProtoBCO Name
-> Word16
-> Word16
-> BcM (OrdList BCInstr)
build_thunk ByteOff
d' [Id]
fvs Word16
size ProtoBCO Name
bco Word16
off Word16
arity

         compile_binds :: [BcM (OrdList BCInstr)]
compile_binds =
            [ ByteOff
-> [Id]
-> Id
-> CgStgRhs
-> Word16
-> Word16
-> Word16
-> BcM (OrdList BCInstr)
forall {a}.
NamedThing a =>
ByteOff
-> [Id]
-> a
-> CgStgRhs
-> Word16
-> Word16
-> Word16
-> BcM (OrdList BCInstr)
compile_bind ByteOff
d' [Id]
fvs Id
x CgStgRhs
rhs Word16
size Word16
arity (WordOff -> Word16
trunc16W WordOff
n)
            | ([Id]
fvs, Id
x, CgStgRhs
rhs, Word16
size, Word16
arity, WordOff
n) <-
                [[Id]]
-> [Id]
-> [CgStgRhs]
-> [Word16]
-> [Word16]
-> [WordOff]
-> [([Id], Id, CgStgRhs, Word16, Word16, WordOff)]
forall a b c d e f.
[a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [(a, b, c, d, e, f)]
zip6 [[Id]]
fvss [Id]
xs [CgStgRhs]
rhss [Word16]
sizes [Word16]
arities [WordOff
n_binds, WordOff
n_bindsWordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
-WordOff
1 .. WordOff
1]
            ]
     OrdList BCInstr
body_code <- ByteOff
-> ByteOff
-> Map Id ByteOff
-> GenStgExpr 'CodeGen
-> BcM (OrdList BCInstr)
schemeE ByteOff
d' ByteOff
s Map Id ByteOff
p' GenStgExpr 'CodeGen
body
     [OrdList BCInstr]
thunk_codes <- [BcM (OrdList BCInstr)] -> BcM [OrdList BCInstr]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [BcM (OrdList BCInstr)]
compile_binds
     OrdList BCInstr -> BcM (OrdList BCInstr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList BCInstr
alloc_code OrdList BCInstr -> OrdList BCInstr -> OrdList BCInstr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [OrdList BCInstr] -> OrdList BCInstr
forall a. [OrdList a] -> OrdList a
concatOL [OrdList BCInstr]
thunk_codes OrdList BCInstr -> OrdList BCInstr -> OrdList BCInstr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList BCInstr
body_code)

schemeE ByteOff
_d ByteOff
_s Map Id ByteOff
_p (StgTick (Breakpoint XBreakpoint 'TickishPassStg
_ Int
bp_id [XTickishId 'TickishPassStg]
_) GenStgExpr 'CodeGen
_rhs)
   = String -> BcM (OrdList BCInstr)
forall a. String -> a
panic (String
"schemeE: Breakpoint without let binding: " String -> String -> String
forall a. [a] -> [a] -> [a]
++
            Int -> String
forall a. Show a => a -> String
show Int
bp_id String -> String -> String
forall a. [a] -> [a] -> [a]
++
            String
" forgot to run bcPrep?")

-- ignore other kinds of tick
schemeE ByteOff
d ByteOff
s Map Id ByteOff
p (StgTick StgTickish
_ GenStgExpr 'CodeGen
rhs) = ByteOff
-> ByteOff
-> Map Id ByteOff
-> GenStgExpr 'CodeGen
-> BcM (OrdList BCInstr)
schemeE ByteOff
d ByteOff
s Map Id ByteOff
p GenStgExpr 'CodeGen
rhs

-- no alts: scrut is guaranteed to diverge
schemeE ByteOff
d ByteOff
s Map Id ByteOff
p (StgCase GenStgExpr 'CodeGen
scrut BinderP 'CodeGen
_ AltType
_ []) = ByteOff
-> ByteOff
-> Map Id ByteOff
-> GenStgExpr 'CodeGen
-> BcM (OrdList BCInstr)
schemeE ByteOff
d ByteOff
s Map Id ByteOff
p GenStgExpr 'CodeGen
scrut

schemeE ByteOff
d ByteOff
s Map Id ByteOff
p (StgCase GenStgExpr 'CodeGen
scrut BinderP 'CodeGen
bndr AltType
_ [CgStgAlt]
alts)
   = ByteOff
-> ByteOff
-> Map Id ByteOff
-> GenStgExpr 'CodeGen
-> Id
-> [CgStgAlt]
-> BcM (OrdList BCInstr)
doCase ByteOff
d ByteOff
s Map Id ByteOff
p GenStgExpr 'CodeGen
scrut Id
BinderP 'CodeGen
bndr [CgStgAlt]
alts

-- Is this Id a not-necessarily-lifted join point?
-- See Note [Not-necessarily-lifted join points], step 1
isNNLJoinPoint :: Id -> Bool
isNNLJoinPoint :: Id -> Bool
isNNLJoinPoint Id
x = Id -> Bool
isJoinId Id
x Bool -> Bool -> Bool
&&
                   Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= HasDebugCallStack => Kind -> Maybe Bool
Kind -> Maybe Bool
isLiftedType_maybe (Id -> Kind
idType Id
x)

-- Update an Id's type to take a Void# argument.
-- Precondition: the Id is a not-necessarily-lifted join point.
-- See Note [Not-necessarily-lifted join points]
protectNNLJoinPointId :: Id -> Id
protectNNLJoinPointId :: Id -> Id
protectNNLJoinPointId Id
x
  = ASSERT( isNNLJoinPoint x )
    (Kind -> Kind) -> Id -> Id
updateIdTypeButNotMult (Kind
unboxedUnitTy Kind -> Kind -> Kind
`mkVisFunTyMany`) Id
x

{-
   Ticked Expressions
   ------------------

  The idea is that the "breakpoint<n,fvs> E" is really just an annotation on
  the code. When we find such a thing, we pull out the useful information,
  and then compile the code as if it was just the expression E.

Note [Not-necessarily-lifted join points]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
A join point variable is essentially a goto-label: it is, for example,
never used as an argument to another function, and it is called only
in tail position. See Note [Join points] and Note [Invariants on join points],
both in GHC.Core. Because join points do not compile to true, red-blooded
variables (with, e.g., registers allocated to them), they are allowed
to be levity-polymorphic. (See invariant #6 in Note [Invariants on join points]
in GHC.Core.)

However, in this byte-code generator, join points *are* treated just as
ordinary variables. There is no check whether a binding is for a join point
or not; they are all treated uniformly. (Perhaps there is a missed optimization
opportunity here, but that is beyond the scope of my (Richard E's) Thursday.)

We thus must have *some* strategy for dealing with levity-polymorphic and
unlifted join points. Levity-polymorphic variables are generally not allowed
(though levity-polymorphic join points *are*; see Note [Invariants on join points]
in GHC.Core, point 6), and we don't wish to evaluate unlifted join points eagerly.
The questionable join points are *not-necessarily-lifted join points*
(NNLJPs). (Not having such a strategy led to #16509, which panicked in the
isUnliftedType check in the AnnVar case of schemeE.) Here is the strategy:

1. Detect NNLJPs. This is done in isNNLJoinPoint.

2. When binding an NNLJP, add a `\ (_ :: (# #)) ->` to its RHS, and modify the
   type to tack on a `(# #) ->`.
   Note that functions are never levity-polymorphic, so this transformation
   changes an NNLJP to a non-levity-polymorphic join point. This is done
   in bcPrepSingleBind.

3. At an occurrence of an NNLJP, add an application to void# (called voidPrimId),
   being careful to note the new type of the NNLJP. This is done in the AnnVar
   case of schemeE, with help from protectNNLJoinPointId.

Here is an example. Suppose we have

  f = \(r :: RuntimeRep) (a :: TYPE r) (x :: T).
      join j :: a
           j = error @r @a "bloop"
      in case x of
           A -> j
           B -> j
           C -> error @r @a "blurp"

Our plan is to behave is if the code was

  f = \(r :: RuntimeRep) (a :: TYPE r) (x :: T).
      let j :: (Void# -> a)
          j = \ _ -> error @r @a "bloop"
      in case x of
           A -> j void#
           B -> j void#
           C -> error @r @a "blurp"

It's a bit hacky, but it works well in practice and is local. I suspect the
Right Fix is to take advantage of join points as goto-labels.

-}

-- Compile code to do a tail call.  Specifically, push the fn,
-- slide the on-stack app back down to the sequel depth,
-- and enter.  Four cases:
--
-- 0.  (Nasty hack).
--     An application "GHC.Prim.tagToEnum# <type> unboxed-int".
--     The int will be on the stack.  Generate a code sequence
--     to convert it to the relevant constructor, SLIDE and ENTER.
--
-- 1.  The fn denotes a ccall.  Defer to generateCCall.
--
-- 2.  An unboxed tuple: push the components on the top of
--     the stack and return.
--
-- 3.  Application of a constructor, by defn saturated.
--     Split the args into ptrs and non-ptrs, and push the nonptrs,
--     then the ptrs, and then do PACK and RETURN.
--
-- 4.  Otherwise, it must be a function call.  Push the args
--     right to left, SLIDE and ENTER.

schemeT :: StackDepth   -- Stack depth
        -> Sequel       -- Sequel depth
        -> BCEnv        -- stack env
        -> CgStgExpr
        -> BcM BCInstrList

   -- Case 0
schemeT :: ByteOff
-> ByteOff
-> Map Id ByteOff
-> GenStgExpr 'CodeGen
-> BcM (OrdList BCInstr)
schemeT ByteOff
d ByteOff
s Map Id ByteOff
p GenStgExpr 'CodeGen
app
   | Just (Id
arg, [Name]
constr_names) <- GenStgExpr 'CodeGen -> Maybe (Id, [Name])
maybe_is_tagToEnum_call GenStgExpr 'CodeGen
app
   = ByteOff
-> ByteOff
-> Map Id ByteOff
-> Id
-> [Name]
-> BcM (OrdList BCInstr)
implement_tagToId ByteOff
d ByteOff
s Map Id ByteOff
p Id
arg [Name]
constr_names

   -- Case 1
schemeT ByteOff
d ByteOff
s Map Id ByteOff
p (StgOpApp (StgFCallOp (CCall CCallSpec
ccall_spec) Kind
_ty) [StgArg]
args Kind
result_ty)
   = if CCallSpec -> Bool
isSupportedCConv CCallSpec
ccall_spec
      then ByteOff
-> ByteOff
-> Map Id ByteOff
-> CCallSpec
-> Kind
-> [StgArg]
-> BcM (OrdList BCInstr)
generateCCall ByteOff
d ByteOff
s Map Id ByteOff
p CCallSpec
ccall_spec Kind
result_ty ([StgArg] -> [StgArg]
forall a. [a] -> [a]
reverse [StgArg]
args)
      else BcM (OrdList BCInstr)
forall a. a
unsupportedCConvException

schemeT ByteOff
d ByteOff
s Map Id ByteOff
p (StgOpApp (StgPrimOp PrimOp
op) [StgArg]
args Kind
_ty)
   = ByteOff
-> ByteOff
-> Map Id ByteOff
-> Id
-> [StgArg]
-> BcM (OrdList BCInstr)
doTailCall ByteOff
d ByteOff
s Map Id ByteOff
p (PrimOp -> Id
primOpId PrimOp
op) ([StgArg] -> [StgArg]
forall a. [a] -> [a]
reverse [StgArg]
args)

schemeT ByteOff
_d ByteOff
_s Map Id ByteOff
_p (StgOpApp StgPrimCallOp{} [StgArg]
_args Kind
_ty)
   = BcM (OrdList BCInstr)
forall a. a
unsupportedCConvException

   -- Case 2: Unboxed tuple
schemeT ByteOff
d ByteOff
s Map Id ByteOff
p (StgConApp DataCon
con XConApp 'CodeGen
_ext [StgArg]
args [Kind]
_tys)
   | DataCon -> Bool
isUnboxedTupleDataCon DataCon
con Bool -> Bool -> Bool
|| DataCon -> Bool
isUnboxedSumDataCon DataCon
con
   = ByteOff
-> ByteOff -> Map Id ByteOff -> [StgArg] -> BcM (OrdList BCInstr)
returnUnboxedTuple ByteOff
d ByteOff
s Map Id ByteOff
p [StgArg]
args

   -- Case 3: Ordinary data constructor
   | Bool
otherwise
   = do OrdList BCInstr
alloc_con <- ByteOff
-> ByteOff
-> Map Id ByteOff
-> DataCon
-> [StgArg]
-> BcM (OrdList BCInstr)
mkConAppCode ByteOff
d ByteOff
s Map Id ByteOff
p DataCon
con [StgArg]
args
        Platform
platform <- Profile -> Platform
profilePlatform (Profile -> Platform) -> BcM Profile -> BcM Platform
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BcM Profile
getProfile
        OrdList BCInstr -> BcM (OrdList BCInstr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList BCInstr
alloc_con         OrdList BCInstr -> OrdList BCInstr -> OrdList BCInstr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                Word16 -> WordOff -> OrdList BCInstr
mkSlideW Word16
1 (Platform -> ByteOff -> WordOff
bytesToWords Platform
platform (ByteOff -> WordOff) -> ByteOff -> WordOff
forall a b. (a -> b) -> a -> b
$ ByteOff
d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
- ByteOff
s) OrdList BCInstr -> BCInstr -> OrdList BCInstr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                if Kind -> Bool
isUnliftedTypeKind (TyCon -> Kind
tyConResKind (DataCon -> TyCon
dataConTyCon DataCon
con))
                then ArgRep -> BCInstr
RETURN_UNLIFTED ArgRep
P
                else BCInstr
ENTER)

   -- Case 4: Tail call of function
schemeT ByteOff
d ByteOff
s Map Id ByteOff
p (StgApp Id
fn [StgArg]
args)
   = ByteOff
-> ByteOff
-> Map Id ByteOff
-> Id
-> [StgArg]
-> BcM (OrdList BCInstr)
doTailCall ByteOff
d ByteOff
s Map Id ByteOff
p Id
fn ([StgArg] -> [StgArg]
forall a. [a] -> [a]
reverse [StgArg]
args)

schemeT ByteOff
_ ByteOff
_ Map Id ByteOff
_ GenStgExpr 'CodeGen
e = String -> SDoc -> BcM (OrdList BCInstr)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"GHC.StgToByteCode.schemeT"
                           (StgPprOpts -> GenStgExpr 'CodeGen -> SDoc
forall (pass :: StgPass).
OutputablePass pass =>
StgPprOpts -> GenStgExpr pass -> SDoc
pprStgExpr StgPprOpts
shortStgPprOpts GenStgExpr 'CodeGen
e)

-- -----------------------------------------------------------------------------
-- Generate code to build a constructor application,
-- leaving it on top of the stack

mkConAppCode
    :: StackDepth
    -> Sequel
    -> BCEnv
    -> DataCon                  -- The data constructor
    -> [StgArg]                 -- Args, in *reverse* order
    -> BcM BCInstrList
mkConAppCode :: ByteOff
-> ByteOff
-> Map Id ByteOff
-> DataCon
-> [StgArg]
-> BcM (OrdList BCInstr)
mkConAppCode ByteOff
orig_d ByteOff
_ Map Id ByteOff
p DataCon
con [StgArg]
args = BcM (OrdList BCInstr)
app_code
  where
    app_code :: BcM (OrdList BCInstr)
app_code = do
        Profile
profile <- BcM Profile
getProfile
        let platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile

            non_voids :: [NonVoid (PrimRep, StgArg)]
non_voids =
                [ (PrimRep, StgArg) -> NonVoid (PrimRep, StgArg)
forall a. a -> NonVoid a
NonVoid (PrimRep
prim_rep, StgArg
arg)
                | StgArg
arg <- [StgArg]
args
                , let prim_rep :: PrimRep
prim_rep = StgArg -> PrimRep
atomPrimRep StgArg
arg
                , Bool -> Bool
not (PrimRep -> Bool
isVoidRep PrimRep
prim_rep)
                ]
            (Int
_, Int
_, [FieldOffOrPadding StgArg]
args_offsets) =
                Profile
-> ClosureHeader
-> [NonVoid (PrimRep, StgArg)]
-> (Int, Int, [FieldOffOrPadding StgArg])
forall a.
Profile
-> ClosureHeader
-> [NonVoid (PrimRep, a)]
-> (Int, Int, [FieldOffOrPadding a])
mkVirtHeapOffsetsWithPadding Profile
profile ClosureHeader
StdHeader [NonVoid (PrimRep, StgArg)]
non_voids

            do_pushery :: ByteOff -> [FieldOffOrPadding StgArg] -> BcM (OrdList BCInstr)
do_pushery !ByteOff
d (FieldOffOrPadding StgArg
arg : [FieldOffOrPadding StgArg]
args) = do
                (OrdList BCInstr
push, ByteOff
arg_bytes) <- case FieldOffOrPadding StgArg
arg of
                    (Padding Int
l Int
_) -> (OrdList BCInstr, ByteOff) -> BcM (OrdList BCInstr, ByteOff)
forall (m :: * -> *) a. Monad m => a -> m a
return ((OrdList BCInstr, ByteOff) -> BcM (OrdList BCInstr, ByteOff))
-> (OrdList BCInstr, ByteOff) -> BcM (OrdList BCInstr, ByteOff)
forall a b. (a -> b) -> a -> b
$! ByteOff -> (OrdList BCInstr, ByteOff)
pushPadding (Int -> ByteOff
ByteOff Int
l)
                    (FieldOff NonVoid StgArg
a Int
_) -> ByteOff
-> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr, ByteOff)
pushConstrAtom ByteOff
d Map Id ByteOff
p (NonVoid StgArg -> StgArg
forall a. NonVoid a -> a
fromNonVoid NonVoid StgArg
a)
                OrdList BCInstr
more_push_code <- ByteOff -> [FieldOffOrPadding StgArg] -> BcM (OrdList BCInstr)
do_pushery (ByteOff
d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ ByteOff
arg_bytes) [FieldOffOrPadding StgArg]
args
                OrdList BCInstr -> BcM (OrdList BCInstr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList BCInstr
push OrdList BCInstr -> OrdList BCInstr -> OrdList BCInstr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList BCInstr
more_push_code)
            do_pushery !ByteOff
d [] = do
                let !n_arg_words :: Word16
n_arg_words = WordOff -> Word16
trunc16W (WordOff -> Word16) -> WordOff -> Word16
forall a b. (a -> b) -> a -> b
$ Platform -> ByteOff -> WordOff
bytesToWords Platform
platform (ByteOff
d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
- ByteOff
orig_d)
                OrdList BCInstr -> BcM (OrdList BCInstr)
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstr -> OrdList BCInstr
forall a. a -> OrdList a
unitOL (DataCon -> Word16 -> BCInstr
PACK DataCon
con Word16
n_arg_words))

        -- Push on the stack in the reverse order.
        ByteOff -> [FieldOffOrPadding StgArg] -> BcM (OrdList BCInstr)
do_pushery ByteOff
orig_d ([FieldOffOrPadding StgArg] -> [FieldOffOrPadding StgArg]
forall a. [a] -> [a]
reverse [FieldOffOrPadding StgArg]
args_offsets)

-- -----------------------------------------------------------------------------
-- Generate code for a tail-call

doTailCall
    :: StackDepth
    -> Sequel
    -> BCEnv
    -> Id
    -> [StgArg]
    -> BcM BCInstrList
doTailCall :: ByteOff
-> ByteOff
-> Map Id ByteOff
-> Id
-> [StgArg]
-> BcM (OrdList BCInstr)
doTailCall ByteOff
init_d ByteOff
s Map Id ByteOff
p Id
fn [StgArg]
args = do
   Platform
platform <- Profile -> Platform
profilePlatform (Profile -> Platform) -> BcM Profile -> BcM Platform
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BcM Profile
getProfile
   ByteOff -> [StgArg] -> [ArgRep] -> BcM (OrdList BCInstr)
do_pushes ByteOff
init_d [StgArg]
args ((StgArg -> ArgRep) -> [StgArg] -> [ArgRep]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> StgArg -> ArgRep
atomRep Platform
platform) [StgArg]
args)
  where
  do_pushes :: ByteOff -> [StgArg] -> [ArgRep] -> BcM (OrdList BCInstr)
do_pushes !ByteOff
d [] [ArgRep]
reps = do
        ASSERT( null reps ) return ()
        (OrdList BCInstr
push_fn, ByteOff
sz) <- ByteOff
-> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr, ByteOff)
pushAtom ByteOff
d Map Id ByteOff
p (Id -> StgArg
StgVarArg Id
fn)
        Platform
platform <- Profile -> Platform
profilePlatform (Profile -> Platform) -> BcM Profile -> BcM Platform
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BcM Profile
getProfile
        ASSERT( sz == wordSize platform ) return ()
        let slide :: OrdList BCInstr
slide = Platform -> ByteOff -> ByteOff -> OrdList BCInstr
mkSlideB Platform
platform (ByteOff
d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
- ByteOff
init_d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ Platform -> ByteOff
wordSize Platform
platform) (ByteOff
init_d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
- ByteOff
s)
            enter :: BCInstr
enter = if HasDebugCallStack => Kind -> Bool
Kind -> Bool
isUnliftedType (Id -> Kind
idType Id
fn)
                    then ArgRep -> BCInstr
RETURN_UNLIFTED ArgRep
P
                    else BCInstr
ENTER
        OrdList BCInstr -> BcM (OrdList BCInstr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList BCInstr
push_fn OrdList BCInstr -> OrdList BCInstr -> OrdList BCInstr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` (OrdList BCInstr
slide OrdList BCInstr -> OrdList BCInstr -> OrdList BCInstr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` BCInstr -> OrdList BCInstr
forall a. a -> OrdList a
unitOL BCInstr
enter))
  do_pushes !ByteOff
d [StgArg]
args [ArgRep]
reps = do
      let (BCInstr
push_apply, Int
n, [ArgRep]
rest_of_reps) = [ArgRep] -> (BCInstr, Int, [ArgRep])
findPushSeq [ArgRep]
reps
          ([StgArg]
these_args, [StgArg]
rest_of_args) = Int -> [StgArg] -> ([StgArg], [StgArg])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n [StgArg]
args
      (ByteOff
next_d, OrdList BCInstr
push_code) <- ByteOff -> [StgArg] -> BcM (ByteOff, OrdList BCInstr)
push_seq ByteOff
d [StgArg]
these_args
      Platform
platform <- Profile -> Platform
profilePlatform (Profile -> Platform) -> BcM Profile -> BcM Platform
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BcM Profile
getProfile
      OrdList BCInstr
instrs <- ByteOff -> [StgArg] -> [ArgRep] -> BcM (OrdList BCInstr)
do_pushes (ByteOff
next_d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ Platform -> ByteOff
wordSize Platform
platform) [StgArg]
rest_of_args [ArgRep]
rest_of_reps
      --                          ^^^ for the PUSH_APPLY_ instruction
      OrdList BCInstr -> BcM (OrdList BCInstr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList BCInstr
push_code OrdList BCInstr -> OrdList BCInstr -> OrdList BCInstr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` (BCInstr
push_apply BCInstr -> OrdList BCInstr -> OrdList BCInstr
forall a. a -> OrdList a -> OrdList a
`consOL` OrdList BCInstr
instrs))

  push_seq :: ByteOff -> [StgArg] -> BcM (ByteOff, OrdList BCInstr)
push_seq ByteOff
d [] = (ByteOff, OrdList BCInstr) -> BcM (ByteOff, OrdList BCInstr)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteOff
d, OrdList BCInstr
forall a. OrdList a
nilOL)
  push_seq ByteOff
d (StgArg
arg:[StgArg]
args) = do
    (OrdList BCInstr
push_code, ByteOff
sz) <- ByteOff
-> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr, ByteOff)
pushAtom ByteOff
d Map Id ByteOff
p StgArg
arg
    (ByteOff
final_d, OrdList BCInstr
more_push_code) <- ByteOff -> [StgArg] -> BcM (ByteOff, OrdList BCInstr)
push_seq (ByteOff
d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ ByteOff
sz) [StgArg]
args
    (ByteOff, OrdList BCInstr) -> BcM (ByteOff, OrdList BCInstr)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteOff
final_d, OrdList BCInstr
push_code OrdList BCInstr -> OrdList BCInstr -> OrdList BCInstr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList BCInstr
more_push_code)

-- v. similar to CgStackery.findMatch, ToDo: merge
findPushSeq :: [ArgRep] -> (BCInstr, Int, [ArgRep])
findPushSeq :: [ArgRep] -> (BCInstr, Int, [ArgRep])
findPushSeq (ArgRep
P: ArgRep
P: ArgRep
P: ArgRep
P: ArgRep
P: ArgRep
P: [ArgRep]
rest)
  = (BCInstr
PUSH_APPLY_PPPPPP, Int
6, [ArgRep]
rest)
findPushSeq (ArgRep
P: ArgRep
P: ArgRep
P: ArgRep
P: ArgRep
P: [ArgRep]
rest)
  = (BCInstr
PUSH_APPLY_PPPPP, Int
5, [ArgRep]
rest)
findPushSeq (ArgRep
P: ArgRep
P: ArgRep
P: ArgRep
P: [ArgRep]
rest)
  = (BCInstr
PUSH_APPLY_PPPP, Int
4, [ArgRep]
rest)
findPushSeq (ArgRep
P: ArgRep
P: ArgRep
P: [ArgRep]
rest)
  = (BCInstr
PUSH_APPLY_PPP, Int
3, [ArgRep]
rest)
findPushSeq (ArgRep
P: ArgRep
P: [ArgRep]
rest)
  = (BCInstr
PUSH_APPLY_PP, Int
2, [ArgRep]
rest)
findPushSeq (ArgRep
P: [ArgRep]
rest)
  = (BCInstr
PUSH_APPLY_P, Int
1, [ArgRep]
rest)
findPushSeq (ArgRep
V: [ArgRep]
rest)
  = (BCInstr
PUSH_APPLY_V, Int
1, [ArgRep]
rest)
findPushSeq (ArgRep
N: [ArgRep]
rest)
  = (BCInstr
PUSH_APPLY_N, Int
1, [ArgRep]
rest)
findPushSeq (ArgRep
F: [ArgRep]
rest)
  = (BCInstr
PUSH_APPLY_F, Int
1, [ArgRep]
rest)
findPushSeq (ArgRep
D: [ArgRep]
rest)
  = (BCInstr
PUSH_APPLY_D, Int
1, [ArgRep]
rest)
findPushSeq (ArgRep
L: [ArgRep]
rest)
  = (BCInstr
PUSH_APPLY_L, Int
1, [ArgRep]
rest)
findPushSeq [ArgRep]
_
  = String -> (BCInstr, Int, [ArgRep])
forall a. String -> a
panic String
"GHC.StgToByteCode.findPushSeq"

-- -----------------------------------------------------------------------------
-- Case expressions

doCase
    :: StackDepth
    -> Sequel
    -> BCEnv
    -> CgStgExpr
    -> Id
    -> [CgStgAlt]
    -> BcM BCInstrList
doCase :: ByteOff
-> ByteOff
-> Map Id ByteOff
-> GenStgExpr 'CodeGen
-> Id
-> [CgStgAlt]
-> BcM (OrdList BCInstr)
doCase ByteOff
d ByteOff
s Map Id ByteOff
p GenStgExpr 'CodeGen
scrut Id
bndr [CgStgAlt]
alts
  = do
     Profile
profile <- BcM Profile
getProfile
     HscEnv
hsc_env <- BcM HscEnv
getHscEnv
     let
        platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile

        -- Are we dealing with an unboxed tuple with a tuple return frame?
        --
        -- 'Simple' tuples with at most one non-void component,
        -- like (# Word# #) or (# Int#, State# RealWorld# #) do not have a
        -- tuple return frame. This is because (# foo #) and (# foo, Void# #)
        -- have the same runtime rep. We have more efficient specialized
        -- return frames for the situations with one non-void element.

        ubx_tuple_frame :: Bool
ubx_tuple_frame =
          (Kind -> Bool
isUnboxedTupleType Kind
bndr_ty Bool -> Bool -> Bool
|| Kind -> Bool
isUnboxedSumType Kind
bndr_ty) Bool -> Bool -> Bool
&&
          [ArgRep] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ArgRep]
non_void_arg_reps Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1

        non_void_arg_reps :: [ArgRep]
non_void_arg_reps = [ArgRep] -> [ArgRep]
non_void (Platform -> Kind -> [ArgRep]
typeArgReps Platform
platform Kind
bndr_ty)

        profiling :: Bool
profiling
          | Just Interp
interp <- HscEnv -> Maybe Interp
hsc_interp HscEnv
hsc_env
          = Interp -> Bool
interpreterProfiled Interp
interp
          | Bool
otherwise = Bool
False

        -- Top of stack is the return itbl, as usual.
        -- underneath it is the pointer to the alt_code BCO.
        -- When an alt is entered, it assumes the returned value is
        -- on top of the itbl.
        ret_frame_size_b :: StackDepth
        ret_frame_size_b :: ByteOff
ret_frame_size_b | Bool
ubx_tuple_frame =
                             (if Bool
profiling then ByteOff
5 else ByteOff
4) ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
* Platform -> ByteOff
wordSize Platform
platform
                         | Bool
otherwise = ByteOff
2 ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
* Platform -> ByteOff
wordSize Platform
platform

        -- The stack space used to save/restore the CCCS when profiling
        save_ccs_size_b :: ByteOff
save_ccs_size_b | Bool
profiling Bool -> Bool -> Bool
&&
                          Bool -> Bool
not Bool
ubx_tuple_frame = ByteOff
2 ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
* Platform -> ByteOff
wordSize Platform
platform
                        | Bool
otherwise = ByteOff
0

        -- An unlifted value gets an extra info table pushed on top
        -- when it is returned.
        unlifted_itbl_size_b :: StackDepth
        unlifted_itbl_size_b :: ByteOff
unlifted_itbl_size_b | Bool
ubx_tuple_frame              = ByteOff
3 ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
* Platform -> ByteOff
wordSize Platform
platform
                             | Bool -> Bool
not (HasDebugCallStack => Kind -> Bool
Kind -> Bool
isUnliftedType Kind
bndr_ty) = ByteOff
0
                             | Bool
otherwise                    = Platform -> ByteOff
wordSize Platform
platform

        (ByteOff
bndr_size, TupleInfo
tuple_info, [(PrimRep, ByteOff)]
args_offsets)
           | Bool
ubx_tuple_frame =
               let bndr_ty :: PrimRep -> CmmType
bndr_ty = Platform -> PrimRep -> CmmType
primRepCmmType Platform
platform
                   bndr_reps :: [PrimRep]
bndr_reps = (PrimRep -> Bool) -> [PrimRep] -> [PrimRep]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not(Bool -> Bool) -> (PrimRep -> Bool) -> PrimRep -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.PrimRep -> Bool
isVoidRep) (Id -> [PrimRep]
bcIdPrimReps Id
bndr)
                   (TupleInfo
tuple_info, [(PrimRep, ByteOff)]
args_offsets) =
                       Profile
-> ByteOff
-> (PrimRep -> CmmType)
-> [PrimRep]
-> (TupleInfo, [(PrimRep, ByteOff)])
forall a.
Profile
-> ByteOff -> (a -> CmmType) -> [a] -> (TupleInfo, [(a, ByteOff)])
layoutTuple Profile
profile ByteOff
0 PrimRep -> CmmType
bndr_ty [PrimRep]
bndr_reps
               in ( Platform -> WordOff -> ByteOff
wordsToBytes Platform
platform (TupleInfo -> WordOff
tupleSize TupleInfo
tuple_info)
                  , TupleInfo
tuple_info
                  , [(PrimRep, ByteOff)]
args_offsets
                  )
           | Bool
otherwise = ( Platform -> WordOff -> ByteOff
wordsToBytes Platform
platform (Platform -> Id -> WordOff
idSizeW Platform
platform Id
bndr)
                         , TupleInfo
voidTupleInfo
                         , []
                         )

        -- depth of stack after the return value has been pushed
        d_bndr :: ByteOff
d_bndr =
            ByteOff
d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ ByteOff
ret_frame_size_b ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ ByteOff
bndr_size

        -- depth of stack after the extra info table for an unlifted return
        -- has been pushed, if any.  This is the stack depth at the
        -- continuation.
        d_alts :: ByteOff
d_alts = ByteOff
d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ ByteOff
ret_frame_size_b ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ ByteOff
bndr_size ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ ByteOff
unlifted_itbl_size_b

        -- Env in which to compile the alts, not including
        -- any vars bound by the alts themselves
        p_alts :: Map Id ByteOff
p_alts = Id -> ByteOff -> Map Id ByteOff -> Map Id ByteOff
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Id
bndr ByteOff
d_bndr Map Id ByteOff
p

        bndr_ty :: Kind
bndr_ty = Id -> Kind
idType Id
bndr
        isAlgCase :: Bool
isAlgCase = Kind -> Bool
isAlgType Kind
bndr_ty

        -- given an alt, return a discr and code for it.
        codeAlt :: (AltCon, [Id], GenStgExpr 'CodeGen) -> BcM (Discr, OrdList BCInstr)
codeAlt (AltCon
DEFAULT, [Id]
_, GenStgExpr 'CodeGen
rhs)
           = do OrdList BCInstr
rhs_code <- ByteOff
-> ByteOff
-> Map Id ByteOff
-> GenStgExpr 'CodeGen
-> BcM (OrdList BCInstr)
schemeE ByteOff
d_alts ByteOff
s Map Id ByteOff
p_alts GenStgExpr 'CodeGen
rhs
                (Discr, OrdList BCInstr) -> BcM (Discr, OrdList BCInstr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Discr
NoDiscr, OrdList BCInstr
rhs_code)

        codeAlt alt :: (AltCon, [Id], GenStgExpr 'CodeGen)
alt@(AltCon
_, [Id]
bndrs, GenStgExpr 'CodeGen
rhs)
           -- primitive or nullary constructor alt: no need to UNPACK
           | [Id] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
real_bndrs = do
                OrdList BCInstr
rhs_code <- ByteOff
-> ByteOff
-> Map Id ByteOff
-> GenStgExpr 'CodeGen
-> BcM (OrdList BCInstr)
schemeE ByteOff
d_alts ByteOff
s Map Id ByteOff
p_alts GenStgExpr 'CodeGen
rhs
                (Discr, OrdList BCInstr) -> BcM (Discr, OrdList BCInstr)
forall (m :: * -> *) a. Monad m => a -> m a
return ((AltCon, [Id], GenStgExpr 'CodeGen) -> Discr
forall {b} {c}. (AltCon, b, c) -> Discr
my_discr (AltCon, [Id], GenStgExpr 'CodeGen)
alt, OrdList BCInstr
rhs_code)
           | Kind -> Bool
isUnboxedTupleType Kind
bndr_ty Bool -> Bool -> Bool
|| Kind -> Bool
isUnboxedSumType Kind
bndr_ty =
             let bndr_ty :: Id -> CmmType
bndr_ty = Platform -> PrimRep -> CmmType
primRepCmmType Platform
platform (PrimRep -> CmmType) -> (Id -> PrimRep) -> Id -> CmmType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> PrimRep
bcIdPrimRep
                 tuple_start :: ByteOff
tuple_start = ByteOff
d_bndr
                 (TupleInfo
tuple_info, [(Id, ByteOff)]
args_offsets) =
                   Profile
-> ByteOff
-> (Id -> CmmType)
-> [Id]
-> (TupleInfo, [(Id, ByteOff)])
forall a.
Profile
-> ByteOff -> (a -> CmmType) -> [a] -> (TupleInfo, [(a, ByteOff)])
layoutTuple Profile
profile
                               ByteOff
0
                               Id -> CmmType
bndr_ty
                               [Id]
bndrs

                 stack_bot :: ByteOff
stack_bot = ByteOff
d_alts

                 p' :: Map Id ByteOff
p' = [(Id, ByteOff)] -> Map Id ByteOff -> Map Id ByteOff
forall key elt.
Ord key =>
[(key, elt)] -> Map key elt -> Map key elt
Map.insertList
                        [ (Id
arg, ByteOff
tuple_start ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
-
                                Platform -> WordOff -> ByteOff
wordsToBytes Platform
platform (TupleInfo -> WordOff
tupleSize TupleInfo
tuple_info) ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+
                                ByteOff
offset)
                        | (Id
arg, ByteOff
offset) <- [(Id, ByteOff)]
args_offsets
                        , Bool -> Bool
not (PrimRep -> Bool
isVoidRep (PrimRep -> Bool) -> PrimRep -> Bool
forall a b. (a -> b) -> a -> b
$ Id -> PrimRep
bcIdPrimRep Id
arg)]
                        Map Id ByteOff
p_alts
             in do
               OrdList BCInstr
rhs_code <- ByteOff
-> ByteOff
-> Map Id ByteOff
-> GenStgExpr 'CodeGen
-> BcM (OrdList BCInstr)
schemeE ByteOff
stack_bot ByteOff
s Map Id ByteOff
p' GenStgExpr 'CodeGen
rhs
               (Discr, OrdList BCInstr) -> BcM (Discr, OrdList BCInstr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Discr
NoDiscr, OrdList BCInstr
rhs_code)
           -- algebraic alt with some binders
           | Bool
otherwise =
             let (Int
tot_wds, Int
_ptrs_wds, [(NonVoid Id, Int)]
args_offsets) =
                     Profile
-> ClosureHeader
-> [NonVoid (PrimRep, Id)]
-> (Int, Int, [(NonVoid Id, Int)])
forall a.
Profile
-> ClosureHeader
-> [NonVoid (PrimRep, a)]
-> (Int, Int, [(NonVoid a, Int)])
mkVirtHeapOffsets Profile
profile ClosureHeader
NoHeader
                         [ (PrimRep, Id) -> NonVoid (PrimRep, Id)
forall a. a -> NonVoid a
NonVoid (Id -> PrimRep
bcIdPrimRep Id
id, Id
id)
                         | NonVoid Id
id <- [Id] -> [NonVoid Id]
nonVoidIds [Id]
real_bndrs
                         ]
                 size :: WordOff
size = Int -> WordOff
WordOff Int
tot_wds

                 stack_bot :: ByteOff
stack_bot = ByteOff
d_alts ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ Platform -> WordOff -> ByteOff
wordsToBytes Platform
platform WordOff
size

                 -- convert offsets from Sp into offsets into the virtual stack
                 p' :: Map Id ByteOff
p' = [(Id, ByteOff)] -> Map Id ByteOff -> Map Id ByteOff
forall key elt.
Ord key =>
[(key, elt)] -> Map key elt -> Map key elt
Map.insertList
                        [ (Id
arg, ByteOff
stack_bot ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
- Int -> ByteOff
ByteOff Int
offset)
                        | (NonVoid Id
arg, Int
offset) <- [(NonVoid Id, Int)]
args_offsets ]
                        Map Id ByteOff
p_alts

                 -- unlifted datatypes have an infotable word on top
                 unpack :: OrdList BCInstr
unpack = if HasDebugCallStack => Kind -> Bool
Kind -> Bool
isUnliftedType Kind
bndr_ty
                          then Word16 -> BCInstr
PUSH_L Word16
1 BCInstr -> OrdList BCInstr -> OrdList BCInstr
forall a. a -> OrdList a -> OrdList a
`consOL`
                               Word16 -> BCInstr
UNPACK (WordOff -> Word16
trunc16W WordOff
size) BCInstr -> OrdList BCInstr -> OrdList BCInstr
forall a. a -> OrdList a -> OrdList a
`consOL`
                               BCInstr -> OrdList BCInstr
forall a. a -> OrdList a
unitOL (Word16 -> Word16 -> BCInstr
SLIDE (WordOff -> Word16
trunc16W WordOff
size) Word16
1)
                          else BCInstr -> OrdList BCInstr
forall a. a -> OrdList a
unitOL (Word16 -> BCInstr
UNPACK (WordOff -> Word16
trunc16W WordOff
size))
             in do
             MASSERT(isAlgCase)
             OrdList BCInstr
rhs_code <- ByteOff
-> ByteOff
-> Map Id ByteOff
-> GenStgExpr 'CodeGen
-> BcM (OrdList BCInstr)
schemeE ByteOff
stack_bot ByteOff
s Map Id ByteOff
p' GenStgExpr 'CodeGen
rhs
             (Discr, OrdList BCInstr) -> BcM (Discr, OrdList BCInstr)
forall (m :: * -> *) a. Monad m => a -> m a
return ((AltCon, [Id], GenStgExpr 'CodeGen) -> Discr
forall {b} {c}. (AltCon, b, c) -> Discr
my_discr (AltCon, [Id], GenStgExpr 'CodeGen)
alt, OrdList BCInstr
unpack OrdList BCInstr -> OrdList BCInstr -> OrdList BCInstr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList BCInstr
rhs_code)
           where
             real_bndrs :: [Id]
real_bndrs = (Id -> Bool) -> [Id] -> [Id]
forall a. (a -> Bool) -> [a] -> [a]
filterOut Id -> Bool
isTyVar [Id]
bndrs

        my_discr :: (AltCon, b, c) -> Discr
my_discr (AltCon
DEFAULT, b
_, c
_) = Discr
NoDiscr {-shouldn't really happen-}
        my_discr (DataAlt DataCon
dc, b
_, c
_)
           | DataCon -> Bool
isUnboxedTupleDataCon DataCon
dc Bool -> Bool -> Bool
|| DataCon -> Bool
isUnboxedSumDataCon DataCon
dc
           = Discr
NoDiscr
           | Bool
otherwise
           = Word16 -> Discr
DiscrP (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (DataCon -> Int
dataConTag DataCon
dc Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
fIRST_TAG))
        my_discr (LitAlt Literal
l, b
_, c
_)
           = case Literal
l of LitNumber LitNumType
LitNumInt Integer
i  -> Int -> Discr
DiscrI (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
i)
                       LitNumber LitNumType
LitNumWord Integer
w -> Word -> Discr
DiscrW (Integer -> Word
forall a. Num a => Integer -> a
fromInteger Integer
w)
                       LitFloat Rational
r   -> Float -> Discr
DiscrF (Rational -> Float
forall a. Fractional a => Rational -> a
fromRational Rational
r)
                       LitDouble Rational
r  -> Double -> Discr
DiscrD (Rational -> Double
forall a. Fractional a => Rational -> a
fromRational Rational
r)
                       LitChar Char
i    -> Int -> Discr
DiscrI (Char -> Int
ord Char
i)
                       Literal
_ -> String -> SDoc -> Discr
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"schemeE(StgCase).my_discr" (Literal -> SDoc
forall a. Outputable a => a -> SDoc
ppr Literal
l)

        maybe_ncons :: Maybe Int
maybe_ncons
           | Bool -> Bool
not Bool
isAlgCase = Maybe Int
forall a. Maybe a
Nothing
           | Bool
otherwise
           = case [DataCon
dc | (DataAlt DataCon
dc, [Id]
_, GenStgExpr 'CodeGen
_) <- [(AltCon, [Id], GenStgExpr 'CodeGen)]
[CgStgAlt]
alts] of
                []     -> Maybe Int
forall a. Maybe a
Nothing
                (DataCon
dc:[DataCon]
_) -> Int -> Maybe Int
forall a. a -> Maybe a
Just (TyCon -> Int
tyConFamilySize (DataCon -> TyCon
dataConTyCon DataCon
dc))

        -- the bitmap is relative to stack depth d, i.e. before the
        -- BCO, info table and return value are pushed on.
        -- This bit of code is v. similar to buildLivenessMask in CgBindery,
        -- except that here we build the bitmap from the known bindings of
        -- things that are pointers, whereas in CgBindery the code builds the
        -- bitmap from the free slots and unboxed bindings.
        -- (ToDo: merge?)
        --
        -- NOTE [7/12/2006] bug #1013, testcase ghci/should_run/ghci002.
        -- The bitmap must cover the portion of the stack up to the sequel only.
        -- Previously we were building a bitmap for the whole depth (d), but we
        -- really want a bitmap up to depth (d-s).  This affects compilation of
        -- case-of-case expressions, which is the only time we can be compiling a
        -- case expression with s /= 0.

        -- unboxed tuples get two more words, the second is a pointer (tuple_bco)
        ([Int]
extra_pointers, Int
extra_slots)
           | Bool
ubx_tuple_frame Bool -> Bool -> Bool
&& Bool
profiling = ([Int
1], Int
3) -- tuple_info, tuple_BCO, CCCS
           | Bool
ubx_tuple_frame              = ([Int
1], Int
2) -- tuple_info, tuple_BCO
           | Bool
otherwise                    = ([], Int
0)

        bitmap_size :: Word16
bitmap_size = WordOff -> Word16
trunc16W (WordOff -> Word16) -> WordOff -> Word16
forall a b. (a -> b) -> a -> b
$ Int -> WordOff
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
extra_slots WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
+
                                 Platform -> ByteOff -> WordOff
bytesToWords Platform
platform (ByteOff
d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
- ByteOff
s)

        bitmap_size' :: Int
        bitmap_size' :: Int
bitmap_size' = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
bitmap_size


        pointers :: [Int]
pointers =
          [Int]
extra_pointers [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++
          [Int] -> [Int]
forall a. Ord a => [a] -> [a]
sort ((Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
bitmap_size') ((Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
extra_slots) [Int]
rel_slots))
          where
          binds :: [(Id, ByteOff)]
binds = Map Id ByteOff -> [(Id, ByteOff)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Id ByteOff
p
          -- NB: unboxed tuple cases bind the scrut binder to the same offset
          -- as one of the alt binders, so we have to remove any duplicates here:
          rel_slots :: [Int]
rel_slots = [Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ (Word16 -> Int) -> [Word16] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Word16] -> [Int]) -> [Word16] -> [Int]
forall a b. (a -> b) -> a -> b
$ ((Id, ByteOff) -> [Word16]) -> [(Id, ByteOff)] -> [Word16]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Id, ByteOff) -> [Word16]
spread [(Id, ByteOff)]
binds
          spread :: (Id, ByteOff) -> [Word16]
spread (Id
id, ByteOff
offset) | Kind -> Bool
isUnboxedTupleType (Id -> Kind
idType Id
id) Bool -> Bool -> Bool
||
                                Kind -> Bool
isUnboxedSumType (Id -> Kind
idType Id
id) = []
                              | ArgRep -> Bool
isFollowableArg (Platform -> Id -> ArgRep
bcIdArgRep Platform
platform Id
id) = [ Word16
rel_offset ]
                              | Bool
otherwise                      = []
                where rel_offset :: Word16
rel_offset = WordOff -> Word16
trunc16W (WordOff -> Word16) -> WordOff -> Word16
forall a b. (a -> b) -> a -> b
$ Platform -> ByteOff -> WordOff
bytesToWords Platform
platform (ByteOff
d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
- ByteOff
offset)

        bitmap :: [StgWord]
bitmap = Platform -> Int -> [Int] -> [StgWord]
intsToReverseBitmap Platform
platform Int
bitmap_size'{-size-} [Int]
pointers

     [(Discr, OrdList BCInstr)]
alt_stuff <- ((AltCon, [Id], GenStgExpr 'CodeGen)
 -> BcM (Discr, OrdList BCInstr))
-> [(AltCon, [Id], GenStgExpr 'CodeGen)]
-> BcM [(Discr, OrdList BCInstr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (AltCon, [Id], GenStgExpr 'CodeGen) -> BcM (Discr, OrdList BCInstr)
codeAlt [(AltCon, [Id], GenStgExpr 'CodeGen)]
[CgStgAlt]
alts
     OrdList BCInstr
alt_final <- Maybe Int -> [(Discr, OrdList BCInstr)] -> BcM (OrdList BCInstr)
mkMultiBranch Maybe Int
maybe_ncons [(Discr, OrdList BCInstr)]
alt_stuff

     let
         alt_bco_name :: Name
alt_bco_name = Id -> Name
forall a. NamedThing a => a -> Name
getName Id
bndr
         alt_bco :: [FFIInfo] -> ProtoBCO Name
alt_bco = Platform
-> Name
-> OrdList BCInstr
-> Either [CgStgAlt] CgStgRhs
-> Int
-> Word16
-> [StgWord]
-> Bool
-> [FFIInfo]
-> ProtoBCO Name
forall name.
Platform
-> name
-> OrdList BCInstr
-> Either [CgStgAlt] CgStgRhs
-> Int
-> Word16
-> [StgWord]
-> Bool
-> [FFIInfo]
-> ProtoBCO name
mkProtoBCO Platform
platform Name
alt_bco_name OrdList BCInstr
alt_final ([(AltCon, [Id], GenStgExpr 'CodeGen)]
-> Either [(AltCon, [Id], GenStgExpr 'CodeGen)] CgStgRhs
forall a b. a -> Either a b
Left [(AltCon, [Id], GenStgExpr 'CodeGen)]
[CgStgAlt]
alts)
                       Int
0{-no arity-} Word16
bitmap_size [StgWord]
bitmap Bool
True{-is alts-}
     OrdList BCInstr
scrut_code <- ByteOff
-> ByteOff
-> Map Id ByteOff
-> GenStgExpr 'CodeGen
-> BcM (OrdList BCInstr)
schemeE (ByteOff
d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ ByteOff
ret_frame_size_b ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ ByteOff
save_ccs_size_b)
                           (ByteOff
d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ ByteOff
ret_frame_size_b ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ ByteOff
save_ccs_size_b)
                           Map Id ByteOff
p GenStgExpr 'CodeGen
scrut
     ProtoBCO Name
alt_bco' <- ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
emitBc [FFIInfo] -> ProtoBCO Name
alt_bco
     if Bool
ubx_tuple_frame
       then do
              let args_ptrs :: [(Bool, ByteOff)]
args_ptrs =
                    ((PrimRep, ByteOff) -> (Bool, ByteOff))
-> [(PrimRep, ByteOff)] -> [(Bool, ByteOff)]
forall a b. (a -> b) -> [a] -> [b]
map (\(PrimRep
rep, ByteOff
off) -> (ArgRep -> Bool
isFollowableArg (Platform -> PrimRep -> ArgRep
toArgRep Platform
platform PrimRep
rep), ByteOff
off))
                        [(PrimRep, ByteOff)]
args_offsets
              ProtoBCO Name
tuple_bco <- ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
emitBc (Platform
-> TupleInfo -> [(Bool, ByteOff)] -> [FFIInfo] -> ProtoBCO Name
tupleBCO Platform
platform TupleInfo
tuple_info [(Bool, ByteOff)]
args_ptrs)
              OrdList BCInstr -> BcM (OrdList BCInstr)
forall (m :: * -> *) a. Monad m => a -> m a
return (ProtoBCO Name -> TupleInfo -> ProtoBCO Name -> BCInstr
PUSH_ALTS_TUPLE ProtoBCO Name
alt_bco' TupleInfo
tuple_info ProtoBCO Name
tuple_bco
                      BCInstr -> OrdList BCInstr -> OrdList BCInstr
forall a. a -> OrdList a -> OrdList a
`consOL` OrdList BCInstr
scrut_code)
       else let push_alts :: BCInstr
push_alts
                  | Bool -> Bool
not (HasDebugCallStack => Kind -> Bool
Kind -> Bool
isUnliftedType Kind
bndr_ty)
                  = ProtoBCO Name -> BCInstr
PUSH_ALTS ProtoBCO Name
alt_bco'
                  | Bool
otherwise
                  = let unlifted_rep :: ArgRep
unlifted_rep =
                          case [ArgRep]
non_void_arg_reps of
                            []    -> ArgRep
V
                            [ArgRep
rep] -> ArgRep
rep
                            [ArgRep]
_     -> String -> ArgRep
forall a. String -> a
panic String
"schemeE(StgCase).push_alts"
                    in ProtoBCO Name -> ArgRep -> BCInstr
PUSH_ALTS_UNLIFTED ProtoBCO Name
alt_bco' ArgRep
unlifted_rep
            in OrdList BCInstr -> BcM (OrdList BCInstr)
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstr
push_alts BCInstr -> OrdList BCInstr -> OrdList BCInstr
forall a. a -> OrdList a -> OrdList a
`consOL` OrdList BCInstr
scrut_code)


-- -----------------------------------------------------------------------------
-- Deal with tuples

-- The native calling convention uses registers for tuples, but in the
-- bytecode interpreter, all values live on the stack.

layoutTuple :: Profile
            -> ByteOff
            -> (a -> CmmType)
            -> [a]
            -> ( TupleInfo      -- See Note [GHCi TupleInfo]
               , [(a, ByteOff)] -- argument, offset on stack
               )
layoutTuple :: forall a.
Profile
-> ByteOff -> (a -> CmmType) -> [a] -> (TupleInfo, [(a, ByteOff)])
layoutTuple Profile
profile ByteOff
start_off a -> CmmType
arg_ty [a]
reps =
  let platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile
      (Int
orig_stk_bytes, [(a, ParamLocation)]
pos) = Profile
-> Int
-> Convention
-> (a -> CmmType)
-> [a]
-> (Int, [(a, ParamLocation)])
forall a.
Profile
-> Int
-> Convention
-> (a -> CmmType)
-> [a]
-> (Int, [(a, ParamLocation)])
assignArgumentsPos Profile
profile
                                                 Int
0
                                                 Convention
NativeReturn
                                                 a -> CmmType
arg_ty
                                                 [a]
reps

      -- keep the stack parameters in the same place
      orig_stk_params :: [(a, ByteOff)]
orig_stk_params = [(a
x, Int -> ByteOff
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
off) | (a
x, StackParam Int
off) <- [(a, ParamLocation)]
pos]

      -- sort the register parameters by register and add them to the stack
      regs_order :: Map.Map GlobalReg Int
      regs_order :: Map GlobalReg Int
regs_order = [(GlobalReg, Int)] -> Map GlobalReg Int
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(GlobalReg, Int)] -> Map GlobalReg Int)
-> [(GlobalReg, Int)] -> Map GlobalReg Int
forall a b. (a -> b) -> a -> b
$ [GlobalReg] -> [Int] -> [(GlobalReg, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Platform -> [GlobalReg]
tupleRegsCover Platform
platform) [Int
0..]

      reg_order :: GlobalReg -> (Int, GlobalReg)
      reg_order :: GlobalReg -> (Int, GlobalReg)
reg_order GlobalReg
reg | Just Int
n <- GlobalReg -> Map GlobalReg Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup GlobalReg
reg Map GlobalReg Int
regs_order = (Int
n, GlobalReg
reg)
      -- a VanillaReg goes to the same place regardless of whether it
      -- contains a pointer
      reg_order (VanillaReg Int
n VGcPtr
VNonGcPtr) = GlobalReg -> (Int, GlobalReg)
reg_order (Int -> VGcPtr -> GlobalReg
VanillaReg Int
n VGcPtr
VGcPtr)
      -- if we don't have a position for a FloatReg then they must be passed
      -- in the equivalent DoubleReg
      reg_order (FloatReg Int
n) = GlobalReg -> (Int, GlobalReg)
reg_order (Int -> GlobalReg
DoubleReg Int
n)
      -- one-tuples can be passed in other registers, but then we don't need
      -- to care about the order
      reg_order GlobalReg
reg          = (Int
0, GlobalReg
reg)

      ([(Int, GlobalReg)]
regs, [a]
reg_params)
          = [((Int, GlobalReg), a)] -> ([(Int, GlobalReg)], [a])
forall a b. [(a, b)] -> ([a], [b])
unzip ([((Int, GlobalReg), a)] -> ([(Int, GlobalReg)], [a]))
-> [((Int, GlobalReg), a)] -> ([(Int, GlobalReg)], [a])
forall a b. (a -> b) -> a -> b
$ (((Int, GlobalReg), a) -> ((Int, GlobalReg), a) -> Ordering)
-> [((Int, GlobalReg), a)] -> [((Int, GlobalReg), a)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((((Int, GlobalReg), a) -> (Int, GlobalReg))
-> ((Int, GlobalReg), a) -> ((Int, GlobalReg), a) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing ((Int, GlobalReg), a) -> (Int, GlobalReg)
forall a b. (a, b) -> a
fst)
                           [(GlobalReg -> (Int, GlobalReg)
reg_order GlobalReg
reg, a
x) | (a
x, RegisterParam GlobalReg
reg) <- [(a, ParamLocation)]
pos]

      (Int
new_stk_bytes, [(a, ParamLocation)]
new_stk_params) = Platform
-> Int -> (a -> CmmType) -> [a] -> (Int, [(a, ParamLocation)])
forall a.
Platform
-> Int -> (a -> CmmType) -> [a] -> (Int, [(a, ParamLocation)])
assignStack Platform
platform
                                                    Int
orig_stk_bytes
                                                    a -> CmmType
arg_ty
                                                    [a]
reg_params

      regs_set :: RegSet GlobalReg
regs_set = [GlobalReg] -> RegSet GlobalReg
forall r. Ord r => [r] -> RegSet r
mkRegSet (((Int, GlobalReg) -> GlobalReg)
-> [(Int, GlobalReg)] -> [GlobalReg]
forall a b. (a -> b) -> [a] -> [b]
map (Int, GlobalReg) -> GlobalReg
forall a b. (a, b) -> b
snd [(Int, GlobalReg)]
regs)

      get_byte_off :: (a, ParamLocation) -> (a, b)
get_byte_off (a
x, StackParam Int
y) = (a
x, Int -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
y)
      get_byte_off (a, ParamLocation)
_                 =
          String -> (a, b)
forall a. String -> a
panic String
"GHC.StgToByteCode.layoutTuple get_byte_off"

  in ( TupleInfo
         { tupleSize :: WordOff
tupleSize        = Platform -> ByteOff -> WordOff
bytesToWords Platform
platform (Int -> ByteOff
ByteOff Int
new_stk_bytes)
         , tupleRegs :: RegSet GlobalReg
tupleRegs        = RegSet GlobalReg
regs_set
         , tupleNativeStackSize :: WordOff
tupleNativeStackSize = Platform -> ByteOff -> WordOff
bytesToWords Platform
platform
                                               (Int -> ByteOff
ByteOff Int
orig_stk_bytes)
         }
     , ((a, ByteOff) -> (a, ByteOff) -> Ordering)
-> [(a, ByteOff)] -> [(a, ByteOff)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((a, ByteOff) -> ByteOff)
-> (a, ByteOff) -> (a, ByteOff) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (a, ByteOff) -> ByteOff
forall a b. (a, b) -> b
snd) ([(a, ByteOff)] -> [(a, ByteOff)])
-> [(a, ByteOff)] -> [(a, ByteOff)]
forall a b. (a -> b) -> a -> b
$
              ((a, ByteOff) -> (a, ByteOff)) -> [(a, ByteOff)] -> [(a, ByteOff)]
forall a b. (a -> b) -> [a] -> [b]
map (\(a
x, ByteOff
o) -> (a
x, ByteOff
o ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ ByteOff
start_off))
                  ([(a, ByteOff)]
orig_stk_params [(a, ByteOff)] -> [(a, ByteOff)] -> [(a, ByteOff)]
forall a. [a] -> [a] -> [a]
++ ((a, ParamLocation) -> (a, ByteOff))
-> [(a, ParamLocation)] -> [(a, ByteOff)]
forall a b. (a -> b) -> [a] -> [b]
map (a, ParamLocation) -> (a, ByteOff)
forall {b} {a}. Num b => (a, ParamLocation) -> (a, b)
get_byte_off [(a, ParamLocation)]
new_stk_params)
     )

{- Note [unboxed tuple bytecodes and tuple_BCO]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

  We have the bytecode instructions RETURN_TUPLE and PUSH_ALTS_TUPLE to
  return and receive arbitrary unboxed tuples, respectively. These
  instructions use the helper data tuple_BCO and tuple_info.

  The helper data is used to convert tuples between GHCs native calling
  convention (object code), which uses stack and registers, and the bytecode
  calling convention, which only uses the stack. See Note [GHCi TupleInfo]
  for more details.


  Returning a tuple
  =================

  Bytecode that returns a tuple first pushes all the tuple fields followed
  by the appropriate tuple_info and tuple_BCO onto the stack. It then
  executes the RETURN_TUPLE instruction, which causes the interpreter
  to push stg_ret_t_info to the top of the stack. The stack (growing down)
  then looks as follows:

      ...
      next_frame
      tuple_field_1
      tuple_field_2
      ...
      tuple_field_n
      tuple_info
      tuple_BCO
      stg_ret_t_info <- Sp

  If next_frame is bytecode, the interpreter will start executing it. If
  it's object code, the interpreter jumps back to the scheduler, which in
  turn jumps to stg_ret_t. stg_ret_t converts the tuple to the native
  calling convention using the description in tuple_info, and then jumps
  to next_frame.


  Receiving a tuple
  =================

  Bytecode that receives a tuple uses the PUSH_ALTS_TUPLE instruction to
  push a continuation, followed by jumping to the code that produces the
  tuple. The PUSH_ALTS_TUPLE instuction contains three pieces of data:

     * cont_BCO: the continuation that receives the tuple
     * tuple_info: see below
     * tuple_BCO: see below

  The interpreter pushes these onto the stack when the PUSH_ALTS_TUPLE
  instruction is executed, followed by stg_ctoi_tN_info, with N depending
  on the number of stack words used by the tuple in the GHC native calling
  convention. N is derived from tuple_info.

  For example if we expect a tuple with three words on the stack, the stack
  looks as follows after PUSH_ALTS_TUPLE:

      ...
      next_frame
      cont_free_var_1
      cont_free_var_2
      ...
      cont_free_var_n
      tuple_info
      tuple_BCO
      cont_BCO
      stg_ctoi_t3_info <- Sp

  If the tuple is returned by object code, stg_ctoi_t3 will deal with
  adjusting the stack pointer and converting the tuple to the bytecode
  calling convention. See Note [GHCi unboxed tuples stack spills] for more
  details.


  The tuple_BCO
  =============

  The tuple_BCO is a helper bytecode object. Its main purpose is describing
  the contents of the stack frame containing the tuple for the storage
  manager. It contains only instructions to immediately return the tuple
  that is already on the stack.


  The tuple_info word
  ===================

  The tuple_info word describes the stack and STG register (e.g. R1..R6,
  D1..D6) usage for the tuple. tuple_info contains enough information to
  convert the tuple between the stack-only bytecode and stack+registers
  GHC native calling conventions.

  See Note [GHCi tuple layout] for more details of how the data is packed
  in a single word.

 -}

tupleBCO :: Platform -> TupleInfo -> [(Bool, ByteOff)] -> [FFIInfo] -> ProtoBCO Name
tupleBCO :: Platform
-> TupleInfo -> [(Bool, ByteOff)] -> [FFIInfo] -> ProtoBCO Name
tupleBCO Platform
platform TupleInfo
info [(Bool, ByteOff)]
pointers =
  Platform
-> Name
-> OrdList BCInstr
-> Either [CgStgAlt] CgStgRhs
-> Int
-> Word16
-> [StgWord]
-> Bool
-> [FFIInfo]
-> ProtoBCO Name
forall name.
Platform
-> name
-> OrdList BCInstr
-> Either [CgStgAlt] CgStgRhs
-> Int
-> Word16
-> [StgWord]
-> Bool
-> [FFIInfo]
-> ProtoBCO name
mkProtoBCO Platform
platform Name
invented_name OrdList BCInstr
body_code ([(AltCon, [Id], GenStgExpr 'CodeGen)]
-> Either [(AltCon, [Id], GenStgExpr 'CodeGen)] CgStgRhs
forall a b. a -> Either a b
Left [])
             Int
0{-no arity-} Word16
bitmap_size [StgWord]
bitmap Bool
False{-is alts-}

  where
    {-
      The tuple BCO is never referred to by name, so we can get away
      with using a fake name here. We will need to change this if we want
      to save some memory by sharing the BCO between places that have
      the same tuple shape
    -}
    invented_name :: Name
invented_name  = Unique -> FastString -> Name
mkSystemVarName (Int -> Unique
mkPseudoUniqueE Int
0) (String -> FastString
fsLit String
"tuple")

    -- the first word in the frame is the tuple_info word,
    -- which is not a pointer
    bitmap_size :: Word16
bitmap_size = WordOff -> Word16
trunc16W (WordOff -> Word16) -> WordOff -> Word16
forall a b. (a -> b) -> a -> b
$ WordOff
1 WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
+ TupleInfo -> WordOff
tupleSize TupleInfo
info
    bitmap :: [StgWord]
bitmap      = Platform -> Int -> [Int] -> [StgWord]
intsToReverseBitmap Platform
platform (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
bitmap_size) ([Int] -> [StgWord]) -> [Int] -> [StgWord]
forall a b. (a -> b) -> a -> b
$
                  ((Bool, ByteOff) -> Int) -> [(Bool, ByteOff)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ((Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Int -> Int) -> ((Bool, ByteOff) -> Int) -> (Bool, ByteOff) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WordOff -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (WordOff -> Int)
-> ((Bool, ByteOff) -> WordOff) -> (Bool, ByteOff) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Platform -> ByteOff -> WordOff
bytesToWords Platform
platform (ByteOff -> WordOff)
-> ((Bool, ByteOff) -> ByteOff) -> (Bool, ByteOff) -> WordOff
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool, ByteOff) -> ByteOff
forall a b. (a, b) -> b
snd)
                      (((Bool, ByteOff) -> Bool) -> [(Bool, ByteOff)] -> [(Bool, ByteOff)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool, ByteOff) -> Bool
forall a b. (a, b) -> a
fst [(Bool, ByteOff)]
pointers)
    body_code :: OrdList BCInstr
body_code = Word16 -> WordOff -> OrdList BCInstr
mkSlideW Word16
0 WordOff
1          -- pop frame header
                OrdList BCInstr -> BCInstr -> OrdList BCInstr
forall a. OrdList a -> a -> OrdList a
`snocOL` BCInstr
RETURN_TUPLE -- and add it again

-- -----------------------------------------------------------------------------
-- Deal with a CCall.

-- Taggedly push the args onto the stack R->L,
-- deferencing ForeignObj#s and adjusting addrs to point to
-- payloads in Ptr/Byte arrays.  Then, generate the marshalling
-- (machine) code for the ccall, and create bytecodes to call that and
-- then return in the right way.

generateCCall
    :: StackDepth
    -> Sequel
    -> BCEnv
    -> CCallSpec               -- where to call
    -> Type
    -> [StgArg]              -- args (atoms)
    -> BcM BCInstrList
generateCCall :: ByteOff
-> ByteOff
-> Map Id ByteOff
-> CCallSpec
-> Kind
-> [StgArg]
-> BcM (OrdList BCInstr)
generateCCall ByteOff
d0 ByteOff
s Map Id ByteOff
p (CCallSpec CCallTarget
target CCallConv
cconv Safety
safety) Kind
result_ty [StgArg]
args_r_to_l
 = do
     Profile
profile <- BcM Profile
getProfile

     let
         platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile
         -- useful constants
         addr_size_b :: ByteOff
         addr_size_b :: ByteOff
addr_size_b = Platform -> ByteOff
wordSize Platform
platform

         arrayish_rep_hdr_size :: TyCon -> Maybe Int
         arrayish_rep_hdr_size :: TyCon -> Maybe Int
arrayish_rep_hdr_size TyCon
t
           | TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
arrayPrimTyCon Bool -> Bool -> Bool
|| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
mutableArrayPrimTyCon
              = Int -> Maybe Int
forall a. a -> Maybe a
Just (Profile -> Int
arrPtrsHdrSize Profile
profile)
           | TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
smallArrayPrimTyCon Bool -> Bool -> Bool
|| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
smallMutableArrayPrimTyCon
              = Int -> Maybe Int
forall a. a -> Maybe a
Just (Profile -> Int
smallArrPtrsHdrSize Profile
profile)
           | TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
byteArrayPrimTyCon Bool -> Bool -> Bool
|| TyCon
t TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
mutableByteArrayPrimTyCon
              = Int -> Maybe Int
forall a. a -> Maybe a
Just (Profile -> Int
arrWordsHdrSize Profile
profile)
           | Bool
otherwise
              = Maybe Int
forall a. Maybe a
Nothing

         -- Get the args on the stack, with tags and suitably
         -- dereferenced for the CCall.  For each arg, return the
         -- depth to the first word of the bits for that arg, and the
         -- ArgRep of what was actually pushed.

         pargs
             :: ByteOff -> [StgArg] -> BcM [(BCInstrList, PrimRep)]
         pargs :: ByteOff -> [StgArg] -> BcM [(OrdList BCInstr, PrimRep)]
pargs ByteOff
_ [] = [(OrdList BCInstr, PrimRep)] -> BcM [(OrdList BCInstr, PrimRep)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
         pargs ByteOff
d (aa :: StgArg
aa@(StgVarArg Id
a):[StgArg]
az)
            | Just TyCon
t      <- Kind -> Maybe TyCon
tyConAppTyCon_maybe (Id -> Kind
idType Id
a)
            , Just Int
hdr_sz <- TyCon -> Maybe Int
arrayish_rep_hdr_size TyCon
t
            -- Do magic for Ptr/Byte arrays.  Push a ptr to the array on
            -- the stack but then advance it over the headers, so as to
            -- point to the payload.
            = do [(OrdList BCInstr, PrimRep)]
rest <- ByteOff -> [StgArg] -> BcM [(OrdList BCInstr, PrimRep)]
pargs (ByteOff
d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ ByteOff
addr_size_b) [StgArg]
az
                 (OrdList BCInstr
push_fo, ByteOff
_) <- ByteOff
-> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr, ByteOff)
pushAtom ByteOff
d Map Id ByteOff
p StgArg
aa
                 -- The ptr points at the header.  Advance it over the
                 -- header and then pretend this is an Addr#.
                 let code :: OrdList BCInstr
code = OrdList BCInstr
push_fo OrdList BCInstr -> BCInstr -> OrdList BCInstr
forall a. OrdList a -> a -> OrdList a
`snocOL` Word16 -> Word16 -> BCInstr
SWIZZLE Word16
0 (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
hdr_sz)
                 [(OrdList BCInstr, PrimRep)] -> BcM [(OrdList BCInstr, PrimRep)]
forall (m :: * -> *) a. Monad m => a -> m a
return ((OrdList BCInstr
code, PrimRep
AddrRep) (OrdList BCInstr, PrimRep)
-> [(OrdList BCInstr, PrimRep)] -> [(OrdList BCInstr, PrimRep)]
forall a. a -> [a] -> [a]
: [(OrdList BCInstr, PrimRep)]
rest)
         pargs ByteOff
d (StgArg
aa:[StgArg]
az) =  do (OrdList BCInstr
code_a, ByteOff
sz_a) <- ByteOff
-> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr, ByteOff)
pushAtom ByteOff
d Map Id ByteOff
p StgArg
aa
                               [(OrdList BCInstr, PrimRep)]
rest <- ByteOff -> [StgArg] -> BcM [(OrdList BCInstr, PrimRep)]
pargs (ByteOff
d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ ByteOff
sz_a) [StgArg]
az
                               [(OrdList BCInstr, PrimRep)] -> BcM [(OrdList BCInstr, PrimRep)]
forall (m :: * -> *) a. Monad m => a -> m a
return ((OrdList BCInstr
code_a, StgArg -> PrimRep
atomPrimRep StgArg
aa) (OrdList BCInstr, PrimRep)
-> [(OrdList BCInstr, PrimRep)] -> [(OrdList BCInstr, PrimRep)]
forall a. a -> [a] -> [a]
: [(OrdList BCInstr, PrimRep)]
rest)

     [(OrdList BCInstr, PrimRep)]
code_n_reps <- ByteOff -> [StgArg] -> BcM [(OrdList BCInstr, PrimRep)]
pargs ByteOff
d0 [StgArg]
args_r_to_l
     let
         ([OrdList BCInstr]
pushs_arg, [PrimRep]
a_reps_pushed_r_to_l) = [(OrdList BCInstr, PrimRep)] -> ([OrdList BCInstr], [PrimRep])
forall a b. [(a, b)] -> ([a], [b])
unzip [(OrdList BCInstr, PrimRep)]
code_n_reps
         a_reps_sizeW :: WordOff
a_reps_sizeW = [WordOff] -> WordOff
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((PrimRep -> WordOff) -> [PrimRep] -> [WordOff]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> PrimRep -> WordOff
repSizeWords Platform
platform) [PrimRep]
a_reps_pushed_r_to_l)

         push_args :: OrdList BCInstr
push_args    = [OrdList BCInstr] -> OrdList BCInstr
forall a. [OrdList a] -> OrdList a
concatOL [OrdList BCInstr]
pushs_arg
         !d_after_args :: ByteOff
d_after_args = ByteOff
d0 ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ Platform -> WordOff -> ByteOff
wordsToBytes Platform
platform WordOff
a_reps_sizeW
         a_reps_pushed_RAW :: [PrimRep]
a_reps_pushed_RAW
            | [PrimRep] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PrimRep]
a_reps_pushed_r_to_l Bool -> Bool -> Bool
|| Bool -> Bool
not (PrimRep -> Bool
isVoidRep ([PrimRep] -> PrimRep
forall a. [a] -> a
head [PrimRep]
a_reps_pushed_r_to_l))
            = String -> [PrimRep]
forall a. String -> a
panic String
"GHC.StgToByteCode.generateCCall: missing or invalid World token?"
            | Bool
otherwise
            = [PrimRep] -> [PrimRep]
forall a. [a] -> [a]
reverse ([PrimRep] -> [PrimRep]
forall a. [a] -> [a]
tail [PrimRep]
a_reps_pushed_r_to_l)

         -- Now: a_reps_pushed_RAW are the reps which are actually on the stack.
         -- push_args is the code to do that.
         -- d_after_args is the stack depth once the args are on.

         -- Get the result rep.
         (Bool
returns_void, PrimRep
r_rep)
            = case Kind -> Maybe PrimRep
maybe_getCCallReturnRep Kind
result_ty of
                 Maybe PrimRep
Nothing -> (Bool
True,  PrimRep
VoidRep)
                 Just PrimRep
rr -> (Bool
False, PrimRep
rr)
         {-
         Because the Haskell stack grows down, the a_reps refer to
         lowest to highest addresses in that order.  The args for the call
         are on the stack.  Now push an unboxed Addr# indicating
         the C function to call.  Then push a dummy placeholder for the
         result.  Finally, emit a CCALL insn with an offset pointing to the
         Addr# just pushed, and a literal field holding the mallocville
         address of the piece of marshalling code we generate.
         So, just prior to the CCALL insn, the stack looks like this
         (growing down, as usual):

            <arg_n>
            ...
            <arg_1>
            Addr# address_of_C_fn
            <placeholder-for-result#> (must be an unboxed type)

         The interpreter then calls the marshall code mentioned
         in the CCALL insn, passing it (& <placeholder-for-result#>),
         that is, the addr of the topmost word in the stack.
         When this returns, the placeholder will have been
         filled in.  The placeholder is slid down to the sequel
         depth, and we RETURN.

         This arrangement makes it simple to do f-i-dynamic since the Addr#
         value is the first arg anyway.

         The marshalling code is generated specifically for this
         call site, and so knows exactly the (Haskell) stack
         offsets of the args, fn address and placeholder.  It
         copies the args to the C stack, calls the stacked addr,
         and parks the result back in the placeholder.  The interpreter
         calls it as a normal C call, assuming it has a signature
            void marshall_code ( StgWord* ptr_to_top_of_stack )
         -}
         -- resolve static address
         maybe_static_target :: Maybe Literal
         maybe_static_target :: Maybe Literal
maybe_static_target =
             case CCallTarget
target of
                 CCallTarget
DynamicTarget -> Maybe Literal
forall a. Maybe a
Nothing
                 StaticTarget SourceText
_ FastString
_ Maybe Unit
_ Bool
False ->
                   String -> Maybe Literal
forall a. String -> a
panic String
"generateCCall: unexpected FFI value import"
                 StaticTarget SourceText
_ FastString
target Maybe Unit
_ Bool
True ->
                   Literal -> Maybe Literal
forall a. a -> Maybe a
Just (FastString -> Maybe Int -> FunctionOrData -> Literal
LitLabel FastString
target Maybe Int
mb_size FunctionOrData
IsFunction)
                   where
                      mb_size :: Maybe Int
mb_size
                          | OS
OSMinGW32 <- Platform -> OS
platformOS Platform
platform
                          , CCallConv
StdCallConv <- CCallConv
cconv
                          = Int -> Maybe Int
forall a. a -> Maybe a
Just (WordOff -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral WordOff
a_reps_sizeW Int -> Int -> Int
forall a. Num a => a -> a -> a
* Platform -> Int
platformWordSizeInBytes Platform
platform)
                          | Bool
otherwise
                          = Maybe Int
forall a. Maybe a
Nothing

     let
         is_static :: Bool
is_static = Maybe Literal -> Bool
forall a. Maybe a -> Bool
isJust Maybe Literal
maybe_static_target

         -- Get the arg reps, zapping the leading Addr# in the dynamic case
         a_reps :: [PrimRep]
a_reps --  | trace (showSDoc (ppr a_reps_pushed_RAW)) False = error "???"
                | Bool
is_static = [PrimRep]
a_reps_pushed_RAW
                | Bool
otherwise = if [PrimRep] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PrimRep]
a_reps_pushed_RAW
                              then String -> [PrimRep]
forall a. String -> a
panic String
"GHC.StgToByteCode.generateCCall: dyn with no args"
                              else [PrimRep] -> [PrimRep]
forall a. [a] -> [a]
tail [PrimRep]
a_reps_pushed_RAW

         -- push the Addr#
         (OrdList BCInstr
push_Addr, ByteOff
d_after_Addr)
            | Just Literal
machlabel <- Maybe Literal
maybe_static_target
            = ([BCInstr] -> OrdList BCInstr
forall a. [a] -> OrdList a
toOL [Literal -> Word16 -> BCInstr
PUSH_UBX Literal
machlabel Word16
1], ByteOff
d_after_args ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ ByteOff
addr_size_b)
            | Bool
otherwise -- is already on the stack
            = (OrdList BCInstr
forall a. OrdList a
nilOL, ByteOff
d_after_args)

         -- Push the return placeholder.  For a call returning nothing,
         -- this is a V (tag).
         r_sizeW :: WordOff
r_sizeW   = Platform -> PrimRep -> WordOff
repSizeWords Platform
platform PrimRep
r_rep
         d_after_r :: ByteOff
d_after_r = ByteOff
d_after_Addr ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ Platform -> WordOff -> ByteOff
wordsToBytes Platform
platform WordOff
r_sizeW
         push_r :: OrdList BCInstr
push_r =
             if Bool
returns_void
                then OrdList BCInstr
forall a. OrdList a
nilOL
                else BCInstr -> OrdList BCInstr
forall a. a -> OrdList a
unitOL (Literal -> Word16 -> BCInstr
PUSH_UBX (Platform -> PrimRep -> Literal
mkDummyLiteral Platform
platform PrimRep
r_rep) (WordOff -> Word16
trunc16W WordOff
r_sizeW))

         -- generate the marshalling code we're going to call

         -- Offset of the next stack frame down the stack.  The CCALL
         -- instruction needs to describe the chunk of stack containing
         -- the ccall args to the GC, so it needs to know how large it
         -- is.  See comment in Interpreter.c with the CCALL instruction.
         stk_offset :: Word16
stk_offset   = WordOff -> Word16
trunc16W (WordOff -> Word16) -> WordOff -> Word16
forall a b. (a -> b) -> a -> b
$ Platform -> ByteOff -> WordOff
bytesToWords Platform
platform (ByteOff
d_after_r ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
- ByteOff
s)

         conv :: FFIConv
conv = case CCallConv
cconv of
           CCallConv
CCallConv -> FFIConv
FFICCall
           CCallConv
StdCallConv -> FFIConv
FFIStdCall
           CCallConv
_ -> String -> FFIConv
forall a. String -> a
panic String
"GHC.StgToByteCode: unexpected calling convention"

     -- the only difference in libffi mode is that we prepare a cif
     -- describing the call type by calling libffi, and we attach the
     -- address of this to the CCALL instruction.


     let ffires :: FFIType
ffires = Platform -> PrimRep -> FFIType
primRepToFFIType Platform
platform PrimRep
r_rep
         ffiargs :: [FFIType]
ffiargs = (PrimRep -> FFIType) -> [PrimRep] -> [FFIType]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> PrimRep -> FFIType
primRepToFFIType Platform
platform) [PrimRep]
a_reps
     Interp
interp <- HscEnv -> Interp
hscInterp (HscEnv -> Interp) -> BcM HscEnv -> BcM Interp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BcM HscEnv
getHscEnv
     RemotePtr C_ffi_cif
token <- IO (RemotePtr C_ffi_cif) -> BcM (RemotePtr C_ffi_cif)
forall a. IO a -> BcM a
ioToBc (IO (RemotePtr C_ffi_cif) -> BcM (RemotePtr C_ffi_cif))
-> IO (RemotePtr C_ffi_cif) -> BcM (RemotePtr C_ffi_cif)
forall a b. (a -> b) -> a -> b
$ Interp -> Message (RemotePtr C_ffi_cif) -> IO (RemotePtr C_ffi_cif)
forall a. Binary a => Interp -> Message a -> IO a
interpCmd Interp
interp (FFIConv -> [FFIType] -> FFIType -> Message (RemotePtr C_ffi_cif)
PrepFFI FFIConv
conv [FFIType]
ffiargs FFIType
ffires)
     RemotePtr C_ffi_cif -> BcM ()
recordFFIBc RemotePtr C_ffi_cif
token

     let
         -- do the call
         do_call :: OrdList BCInstr
do_call      = BCInstr -> OrdList BCInstr
forall a. a -> OrdList a
unitOL (Word16 -> RemotePtr C_ffi_cif -> Word16 -> BCInstr
CCALL Word16
stk_offset RemotePtr C_ffi_cif
token Word16
flags)
           where flags :: Word16
flags = case Safety
safety of
                           Safety
PlaySafe          -> Word16
0x0
                           Safety
PlayInterruptible -> Word16
0x1
                           Safety
PlayRisky         -> Word16
0x2

         -- slide and return
         d_after_r_min_s :: WordOff
d_after_r_min_s = Platform -> ByteOff -> WordOff
bytesToWords Platform
platform (ByteOff
d_after_r ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
- ByteOff
s)
         wrapup :: OrdList BCInstr
wrapup       = Word16 -> WordOff -> OrdList BCInstr
mkSlideW (WordOff -> Word16
trunc16W WordOff
r_sizeW) (WordOff
d_after_r_min_s WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
- WordOff
r_sizeW)
                        OrdList BCInstr -> BCInstr -> OrdList BCInstr
forall a. OrdList a -> a -> OrdList a
`snocOL` ArgRep -> BCInstr
RETURN_UNLIFTED (Platform -> PrimRep -> ArgRep
toArgRep Platform
platform PrimRep
r_rep)
         --trace (show (arg1_offW, args_offW  ,  (map argRepSizeW a_reps) )) $
     OrdList BCInstr -> BcM (OrdList BCInstr)
forall (m :: * -> *) a. Monad m => a -> m a
return (
         OrdList BCInstr
push_args OrdList BCInstr -> OrdList BCInstr -> OrdList BCInstr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
         OrdList BCInstr
push_Addr OrdList BCInstr -> OrdList BCInstr -> OrdList BCInstr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList BCInstr
push_r OrdList BCInstr -> OrdList BCInstr -> OrdList BCInstr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList BCInstr
do_call OrdList BCInstr -> OrdList BCInstr -> OrdList BCInstr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList BCInstr
wrapup
         )

primRepToFFIType :: Platform -> PrimRep -> FFIType
primRepToFFIType :: Platform -> PrimRep -> FFIType
primRepToFFIType Platform
platform PrimRep
r
  = case PrimRep
r of
     PrimRep
VoidRep     -> FFIType
FFIVoid
     PrimRep
IntRep      -> FFIType
signed_word
     PrimRep
WordRep     -> FFIType
unsigned_word
     PrimRep
Int8Rep     -> FFIType
FFISInt8
     PrimRep
Word8Rep    -> FFIType
FFIUInt8
     PrimRep
Int16Rep    -> FFIType
FFISInt16
     PrimRep
Word16Rep   -> FFIType
FFIUInt16
     PrimRep
Int32Rep    -> FFIType
FFISInt32
     PrimRep
Word32Rep   -> FFIType
FFIUInt32
     PrimRep
Int64Rep    -> FFIType
FFISInt64
     PrimRep
Word64Rep   -> FFIType
FFIUInt64
     PrimRep
AddrRep     -> FFIType
FFIPointer
     PrimRep
FloatRep    -> FFIType
FFIFloat
     PrimRep
DoubleRep   -> FFIType
FFIDouble
     PrimRep
_           -> String -> FFIType
forall a. String -> a
panic String
"primRepToFFIType"
  where
    (FFIType
signed_word, FFIType
unsigned_word) = case Platform -> PlatformWordSize
platformWordSize Platform
platform of
       PlatformWordSize
PW4 -> (FFIType
FFISInt32, FFIType
FFIUInt32)
       PlatformWordSize
PW8 -> (FFIType
FFISInt64, FFIType
FFIUInt64)

-- Make a dummy literal, to be used as a placeholder for FFI return
-- values on the stack.
mkDummyLiteral :: Platform -> PrimRep -> Literal
mkDummyLiteral :: Platform -> PrimRep -> Literal
mkDummyLiteral Platform
platform PrimRep
pr
   = case PrimRep
pr of
        PrimRep
IntRep    -> Platform -> Integer -> Literal
mkLitInt  Platform
platform Integer
0
        PrimRep
WordRep   -> Platform -> Integer -> Literal
mkLitWord Platform
platform Integer
0
        PrimRep
Int8Rep   -> Integer -> Literal
mkLitInt8 Integer
0
        PrimRep
Word8Rep  -> Integer -> Literal
mkLitWord8 Integer
0
        PrimRep
Int16Rep  -> Integer -> Literal
mkLitInt16 Integer
0
        PrimRep
Word16Rep -> Integer -> Literal
mkLitWord16 Integer
0
        PrimRep
Int32Rep  -> Integer -> Literal
mkLitInt32 Integer
0
        PrimRep
Word32Rep -> Integer -> Literal
mkLitWord32 Integer
0
        PrimRep
Int64Rep  -> Integer -> Literal
mkLitInt64 Integer
0
        PrimRep
Word64Rep -> Integer -> Literal
mkLitWord64 Integer
0
        PrimRep
AddrRep   -> Literal
LitNullAddr
        PrimRep
DoubleRep -> Rational -> Literal
LitDouble Rational
0
        PrimRep
FloatRep  -> Rational -> Literal
LitFloat Rational
0
        PrimRep
_         -> String -> SDoc -> Literal
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"mkDummyLiteral" (PrimRep -> SDoc
forall a. Outputable a => a -> SDoc
ppr PrimRep
pr)


-- Convert (eg)
--     GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld
--                   -> (# GHC.Prim.State# GHC.Prim.RealWorld, GHC.Prim.Int# #)
--
-- to  Just IntRep
-- and check that an unboxed pair is returned wherein the first arg is V'd.
--
-- Alternatively, for call-targets returning nothing, convert
--
--     GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld
--                   -> (# GHC.Prim.State# GHC.Prim.RealWorld #)
--
-- to  Nothing

maybe_getCCallReturnRep :: Type -> Maybe PrimRep
maybe_getCCallReturnRep :: Kind -> Maybe PrimRep
maybe_getCCallReturnRep Kind
fn_ty
   = let
       ([Scaled Kind]
_a_tys, Kind
r_ty) = Kind -> ([Scaled Kind], Kind)
splitFunTys (Kind -> Kind
dropForAlls Kind
fn_ty)
       r_reps :: [PrimRep]
r_reps = HasDebugCallStack => Kind -> [PrimRep]
Kind -> [PrimRep]
typePrimRepArgs Kind
r_ty

       blargh :: a -- Used at more than one type
       blargh :: forall a. a
blargh = String -> SDoc -> a
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"maybe_getCCallReturn: can't handle:"
                         (Kind -> SDoc
pprType Kind
fn_ty)
     in
       case [PrimRep]
r_reps of
         []            -> String -> Maybe PrimRep
forall a. String -> a
panic String
"empty typePrimRepArgs"
         [PrimRep
VoidRep]     -> Maybe PrimRep
forall a. Maybe a
Nothing
         [PrimRep
rep]
           | PrimRep -> Bool
isGcPtrRep PrimRep
rep -> Maybe PrimRep
forall a. a
blargh
           | Bool
otherwise      -> PrimRep -> Maybe PrimRep
forall a. a -> Maybe a
Just PrimRep
rep

                 -- if it was, it would be impossible to create a
                 -- valid return value placeholder on the stack
         [PrimRep]
_             -> Maybe PrimRep
forall a. a
blargh

maybe_is_tagToEnum_call :: CgStgExpr -> Maybe (Id, [Name])
-- Detect and extract relevant info for the tagToEnum kludge.
maybe_is_tagToEnum_call :: GenStgExpr 'CodeGen -> Maybe (Id, [Name])
maybe_is_tagToEnum_call (StgOpApp (StgPrimOp PrimOp
TagToEnumOp) [StgVarArg Id
v] Kind
t)
  = (Id, [Name]) -> Maybe (Id, [Name])
forall a. a -> Maybe a
Just (Id
v, Kind -> [Name]
extract_constr_Names Kind
t)
  where
    extract_constr_Names :: Kind -> [Name]
extract_constr_Names Kind
ty
           | Kind
rep_ty <- Kind -> Kind
unwrapType Kind
ty
           , Just TyCon
tyc <- Kind -> Maybe TyCon
tyConAppTyCon_maybe Kind
rep_ty
           , TyCon -> Bool
isDataTyCon TyCon
tyc
           = (DataCon -> Name) -> [DataCon] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Id -> Name
forall a. NamedThing a => a -> Name
getName (Id -> Name) -> (DataCon -> Id) -> DataCon -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataCon -> Id
dataConWorkId) (TyCon -> [DataCon]
tyConDataCons TyCon
tyc)
           -- NOTE: use the worker name, not the source name of
           -- the DataCon.  See "GHC.Core.DataCon" for details.
           | Bool
otherwise
           = String -> SDoc -> [Name]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"maybe_is_tagToEnum_call.extract_constr_Ids" (Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
ty)
maybe_is_tagToEnum_call GenStgExpr 'CodeGen
_ = Maybe (Id, [Name])
forall a. Maybe a
Nothing

{- -----------------------------------------------------------------------------
Note [Implementing tagToEnum#]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(implement_tagToId arg names) compiles code which takes an argument
'arg', (call it i), and enters the i'th closure in the supplied list
as a consequence.  The [Name] is a list of the constructors of this
(enumeration) type.

The code we generate is this:
                push arg
                push bogus-word

                TESTEQ_I 0 L1
                  PUSH_G <lbl for first data con>
                  JMP L_Exit

        L1:     TESTEQ_I 1 L2
                  PUSH_G <lbl for second data con>
                  JMP L_Exit
        ...etc...
        Ln:     TESTEQ_I n L_fail
                  PUSH_G <lbl for last data con>
                  JMP L_Exit

        L_fail: CASEFAIL

        L_exit: SLIDE 1 n
                ENTER

The 'bogus-word' push is because TESTEQ_I expects the top of the stack
to have an info-table, and the next word to have the value to be
tested.  This is very weird, but it's the way it is right now.  See
Interpreter.c.  We don't actually need an info-table here; we just
need to have the argument to be one-from-top on the stack, hence pushing
a 1-word null. See #8383.
-}


implement_tagToId
    :: StackDepth
    -> Sequel
    -> BCEnv
    -> Id
    -> [Name]
    -> BcM BCInstrList
-- See Note [Implementing tagToEnum#]
implement_tagToId :: ByteOff
-> ByteOff
-> Map Id ByteOff
-> Id
-> [Name]
-> BcM (OrdList BCInstr)
implement_tagToId ByteOff
d ByteOff
s Map Id ByteOff
p Id
arg [Name]
names
  = ASSERT( notNull names )
    do (OrdList BCInstr
push_arg, ByteOff
arg_bytes) <- ByteOff
-> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr, ByteOff)
pushAtom ByteOff
d Map Id ByteOff
p (Id -> StgArg
StgVarArg Id
arg)
       [LocalLabel]
labels <- Word32 -> BcM [LocalLabel]
getLabelsBc ([Name] -> Word32
forall i a. Num i => [a] -> i
genericLength [Name]
names)
       LocalLabel
label_fail <- BcM LocalLabel
getLabelBc
       LocalLabel
label_exit <- BcM LocalLabel
getLabelBc
       DynFlags
dflags <- BcM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       let infos :: [(LocalLabel, LocalLabel, Int, Name)]
infos = [LocalLabel]
-> [LocalLabel]
-> [Int]
-> [Name]
-> [(LocalLabel, LocalLabel, Int, Name)]
forall a b c d. [a] -> [b] -> [c] -> [d] -> [(a, b, c, d)]
zip4 [LocalLabel]
labels ([LocalLabel] -> [LocalLabel]
forall a. [a] -> [a]
tail [LocalLabel]
labels [LocalLabel] -> [LocalLabel] -> [LocalLabel]
forall a. [a] -> [a] -> [a]
++ [LocalLabel
label_fail])
                               [Int
0 ..] [Name]
names
           platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
           steps :: [OrdList BCInstr]
steps = ((LocalLabel, LocalLabel, Int, Name) -> OrdList BCInstr)
-> [(LocalLabel, LocalLabel, Int, Name)] -> [OrdList BCInstr]
forall a b. (a -> b) -> [a] -> [b]
map (LocalLabel
-> (LocalLabel, LocalLabel, Int, Name) -> OrdList BCInstr
mkStep LocalLabel
label_exit) [(LocalLabel, LocalLabel, Int, Name)]
infos
           slide_ws :: WordOff
slide_ws = Platform -> ByteOff -> WordOff
bytesToWords Platform
platform (ByteOff
d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
- ByteOff
s ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ ByteOff
arg_bytes)

       OrdList BCInstr -> BcM (OrdList BCInstr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList BCInstr
push_arg
               OrdList BCInstr -> OrdList BCInstr -> OrdList BCInstr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` BCInstr -> OrdList BCInstr
forall a. a -> OrdList a
unitOL (Literal -> Word16 -> BCInstr
PUSH_UBX Literal
LitNullAddr Word16
1)
                   -- Push bogus word (see Note [Implementing tagToEnum#])
               OrdList BCInstr -> OrdList BCInstr -> OrdList BCInstr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [OrdList BCInstr] -> OrdList BCInstr
forall a. [OrdList a] -> OrdList a
concatOL [OrdList BCInstr]
steps
               OrdList BCInstr -> OrdList BCInstr -> OrdList BCInstr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [BCInstr] -> OrdList BCInstr
forall a. [a] -> OrdList a
toOL [ LocalLabel -> BCInstr
LABEL LocalLabel
label_fail, BCInstr
CASEFAIL,
                              LocalLabel -> BCInstr
LABEL LocalLabel
label_exit ]
               OrdList BCInstr -> OrdList BCInstr -> OrdList BCInstr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Word16 -> WordOff -> OrdList BCInstr
mkSlideW Word16
1 (WordOff
slide_ws WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
+ WordOff
1)
                   -- "+1" to account for bogus word
                   --      (see Note [Implementing tagToEnum#])
               OrdList BCInstr -> OrdList BCInstr -> OrdList BCInstr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` BCInstr -> OrdList BCInstr
forall a. a -> OrdList a
unitOL BCInstr
ENTER)
  where
        mkStep :: LocalLabel
-> (LocalLabel, LocalLabel, Int, Name) -> OrdList BCInstr
mkStep LocalLabel
l_exit (LocalLabel
my_label, LocalLabel
next_label, Int
n, Name
name_for_n)
           = [BCInstr] -> OrdList BCInstr
forall a. [a] -> OrdList a
toOL [LocalLabel -> BCInstr
LABEL LocalLabel
my_label,
                   Int -> LocalLabel -> BCInstr
TESTEQ_I Int
n LocalLabel
next_label,
                   Name -> BCInstr
PUSH_G Name
name_for_n,
                   LocalLabel -> BCInstr
JMP LocalLabel
l_exit]


-- -----------------------------------------------------------------------------
-- pushAtom

-- Push an atom onto the stack, returning suitable code & number of
-- stack words used.
--
-- The env p must map each variable to the highest- numbered stack
-- slot for it.  For example, if the stack has depth 4 and we
-- tagged-ly push (v :: Int#) on it, the value will be in stack[4],
-- the tag in stack[5], the stack will have depth 6, and p must map v
-- to 5 and not to 4.  Stack locations are numbered from zero, so a
-- depth 6 stack has valid words 0 .. 5.

pushAtom
    :: StackDepth -> BCEnv -> StgArg -> BcM (BCInstrList, ByteOff)

-- See Note [Empty case alternatives] in GHC.Core
-- and Note [Bottoming expressions] in GHC.Core.Utils:
-- The scrutinee of an empty case evaluates to bottom
pushAtom :: ByteOff
-> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr, ByteOff)
pushAtom ByteOff
d Map Id ByteOff
p (StgVarArg Id
var)
   | [] <- HasDebugCallStack => Kind -> [PrimRep]
Kind -> [PrimRep]
typePrimRep (Id -> Kind
idType Id
var)
   = (OrdList BCInstr, ByteOff) -> BcM (OrdList BCInstr, ByteOff)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList BCInstr
forall a. OrdList a
nilOL, ByteOff
0)

   | Id -> Bool
isFCallId Id
var
   = String -> SDoc -> BcM (OrdList BCInstr, ByteOff)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"pushAtom: shouldn't get an FCallId here" (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
var)

   | Just PrimOp
primop <- Id -> Maybe PrimOp
isPrimOpId_maybe Id
var
   = do
       Platform
platform <- DynFlags -> Platform
targetPlatform (DynFlags -> Platform) -> BcM DynFlags -> BcM Platform
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BcM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       (OrdList BCInstr, ByteOff) -> BcM (OrdList BCInstr, ByteOff)
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstr -> OrdList BCInstr
forall a. a -> OrdList a
unitOL (PrimOp -> BCInstr
PUSH_PRIMOP PrimOp
primop), Platform -> ByteOff
wordSize Platform
platform)

   | Just ByteOff
d_v <- Id -> Map Id ByteOff -> Maybe ByteOff
lookupBCEnv_maybe Id
var Map Id ByteOff
p  -- var is a local variable
   = do Platform
platform <- DynFlags -> Platform
targetPlatform (DynFlags -> Platform) -> BcM DynFlags -> BcM Platform
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BcM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags

        let !szb :: ByteOff
szb = Platform -> Id -> ByteOff
idSizeCon Platform
platform Id
var
            with_instr :: (Word16 -> BCInstr) -> BcM (OrdList BCInstr, ByteOff)
with_instr Word16 -> BCInstr
instr = do
                let !off_b :: Word16
off_b = ByteOff -> Word16
trunc16B (ByteOff -> Word16) -> ByteOff -> Word16
forall a b. (a -> b) -> a -> b
$ ByteOff
d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
- ByteOff
d_v
                (OrdList BCInstr, ByteOff) -> BcM (OrdList BCInstr, ByteOff)
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstr -> OrdList BCInstr
forall a. a -> OrdList a
unitOL (Word16 -> BCInstr
instr Word16
off_b), Platform -> ByteOff
wordSize Platform
platform)

        case ByteOff
szb of
            ByteOff
1 -> (Word16 -> BCInstr) -> BcM (OrdList BCInstr, ByteOff)
with_instr Word16 -> BCInstr
PUSH8_W
            ByteOff
2 -> (Word16 -> BCInstr) -> BcM (OrdList BCInstr, ByteOff)
with_instr Word16 -> BCInstr
PUSH16_W
            ByteOff
4 -> (Word16 -> BCInstr) -> BcM (OrdList BCInstr, ByteOff)
with_instr Word16 -> BCInstr
PUSH32_W
            ByteOff
_ -> do
                let !szw :: WordOff
szw = Platform -> ByteOff -> WordOff
bytesToWords Platform
platform ByteOff
szb
                    !off_w :: Word16
off_w = WordOff -> Word16
trunc16W (WordOff -> Word16) -> WordOff -> Word16
forall a b. (a -> b) -> a -> b
$ Platform -> ByteOff -> WordOff
bytesToWords Platform
platform (ByteOff
d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
- ByteOff
d_v) WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
+ WordOff
szw WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
- WordOff
1
                (OrdList BCInstr, ByteOff) -> BcM (OrdList BCInstr, ByteOff)
forall (m :: * -> *) a. Monad m => a -> m a
return ([BCInstr] -> OrdList BCInstr
forall a. [a] -> OrdList a
toOL (WordOff -> BCInstr -> [BCInstr]
forall i a. Integral i => i -> a -> [a]
genericReplicate WordOff
szw (Word16 -> BCInstr
PUSH_L Word16
off_w)),
                              Platform -> WordOff -> ByteOff
wordsToBytes Platform
platform WordOff
szw)
        -- d - d_v           offset from TOS to the first slot of the object
        --
        -- d - d_v + sz - 1  offset from the TOS of the last slot of the object
        --
        -- Having found the last slot, we proceed to copy the right number of
        -- slots on to the top of the stack.

   | Bool
otherwise  -- var must be a global variable
   = do IdEnv (RemotePtr ())
topStrings <- BcM (IdEnv (RemotePtr ()))
getTopStrings
        Platform
platform <- DynFlags -> Platform
targetPlatform (DynFlags -> Platform) -> BcM DynFlags -> BcM Platform
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BcM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
        case IdEnv (RemotePtr ()) -> Id -> Maybe (RemotePtr ())
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv IdEnv (RemotePtr ())
topStrings Id
var of
            Just RemotePtr ()
ptr -> ByteOff
-> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr, ByteOff)
pushAtom ByteOff
d Map Id ByteOff
p (StgArg -> BcM (OrdList BCInstr, ByteOff))
-> StgArg -> BcM (OrdList BCInstr, ByteOff)
forall a b. (a -> b) -> a -> b
$ Literal -> StgArg
StgLitArg (Literal -> StgArg) -> Literal -> StgArg
forall a b. (a -> b) -> a -> b
$ Platform -> Integer -> Literal
mkLitWord Platform
platform (Integer -> Literal) -> Integer -> Literal
forall a b. (a -> b) -> a -> b
$
              WordPtr -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (WordPtr -> Integer) -> WordPtr -> Integer
forall a b. (a -> b) -> a -> b
$ Ptr () -> WordPtr
forall a. Ptr a -> WordPtr
ptrToWordPtr (Ptr () -> WordPtr) -> Ptr () -> WordPtr
forall a b. (a -> b) -> a -> b
$ RemotePtr () -> Ptr ()
forall a. RemotePtr a -> Ptr a
fromRemotePtr RemotePtr ()
ptr
            Maybe (RemotePtr ())
Nothing -> do
                let sz :: ByteOff
sz = Platform -> Id -> ByteOff
idSizeCon Platform
platform Id
var
                MASSERT( sz == wordSize platform )
                (OrdList BCInstr, ByteOff) -> BcM (OrdList BCInstr, ByteOff)
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstr -> OrdList BCInstr
forall a. a -> OrdList a
unitOL (Name -> BCInstr
PUSH_G (Id -> Name
forall a. NamedThing a => a -> Name
getName Id
var)), ByteOff
sz)


pushAtom ByteOff
_ Map Id ByteOff
_ (StgLitArg Literal
lit) = Bool -> Literal -> BcM (OrdList BCInstr, ByteOff)
pushLiteral Bool
True Literal
lit

pushLiteral :: Bool -> Literal -> BcM (BCInstrList, ByteOff)
pushLiteral :: Bool -> Literal -> BcM (OrdList BCInstr, ByteOff)
pushLiteral Bool
padded Literal
lit =
  do
     Platform
platform <- DynFlags -> Platform
targetPlatform (DynFlags -> Platform) -> BcM DynFlags -> BcM Platform
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BcM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
     let code :: PrimRep -> BcM (BCInstrList, ByteOff)
         code :: PrimRep -> BcM (OrdList BCInstr, ByteOff)
code PrimRep
rep =
            (OrdList BCInstr, ByteOff) -> BcM (OrdList BCInstr, ByteOff)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList BCInstr
padding_instr OrdList BCInstr -> BCInstr -> OrdList BCInstr
forall a. OrdList a -> a -> OrdList a
`snocOL` BCInstr
instr, ByteOff
size_bytes ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ ByteOff
padding_bytes)
          where
            size_bytes :: ByteOff
size_bytes = Int -> ByteOff
ByteOff (Int -> ByteOff) -> Int -> ByteOff
forall a b. (a -> b) -> a -> b
$ Platform -> PrimRep -> Int
primRepSizeB Platform
platform PrimRep
rep

            -- Here we handle the non-word-width cases specifically since we
            -- must emit different bytecode for them.

            round_to_words :: ByteOff -> ByteOff
round_to_words (ByteOff Int
bytes) =
              Int -> ByteOff
ByteOff (Platform -> Int -> Int
roundUpToWords Platform
platform Int
bytes)

            padding_bytes :: ByteOff
padding_bytes
                | Bool
padded    = ByteOff -> ByteOff
round_to_words ByteOff
size_bytes ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
- ByteOff
size_bytes
                | Bool
otherwise = ByteOff
0

            (OrdList BCInstr
padding_instr, ByteOff
_) = ByteOff -> (OrdList BCInstr, ByteOff)
pushPadding ByteOff
padding_bytes

            instr :: BCInstr
instr =
              case ByteOff
size_bytes of
                ByteOff
1  -> Literal -> BCInstr
PUSH_UBX8 Literal
lit
                ByteOff
2  -> Literal -> BCInstr
PUSH_UBX16 Literal
lit
                ByteOff
4  -> Literal -> BCInstr
PUSH_UBX32 Literal
lit
                ByteOff
_  -> Literal -> Word16 -> BCInstr
PUSH_UBX Literal
lit (WordOff -> Word16
trunc16W (WordOff -> Word16) -> WordOff -> Word16
forall a b. (a -> b) -> a -> b
$ Platform -> ByteOff -> WordOff
bytesToWords Platform
platform ByteOff
size_bytes)

     case Literal
lit of
        LitLabel {}     -> PrimRep -> BcM (OrdList BCInstr, ByteOff)
code PrimRep
AddrRep
        LitFloat {}     -> PrimRep -> BcM (OrdList BCInstr, ByteOff)
code PrimRep
FloatRep
        LitDouble {}    -> PrimRep -> BcM (OrdList BCInstr, ByteOff)
code PrimRep
DoubleRep
        LitChar {}      -> PrimRep -> BcM (OrdList BCInstr, ByteOff)
code PrimRep
WordRep
        Literal
LitNullAddr     -> PrimRep -> BcM (OrdList BCInstr, ByteOff)
code PrimRep
AddrRep
        LitString {}    -> PrimRep -> BcM (OrdList BCInstr, ByteOff)
code PrimRep
AddrRep
        LitRubbish {}   -> PrimRep -> BcM (OrdList BCInstr, ByteOff)
code PrimRep
WordRep
        LitNumber LitNumType
nt Integer
_  -> case LitNumType
nt of
          LitNumType
LitNumInt     -> PrimRep -> BcM (OrdList BCInstr, ByteOff)
code PrimRep
IntRep
          LitNumType
LitNumWord    -> PrimRep -> BcM (OrdList BCInstr, ByteOff)
code PrimRep
WordRep
          LitNumType
LitNumInt8    -> PrimRep -> BcM (OrdList BCInstr, ByteOff)
code PrimRep
Int8Rep
          LitNumType
LitNumWord8   -> PrimRep -> BcM (OrdList BCInstr, ByteOff)
code PrimRep
Word8Rep
          LitNumType
LitNumInt16   -> PrimRep -> BcM (OrdList BCInstr, ByteOff)
code PrimRep
Int16Rep
          LitNumType
LitNumWord16  -> PrimRep -> BcM (OrdList BCInstr, ByteOff)
code PrimRep
Word16Rep
          LitNumType
LitNumInt32   -> PrimRep -> BcM (OrdList BCInstr, ByteOff)
code PrimRep
Int32Rep
          LitNumType
LitNumWord32  -> PrimRep -> BcM (OrdList BCInstr, ByteOff)
code PrimRep
Word32Rep
          LitNumType
LitNumInt64   -> PrimRep -> BcM (OrdList BCInstr, ByteOff)
code PrimRep
Int64Rep
          LitNumType
LitNumWord64  -> PrimRep -> BcM (OrdList BCInstr, ByteOff)
code PrimRep
Word64Rep
          -- No LitInteger's or LitNatural's should be left by the time this is
          -- called. CorePrep should have converted them all to a real core
          -- representation.
          LitNumType
LitNumInteger -> String -> BcM (OrdList BCInstr, ByteOff)
forall a. String -> a
panic String
"pushAtom: LitInteger"
          LitNumType
LitNumNatural -> String -> BcM (OrdList BCInstr, ByteOff)
forall a. String -> a
panic String
"pushAtom: LitNatural"

-- | Push an atom for constructor (i.e., PACK instruction) onto the stack.
-- This is slightly different to @pushAtom@ due to the fact that we allow
-- packing constructor fields. See also @mkConAppCode@ and @pushPadding@.
pushConstrAtom
    :: StackDepth -> BCEnv -> StgArg -> BcM (BCInstrList, ByteOff)
pushConstrAtom :: ByteOff
-> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr, ByteOff)
pushConstrAtom ByteOff
_ Map Id ByteOff
_ (StgLitArg Literal
lit) = Bool -> Literal -> BcM (OrdList BCInstr, ByteOff)
pushLiteral Bool
False Literal
lit

pushConstrAtom ByteOff
d Map Id ByteOff
p va :: StgArg
va@(StgVarArg Id
v)
    | Just ByteOff
d_v <- Id -> Map Id ByteOff -> Maybe ByteOff
lookupBCEnv_maybe Id
v Map Id ByteOff
p = do  -- v is a local variable
        Platform
platform <- DynFlags -> Platform
targetPlatform (DynFlags -> Platform) -> BcM DynFlags -> BcM Platform
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BcM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
        let !szb :: ByteOff
szb = Platform -> Id -> ByteOff
idSizeCon Platform
platform Id
v
            done :: (Word16 -> BCInstr) -> BcM (OrdList BCInstr, ByteOff)
done Word16 -> BCInstr
instr = do
                let !off :: Word16
off = ByteOff -> Word16
trunc16B (ByteOff -> Word16) -> ByteOff -> Word16
forall a b. (a -> b) -> a -> b
$ ByteOff
d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
- ByteOff
d_v
                (OrdList BCInstr, ByteOff) -> BcM (OrdList BCInstr, ByteOff)
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstr -> OrdList BCInstr
forall a. a -> OrdList a
unitOL (Word16 -> BCInstr
instr Word16
off), ByteOff
szb)
        case ByteOff
szb of
            ByteOff
1 -> (Word16 -> BCInstr) -> BcM (OrdList BCInstr, ByteOff)
done Word16 -> BCInstr
PUSH8
            ByteOff
2 -> (Word16 -> BCInstr) -> BcM (OrdList BCInstr, ByteOff)
done Word16 -> BCInstr
PUSH16
            ByteOff
4 -> (Word16 -> BCInstr) -> BcM (OrdList BCInstr, ByteOff)
done Word16 -> BCInstr
PUSH32
            ByteOff
_ -> ByteOff
-> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr, ByteOff)
pushAtom ByteOff
d Map Id ByteOff
p StgArg
va

pushConstrAtom ByteOff
d Map Id ByteOff
p StgArg
expr = ByteOff
-> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr, ByteOff)
pushAtom ByteOff
d Map Id ByteOff
p StgArg
expr

pushPadding :: ByteOff -> (BCInstrList, ByteOff)
pushPadding :: ByteOff -> (OrdList BCInstr, ByteOff)
pushPadding (ByteOff Int
n) = Int -> (OrdList BCInstr, ByteOff) -> (OrdList BCInstr, ByteOff)
forall {t} {b}.
(Eq t, Num t, Num b) =>
t -> (OrdList BCInstr, b) -> (OrdList BCInstr, b)
go Int
n (OrdList BCInstr
forall a. OrdList a
nilOL, ByteOff
0)
  where
    go :: t -> (OrdList BCInstr, b) -> (OrdList BCInstr, b)
go t
n acc :: (OrdList BCInstr, b)
acc@(!OrdList BCInstr
instrs, !b
off) = case t
n of
        t
0 -> (OrdList BCInstr, b)
acc
        t
1 -> (OrdList BCInstr
instrs OrdList BCInstr -> OrdList BCInstr -> OrdList BCInstr
forall a. Monoid a => a -> a -> a
`mappend` BCInstr -> OrdList BCInstr
forall a. a -> OrdList a
unitOL BCInstr
PUSH_PAD8, b
off b -> b -> b
forall a. Num a => a -> a -> a
+ b
1)
        t
2 -> (OrdList BCInstr
instrs OrdList BCInstr -> OrdList BCInstr -> OrdList BCInstr
forall a. Monoid a => a -> a -> a
`mappend` BCInstr -> OrdList BCInstr
forall a. a -> OrdList a
unitOL BCInstr
PUSH_PAD16, b
off b -> b -> b
forall a. Num a => a -> a -> a
+ b
2)
        t
3 -> t -> (OrdList BCInstr, b) -> (OrdList BCInstr, b)
go t
1 (t -> (OrdList BCInstr, b) -> (OrdList BCInstr, b)
go t
2 (OrdList BCInstr, b)
acc)
        t
4 -> (OrdList BCInstr
instrs OrdList BCInstr -> OrdList BCInstr -> OrdList BCInstr
forall a. Monoid a => a -> a -> a
`mappend` BCInstr -> OrdList BCInstr
forall a. a -> OrdList a
unitOL BCInstr
PUSH_PAD32, b
off b -> b -> b
forall a. Num a => a -> a -> a
+ b
4)
        t
_ -> t -> (OrdList BCInstr, b) -> (OrdList BCInstr, b)
go (t
n t -> t -> t
forall a. Num a => a -> a -> a
- t
4) (t -> (OrdList BCInstr, b) -> (OrdList BCInstr, b)
go t
4 (OrdList BCInstr, b)
acc)

-- -----------------------------------------------------------------------------
-- Given a bunch of alts code and their discrs, do the donkey work
-- of making a multiway branch using a switch tree.
-- What a load of hassle!

mkMultiBranch :: Maybe Int      -- # datacons in tycon, if alg alt
                                -- a hint; generates better code
                                -- Nothing is always safe
              -> [(Discr, BCInstrList)]
              -> BcM BCInstrList
mkMultiBranch :: Maybe Int -> [(Discr, OrdList BCInstr)] -> BcM (OrdList BCInstr)
mkMultiBranch Maybe Int
maybe_ncons [(Discr, OrdList BCInstr)]
raw_ways = do
     LocalLabel
lbl_default <- BcM LocalLabel
getLabelBc

     let
         mkTree :: [(Discr, BCInstrList)] -> Discr -> Discr -> BcM BCInstrList
         mkTree :: [(Discr, OrdList BCInstr)]
-> Discr -> Discr -> BcM (OrdList BCInstr)
mkTree [] Discr
_range_lo Discr
_range_hi = OrdList BCInstr -> BcM (OrdList BCInstr)
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstr -> OrdList BCInstr
forall a. a -> OrdList a
unitOL (LocalLabel -> BCInstr
JMP LocalLabel
lbl_default))
             -- shouldn't happen?

         mkTree [(Discr, OrdList BCInstr)
val] Discr
range_lo Discr
range_hi
            | Discr
range_lo Discr -> Discr -> Bool
forall a. Eq a => a -> a -> Bool
== Discr
range_hi
            = OrdList BCInstr -> BcM (OrdList BCInstr)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Discr, OrdList BCInstr) -> OrdList BCInstr
forall a b. (a, b) -> b
snd (Discr, OrdList BCInstr)
val)
            | [(Discr, OrdList BCInstr)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Discr, OrdList BCInstr)]
defaults -- Note [CASEFAIL]
            = do LocalLabel
lbl <- BcM LocalLabel
getLabelBc
                 OrdList BCInstr -> BcM (OrdList BCInstr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Discr -> LocalLabel -> BCInstr
testEQ ((Discr, OrdList BCInstr) -> Discr
forall a b. (a, b) -> a
fst (Discr, OrdList BCInstr)
val) LocalLabel
lbl
                            BCInstr -> OrdList BCInstr -> OrdList BCInstr
forall a. a -> OrdList a -> OrdList a
`consOL` ((Discr, OrdList BCInstr) -> OrdList BCInstr
forall a b. (a, b) -> b
snd (Discr, OrdList BCInstr)
val
                            OrdList BCInstr -> OrdList BCInstr -> OrdList BCInstr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`  (LocalLabel -> BCInstr
LABEL LocalLabel
lbl BCInstr -> OrdList BCInstr -> OrdList BCInstr
forall a. a -> OrdList a -> OrdList a
`consOL` BCInstr -> OrdList BCInstr
forall a. a -> OrdList a
unitOL BCInstr
CASEFAIL)))
            | Bool
otherwise
            = OrdList BCInstr -> BcM (OrdList BCInstr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Discr -> LocalLabel -> BCInstr
testEQ ((Discr, OrdList BCInstr) -> Discr
forall a b. (a, b) -> a
fst (Discr, OrdList BCInstr)
val) LocalLabel
lbl_default BCInstr -> OrdList BCInstr -> OrdList BCInstr
forall a. a -> OrdList a -> OrdList a
`consOL` (Discr, OrdList BCInstr) -> OrdList BCInstr
forall a b. (a, b) -> b
snd (Discr, OrdList BCInstr)
val)

            -- Note [CASEFAIL] It may be that this case has no default
            -- branch, but the alternatives are not exhaustive - this
            -- happens for GADT cases for example, where the types
            -- prove that certain branches are impossible.  We could
            -- just assume that the other cases won't occur, but if
            -- this assumption was wrong (because of a bug in GHC)
            -- then the result would be a segfault.  So instead we
            -- emit an explicit test and a CASEFAIL instruction that
            -- causes the interpreter to barf() if it is ever
            -- executed.

         mkTree [(Discr, OrdList BCInstr)]
vals Discr
range_lo Discr
range_hi
            = let n :: Int
n = [(Discr, OrdList BCInstr)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Discr, OrdList BCInstr)]
vals Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
                  vals_lo :: [(Discr, OrdList BCInstr)]
vals_lo = Int -> [(Discr, OrdList BCInstr)] -> [(Discr, OrdList BCInstr)]
forall a. Int -> [a] -> [a]
take Int
n [(Discr, OrdList BCInstr)]
vals
                  vals_hi :: [(Discr, OrdList BCInstr)]
vals_hi = Int -> [(Discr, OrdList BCInstr)] -> [(Discr, OrdList BCInstr)]
forall a. Int -> [a] -> [a]
drop Int
n [(Discr, OrdList BCInstr)]
vals
                  v_mid :: Discr
v_mid = (Discr, OrdList BCInstr) -> Discr
forall a b. (a, b) -> a
fst ([(Discr, OrdList BCInstr)] -> (Discr, OrdList BCInstr)
forall a. [a] -> a
head [(Discr, OrdList BCInstr)]
vals_hi)
              in do
              LocalLabel
label_geq <- BcM LocalLabel
getLabelBc
              OrdList BCInstr
code_lo <- [(Discr, OrdList BCInstr)]
-> Discr -> Discr -> BcM (OrdList BCInstr)
mkTree [(Discr, OrdList BCInstr)]
vals_lo Discr
range_lo (Discr -> Discr
dec Discr
v_mid)
              OrdList BCInstr
code_hi <- [(Discr, OrdList BCInstr)]
-> Discr -> Discr -> BcM (OrdList BCInstr)
mkTree [(Discr, OrdList BCInstr)]
vals_hi Discr
v_mid Discr
range_hi
              OrdList BCInstr -> BcM (OrdList BCInstr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Discr -> LocalLabel -> BCInstr
testLT Discr
v_mid LocalLabel
label_geq
                      BCInstr -> OrdList BCInstr -> OrdList BCInstr
forall a. a -> OrdList a -> OrdList a
`consOL` (OrdList BCInstr
code_lo
                      OrdList BCInstr -> OrdList BCInstr -> OrdList BCInstr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`   BCInstr -> OrdList BCInstr
forall a. a -> OrdList a
unitOL (LocalLabel -> BCInstr
LABEL LocalLabel
label_geq)
                      OrdList BCInstr -> OrdList BCInstr -> OrdList BCInstr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`   OrdList BCInstr
code_hi))

         the_default :: OrdList BCInstr
the_default
            = case [(Discr, OrdList BCInstr)]
defaults of
                []         -> OrdList BCInstr
forall a. OrdList a
nilOL
                [(Discr
_, OrdList BCInstr
def)] -> LocalLabel -> BCInstr
LABEL LocalLabel
lbl_default BCInstr -> OrdList BCInstr -> OrdList BCInstr
forall a. a -> OrdList a -> OrdList a
`consOL` OrdList BCInstr
def
                [(Discr, OrdList BCInstr)]
_          -> String -> OrdList BCInstr
forall a. String -> a
panic String
"mkMultiBranch/the_default"
     OrdList BCInstr
instrs <- [(Discr, OrdList BCInstr)]
-> Discr -> Discr -> BcM (OrdList BCInstr)
mkTree [(Discr, OrdList BCInstr)]
notd_ways Discr
init_lo Discr
init_hi
     OrdList BCInstr -> BcM (OrdList BCInstr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList BCInstr
instrs OrdList BCInstr -> OrdList BCInstr -> OrdList BCInstr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList BCInstr
the_default)
  where
         ([(Discr, OrdList BCInstr)]
defaults, [(Discr, OrdList BCInstr)]
not_defaults) = ((Discr, OrdList BCInstr) -> Bool)
-> [(Discr, OrdList BCInstr)]
-> ([(Discr, OrdList BCInstr)], [(Discr, OrdList BCInstr)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (Discr -> Bool
isNoDiscr(Discr -> Bool)
-> ((Discr, OrdList BCInstr) -> Discr)
-> (Discr, OrdList BCInstr)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Discr, OrdList BCInstr) -> Discr
forall a b. (a, b) -> a
fst) [(Discr, OrdList BCInstr)]
raw_ways
         notd_ways :: [(Discr, OrdList BCInstr)]
notd_ways = ((Discr, OrdList BCInstr) -> (Discr, OrdList BCInstr) -> Ordering)
-> [(Discr, OrdList BCInstr)] -> [(Discr, OrdList BCInstr)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((Discr, OrdList BCInstr) -> Discr)
-> (Discr, OrdList BCInstr) -> (Discr, OrdList BCInstr) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Discr, OrdList BCInstr) -> Discr
forall a b. (a, b) -> a
fst) [(Discr, OrdList BCInstr)]
not_defaults

         testLT :: Discr -> LocalLabel -> BCInstr
testLT (DiscrI Int
i) LocalLabel
fail_label = Int -> LocalLabel -> BCInstr
TESTLT_I Int
i LocalLabel
fail_label
         testLT (DiscrW Word
i) LocalLabel
fail_label = Word -> LocalLabel -> BCInstr
TESTLT_W Word
i LocalLabel
fail_label
         testLT (DiscrF Float
i) LocalLabel
fail_label = Float -> LocalLabel -> BCInstr
TESTLT_F Float
i LocalLabel
fail_label
         testLT (DiscrD Double
i) LocalLabel
fail_label = Double -> LocalLabel -> BCInstr
TESTLT_D Double
i LocalLabel
fail_label
         testLT (DiscrP Word16
i) LocalLabel
fail_label = Word16 -> LocalLabel -> BCInstr
TESTLT_P Word16
i LocalLabel
fail_label
         testLT Discr
NoDiscr    LocalLabel
_          = String -> BCInstr
forall a. String -> a
panic String
"mkMultiBranch NoDiscr"

         testEQ :: Discr -> LocalLabel -> BCInstr
testEQ (DiscrI Int
i) LocalLabel
fail_label = Int -> LocalLabel -> BCInstr
TESTEQ_I Int
i LocalLabel
fail_label
         testEQ (DiscrW Word
i) LocalLabel
fail_label = Word -> LocalLabel -> BCInstr
TESTEQ_W Word
i LocalLabel
fail_label
         testEQ (DiscrF Float
i) LocalLabel
fail_label = Float -> LocalLabel -> BCInstr
TESTEQ_F Float
i LocalLabel
fail_label
         testEQ (DiscrD Double
i) LocalLabel
fail_label = Double -> LocalLabel -> BCInstr
TESTEQ_D Double
i LocalLabel
fail_label
         testEQ (DiscrP Word16
i) LocalLabel
fail_label = Word16 -> LocalLabel -> BCInstr
TESTEQ_P Word16
i LocalLabel
fail_label
         testEQ Discr
NoDiscr    LocalLabel
_          = String -> BCInstr
forall a. String -> a
panic String
"mkMultiBranch NoDiscr"

         -- None of these will be needed if there are no non-default alts
         (Discr
init_lo, Discr
init_hi)
            | [(Discr, OrdList BCInstr)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Discr, OrdList BCInstr)]
notd_ways
            = String -> (Discr, Discr)
forall a. String -> a
panic String
"mkMultiBranch: awesome foursome"
            | Bool
otherwise
            = case (Discr, OrdList BCInstr) -> Discr
forall a b. (a, b) -> a
fst ([(Discr, OrdList BCInstr)] -> (Discr, OrdList BCInstr)
forall a. [a] -> a
head [(Discr, OrdList BCInstr)]
notd_ways) of
                DiscrI Int
_ -> ( Int -> Discr
DiscrI Int
forall a. Bounded a => a
minBound,  Int -> Discr
DiscrI Int
forall a. Bounded a => a
maxBound )
                DiscrW Word
_ -> ( Word -> Discr
DiscrW Word
forall a. Bounded a => a
minBound,  Word -> Discr
DiscrW Word
forall a. Bounded a => a
maxBound )
                DiscrF Float
_ -> ( Float -> Discr
DiscrF Float
minF,      Float -> Discr
DiscrF Float
maxF )
                DiscrD Double
_ -> ( Double -> Discr
DiscrD Double
minD,      Double -> Discr
DiscrD Double
maxD )
                DiscrP Word16
_ -> ( Word16 -> Discr
DiscrP Word16
algMinBound, Word16 -> Discr
DiscrP Word16
algMaxBound )
                Discr
NoDiscr -> String -> (Discr, Discr)
forall a. String -> a
panic String
"mkMultiBranch NoDiscr"

         (Word16
algMinBound, Word16
algMaxBound)
            = case Maybe Int
maybe_ncons of
                 -- XXX What happens when n == 0?
                 Just Int
n  -> (Word16
0, Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
- Word16
1)
                 Maybe Int
Nothing -> (Word16
forall a. Bounded a => a
minBound, Word16
forall a. Bounded a => a
maxBound)

         isNoDiscr :: Discr -> Bool
isNoDiscr Discr
NoDiscr = Bool
True
         isNoDiscr Discr
_       = Bool
False

         dec :: Discr -> Discr
dec (DiscrI Int
i) = Int -> Discr
DiscrI (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
         dec (DiscrW Word
w) = Word -> Discr
DiscrW (Word
wWord -> Word -> Word
forall a. Num a => a -> a -> a
-Word
1)
         dec (DiscrP Word16
i) = Word16 -> Discr
DiscrP (Word16
iWord16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
-Word16
1)
         dec Discr
other      = Discr
other         -- not really right, but if you
                -- do cases on floating values, you'll get what you deserve

         -- same snotty comment applies to the following
         minF, maxF :: Float
         minD, maxD :: Double
         minF :: Float
minF = -Float
1.0e37
         maxF :: Float
maxF =  Float
1.0e37
         minD :: Double
minD = -Double
1.0e308
         maxD :: Double
maxD =  Double
1.0e308


-- -----------------------------------------------------------------------------
-- Supporting junk for the compilation schemes

-- Describes case alts
data Discr
   = DiscrI Int
   | DiscrW Word
   | DiscrF Float
   | DiscrD Double
   | DiscrP Word16
   | NoDiscr
    deriving (Discr -> Discr -> Bool
(Discr -> Discr -> Bool) -> (Discr -> Discr -> Bool) -> Eq Discr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Discr -> Discr -> Bool
$c/= :: Discr -> Discr -> Bool
== :: Discr -> Discr -> Bool
$c== :: Discr -> Discr -> Bool
Eq, Eq Discr
Eq Discr
-> (Discr -> Discr -> Ordering)
-> (Discr -> Discr -> Bool)
-> (Discr -> Discr -> Bool)
-> (Discr -> Discr -> Bool)
-> (Discr -> Discr -> Bool)
-> (Discr -> Discr -> Discr)
-> (Discr -> Discr -> Discr)
-> Ord Discr
Discr -> Discr -> Bool
Discr -> Discr -> Ordering
Discr -> Discr -> Discr
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Discr -> Discr -> Discr
$cmin :: Discr -> Discr -> Discr
max :: Discr -> Discr -> Discr
$cmax :: Discr -> Discr -> Discr
>= :: Discr -> Discr -> Bool
$c>= :: Discr -> Discr -> Bool
> :: Discr -> Discr -> Bool
$c> :: Discr -> Discr -> Bool
<= :: Discr -> Discr -> Bool
$c<= :: Discr -> Discr -> Bool
< :: Discr -> Discr -> Bool
$c< :: Discr -> Discr -> Bool
compare :: Discr -> Discr -> Ordering
$ccompare :: Discr -> Discr -> Ordering
Ord)

instance Outputable Discr where
   ppr :: Discr -> SDoc
ppr (DiscrI Int
i) = Int -> SDoc
int Int
i
   ppr (DiscrW Word
w) = String -> SDoc
text (Word -> String
forall a. Show a => a -> String
show Word
w)
   ppr (DiscrF Float
f) = String -> SDoc
text (Float -> String
forall a. Show a => a -> String
show Float
f)
   ppr (DiscrD Double
d) = String -> SDoc
text (Double -> String
forall a. Show a => a -> String
show Double
d)
   ppr (DiscrP Word16
i) = Word16 -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word16
i
   ppr Discr
NoDiscr    = String -> SDoc
text String
"DEF"


lookupBCEnv_maybe :: Id -> BCEnv -> Maybe ByteOff
lookupBCEnv_maybe :: Id -> Map Id ByteOff -> Maybe ByteOff
lookupBCEnv_maybe = Id -> Map Id ByteOff -> Maybe ByteOff
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup

idSizeW :: Platform -> Id -> WordOff
idSizeW :: Platform -> Id -> WordOff
idSizeW Platform
platform = Int -> WordOff
WordOff (Int -> WordOff) -> (Id -> Int) -> Id -> WordOff
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Platform -> ArgRep -> Int
argRepSizeW Platform
platform (ArgRep -> Int) -> (Id -> ArgRep) -> Id -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Platform -> Id -> ArgRep
bcIdArgRep Platform
platform

idSizeCon :: Platform -> Id -> ByteOff
idSizeCon :: Platform -> Id -> ByteOff
idSizeCon Platform
platform Id
var
  -- unboxed tuple components are padded to word size
  | Kind -> Bool
isUnboxedTupleType (Id -> Kind
idType Id
var) Bool -> Bool -> Bool
||
    Kind -> Bool
isUnboxedSumType (Id -> Kind
idType Id
var) =
    Platform -> WordOff -> ByteOff
wordsToBytes Platform
platform (WordOff -> ByteOff) -> (Id -> WordOff) -> Id -> ByteOff
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    Int -> WordOff
WordOff (Int -> WordOff) -> (Id -> Int) -> Id -> WordOff
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> (Id -> [Int]) -> Id -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PrimRep -> Int) -> [PrimRep] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> ArgRep -> Int
argRepSizeW Platform
platform (ArgRep -> Int) -> (PrimRep -> ArgRep) -> PrimRep -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Platform -> PrimRep -> ArgRep
toArgRep Platform
platform) ([PrimRep] -> [Int]) -> (Id -> [PrimRep]) -> Id -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    Id -> [PrimRep]
bcIdPrimReps (Id -> ByteOff) -> Id -> ByteOff
forall a b. (a -> b) -> a -> b
$ Id
var
  | Bool
otherwise = Int -> ByteOff
ByteOff (Platform -> PrimRep -> Int
primRepSizeB Platform
platform (Id -> PrimRep
bcIdPrimRep Id
var))

bcIdArgRep :: Platform -> Id -> ArgRep
bcIdArgRep :: Platform -> Id -> ArgRep
bcIdArgRep Platform
platform = Platform -> PrimRep -> ArgRep
toArgRep Platform
platform (PrimRep -> ArgRep) -> (Id -> PrimRep) -> Id -> ArgRep
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> PrimRep
bcIdPrimRep

bcIdPrimRep :: Id -> PrimRep
bcIdPrimRep :: Id -> PrimRep
bcIdPrimRep Id
id
  | [PrimRep
rep] <- HasDebugCallStack => Kind -> [PrimRep]
Kind -> [PrimRep]
typePrimRepArgs (Id -> Kind
idType Id
id)
  = PrimRep
rep
  | Bool
otherwise
  = String -> SDoc -> PrimRep
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"bcIdPrimRep" (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
id SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Kind
idType Id
id))


bcIdPrimReps :: Id -> [PrimRep]
bcIdPrimReps :: Id -> [PrimRep]
bcIdPrimReps Id
id = HasDebugCallStack => Kind -> [PrimRep]
Kind -> [PrimRep]
typePrimRepArgs (Id -> Kind
idType Id
id)

repSizeWords :: Platform -> PrimRep -> WordOff
repSizeWords :: Platform -> PrimRep -> WordOff
repSizeWords Platform
platform PrimRep
rep = Int -> WordOff
WordOff (Int -> WordOff) -> Int -> WordOff
forall a b. (a -> b) -> a -> b
$ Platform -> ArgRep -> Int
argRepSizeW Platform
platform (Platform -> PrimRep -> ArgRep
toArgRep Platform
platform PrimRep
rep)

isFollowableArg :: ArgRep -> Bool
isFollowableArg :: ArgRep -> Bool
isFollowableArg ArgRep
P = Bool
True
isFollowableArg ArgRep
_ = Bool
False

-- | Indicate if the calling convention is supported
isSupportedCConv :: CCallSpec -> Bool
isSupportedCConv :: CCallSpec -> Bool
isSupportedCConv (CCallSpec CCallTarget
_ CCallConv
cconv Safety
_) = case CCallConv
cconv of
   CCallConv
CCallConv            -> Bool
True     -- we explicitly pattern match on every
   CCallConv
StdCallConv          -> Bool
True     -- convention to ensure that a warning
   CCallConv
PrimCallConv         -> Bool
False    -- is triggered when a new one is added
   CCallConv
JavaScriptCallConv   -> Bool
False
   CCallConv
CApiConv             -> Bool
False

-- See bug #10462
unsupportedCConvException :: a
unsupportedCConvException :: forall a. a
unsupportedCConvException = GhcException -> a
forall a. GhcException -> a
throwGhcException (String -> GhcException
ProgramError
  (String
"Error: bytecode compiler can't handle some foreign calling conventions\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++
   String
"  Workaround: use -fobject-code, or compile this module to .o separately."))

mkSlideB :: Platform -> ByteOff -> ByteOff -> OrdList BCInstr
mkSlideB :: Platform -> ByteOff -> ByteOff -> OrdList BCInstr
mkSlideB Platform
platform !ByteOff
nb !ByteOff
db = Word16 -> WordOff -> OrdList BCInstr
mkSlideW Word16
n WordOff
d
  where
    !n :: Word16
n = WordOff -> Word16
trunc16W (WordOff -> Word16) -> WordOff -> Word16
forall a b. (a -> b) -> a -> b
$ Platform -> ByteOff -> WordOff
bytesToWords Platform
platform ByteOff
nb
    !d :: WordOff
d = Platform -> ByteOff -> WordOff
bytesToWords Platform
platform ByteOff
db

mkSlideW :: Word16 -> WordOff -> OrdList BCInstr
mkSlideW :: Word16 -> WordOff -> OrdList BCInstr
mkSlideW !Word16
n !WordOff
ws
    | WordOff
ws WordOff -> WordOff -> Bool
forall a. Ord a => a -> a -> Bool
> Word16 -> WordOff
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
limit
    -- If the amount to slide doesn't fit in a Word16, generate multiple slide
    -- instructions
    = Word16 -> Word16 -> BCInstr
SLIDE Word16
n Word16
limit BCInstr -> OrdList BCInstr -> OrdList BCInstr
forall a. a -> OrdList a -> OrdList a
`consOL` Word16 -> WordOff -> OrdList BCInstr
mkSlideW Word16
n (WordOff
ws WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
- Word16 -> WordOff
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
limit)
    | WordOff
ws WordOff -> WordOff -> Bool
forall a. Eq a => a -> a -> Bool
== WordOff
0
    = OrdList BCInstr
forall a. OrdList a
nilOL
    | Bool
otherwise
    = BCInstr -> OrdList BCInstr
forall a. a -> OrdList a
unitOL (Word16 -> Word16 -> BCInstr
SLIDE Word16
n (Word16 -> BCInstr) -> Word16 -> BCInstr
forall a b. (a -> b) -> a -> b
$ WordOff -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral WordOff
ws)
  where
    limit :: Word16
    limit :: Word16
limit = Word16
forall a. Bounded a => a
maxBound

atomPrimRep :: StgArg -> PrimRep
atomPrimRep :: StgArg -> PrimRep
atomPrimRep (StgVarArg Id
v) = Id -> PrimRep
bcIdPrimRep Id
v
atomPrimRep (StgLitArg Literal
l) = HasDebugCallStack => Kind -> PrimRep
Kind -> PrimRep
typePrimRep1 (Literal -> Kind
literalType Literal
l)

atomRep :: Platform -> StgArg -> ArgRep
atomRep :: Platform -> StgArg -> ArgRep
atomRep Platform
platform StgArg
e = Platform -> PrimRep -> ArgRep
toArgRep Platform
platform (StgArg -> PrimRep
atomPrimRep StgArg
e)

-- | Let szsw be the sizes in bytes of some items pushed onto the stack, which
-- has initial depth @original_depth@.  Return the values which the stack
-- environment should map these items to.
mkStackOffsets :: ByteOff -> [ByteOff] -> [ByteOff]
mkStackOffsets :: ByteOff -> [ByteOff] -> [ByteOff]
mkStackOffsets ByteOff
original_depth [ByteOff]
szsb = [ByteOff] -> [ByteOff]
forall a. [a] -> [a]
tail ((ByteOff -> ByteOff -> ByteOff)
-> ByteOff -> [ByteOff] -> [ByteOff]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl' ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
(+) ByteOff
original_depth [ByteOff]
szsb)

typeArgReps :: Platform -> Type -> [ArgRep]
typeArgReps :: Platform -> Kind -> [ArgRep]
typeArgReps Platform
platform = (PrimRep -> ArgRep) -> [PrimRep] -> [ArgRep]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> PrimRep -> ArgRep
toArgRep Platform
platform) ([PrimRep] -> [ArgRep]) -> (Kind -> [PrimRep]) -> Kind -> [ArgRep]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack => Kind -> [PrimRep]
Kind -> [PrimRep]
typePrimRepArgs

-- -----------------------------------------------------------------------------
-- The bytecode generator's monad

data BcM_State
   = BcM_State
        { BcM_State -> HscEnv
bcm_hsc_env :: HscEnv
        , BcM_State -> UniqSupply
uniqSupply  :: UniqSupply      -- for generating fresh variable names
        , BcM_State -> Module
thisModule  :: Module          -- current module (for breakpoints)
        , BcM_State -> Word32
nextlabel   :: Word32          -- for generating local labels
        , BcM_State -> [FFIInfo]
ffis        :: [FFIInfo]       -- ffi info blocks, to free later
                                         -- Should be free()d when it is GCd
        , BcM_State -> Maybe ModBreaks
modBreaks   :: Maybe ModBreaks -- info about breakpoints
        , BcM_State -> IntMap CgBreakInfo
breakInfo   :: IntMap CgBreakInfo
        , BcM_State -> IdEnv (RemotePtr ())
topStrings  :: IdEnv (RemotePtr ()) -- top-level string literals
          -- See Note [generating code for top-level string literal bindings].
        }

newtype BcM r = BcM (BcM_State -> IO (BcM_State, r)) deriving ((forall a b. (a -> b) -> BcM a -> BcM b)
-> (forall a b. a -> BcM b -> BcM a) -> Functor BcM
forall a b. a -> BcM b -> BcM a
forall a b. (a -> b) -> BcM a -> BcM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> BcM b -> BcM a
$c<$ :: forall a b. a -> BcM b -> BcM a
fmap :: forall a b. (a -> b) -> BcM a -> BcM b
$cfmap :: forall a b. (a -> b) -> BcM a -> BcM b
Functor)

ioToBc :: IO a -> BcM a
ioToBc :: forall a. IO a -> BcM a
ioToBc IO a
io = (BcM_State -> IO (BcM_State, a)) -> BcM a
forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
BcM ((BcM_State -> IO (BcM_State, a)) -> BcM a)
-> (BcM_State -> IO (BcM_State, a)) -> BcM a
forall a b. (a -> b) -> a -> b
$ \BcM_State
st -> do
  a
x <- IO a
io
  (BcM_State, a) -> IO (BcM_State, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (BcM_State
st, a
x)

runBc :: HscEnv -> UniqSupply -> Module -> Maybe ModBreaks
      -> IdEnv (RemotePtr ())
      -> BcM r
      -> IO (BcM_State, r)
runBc :: forall r.
HscEnv
-> UniqSupply
-> Module
-> Maybe ModBreaks
-> IdEnv (RemotePtr ())
-> BcM r
-> IO (BcM_State, r)
runBc HscEnv
hsc_env UniqSupply
us Module
this_mod Maybe ModBreaks
modBreaks IdEnv (RemotePtr ())
topStrings (BcM BcM_State -> IO (BcM_State, r)
m)
   = BcM_State -> IO (BcM_State, r)
m (HscEnv
-> UniqSupply
-> Module
-> Word32
-> [FFIInfo]
-> Maybe ModBreaks
-> IntMap CgBreakInfo
-> IdEnv (RemotePtr ())
-> BcM_State
BcM_State HscEnv
hsc_env UniqSupply
us Module
this_mod Word32
0 [] Maybe ModBreaks
modBreaks IntMap CgBreakInfo
forall a. IntMap a
IntMap.empty IdEnv (RemotePtr ())
topStrings)

thenBc :: BcM a -> (a -> BcM b) -> BcM b
thenBc :: forall a b. BcM a -> (a -> BcM b) -> BcM b
thenBc (BcM BcM_State -> IO (BcM_State, a)
expr) a -> BcM b
cont = (BcM_State -> IO (BcM_State, b)) -> BcM b
forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
BcM ((BcM_State -> IO (BcM_State, b)) -> BcM b)
-> (BcM_State -> IO (BcM_State, b)) -> BcM b
forall a b. (a -> b) -> a -> b
$ \BcM_State
st0 -> do
  (BcM_State
st1, a
q) <- BcM_State -> IO (BcM_State, a)
expr BcM_State
st0
  let BcM BcM_State -> IO (BcM_State, b)
k = a -> BcM b
cont a
q
  (BcM_State
st2, b
r) <- BcM_State -> IO (BcM_State, b)
k BcM_State
st1
  (BcM_State, b) -> IO (BcM_State, b)
forall (m :: * -> *) a. Monad m => a -> m a
return (BcM_State
st2, b
r)

thenBc_ :: BcM a -> BcM b -> BcM b
thenBc_ :: forall a b. BcM a -> BcM b -> BcM b
thenBc_ (BcM BcM_State -> IO (BcM_State, a)
expr) (BcM BcM_State -> IO (BcM_State, b)
cont) = (BcM_State -> IO (BcM_State, b)) -> BcM b
forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
BcM ((BcM_State -> IO (BcM_State, b)) -> BcM b)
-> (BcM_State -> IO (BcM_State, b)) -> BcM b
forall a b. (a -> b) -> a -> b
$ \BcM_State
st0 -> do
  (BcM_State
st1, a
_) <- BcM_State -> IO (BcM_State, a)
expr BcM_State
st0
  (BcM_State
st2, b
r) <- BcM_State -> IO (BcM_State, b)
cont BcM_State
st1
  (BcM_State, b) -> IO (BcM_State, b)
forall (m :: * -> *) a. Monad m => a -> m a
return (BcM_State
st2, b
r)

returnBc :: a -> BcM a
returnBc :: forall a. a -> BcM a
returnBc a
result = (BcM_State -> IO (BcM_State, a)) -> BcM a
forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
BcM ((BcM_State -> IO (BcM_State, a)) -> BcM a)
-> (BcM_State -> IO (BcM_State, a)) -> BcM a
forall a b. (a -> b) -> a -> b
$ \BcM_State
st -> ((BcM_State, a) -> IO (BcM_State, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (BcM_State
st, a
result))

instance Applicative BcM where
    pure :: forall a. a -> BcM a
pure = a -> BcM a
forall a. a -> BcM a
returnBc
    <*> :: forall a b. BcM (a -> b) -> BcM a -> BcM b
(<*>) = BcM (a -> b) -> BcM a -> BcM b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
    *> :: forall a b. BcM a -> BcM b -> BcM b
(*>) = BcM a -> BcM b -> BcM b
forall a b. BcM a -> BcM b -> BcM b
thenBc_

instance Monad BcM where
  >>= :: forall a b. BcM a -> (a -> BcM b) -> BcM b
(>>=) = BcM a -> (a -> BcM b) -> BcM b
forall a b. BcM a -> (a -> BcM b) -> BcM b
thenBc
  >> :: forall a b. BcM a -> BcM b -> BcM b
(>>)  = BcM a -> BcM b -> BcM b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
(*>)

instance HasDynFlags BcM where
    getDynFlags :: BcM DynFlags
getDynFlags = (BcM_State -> IO (BcM_State, DynFlags)) -> BcM DynFlags
forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
BcM ((BcM_State -> IO (BcM_State, DynFlags)) -> BcM DynFlags)
-> (BcM_State -> IO (BcM_State, DynFlags)) -> BcM DynFlags
forall a b. (a -> b) -> a -> b
$ \BcM_State
st -> (BcM_State, DynFlags) -> IO (BcM_State, DynFlags)
forall (m :: * -> *) a. Monad m => a -> m a
return (BcM_State
st, HscEnv -> DynFlags
hsc_dflags (BcM_State -> HscEnv
bcm_hsc_env BcM_State
st))

getHscEnv :: BcM HscEnv
getHscEnv :: BcM HscEnv
getHscEnv = (BcM_State -> IO (BcM_State, HscEnv)) -> BcM HscEnv
forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
BcM ((BcM_State -> IO (BcM_State, HscEnv)) -> BcM HscEnv)
-> (BcM_State -> IO (BcM_State, HscEnv)) -> BcM HscEnv
forall a b. (a -> b) -> a -> b
$ \BcM_State
st -> (BcM_State, HscEnv) -> IO (BcM_State, HscEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (BcM_State
st, BcM_State -> HscEnv
bcm_hsc_env BcM_State
st)

getProfile :: BcM Profile
getProfile :: BcM Profile
getProfile = DynFlags -> Profile
targetProfile (DynFlags -> Profile) -> BcM DynFlags -> BcM Profile
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BcM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags

emitBc :: ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
emitBc :: ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
emitBc [FFIInfo] -> ProtoBCO Name
bco
  = (BcM_State -> IO (BcM_State, ProtoBCO Name)) -> BcM (ProtoBCO Name)
forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
BcM ((BcM_State -> IO (BcM_State, ProtoBCO Name))
 -> BcM (ProtoBCO Name))
-> (BcM_State -> IO (BcM_State, ProtoBCO Name))
-> BcM (ProtoBCO Name)
forall a b. (a -> b) -> a -> b
$ \BcM_State
st -> (BcM_State, ProtoBCO Name) -> IO (BcM_State, ProtoBCO Name)
forall (m :: * -> *) a. Monad m => a -> m a
return (BcM_State
st{ffis :: [FFIInfo]
ffis=[]}, [FFIInfo] -> ProtoBCO Name
bco (BcM_State -> [FFIInfo]
ffis BcM_State
st))

recordFFIBc :: RemotePtr C_ffi_cif -> BcM ()
recordFFIBc :: RemotePtr C_ffi_cif -> BcM ()
recordFFIBc RemotePtr C_ffi_cif
a
  = (BcM_State -> IO (BcM_State, ())) -> BcM ()
forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
BcM ((BcM_State -> IO (BcM_State, ())) -> BcM ())
-> (BcM_State -> IO (BcM_State, ())) -> BcM ()
forall a b. (a -> b) -> a -> b
$ \BcM_State
st -> (BcM_State, ()) -> IO (BcM_State, ())
forall (m :: * -> *) a. Monad m => a -> m a
return (BcM_State
st{ffis :: [FFIInfo]
ffis = RemotePtr C_ffi_cif -> FFIInfo
FFIInfo RemotePtr C_ffi_cif
a FFIInfo -> [FFIInfo] -> [FFIInfo]
forall a. a -> [a] -> [a]
: BcM_State -> [FFIInfo]
ffis BcM_State
st}, ())

getLabelBc :: BcM LocalLabel
getLabelBc :: BcM LocalLabel
getLabelBc
  = (BcM_State -> IO (BcM_State, LocalLabel)) -> BcM LocalLabel
forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
BcM ((BcM_State -> IO (BcM_State, LocalLabel)) -> BcM LocalLabel)
-> (BcM_State -> IO (BcM_State, LocalLabel)) -> BcM LocalLabel
forall a b. (a -> b) -> a -> b
$ \BcM_State
st -> do let nl :: Word32
nl = BcM_State -> Word32
nextlabel BcM_State
st
                    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word32
nl Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
forall a. Bounded a => a
maxBound) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                        String -> IO ()
forall a. String -> a
panic String
"getLabelBc: Ran out of labels"
                    (BcM_State, LocalLabel) -> IO (BcM_State, LocalLabel)
forall (m :: * -> *) a. Monad m => a -> m a
return (BcM_State
st{nextlabel :: Word32
nextlabel = Word32
nl Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
1}, Word32 -> LocalLabel
LocalLabel Word32
nl)

getLabelsBc :: Word32 -> BcM [LocalLabel]
getLabelsBc :: Word32 -> BcM [LocalLabel]
getLabelsBc Word32
n
  = (BcM_State -> IO (BcM_State, [LocalLabel])) -> BcM [LocalLabel]
forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
BcM ((BcM_State -> IO (BcM_State, [LocalLabel])) -> BcM [LocalLabel])
-> (BcM_State -> IO (BcM_State, [LocalLabel])) -> BcM [LocalLabel]
forall a b. (a -> b) -> a -> b
$ \BcM_State
st -> let ctr :: Word32
ctr = BcM_State -> Word32
nextlabel BcM_State
st
                 in (BcM_State, [LocalLabel]) -> IO (BcM_State, [LocalLabel])
forall (m :: * -> *) a. Monad m => a -> m a
return (BcM_State
st{nextlabel :: Word32
nextlabel = Word32
ctrWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+Word32
n}, [Word32] -> [LocalLabel]
coerce [Word32
ctr .. Word32
ctrWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+Word32
nWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
-Word32
1])

getCCArray :: BcM (Array BreakIndex (RemotePtr CostCentre))
getCCArray :: BcM (Array Int (RemotePtr CostCentre))
getCCArray = (BcM_State -> IO (BcM_State, Array Int (RemotePtr CostCentre)))
-> BcM (Array Int (RemotePtr CostCentre))
forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
BcM ((BcM_State -> IO (BcM_State, Array Int (RemotePtr CostCentre)))
 -> BcM (Array Int (RemotePtr CostCentre)))
-> (BcM_State -> IO (BcM_State, Array Int (RemotePtr CostCentre)))
-> BcM (Array Int (RemotePtr CostCentre))
forall a b. (a -> b) -> a -> b
$ \BcM_State
st ->
  let breaks :: ModBreaks
breaks = String -> Maybe ModBreaks -> ModBreaks
forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"GHC.StgToByteCode.getCCArray" (Maybe ModBreaks -> ModBreaks) -> Maybe ModBreaks -> ModBreaks
forall a b. (a -> b) -> a -> b
$ BcM_State -> Maybe ModBreaks
modBreaks BcM_State
st in
  (BcM_State, Array Int (RemotePtr CostCentre))
-> IO (BcM_State, Array Int (RemotePtr CostCentre))
forall (m :: * -> *) a. Monad m => a -> m a
return (BcM_State
st, ModBreaks -> Array Int (RemotePtr CostCentre)
modBreaks_ccs ModBreaks
breaks)


newBreakInfo :: BreakIndex -> CgBreakInfo -> BcM ()
newBreakInfo :: Int -> CgBreakInfo -> BcM ()
newBreakInfo Int
ix CgBreakInfo
info = (BcM_State -> IO (BcM_State, ())) -> BcM ()
forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
BcM ((BcM_State -> IO (BcM_State, ())) -> BcM ())
-> (BcM_State -> IO (BcM_State, ())) -> BcM ()
forall a b. (a -> b) -> a -> b
$ \BcM_State
st ->
  (BcM_State, ()) -> IO (BcM_State, ())
forall (m :: * -> *) a. Monad m => a -> m a
return (BcM_State
st{breakInfo :: IntMap CgBreakInfo
breakInfo = Int -> CgBreakInfo -> IntMap CgBreakInfo -> IntMap CgBreakInfo
forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
ix CgBreakInfo
info (BcM_State -> IntMap CgBreakInfo
breakInfo BcM_State
st)}, ())

newUnique :: BcM Unique
newUnique :: BcM Unique
newUnique = (BcM_State -> IO (BcM_State, Unique)) -> BcM Unique
forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
BcM ((BcM_State -> IO (BcM_State, Unique)) -> BcM Unique)
-> (BcM_State -> IO (BcM_State, Unique)) -> BcM Unique
forall a b. (a -> b) -> a -> b
$
   \BcM_State
st -> case UniqSupply -> (Unique, UniqSupply)
takeUniqFromSupply (BcM_State -> UniqSupply
uniqSupply BcM_State
st) of
             (Unique
uniq, UniqSupply
us) -> let newState :: BcM_State
newState = BcM_State
st { uniqSupply :: UniqSupply
uniqSupply = UniqSupply
us }
                           in  (BcM_State, Unique) -> IO (BcM_State, Unique)
forall (m :: * -> *) a. Monad m => a -> m a
return (BcM_State
newState, Unique
uniq)

getCurrentModule :: BcM Module
getCurrentModule :: BcM Module
getCurrentModule = (BcM_State -> IO (BcM_State, Module)) -> BcM Module
forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
BcM ((BcM_State -> IO (BcM_State, Module)) -> BcM Module)
-> (BcM_State -> IO (BcM_State, Module)) -> BcM Module
forall a b. (a -> b) -> a -> b
$ \BcM_State
st -> (BcM_State, Module) -> IO (BcM_State, Module)
forall (m :: * -> *) a. Monad m => a -> m a
return (BcM_State
st, BcM_State -> Module
thisModule BcM_State
st)

getTopStrings :: BcM (IdEnv (RemotePtr ()))
getTopStrings :: BcM (IdEnv (RemotePtr ()))
getTopStrings = (BcM_State -> IO (BcM_State, IdEnv (RemotePtr ())))
-> BcM (IdEnv (RemotePtr ()))
forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
BcM ((BcM_State -> IO (BcM_State, IdEnv (RemotePtr ())))
 -> BcM (IdEnv (RemotePtr ())))
-> (BcM_State -> IO (BcM_State, IdEnv (RemotePtr ())))
-> BcM (IdEnv (RemotePtr ()))
forall a b. (a -> b) -> a -> b
$ \BcM_State
st -> (BcM_State, IdEnv (RemotePtr ()))
-> IO (BcM_State, IdEnv (RemotePtr ()))
forall (m :: * -> *) a. Monad m => a -> m a
return (BcM_State
st, BcM_State -> IdEnv (RemotePtr ())
topStrings BcM_State
st)

newId :: Type -> BcM Id
newId :: Kind -> BcM Id
newId Kind
ty = do
    Unique
uniq <- BcM Unique
newUnique
    Id -> BcM Id
forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> BcM Id) -> Id -> BcM Id
forall a b. (a -> b) -> a -> b
$ FastString -> Unique -> Kind -> Kind -> Id
mkSysLocal FastString
tickFS Unique
uniq Kind
Many Kind
ty

tickFS :: FastString
tickFS :: FastString
tickFS = String -> FastString
fsLit String
"ticked"