{-# LANGUAGE CPP, MagicHash, RecordWildCards, BangPatterns #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE PatternSynonyms #-}
{-# OPTIONS_GHC -fprof-auto-top #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
--
--  (c) The University of Glasgow 2002-2006
--

-- | GHC.CoreToByteCode: Generate bytecode from Core
module GHC.CoreToByteCode ( UnlinkedBCO, byteCodeGen, coreExprToBCOs ) where

#include "HsVersions.h"

import GHC.Prelude

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

import GHC.Runtime.Interpreter
import GHCi.FFI
import GHCi.RemoteTypes
import GHC.Types.Basic
import GHC.Driver.Session
import GHC.Utils.Outputable
import GHC.Platform
import GHC.Types.Name
import GHC.Types.Id.Make
import GHC.Types.Id
import GHC.Types.ForeignCall
import GHC.Driver.Types
import GHC.Core.Utils
import GHC.Core
import GHC.Core.Ppr
import GHC.Types.Literal
import GHC.Builtin.PrimOps
import GHC.Core.FVs
import GHC.Core.Type
import GHC.Types.RepType
import GHC.Core.DataCon
import GHC.Core.TyCon
import GHC.Utils.Misc
import GHC.Types.Var.Set
import GHC.Builtin.Types.Prim
import GHC.Core.TyCo.Ppr ( pprType )
import GHC.Utils.Error
import GHC.Types.Unique
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.Builtin.Names ( unsafeEqualityProofName )

import Data.List
import Foreign
import Control.Monad
import Data.Char

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

import Control.Exception
import Data.Array
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 )

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

byteCodeGen :: HscEnv
            -> Module
            -> CoreProgram
            -> [TyCon]
            -> Maybe ModBreaks
            -> IO CompiledByteCode
byteCodeGen :: HscEnv
-> Module
-> CoreProgram
-> [TyCon]
-> Maybe ModBreaks
-> IO CompiledByteCode
byteCodeGen HscEnv
hsc_env Module
this_mod CoreProgram
binds [TyCon]
tycs Maybe ModBreaks
mb_modBreaks
   = DynFlags
-> SDoc
-> (CompiledByteCode -> ())
-> IO CompiledByteCode
-> IO CompiledByteCode
forall (m :: * -> *) a.
MonadIO m =>
DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTiming DynFlags
dflags
                (String -> SDoc
text String
"GHC.CoreToByteCode"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, [(Id, AnnExpr Id DVarSet)]
flatBinds) = [Either (Id, ByteString) (Id, AnnExpr Id DVarSet)]
-> ([(Id, ByteString)], [(Id, AnnExpr Id DVarSet)])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either (Id, ByteString) (Id, AnnExpr Id DVarSet)]
 -> ([(Id, ByteString)], [(Id, AnnExpr Id DVarSet)]))
-> [Either (Id, ByteString) (Id, AnnExpr Id DVarSet)]
-> ([(Id, ByteString)], [(Id, AnnExpr Id DVarSet)])
forall a b. (a -> b) -> a -> b
$ do  -- list monad
                (Id
bndr, Expr Id
rhs) <- CoreProgram -> [(Id, Expr Id)]
forall b. [Bind b] -> [(b, Expr b)]
flattenBinds CoreProgram
binds
                Either (Id, ByteString) (Id, AnnExpr Id DVarSet)
-> [Either (Id, ByteString) (Id, AnnExpr Id DVarSet)]
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (Id, ByteString) (Id, AnnExpr Id DVarSet)
 -> [Either (Id, ByteString) (Id, AnnExpr Id DVarSet)])
-> Either (Id, ByteString) (Id, AnnExpr Id DVarSet)
-> [Either (Id, ByteString) (Id, AnnExpr Id DVarSet)]
forall a b. (a -> b) -> a -> b
$ case Expr Id -> Maybe ByteString
exprIsTickedString_maybe Expr Id
rhs of
                    Just ByteString
str -> (Id, ByteString)
-> Either (Id, ByteString) (Id, AnnExpr Id DVarSet)
forall a b. a -> Either a b
Left (Id
bndr, ByteString
str)
                    Maybe ByteString
_ -> (Id, AnnExpr Id DVarSet)
-> Either (Id, ByteString) (Id, AnnExpr Id DVarSet)
forall a b. b -> Either a b
Right (Id
bndr, Expr Id -> AnnExpr Id DVarSet
simpleFreeVars Expr Id
rhs)
        [(Id, RemotePtr ())]
stringPtrs <- HscEnv -> [(Id, ByteString)] -> IO [(Id, RemotePtr ())]
allocateTopStrings HscEnv
hsc_env [(Id, ByteString)]
strings

        UniqSupply
us <- Char -> IO UniqSupply
mkSplitUniqSupply Char
'y'
        (BcM_State{[FFIInfo]
Maybe ModBreaks
Word16
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 -> Word16
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 :: Word16
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
$
             ((Id, AnnExpr Id DVarSet) -> BcM (ProtoBCO Name))
-> [(Id, AnnExpr Id DVarSet)] -> BcM [ProtoBCO Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Id, AnnExpr Id DVarSet) -> BcM (ProtoBCO Name)
schemeTopBind [(Id, AnnExpr Id DVarSet)]
flatBinds

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

        DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn 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 <- HscEnv
-> [ProtoBCO Name]
-> [TyCon]
-> [RemotePtr ()]
-> Maybe ModBreaks
-> IO CompiledByteCode
assembleBCOs HscEnv
hsc_env [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

allocateTopStrings
  :: HscEnv
  -> [(Id, ByteString)]
  -> IO [(Var, RemotePtr ())]
allocateTopStrings :: HscEnv -> [(Id, ByteString)] -> IO [(Id, RemotePtr ())]
allocateTopStrings HscEnv
hsc_env [(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 <- HscEnv -> Message [RemotePtr ()] -> IO [RemotePtr ()]
forall a. Binary a => HscEnv -> Message a -> IO a
iservCmd HscEnv
hsc_env (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 iservCmd, in allocateTopStrings

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

-- -----------------------------------------------------------------------------
-- Generating byte code for an expression

-- Returns: the root BCO for this expression
coreExprToBCOs :: HscEnv
               -> Module
               -> CoreExpr
               -> IO UnlinkedBCO
coreExprToBCOs :: HscEnv -> Module -> Expr Id -> IO UnlinkedBCO
coreExprToBCOs HscEnv
hsc_env Module
this_mod Expr Id
expr
 = DynFlags
-> SDoc -> (UnlinkedBCO -> ()) -> IO UnlinkedBCO -> IO UnlinkedBCO
forall (m :: * -> *) a.
MonadIO m =>
DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTiming DynFlags
dflags
              (String -> SDoc
text String
"GHC.CoreToByteCode"SDoc -> SDoc -> SDoc
<+>SDoc -> SDoc
brackets (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
this_mod))
              (() -> UnlinkedBCO -> ()
forall a b. a -> b -> a
const ()) (IO UnlinkedBCO -> IO UnlinkedBCO)
-> IO UnlinkedBCO -> IO UnlinkedBCO
forall a b. (a -> b) -> a -> b
$ do
      -- create a totally bogus name for the top-level BCO; this
      -- should be harmless, since it's never used for anything
      let invented_name :: Name
invented_name  = Unique -> FastString -> Name
mkSystemVarName (Int -> Unique
mkPseudoUniqueE Int
0) (String -> FastString
fsLit String
"ExprTopLevel")

      -- the uniques are needed to generate fresh variables when we introduce new
      -- let bindings for ticked expressions
      UniqSupply
us <- Char -> IO UniqSupply
mkSplitUniqSupply Char
'y'
      (BcM_State HscEnv
_dflags UniqSupply
_us Module
_this_mod Word16
_final_ctr [FFIInfo]
mallocd Maybe ModBreaks
_ IntMap CgBreakInfo
_ IdEnv (RemotePtr ())
_, ProtoBCO Name
proto_bco)
         <- 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
forall a. Maybe a
Nothing IdEnv (RemotePtr ())
forall a. VarEnv a
emptyVarEnv (BcM (ProtoBCO Name) -> IO (BcM_State, ProtoBCO Name))
-> BcM (ProtoBCO Name) -> IO (BcM_State, ProtoBCO Name)
forall a b. (a -> b) -> a -> b
$
              [Id] -> (Name, AnnExpr Id DVarSet) -> BcM (ProtoBCO Name)
schemeR [] (Name
invented_name, Expr Id -> AnnExpr Id DVarSet
simpleFreeVars Expr Id
expr)

      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([FFIInfo] -> Bool
forall a. [a] -> Bool
notNull [FFIInfo]
mallocd)
           (String -> IO ()
forall a. String -> a
panic String
"GHC.CoreToByteCode.coreExprToBCOs: missing final emitBc?")

      DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags DumpFlag
Opt_D_dump_BCOs String
"Proto-BCOs" DumpFormat
FormatByteCode
         (ProtoBCO Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr ProtoBCO Name
proto_bco)

      HscEnv -> ProtoBCO Name -> IO UnlinkedBCO
assembleOneBCO HscEnv
hsc_env ProtoBCO Name
proto_bco
  where dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env

-- The regular freeVars function gives more information than is useful to
-- us here. We need only the free variables, not everything in an FVAnn.
-- Historical note: At one point FVAnn was more sophisticated than just
-- a set. Now it isn't. So this function is much simpler. Keeping it around
-- so that if someone changes FVAnn, they will get a nice type error right
-- here.
simpleFreeVars :: CoreExpr -> AnnExpr Id DVarSet
simpleFreeVars :: Expr Id -> AnnExpr Id DVarSet
simpleFreeVars = Expr Id -> AnnExpr Id DVarSet
freeVars

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

type BCInstrList = OrdList BCInstr

newtype ByteOff = ByteOff Int
    deriving (Int -> ByteOff
ByteOff -> Int
ByteOff -> [ByteOff]
ByteOff -> ByteOff
ByteOff -> ByteOff -> [ByteOff]
ByteOff -> ByteOff -> ByteOff -> [ByteOff]
(ByteOff -> ByteOff)
-> (ByteOff -> ByteOff)
-> (Int -> ByteOff)
-> (ByteOff -> Int)
-> (ByteOff -> [ByteOff])
-> (ByteOff -> ByteOff -> [ByteOff])
-> (ByteOff -> ByteOff -> [ByteOff])
-> (ByteOff -> ByteOff -> ByteOff -> [ByteOff])
-> Enum ByteOff
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: ByteOff -> ByteOff -> ByteOff -> [ByteOff]
$cenumFromThenTo :: ByteOff -> ByteOff -> ByteOff -> [ByteOff]
enumFromTo :: ByteOff -> ByteOff -> [ByteOff]
$cenumFromTo :: ByteOff -> ByteOff -> [ByteOff]
enumFromThen :: ByteOff -> ByteOff -> [ByteOff]
$cenumFromThen :: ByteOff -> ByteOff -> [ByteOff]
enumFrom :: ByteOff -> [ByteOff]
$cenumFrom :: ByteOff -> [ByteOff]
fromEnum :: ByteOff -> Int
$cfromEnum :: ByteOff -> Int
toEnum :: Int -> ByteOff
$ctoEnum :: Int -> ByteOff
pred :: ByteOff -> ByteOff
$cpred :: ByteOff -> ByteOff
succ :: ByteOff -> ByteOff
$csucc :: ByteOff -> ByteOff
Enum, ByteOff -> ByteOff -> Bool
(ByteOff -> ByteOff -> Bool)
-> (ByteOff -> ByteOff -> Bool) -> Eq ByteOff
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ByteOff -> ByteOff -> Bool
$c/= :: ByteOff -> ByteOff -> Bool
== :: ByteOff -> ByteOff -> Bool
$c== :: ByteOff -> ByteOff -> Bool
Eq, Enum ByteOff
Real ByteOff
Real ByteOff
-> Enum ByteOff
-> (ByteOff -> ByteOff -> ByteOff)
-> (ByteOff -> ByteOff -> ByteOff)
-> (ByteOff -> ByteOff -> ByteOff)
-> (ByteOff -> ByteOff -> ByteOff)
-> (ByteOff -> ByteOff -> (ByteOff, ByteOff))
-> (ByteOff -> ByteOff -> (ByteOff, ByteOff))
-> (ByteOff -> Integer)
-> Integral ByteOff
ByteOff -> Integer
ByteOff -> ByteOff -> (ByteOff, ByteOff)
ByteOff -> ByteOff -> ByteOff
forall a.
Real a
-> Enum a
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> (a, a))
-> (a -> a -> (a, a))
-> (a -> Integer)
-> Integral a
toInteger :: ByteOff -> Integer
$ctoInteger :: ByteOff -> Integer
divMod :: ByteOff -> ByteOff -> (ByteOff, ByteOff)
$cdivMod :: ByteOff -> ByteOff -> (ByteOff, ByteOff)
quotRem :: ByteOff -> ByteOff -> (ByteOff, ByteOff)
$cquotRem :: ByteOff -> ByteOff -> (ByteOff, ByteOff)
mod :: ByteOff -> ByteOff -> ByteOff
$cmod :: ByteOff -> ByteOff -> ByteOff
div :: ByteOff -> ByteOff -> ByteOff
$cdiv :: ByteOff -> ByteOff -> ByteOff
rem :: ByteOff -> ByteOff -> ByteOff
$crem :: ByteOff -> ByteOff -> ByteOff
quot :: ByteOff -> ByteOff -> ByteOff
$cquot :: ByteOff -> ByteOff -> ByteOff
Integral, Integer -> ByteOff
ByteOff -> ByteOff
ByteOff -> ByteOff -> ByteOff
(ByteOff -> ByteOff -> ByteOff)
-> (ByteOff -> ByteOff -> ByteOff)
-> (ByteOff -> ByteOff -> ByteOff)
-> (ByteOff -> ByteOff)
-> (ByteOff -> ByteOff)
-> (ByteOff -> ByteOff)
-> (Integer -> ByteOff)
-> Num ByteOff
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
fromInteger :: Integer -> ByteOff
$cfromInteger :: Integer -> ByteOff
signum :: ByteOff -> ByteOff
$csignum :: ByteOff -> ByteOff
abs :: ByteOff -> ByteOff
$cabs :: ByteOff -> ByteOff
negate :: ByteOff -> ByteOff
$cnegate :: ByteOff -> ByteOff
* :: ByteOff -> ByteOff -> ByteOff
$c* :: ByteOff -> ByteOff -> ByteOff
- :: ByteOff -> ByteOff -> ByteOff
$c- :: ByteOff -> ByteOff -> ByteOff
+ :: ByteOff -> ByteOff -> ByteOff
$c+ :: ByteOff -> ByteOff -> ByteOff
Num, Eq ByteOff
Eq ByteOff
-> (ByteOff -> ByteOff -> Ordering)
-> (ByteOff -> ByteOff -> Bool)
-> (ByteOff -> ByteOff -> Bool)
-> (ByteOff -> ByteOff -> Bool)
-> (ByteOff -> ByteOff -> Bool)
-> (ByteOff -> ByteOff -> ByteOff)
-> (ByteOff -> ByteOff -> ByteOff)
-> Ord ByteOff
ByteOff -> ByteOff -> Bool
ByteOff -> ByteOff -> Ordering
ByteOff -> ByteOff -> ByteOff
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 :: ByteOff -> ByteOff -> ByteOff
$cmin :: ByteOff -> ByteOff -> ByteOff
max :: ByteOff -> ByteOff -> ByteOff
$cmax :: ByteOff -> ByteOff -> ByteOff
>= :: ByteOff -> ByteOff -> Bool
$c>= :: ByteOff -> ByteOff -> Bool
> :: ByteOff -> ByteOff -> Bool
$c> :: ByteOff -> ByteOff -> Bool
<= :: ByteOff -> ByteOff -> Bool
$c<= :: ByteOff -> ByteOff -> Bool
< :: ByteOff -> ByteOff -> Bool
$c< :: ByteOff -> ByteOff -> Bool
compare :: ByteOff -> ByteOff -> Ordering
$ccompare :: ByteOff -> ByteOff -> Ordering
Ord, Num ByteOff
Ord ByteOff
Num ByteOff -> Ord ByteOff -> (ByteOff -> Rational) -> Real ByteOff
ByteOff -> Rational
forall a. Num a -> Ord a -> (a -> Rational) -> Real a
toRational :: ByteOff -> Rational
$ctoRational :: ByteOff -> Rational
Real)

newtype WordOff = WordOff Int
    deriving (Int -> WordOff
WordOff -> Int
WordOff -> [WordOff]
WordOff -> WordOff
WordOff -> WordOff -> [WordOff]
WordOff -> WordOff -> WordOff -> [WordOff]
(WordOff -> WordOff)
-> (WordOff -> WordOff)
-> (Int -> WordOff)
-> (WordOff -> Int)
-> (WordOff -> [WordOff])
-> (WordOff -> WordOff -> [WordOff])
-> (WordOff -> WordOff -> [WordOff])
-> (WordOff -> WordOff -> WordOff -> [WordOff])
-> Enum WordOff
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: WordOff -> WordOff -> WordOff -> [WordOff]
$cenumFromThenTo :: WordOff -> WordOff -> WordOff -> [WordOff]
enumFromTo :: WordOff -> WordOff -> [WordOff]
$cenumFromTo :: WordOff -> WordOff -> [WordOff]
enumFromThen :: WordOff -> WordOff -> [WordOff]
$cenumFromThen :: WordOff -> WordOff -> [WordOff]
enumFrom :: WordOff -> [WordOff]
$cenumFrom :: WordOff -> [WordOff]
fromEnum :: WordOff -> Int
$cfromEnum :: WordOff -> Int
toEnum :: Int -> WordOff
$ctoEnum :: Int -> WordOff
pred :: WordOff -> WordOff
$cpred :: WordOff -> WordOff
succ :: WordOff -> WordOff
$csucc :: WordOff -> WordOff
Enum, WordOff -> WordOff -> Bool
(WordOff -> WordOff -> Bool)
-> (WordOff -> WordOff -> Bool) -> Eq WordOff
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: WordOff -> WordOff -> Bool
$c/= :: WordOff -> WordOff -> Bool
== :: WordOff -> WordOff -> Bool
$c== :: WordOff -> WordOff -> Bool
Eq, Enum WordOff
Real WordOff
Real WordOff
-> Enum WordOff
-> (WordOff -> WordOff -> WordOff)
-> (WordOff -> WordOff -> WordOff)
-> (WordOff -> WordOff -> WordOff)
-> (WordOff -> WordOff -> WordOff)
-> (WordOff -> WordOff -> (WordOff, WordOff))
-> (WordOff -> WordOff -> (WordOff, WordOff))
-> (WordOff -> Integer)
-> Integral WordOff
WordOff -> Integer
WordOff -> WordOff -> (WordOff, WordOff)
WordOff -> WordOff -> WordOff
forall a.
Real a
-> Enum a
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> (a, a))
-> (a -> a -> (a, a))
-> (a -> Integer)
-> Integral a
toInteger :: WordOff -> Integer
$ctoInteger :: WordOff -> Integer
divMod :: WordOff -> WordOff -> (WordOff, WordOff)
$cdivMod :: WordOff -> WordOff -> (WordOff, WordOff)
quotRem :: WordOff -> WordOff -> (WordOff, WordOff)
$cquotRem :: WordOff -> WordOff -> (WordOff, WordOff)
mod :: WordOff -> WordOff -> WordOff
$cmod :: WordOff -> WordOff -> WordOff
div :: WordOff -> WordOff -> WordOff
$cdiv :: WordOff -> WordOff -> WordOff
rem :: WordOff -> WordOff -> WordOff
$crem :: WordOff -> WordOff -> WordOff
quot :: WordOff -> WordOff -> WordOff
$cquot :: WordOff -> WordOff -> WordOff
Integral, Integer -> WordOff
WordOff -> WordOff
WordOff -> WordOff -> WordOff
(WordOff -> WordOff -> WordOff)
-> (WordOff -> WordOff -> WordOff)
-> (WordOff -> WordOff -> WordOff)
-> (WordOff -> WordOff)
-> (WordOff -> WordOff)
-> (WordOff -> WordOff)
-> (Integer -> WordOff)
-> Num WordOff
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
fromInteger :: Integer -> WordOff
$cfromInteger :: Integer -> WordOff
signum :: WordOff -> WordOff
$csignum :: WordOff -> WordOff
abs :: WordOff -> WordOff
$cabs :: WordOff -> WordOff
negate :: WordOff -> WordOff
$cnegate :: WordOff -> WordOff
* :: WordOff -> WordOff -> WordOff
$c* :: WordOff -> WordOff -> WordOff
- :: WordOff -> WordOff -> WordOff
$c- :: WordOff -> WordOff -> WordOff
+ :: WordOff -> WordOff -> WordOff
$c+ :: WordOff -> WordOff -> WordOff
Num, Eq WordOff
Eq WordOff
-> (WordOff -> WordOff -> Ordering)
-> (WordOff -> WordOff -> Bool)
-> (WordOff -> WordOff -> Bool)
-> (WordOff -> WordOff -> Bool)
-> (WordOff -> WordOff -> Bool)
-> (WordOff -> WordOff -> WordOff)
-> (WordOff -> WordOff -> WordOff)
-> Ord WordOff
WordOff -> WordOff -> Bool
WordOff -> WordOff -> Ordering
WordOff -> WordOff -> WordOff
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 :: WordOff -> WordOff -> WordOff
$cmin :: WordOff -> WordOff -> WordOff
max :: WordOff -> WordOff -> WordOff
$cmax :: WordOff -> WordOff -> WordOff
>= :: WordOff -> WordOff -> Bool
$c>= :: WordOff -> WordOff -> Bool
> :: WordOff -> WordOff -> Bool
$c> :: WordOff -> WordOff -> Bool
<= :: WordOff -> WordOff -> Bool
$c<= :: WordOff -> WordOff -> Bool
< :: WordOff -> WordOff -> Bool
$c< :: WordOff -> WordOff -> Bool
compare :: WordOff -> WordOff -> Ordering
$ccompare :: WordOff -> WordOff -> Ordering
Ord, Num WordOff
Ord WordOff
Num WordOff -> Ord WordOff -> (WordOff -> Rational) -> Real WordOff
WordOff -> Rational
forall a. Num a -> Ord a -> (a -> Rational) -> Real a
toRational :: WordOff -> Rational
$ctoRational :: WordOff -> Rational
Real)

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 -> WordOff
forall a. String -> a
panic (String -> WordOff) -> String -> WordOff
forall a b. (a -> b) -> a -> b
$ String
"GHC.CoreToByteCode.bytesToWords: bytes=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show 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, offset) = int offset <> colon <+> ppr var <+> ppr (bcIdArgRep 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
   :: DynFlags
   -> name
   -> BCInstrList
   -> Either  [AnnAlt Id DVarSet] (AnnExpr Id DVarSet)
        -- ^ original expression; for debugging only
   -> Int
   -> Word16
   -> [StgWord]
   -> Bool      -- True <=> is a return point, rather than a function
   -> [FFIInfo]
   -> ProtoBCO name
mkProtoBCO :: forall name.
DynFlags
-> name
-> BCInstrList
-> Either [AnnAlt Id DVarSet] (AnnExpr Id DVarSet)
-> Int
-> Word16
-> [StgWord]
-> Bool
-> [FFIInfo]
-> ProtoBCO name
mkProtoBCO DynFlags
dflags name
nm BCInstrList
instrs_ordlist Either [AnnAlt Id DVarSet] (AnnExpr Id DVarSet)
origin Int
arity Word16
bitmap_size [StgWord]
bitmap Bool
is_ret [FFIInfo]
ffis
   = ProtoBCO :: forall a.
a
-> [BCInstr]
-> [StgWord]
-> Word16
-> Int
-> Either [AnnAlt Id DVarSet] (AnnExpr Id DVarSet)
-> [FFIInfo]
-> ProtoBCO a
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 [AnnAlt Id DVarSet] (AnnExpr Id DVarSet)
protoBCOExpr = Either [AnnAlt Id DVarSet] (AnnExpr Id DVarSet)
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 (DynFlags -> Int
aP_STACK_SPLIM DynFlags
dflags) = [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 (BCInstrList -> [BCInstr]
forall a. OrdList a -> [a]
fromOL BCInstrList
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

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

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

schemeTopBind :: (Id, AnnExpr Id DVarSet) -> BcM (ProtoBCO Name)
schemeTopBind :: (Id, AnnExpr Id DVarSet) -> BcM (ProtoBCO Name)
schemeTopBind (Id
id, AnnExpr Id DVarSet
rhs)
  | Just DataCon
data_con <- Id -> Maybe DataCon
isDataConWorkId_maybe Id
id,
    DataCon -> Bool
isNullaryRepDataCon DataCon
data_con = do
    DynFlags
dflags <- BcM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
        -- 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")
    ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
emitBc (DynFlags
-> Name
-> BCInstrList
-> Either [AnnAlt Id DVarSet] (AnnExpr Id DVarSet)
-> Int
-> Word16
-> [StgWord]
-> Bool
-> [FFIInfo]
-> ProtoBCO Name
forall name.
DynFlags
-> name
-> BCInstrList
-> Either [AnnAlt Id DVarSet] (AnnExpr Id DVarSet)
-> Int
-> Word16
-> [StgWord]
-> Bool
-> [FFIInfo]
-> ProtoBCO name
mkProtoBCO DynFlags
dflags (Id -> Name
forall a. NamedThing a => a -> Name
getName Id
id) ([BCInstr] -> BCInstrList
forall a. [a] -> OrdList a
toOL [DataCon -> Word16 -> BCInstr
PACK DataCon
data_con Word16
0, BCInstr
ENTER])
                       (AnnExpr Id DVarSet
-> Either [AnnAlt Id DVarSet] (AnnExpr Id DVarSet)
forall a b. b -> Either a b
Right AnnExpr Id DVarSet
rhs) Int
0 Word16
0 [{-no bitmap-}] Bool
False{-not alts-})

  | Bool
otherwise
  = [Id] -> (Name, AnnExpr Id DVarSet) -> BcM (ProtoBCO Name)
schemeR [{- No free variables -}] (Id -> Name
forall a. NamedThing a => a -> Name
getName Id
id, AnnExpr Id DVarSet
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, AnnExpr Id DVarSet)
        -> BcM (ProtoBCO Name)
schemeR :: [Id] -> (Name, AnnExpr Id DVarSet) -> BcM (ProtoBCO Name)
schemeR [Id]
fvs (Name
nm, AnnExpr Id DVarSet
rhs)
{-
   | trace (showSDoc (
              (char ' '
               $$ (ppr.filter (not.isTyVar).dVarSetElems.fst) rhs
               $$ pprCoreExpr (deAnnotate rhs)
               $$ char ' '
              ))) False
   = undefined
   | otherwise
-}
   = [Id]
-> Name
-> AnnExpr Id DVarSet
-> ([Id], AnnExpr' Id DVarSet)
-> BcM (ProtoBCO Name)
schemeR_wrk [Id]
fvs Name
nm AnnExpr Id DVarSet
rhs (AnnExpr Id DVarSet -> ([Id], AnnExpr' Id DVarSet)
collect AnnExpr Id DVarSet
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 :: AnnExpr Id DVarSet -> ([Var], AnnExpr' Id DVarSet)
collect :: AnnExpr Id DVarSet -> ([Id], AnnExpr' Id DVarSet)
collect (DVarSet
_, AnnExpr' Id DVarSet
e) = [Id] -> AnnExpr' Id DVarSet -> ([Id], AnnExpr' Id DVarSet)
forall {ann}. [Id] -> AnnExpr' Id ann -> ([Id], AnnExpr' Id ann)
go [] AnnExpr' Id DVarSet
e
  where
    go :: [Id] -> AnnExpr' Id ann -> ([Id], AnnExpr' Id ann)
go [Id]
xs AnnExpr' Id ann
e | Just AnnExpr' Id ann
e' <- AnnExpr' Id ann -> Maybe (AnnExpr' Id ann)
forall ann. AnnExpr' Id ann -> Maybe (AnnExpr' Id ann)
bcView AnnExpr' Id ann
e = [Id] -> AnnExpr' Id ann -> ([Id], AnnExpr' Id ann)
go [Id]
xs AnnExpr' Id ann
e'
    go [Id]
xs (AnnLam Id
x (ann
_,AnnExpr' Id ann
e))
      | HasDebugCallStack => Kind -> [PrimRep]
Kind -> [PrimRep]
typePrimRep (Id -> Kind
idType Id
x) [PrimRep] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthExceeds` Int
1
      = ([Id], AnnExpr' Id ann)
forall a. a
multiValException
      | Bool
otherwise
      = [Id] -> AnnExpr' Id ann -> ([Id], AnnExpr' Id ann)
go (Id
xId -> [Id] -> [Id]
forall a. a -> [a] -> [a]
:[Id]
xs) AnnExpr' Id ann
e
    go [Id]
xs AnnExpr' Id ann
not_lambda = ([Id] -> [Id]
forall a. [a] -> [a]
reverse [Id]
xs, AnnExpr' Id ann
not_lambda)

schemeR_wrk
    :: [Id]
    -> Name
    -> AnnExpr Id DVarSet             -- expression e, for debugging only
    -> ([Var], AnnExpr' Var DVarSet)  -- result of collect on e
    -> BcM (ProtoBCO Name)
schemeR_wrk :: [Id]
-> Name
-> AnnExpr Id DVarSet
-> ([Id], AnnExpr' Id DVarSet)
-> BcM (ProtoBCO Name)
schemeR_wrk [Id]
fvs Name
nm AnnExpr Id DVarSet
original_body ([Id]
args, AnnExpr' Id DVarSet
body)
   = do
     DynFlags
dflags <- BcM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
     let
         platform :: Platform
platform  = DynFlags -> Platform
targetPlatform DynFlags
dflags
         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 Id -> ArgRep
bcIdArgRep [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
     BCInstrList
body_code <- ByteOff -> Map Id ByteOff -> AnnExpr' Id DVarSet -> BcM BCInstrList
schemeER_wrk ByteOff
sum_szsb_args Map Id ByteOff
p_init AnnExpr' Id DVarSet
body

     ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
emitBc (DynFlags
-> Name
-> BCInstrList
-> Either [AnnAlt Id DVarSet] (AnnExpr Id DVarSet)
-> Int
-> Word16
-> [StgWord]
-> Bool
-> [FFIInfo]
-> ProtoBCO Name
forall name.
DynFlags
-> name
-> BCInstrList
-> Either [AnnAlt Id DVarSet] (AnnExpr Id DVarSet)
-> Int
-> Word16
-> [StgWord]
-> Bool
-> [FFIInfo]
-> ProtoBCO name
mkProtoBCO DynFlags
dflags Name
nm BCInstrList
body_code (AnnExpr Id DVarSet
-> Either [AnnAlt Id DVarSet] (AnnExpr Id DVarSet)
forall a b. b -> Either a b
Right AnnExpr Id DVarSet
original_body)
                 Int
arity Word16
bitmap_size [StgWord]
bitmap Bool
False{-not alts-})

-- introduce break instructions for ticked expressions
schemeER_wrk :: StackDepth -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList
schemeER_wrk :: ByteOff -> Map Id ByteOff -> AnnExpr' Id DVarSet -> BcM BCInstrList
schemeER_wrk ByteOff
d Map Id ByteOff
p AnnExpr' Id DVarSet
rhs
  | AnnTick (Breakpoint Int
tick_no [Id]
fvs) (DVarSet
_annot, AnnExpr' Id DVarSet
newRhs) <- AnnExpr' Id DVarSet
rhs
  = do  BCInstrList
code <- ByteOff
-> ByteOff
-> Map Id ByteOff
-> AnnExpr' Id DVarSet
-> BcM BCInstrList
schemeE ByteOff
d ByteOff
0 Map Id ByteOff
p AnnExpr' Id DVarSet
newRhs
        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
        DynFlags
dflags <- BcM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
        let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
        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]
fvs
        let breakInfo :: CgBreakInfo
breakInfo = CgBreakInfo :: [Maybe (Id, Word16)] -> Kind -> CgBreakInfo
CgBreakInfo
                        { cgb_vars :: [Maybe (Id, Word16)]
cgb_vars = [Maybe (Id, Word16)]
idOffSets
                        , cgb_resty :: Kind
cgb_resty = Expr Id -> Kind
exprType (AnnExpr' Id DVarSet -> Expr Id
forall bndr annot. AnnExpr' bndr annot -> Expr bndr
deAnnotate' AnnExpr' Id DVarSet
newRhs)
                        }
        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
        BCInstrList -> BcM BCInstrList
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstrList -> BcM BCInstrList) -> BCInstrList -> BcM BCInstrList
forall a b. (a -> b) -> a -> b
$ BCInstr
breakInstr BCInstr -> BCInstrList -> BCInstrList
forall a. a -> OrdList a -> OrdList a
`consOL` BCInstrList
code
   | Bool
otherwise = ByteOff
-> ByteOff
-> Map Id ByteOff
-> AnnExpr' Id DVarSet
-> BcM BCInstrList
schemeE ByteOff
d ByteOff
0 Map Id ByteOff
p AnnExpr' Id DVarSet
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 -> DVarSet -> [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 -> DVarSet -> [Id]
fvsToEnv Map Id ByteOff
p DVarSet
fvs = [Id
v | Id
v <- DVarSet -> [Id]
dVarSetElems DVarSet
fvs,
                      Id -> Bool
isId Id
v,           -- Could be a type variable
                      Id
v Id -> Map Id ByteOff -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map Id ByteOff
p]

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

returnUnboxedAtom
    :: StackDepth
    -> Sequel
    -> BCEnv
    -> AnnExpr' Id DVarSet
    -> ArgRep
    -> BcM BCInstrList
-- Returning an unlifted value.
-- Heave it on the stack, SLIDE, and RETURN.
returnUnboxedAtom :: ByteOff
-> ByteOff
-> Map Id ByteOff
-> AnnExpr' Id DVarSet
-> ArgRep
-> BcM BCInstrList
returnUnboxedAtom ByteOff
d ByteOff
s Map Id ByteOff
p AnnExpr' Id DVarSet
e ArgRep
e_rep = do
    DynFlags
dflags <- BcM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
    (BCInstrList
push, ByteOff
szb) <- ByteOff
-> Map Id ByteOff
-> AnnExpr' Id DVarSet
-> BcM (BCInstrList, ByteOff)
pushAtom ByteOff
d Map Id ByteOff
p AnnExpr' Id DVarSet
e
    BCInstrList -> BcM BCInstrList
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstrList
push                                  -- value onto stack
           BCInstrList -> BCInstrList -> BCInstrList
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`  Platform -> ByteOff -> ByteOff -> BCInstrList
mkSlideB Platform
platform ByteOff
szb (ByteOff
d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
- ByteOff
s) -- clear to sequel
           BCInstrList -> BCInstr -> BCInstrList
forall a. OrdList a -> a -> OrdList a
`snocOL` ArgRep -> BCInstr
RETURN_UBX ArgRep
e_rep)             -- go

-- Compile code to apply the given expression to the remaining args
-- on the stack, returning a HNF.
schemeE
    :: StackDepth -> Sequel -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList
schemeE :: ByteOff
-> ByteOff
-> Map Id ByteOff
-> AnnExpr' Id DVarSet
-> BcM BCInstrList
schemeE ByteOff
d ByteOff
s Map Id ByteOff
p AnnExpr' Id DVarSet
e
   | Just AnnExpr' Id DVarSet
e' <- AnnExpr' Id DVarSet -> Maybe (AnnExpr' Id DVarSet)
forall ann. AnnExpr' Id ann -> Maybe (AnnExpr' Id ann)
bcView AnnExpr' Id DVarSet
e
   = ByteOff
-> ByteOff
-> Map Id ByteOff
-> AnnExpr' Id DVarSet
-> BcM BCInstrList
schemeE ByteOff
d ByteOff
s Map Id ByteOff
p AnnExpr' Id DVarSet
e'

-- Delegate tail-calls to schemeT.
schemeE ByteOff
d ByteOff
s Map Id ByteOff
p e :: AnnExpr' Id DVarSet
e@(AnnApp AnnExpr Id DVarSet
_ AnnExpr Id DVarSet
_) = ByteOff
-> ByteOff
-> Map Id ByteOff
-> AnnExpr' Id DVarSet
-> BcM BCInstrList
schemeT ByteOff
d ByteOff
s Map Id ByteOff
p AnnExpr' Id DVarSet
e

schemeE ByteOff
d ByteOff
s Map Id ByteOff
p e :: AnnExpr' Id DVarSet
e@(AnnLit Literal
lit)     = ByteOff
-> ByteOff
-> Map Id ByteOff
-> AnnExpr' Id DVarSet
-> ArgRep
-> BcM BCInstrList
returnUnboxedAtom ByteOff
d ByteOff
s Map Id ByteOff
p AnnExpr' Id DVarSet
e (Kind -> ArgRep
typeArgRep (Literal -> Kind
literalType Literal
lit))
schemeE ByteOff
d ByteOff
s Map Id ByteOff
p e :: AnnExpr' Id DVarSet
e@(AnnCoercion {}) = ByteOff
-> ByteOff
-> Map Id ByteOff
-> AnnExpr' Id DVarSet
-> ArgRep
-> BcM BCInstrList
returnUnboxedAtom ByteOff
d ByteOff
s Map Id ByteOff
p AnnExpr' Id DVarSet
e ArgRep
V

schemeE ByteOff
d ByteOff
s Map Id ByteOff
p e :: AnnExpr' Id DVarSet
e@(AnnVar Id
v)
      -- See Note [Not-necessarily-lifted join points], step 3.
    | Id -> Bool
isNNLJoinPoint Id
v          = ByteOff
-> ByteOff
-> Map Id ByteOff
-> Id
-> [AnnExpr' Id DVarSet]
-> BcM BCInstrList
doTailCall ByteOff
d ByteOff
s Map Id ByteOff
p (Id -> Id
protectNNLJoinPointId Id
v) [Id -> AnnExpr' Id DVarSet
forall bndr annot. Id -> AnnExpr' bndr annot
AnnVar Id
voidPrimId]
    | HasDebugCallStack => Kind -> Bool
Kind -> Bool
isUnliftedType (Id -> Kind
idType Id
v) = ByteOff
-> ByteOff
-> Map Id ByteOff
-> AnnExpr' Id DVarSet
-> ArgRep
-> BcM BCInstrList
returnUnboxedAtom ByteOff
d ByteOff
s Map Id ByteOff
p AnnExpr' Id DVarSet
e (Id -> ArgRep
bcIdArgRep Id
v)
    | Bool
otherwise                 = ByteOff
-> ByteOff
-> Map Id ByteOff
-> AnnExpr' Id DVarSet
-> BcM BCInstrList
schemeT ByteOff
d ByteOff
s Map Id ByteOff
p AnnExpr' Id DVarSet
e

schemeE ByteOff
d ByteOff
s Map Id ByteOff
p (AnnLet (AnnNonRec Id
x (DVarSet
_,AnnExpr' Id DVarSet
rhs)) (DVarSet
_,AnnExpr' Id DVarSet
body))
   | (AnnVar Id
v, [AnnExpr' Id DVarSet]
args_r_to_l) <- AnnExpr' Id DVarSet -> (AnnExpr' Id DVarSet, [AnnExpr' Id DVarSet])
forall ann. AnnExpr' Id ann -> (AnnExpr' Id ann, [AnnExpr' Id ann])
splitApp AnnExpr' Id DVarSet
rhs,
     Just DataCon
data_con <- Id -> Maybe DataCon
isDataConWorkId_maybe Id
v,
     DataCon -> Int
dataConRepArity DataCon
data_con Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [AnnExpr' Id DVarSet] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [AnnExpr' Id DVarSet]
args_r_to_l
   = do -- Special case for a non-recursive let whose RHS is a
        -- saturated constructor application.
        -- Just allocate the constructor and carry on
        BCInstrList
alloc_code <- ByteOff
-> ByteOff
-> Map Id ByteOff
-> DataCon
-> [AnnExpr' Id DVarSet]
-> BcM BCInstrList
mkConAppCode ByteOff
d ByteOff
s Map Id ByteOff
p DataCon
data_con [AnnExpr' Id DVarSet]
args_r_to_l
        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
        BCInstrList
body_code <- ByteOff
-> ByteOff
-> Map Id ByteOff
-> AnnExpr' Id DVarSet
-> BcM BCInstrList
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
x ByteOff
d2 Map Id ByteOff
p) AnnExpr' Id DVarSet
body
        BCInstrList -> BcM BCInstrList
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstrList
alloc_code BCInstrList -> BCInstrList -> BCInstrList
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` BCInstrList
body_code)

-- General case for let.  Generates correct, if inefficient, code in
-- all situations.
schemeE ByteOff
d ByteOff
s Map Id ByteOff
p (AnnLet AnnBind Id DVarSet
binds (DVarSet
_,AnnExpr' Id DVarSet
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,[AnnExpr Id DVarSet]
rhss) = case AnnBind Id DVarSet
binds of AnnNonRec Id
x AnnExpr Id DVarSet
rhs  -> ([Id
x],[AnnExpr Id DVarSet
rhs])
                                   AnnRec [(Id, AnnExpr Id DVarSet)]
xs_n_rhss -> [(Id, AnnExpr Id DVarSet)] -> ([Id], [AnnExpr Id DVarSet])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Id, AnnExpr Id DVarSet)]
xs_n_rhss
         n_binds :: WordOff
n_binds = [Id] -> WordOff
forall i a. Num i => [a] -> i
genericLength [Id]
xs

         fvss :: [[Id]]
fvss  = (AnnExpr Id DVarSet -> [Id]) -> [AnnExpr Id DVarSet] -> [[Id]]
forall a b. (a -> b) -> [a] -> [b]
map (Map Id ByteOff -> DVarSet -> [Id]
fvsToEnv Map Id ByteOff
p' (DVarSet -> [Id])
-> (AnnExpr Id DVarSet -> DVarSet) -> AnnExpr Id DVarSet -> [Id]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnnExpr Id DVarSet -> DVarSet
forall a b. (a, b) -> a
fst) [AnnExpr Id DVarSet]
rhss

           -- See Note [Not-necessarily-lifted join points], step 2.
         ([Id]
xs',[AnnExpr Id DVarSet]
rhss') = (Id -> AnnExpr Id DVarSet -> (Id, AnnExpr Id DVarSet))
-> [Id] -> [AnnExpr Id DVarSet] -> ([Id], [AnnExpr Id DVarSet])
forall a b c d. (a -> b -> (c, d)) -> [a] -> [b] -> ([c], [d])
zipWithAndUnzip Id -> AnnExpr Id DVarSet -> (Id, AnnExpr Id DVarSet)
protectNNLJoinPointBind [Id]
xs [AnnExpr Id DVarSet]
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 = (AnnExpr Id DVarSet -> Word16) -> [AnnExpr Id DVarSet] -> [Word16]
forall a b. (a -> b) -> [a] -> [b]
map ([Id] -> Word16
forall i a. Num i => [a] -> i
genericLength ([Id] -> Word16)
-> (AnnExpr Id DVarSet -> [Id]) -> AnnExpr Id DVarSet -> Word16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Id], AnnExpr' Id DVarSet) -> [Id]
forall a b. (a, b) -> a
fst (([Id], AnnExpr' Id DVarSet) -> [Id])
-> (AnnExpr Id DVarSet -> ([Id], AnnExpr' Id DVarSet))
-> AnnExpr Id DVarSet
-> [Id]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnnExpr Id DVarSet -> ([Id], AnnExpr' Id DVarSet)
collect) [AnnExpr Id DVarSet]
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 BCInstrList
build_thunk ByteOff
_ [] Word16
size ProtoBCO Name
bco Word16
off Word16
arity
            = BCInstrList -> BcM BCInstrList
forall (m :: * -> *) a. Monad m => a -> m a
return (ProtoBCO Name -> BCInstr
PUSH_BCO ProtoBCO Name
bco BCInstr -> BCInstrList -> BCInstrList
forall a. a -> OrdList a -> OrdList a
`consOL` BCInstr -> BCInstrList
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
              (BCInstrList
push_code, ByteOff
pushed_szb) <- ByteOff
-> Map Id ByteOff
-> AnnExpr' Id DVarSet
-> BcM (BCInstrList, ByteOff)
pushAtom ByteOff
dd Map Id ByteOff
p' (Id -> AnnExpr' Id DVarSet
forall bndr annot. Id -> AnnExpr' bndr annot
AnnVar Id
fv)
              BCInstrList
more_push_code <-
                  ByteOff
-> [Id]
-> Word16
-> ProtoBCO Name
-> Word16
-> Word16
-> BcM BCInstrList
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
              BCInstrList -> BcM BCInstrList
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstrList
push_code BCInstrList -> BCInstrList -> BCInstrList
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` BCInstrList
more_push_code)

         alloc_code :: BCInstrList
alloc_code = [BCInstr] -> BCInstrList
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 AnnBind Id DVarSet
binds of
                     AnnNonRec Id
id AnnExpr Id DVarSet
_ -> OccName -> FastString
occNameFS (Id -> OccName
forall a. NamedThing a => a -> OccName
getOccName Id
id) FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
== FastString
tickFS
                     AnnBind Id DVarSet
_other -> Bool
False

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

         compile_binds :: [BcM BCInstrList]
compile_binds =
            [ ByteOff
-> [Id]
-> Id
-> AnnExpr Id DVarSet
-> Word16
-> Word16
-> Word16
-> BcM BCInstrList
forall {a}.
NamedThing a =>
ByteOff
-> [Id]
-> a
-> AnnExpr Id DVarSet
-> Word16
-> Word16
-> Word16
-> BcM BCInstrList
compile_bind ByteOff
d' [Id]
fvs Id
x AnnExpr Id DVarSet
rhs Word16
size Word16
arity (WordOff -> Word16
trunc16W WordOff
n)
            | ([Id]
fvs, Id
x, AnnExpr Id DVarSet
rhs, Word16
size, Word16
arity, WordOff
n) <-
                [[Id]]
-> [Id]
-> [AnnExpr Id DVarSet]
-> [Word16]
-> [Word16]
-> [WordOff]
-> [([Id], Id, AnnExpr Id DVarSet, 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' [AnnExpr Id DVarSet]
rhss' [Word16]
sizes [Word16]
arities [WordOff
n_binds, WordOff
n_bindsWordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
-WordOff
1 .. WordOff
1]
            ]
     BCInstrList
body_code <- ByteOff
-> ByteOff
-> Map Id ByteOff
-> AnnExpr' Id DVarSet
-> BcM BCInstrList
schemeE ByteOff
d' ByteOff
s Map Id ByteOff
p' AnnExpr' Id DVarSet
body
     [BCInstrList]
thunk_codes <- [BcM BCInstrList] -> BcM [BCInstrList]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [BcM BCInstrList]
compile_binds
     BCInstrList -> BcM BCInstrList
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstrList
alloc_code BCInstrList -> BCInstrList -> BCInstrList
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [BCInstrList] -> BCInstrList
forall a. [OrdList a] -> OrdList a
concatOL [BCInstrList]
thunk_codes BCInstrList -> BCInstrList -> BCInstrList
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` BCInstrList
body_code)

-- Introduce a let binding for a ticked case expression. This rule
-- *should* only fire when the expression was not already let-bound
-- (the code gen for let bindings should take care of that).  Todo: we
-- call exprFreeVars on a deAnnotated expression, this may not be the
-- best way to calculate the free vars but it seemed like the least
-- intrusive thing to do
schemeE ByteOff
d ByteOff
s Map Id ByteOff
p exp :: AnnExpr' Id DVarSet
exp@(AnnTick (Breakpoint Int
_id [Id]
_fvs) AnnExpr Id DVarSet
_rhs)
   | Kind -> Bool
isLiftedTypeKind (HasDebugCallStack => Kind -> Kind
Kind -> Kind
typeKind Kind
ty)
   = do   Id
id <- Kind -> BcM Id
newId Kind
ty
          -- Todo: is emptyVarSet correct on the next line?
          let letExp :: AnnExpr' Id DVarSet
letExp = AnnBind Id DVarSet -> AnnExpr Id DVarSet -> AnnExpr' Id DVarSet
forall bndr annot.
AnnBind bndr annot -> AnnExpr bndr annot -> AnnExpr' bndr annot
AnnLet (Id -> AnnExpr Id DVarSet -> AnnBind Id DVarSet
forall bndr annot. bndr -> AnnExpr bndr annot -> AnnBind bndr annot
AnnNonRec Id
id (DVarSet
fvs, AnnExpr' Id DVarSet
exp)) (DVarSet
emptyDVarSet, Id -> AnnExpr' Id DVarSet
forall bndr annot. Id -> AnnExpr' bndr annot
AnnVar Id
id)
          ByteOff
-> ByteOff
-> Map Id ByteOff
-> AnnExpr' Id DVarSet
-> BcM BCInstrList
schemeE ByteOff
d ByteOff
s Map Id ByteOff
p AnnExpr' Id DVarSet
letExp

   | Bool
otherwise
   = do   -- If the result type is not definitely lifted, then we must generate
          --   let f = \s . tick<n> e
          --   in  f realWorld#
          -- When we stop at the breakpoint, _result will have an unlifted
          -- type and hence won't be bound in the environment, but the
          -- breakpoint will otherwise work fine.
          --
          -- NB (#12007) this /also/ applies for if (ty :: TYPE r), where
          --    r :: RuntimeRep is a variable. This can happen in the
          --    continuations for a pattern-synonym matcher
          --    match = /\(r::RuntimeRep) /\(a::TYPE r).
          --            \(k :: Int -> a) \(v::T).
          --            case v of MkV n -> k n
          -- Here (k n) :: a :: Type r, so we don't know if it's lifted
          -- or not; but that should be fine provided we add that void arg.

          Id
id <- Kind -> BcM Id
newId (Kind -> Kind -> Kind
mkVisFunTyMany Kind
realWorldStatePrimTy Kind
ty)
          Id
st <- Kind -> BcM Id
newId Kind
realWorldStatePrimTy
          let letExp :: AnnExpr' Id DVarSet
letExp = AnnBind Id DVarSet -> AnnExpr Id DVarSet -> AnnExpr' Id DVarSet
forall bndr annot.
AnnBind bndr annot -> AnnExpr bndr annot -> AnnExpr' bndr annot
AnnLet (Id -> AnnExpr Id DVarSet -> AnnBind Id DVarSet
forall bndr annot. bndr -> AnnExpr bndr annot -> AnnBind bndr annot
AnnNonRec Id
id (DVarSet
fvs, Id -> AnnExpr Id DVarSet -> AnnExpr' Id DVarSet
forall bndr annot.
bndr -> AnnExpr bndr annot -> AnnExpr' bndr annot
AnnLam Id
st (DVarSet
emptyDVarSet, AnnExpr' Id DVarSet
exp)))
                              (DVarSet
emptyDVarSet, (AnnExpr Id DVarSet -> AnnExpr Id DVarSet -> AnnExpr' Id DVarSet
forall bndr annot.
AnnExpr bndr annot -> AnnExpr bndr annot -> AnnExpr' bndr annot
AnnApp (DVarSet
emptyDVarSet, Id -> AnnExpr' Id DVarSet
forall bndr annot. Id -> AnnExpr' bndr annot
AnnVar Id
id)
                                                    (DVarSet
emptyDVarSet, Id -> AnnExpr' Id DVarSet
forall bndr annot. Id -> AnnExpr' bndr annot
AnnVar Id
realWorldPrimId)))
          ByteOff
-> ByteOff
-> Map Id ByteOff
-> AnnExpr' Id DVarSet
-> BcM BCInstrList
schemeE ByteOff
d ByteOff
s Map Id ByteOff
p AnnExpr' Id DVarSet
letExp

   where
     exp' :: Expr Id
exp' = AnnExpr' Id DVarSet -> Expr Id
forall bndr annot. AnnExpr' bndr annot -> Expr bndr
deAnnotate' AnnExpr' Id DVarSet
exp
     fvs :: DVarSet
fvs  = Expr Id -> DVarSet
exprFreeVarsDSet Expr Id
exp'
     ty :: Kind
ty   = Expr Id -> Kind
exprType Expr Id
exp'

-- ignore other kinds of tick
schemeE ByteOff
d ByteOff
s Map Id ByteOff
p (AnnTick Tickish Id
_ (DVarSet
_, AnnExpr' Id DVarSet
rhs)) = ByteOff
-> ByteOff
-> Map Id ByteOff
-> AnnExpr' Id DVarSet
-> BcM BCInstrList
schemeE ByteOff
d ByteOff
s Map Id ByteOff
p AnnExpr' Id DVarSet
rhs

-- no alts: scrut is guaranteed to diverge
schemeE ByteOff
d ByteOff
s Map Id ByteOff
p (AnnCase (DVarSet
_,AnnExpr' Id DVarSet
scrut) Id
_ Kind
_ []) = ByteOff
-> ByteOff
-> Map Id ByteOff
-> AnnExpr' Id DVarSet
-> BcM BCInstrList
schemeE ByteOff
d ByteOff
s Map Id ByteOff
p AnnExpr' Id DVarSet
scrut

-- handle pairs with one void argument (e.g. state token)
schemeE ByteOff
d ByteOff
s Map Id ByteOff
p (AnnCase AnnExpr Id DVarSet
scrut Id
bndr Kind
_ [(DataAlt DataCon
dc, [Id
bind1, Id
bind2], AnnExpr Id DVarSet
rhs)])
   | DataCon -> Bool
isUnboxedTupleCon DataCon
dc
        -- Convert
        --      case .... of x { (# V'd-thing, a #) -> ... }
        -- to
        --      case .... of a { DEFAULT -> ... }
        -- because the return convention for both are identical.
        --
        -- Note that it does not matter losing the void-rep thing from the
        -- envt (it won't be bound now) because we never look such things up.
   , Just BcM BCInstrList
res <- case (HasDebugCallStack => Kind -> [PrimRep]
Kind -> [PrimRep]
typePrimRep (Id -> Kind
idType Id
bind1), HasDebugCallStack => Kind -> [PrimRep]
Kind -> [PrimRep]
typePrimRep (Id -> Kind
idType Id
bind2)) of
                   ([], [PrimRep
_])
                     -> BcM BCInstrList -> Maybe (BcM BCInstrList)
forall a. a -> Maybe a
Just (BcM BCInstrList -> Maybe (BcM BCInstrList))
-> BcM BCInstrList -> Maybe (BcM BCInstrList)
forall a b. (a -> b) -> a -> b
$ ByteOff
-> ByteOff
-> Map Id ByteOff
-> AnnExpr Id DVarSet
-> Id
-> [AnnAlt Id DVarSet]
-> Maybe Id
-> BcM BCInstrList
doCase ByteOff
d ByteOff
s Map Id ByteOff
p AnnExpr Id DVarSet
scrut Id
bind2 [(AltCon
DEFAULT, [], AnnExpr Id DVarSet
rhs)] (Id -> Maybe Id
forall a. a -> Maybe a
Just Id
bndr)
                   ([PrimRep
_], [])
                     -> BcM BCInstrList -> Maybe (BcM BCInstrList)
forall a. a -> Maybe a
Just (BcM BCInstrList -> Maybe (BcM BCInstrList))
-> BcM BCInstrList -> Maybe (BcM BCInstrList)
forall a b. (a -> b) -> a -> b
$ ByteOff
-> ByteOff
-> Map Id ByteOff
-> AnnExpr Id DVarSet
-> Id
-> [AnnAlt Id DVarSet]
-> Maybe Id
-> BcM BCInstrList
doCase ByteOff
d ByteOff
s Map Id ByteOff
p AnnExpr Id DVarSet
scrut Id
bind1 [(AltCon
DEFAULT, [], AnnExpr Id DVarSet
rhs)] (Id -> Maybe Id
forall a. a -> Maybe a
Just Id
bndr)
                   ([PrimRep], [PrimRep])
_ -> Maybe (BcM BCInstrList)
forall a. Maybe a
Nothing
   = BcM BCInstrList
res

-- handle unit tuples
schemeE ByteOff
d ByteOff
s Map Id ByteOff
p (AnnCase AnnExpr Id DVarSet
scrut Id
bndr Kind
_ [(DataAlt DataCon
dc, [Id
bind1], AnnExpr Id DVarSet
rhs)])
   | DataCon -> Bool
isUnboxedTupleCon DataCon
dc
   , HasDebugCallStack => Kind -> [PrimRep]
Kind -> [PrimRep]
typePrimRep (Id -> Kind
idType Id
bndr) [PrimRep] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthAtMost` Int
1
   = ByteOff
-> ByteOff
-> Map Id ByteOff
-> AnnExpr Id DVarSet
-> Id
-> [AnnAlt Id DVarSet]
-> Maybe Id
-> BcM BCInstrList
doCase ByteOff
d ByteOff
s Map Id ByteOff
p AnnExpr Id DVarSet
scrut Id
bind1 [(AltCon
DEFAULT, [], AnnExpr Id DVarSet
rhs)] (Id -> Maybe Id
forall a. a -> Maybe a
Just Id
bndr)

-- handle nullary tuples
schemeE ByteOff
d ByteOff
s Map Id ByteOff
p (AnnCase AnnExpr Id DVarSet
scrut Id
bndr Kind
_ alt :: [AnnAlt Id DVarSet]
alt@[(AltCon
DEFAULT, [], AnnExpr Id DVarSet
_)])
   | Kind -> Bool
isUnboxedTupleType (Id -> Kind
idType Id
bndr)
   , Just Kind
ty <- case HasDebugCallStack => Kind -> [PrimRep]
Kind -> [PrimRep]
typePrimRep (Id -> Kind
idType Id
bndr) of
       [PrimRep
_]  -> Kind -> Maybe Kind
forall a. a -> Maybe a
Just (Kind -> Kind
unwrapType (Id -> Kind
idType Id
bndr))
       []   -> Kind -> Maybe Kind
forall a. a -> Maybe a
Just Kind
voidPrimTy
       [PrimRep]
_    -> Maybe Kind
forall a. Maybe a
Nothing
       -- handles any pattern with a single non-void binder; in particular I/O
       -- monad returns (# RealWorld#, a #)
   = ByteOff
-> ByteOff
-> Map Id ByteOff
-> AnnExpr Id DVarSet
-> Id
-> [AnnAlt Id DVarSet]
-> Maybe Id
-> BcM BCInstrList
doCase ByteOff
d ByteOff
s Map Id ByteOff
p AnnExpr Id DVarSet
scrut (Id
bndr Id -> Kind -> Id
`setIdType` Kind
ty) [AnnAlt Id DVarSet]
alt (Id -> Maybe Id
forall a. a -> Maybe a
Just Id
bndr)

schemeE ByteOff
d ByteOff
s Map Id ByteOff
p (AnnCase AnnExpr Id DVarSet
scrut Id
bndr Kind
_ [AnnAlt Id DVarSet]
alts)
   = ByteOff
-> ByteOff
-> Map Id ByteOff
-> AnnExpr Id DVarSet
-> Id
-> [AnnAlt Id DVarSet]
-> Maybe Id
-> BcM BCInstrList
doCase ByteOff
d ByteOff
s Map Id ByteOff
p AnnExpr Id DVarSet
scrut Id
bndr [AnnAlt Id DVarSet]
alts Maybe Id
forall a. Maybe a
Nothing{-not an unboxed tuple-}

schemeE ByteOff
_ ByteOff
_ Map Id ByteOff
_ AnnExpr' Id DVarSet
expr
   = String -> SDoc -> BcM BCInstrList
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"GHC.CoreToByteCode.schemeE: unhandled case"
               (Expr Id -> SDoc
forall b. OutputableBndr b => Expr b -> SDoc
pprCoreExpr (AnnExpr' Id DVarSet -> Expr Id
forall bndr annot. AnnExpr' bndr annot -> Expr bndr
deAnnotate' AnnExpr' Id DVarSet
expr))

-- 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)

-- If necessary, modify this Id and body to protect not-necessarily-lifted join points.
-- See Note [Not-necessarily-lifted join points], step 2.
protectNNLJoinPointBind :: Id -> AnnExpr Id DVarSet -> (Id, AnnExpr Id DVarSet)
protectNNLJoinPointBind :: Id -> AnnExpr Id DVarSet -> (Id, AnnExpr Id DVarSet)
protectNNLJoinPointBind Id
x rhs :: AnnExpr Id DVarSet
rhs@(DVarSet
fvs, AnnExpr' Id DVarSet
_)
  | Id -> Bool
isNNLJoinPoint Id
x
  = (Id -> Id
protectNNLJoinPointId Id
x, (DVarSet
fvs, Id -> AnnExpr Id DVarSet -> AnnExpr' Id DVarSet
forall bndr annot.
bndr -> AnnExpr bndr annot -> AnnExpr' bndr annot
AnnLam Id
voidArgId AnnExpr Id DVarSet
rhs))

  | Bool
otherwise
  = (Id
x, AnnExpr Id DVarSet
rhs)

-- 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
voidPrimTy 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 `\ (_ :: Void#) ->` to its RHS, and modify the
   type to tack on a `Void# ->`. (Void# is written voidPrimTy within GHC.)
   Note that functions are never levity-polymorphic, so this transformation
   changes an NNLJP to a non-levity-polymorphic join point. This is done
   in protectNNLJoinPointBind, called from the AnnLet case of schemeE.

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.  (Another nasty hack).  Spot (# a::V, b #) and treat
--     it simply as  b  -- since the representations are identical
--     (the V takes up zero stack space).  Also, spot
--     (# b #) and treat it as  b.
--
-- 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
        -> AnnExpr' Id DVarSet
        -> BcM BCInstrList

schemeT :: ByteOff
-> ByteOff
-> Map Id ByteOff
-> AnnExpr' Id DVarSet
-> BcM BCInstrList
schemeT ByteOff
d ByteOff
s Map Id ByteOff
p AnnExpr' Id DVarSet
app

   -- Case 0
   | Just (AnnExpr' Id DVarSet
arg, [Name]
constr_names) <- AnnExpr' Id DVarSet -> Maybe (AnnExpr' Id DVarSet, [Name])
maybe_is_tagToEnum_call AnnExpr' Id DVarSet
app
   = ByteOff
-> ByteOff
-> Map Id ByteOff
-> AnnExpr' Id DVarSet
-> [Name]
-> BcM BCInstrList
implement_tagToId ByteOff
d ByteOff
s Map Id ByteOff
p AnnExpr' Id DVarSet
arg [Name]
constr_names

   -- Case 1
   | Just (CCall CCallSpec
ccall_spec) <- Id -> Maybe ForeignCall
isFCallId_maybe Id
fn
   = if CCallSpec -> Bool
isSupportedCConv CCallSpec
ccall_spec
      then ByteOff
-> ByteOff
-> Map Id ByteOff
-> CCallSpec
-> Id
-> [AnnExpr' Id DVarSet]
-> BcM BCInstrList
generateCCall ByteOff
d ByteOff
s Map Id ByteOff
p CCallSpec
ccall_spec Id
fn [AnnExpr' Id DVarSet]
args_r_to_l
      else BcM BCInstrList
forall a. a
unsupportedCConvException


   -- Case 2: Constructor application
   | Just DataCon
con <- Maybe DataCon
maybe_saturated_dcon
   , DataCon -> Bool
isUnboxedTupleCon DataCon
con
   = case [AnnExpr' Id DVarSet]
args_r_to_l of
        [AnnExpr' Id DVarSet
arg1,AnnExpr' Id DVarSet
arg2] | AnnExpr' Id DVarSet -> Bool
forall ann. AnnExpr' Id ann -> Bool
isVAtom AnnExpr' Id DVarSet
arg1 ->
                  ByteOff
-> ByteOff
-> Map Id ByteOff
-> AnnExpr' Id DVarSet
-> BcM BCInstrList
unboxedTupleReturn ByteOff
d ByteOff
s Map Id ByteOff
p AnnExpr' Id DVarSet
arg2
        [AnnExpr' Id DVarSet
arg1,AnnExpr' Id DVarSet
arg2] | AnnExpr' Id DVarSet -> Bool
forall ann. AnnExpr' Id ann -> Bool
isVAtom AnnExpr' Id DVarSet
arg2 ->
                  ByteOff
-> ByteOff
-> Map Id ByteOff
-> AnnExpr' Id DVarSet
-> BcM BCInstrList
unboxedTupleReturn ByteOff
d ByteOff
s Map Id ByteOff
p AnnExpr' Id DVarSet
arg1
        [AnnExpr' Id DVarSet]
_other -> BcM BCInstrList
forall a. a
multiValException

   -- Case 3: Ordinary data constructor
   | Just DataCon
con <- Maybe DataCon
maybe_saturated_dcon
   = do BCInstrList
alloc_con <- ByteOff
-> ByteOff
-> Map Id ByteOff
-> DataCon
-> [AnnExpr' Id DVarSet]
-> BcM BCInstrList
mkConAppCode ByteOff
d ByteOff
s Map Id ByteOff
p DataCon
con [AnnExpr' Id DVarSet]
args_r_to_l
        DynFlags
dflags <- BcM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
        let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
        BCInstrList -> BcM BCInstrList
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstrList
alloc_con         BCInstrList -> BCInstrList -> BCInstrList
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                Word16 -> WordOff -> BCInstrList
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) BCInstrList -> BCInstr -> BCInstrList
forall a. OrdList a -> a -> OrdList a
`snocOL`
                BCInstr
ENTER)

   -- Case 4: Tail call of function
   | Bool
otherwise
   = ByteOff
-> ByteOff
-> Map Id ByteOff
-> Id
-> [AnnExpr' Id DVarSet]
-> BcM BCInstrList
doTailCall ByteOff
d ByteOff
s Map Id ByteOff
p Id
fn [AnnExpr' Id DVarSet]
args_r_to_l

   where
        -- Extract the args (R->L) and fn
        -- The function will necessarily be a variable,
        -- because we are compiling a tail call
      (AnnVar Id
fn, [AnnExpr' Id DVarSet]
args_r_to_l) = AnnExpr' Id DVarSet -> (AnnExpr' Id DVarSet, [AnnExpr' Id DVarSet])
forall ann. AnnExpr' Id ann -> (AnnExpr' Id ann, [AnnExpr' Id ann])
splitApp AnnExpr' Id DVarSet
app

      -- Only consider this to be a constructor application iff it is
      -- saturated.  Otherwise, we'll call the constructor wrapper.
      n_args :: Int
n_args = [AnnExpr' Id DVarSet] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [AnnExpr' Id DVarSet]
args_r_to_l
      maybe_saturated_dcon :: Maybe DataCon
maybe_saturated_dcon
        = case Id -> Maybe DataCon
isDataConWorkId_maybe Id
fn of
                Just DataCon
con | DataCon -> Int
dataConRepArity DataCon
con Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n_args -> DataCon -> Maybe DataCon
forall a. a -> Maybe a
Just DataCon
con
                Maybe DataCon
_ -> Maybe DataCon
forall a. Maybe a
Nothing

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

mkConAppCode
    :: StackDepth
    -> Sequel
    -> BCEnv
    -> DataCon                  -- The data constructor
    -> [AnnExpr' Id DVarSet]    -- Args, in *reverse* order
    -> BcM BCInstrList
mkConAppCode :: ByteOff
-> ByteOff
-> Map Id ByteOff
-> DataCon
-> [AnnExpr' Id DVarSet]
-> BcM BCInstrList
mkConAppCode ByteOff
_ ByteOff
_ Map Id ByteOff
_ DataCon
con []       -- Nullary constructor
  = ASSERT( isNullaryRepDataCon con )
    BCInstrList -> BcM BCInstrList
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstr -> BCInstrList
forall a. a -> OrdList a
unitOL (Name -> BCInstr
PUSH_G (Id -> Name
forall a. NamedThing a => a -> Name
getName (DataCon -> Id
dataConWorkId DataCon
con))))
        -- Instead of doing a PACK, which would allocate a fresh
        -- copy of this constructor, use the single shared version.

mkConAppCode ByteOff
orig_d ByteOff
_ Map Id ByteOff
p DataCon
con [AnnExpr' Id DVarSet]
args_r_to_l =
    ASSERT( args_r_to_l `lengthIs` dataConRepArity con ) app_code
  where
    app_code :: BcM BCInstrList
app_code = do
        DynFlags
dflags <- BcM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
        let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags

        -- The args are initially in reverse order, but mkVirtHeapOffsets
        -- expects them to be left-to-right.
        let non_voids :: [NonVoid (PrimRep, AnnExpr' Id DVarSet)]
non_voids =
                [ (PrimRep, AnnExpr' Id DVarSet)
-> NonVoid (PrimRep, AnnExpr' Id DVarSet)
forall a. a -> NonVoid a
NonVoid (PrimRep
prim_rep, AnnExpr' Id DVarSet
arg)
                | AnnExpr' Id DVarSet
arg <- [AnnExpr' Id DVarSet] -> [AnnExpr' Id DVarSet]
forall a. [a] -> [a]
reverse [AnnExpr' Id DVarSet]
args_r_to_l
                , let prim_rep :: PrimRep
prim_rep = AnnExpr' Id DVarSet -> PrimRep
forall ann. AnnExpr' Id ann -> PrimRep
atomPrimRep AnnExpr' Id DVarSet
arg
                , Bool -> Bool
not (PrimRep -> Bool
isVoidRep PrimRep
prim_rep)
                ]
            (Int
_, Int
_, [FieldOffOrPadding (AnnExpr' Id DVarSet)]
args_offsets) =
                DynFlags
-> ClosureHeader
-> [NonVoid (PrimRep, AnnExpr' Id DVarSet)]
-> (Int, Int, [FieldOffOrPadding (AnnExpr' Id DVarSet)])
forall a.
DynFlags
-> ClosureHeader
-> [NonVoid (PrimRep, a)]
-> (Int, Int, [FieldOffOrPadding a])
mkVirtHeapOffsetsWithPadding DynFlags
dflags ClosureHeader
StdHeader [NonVoid (PrimRep, AnnExpr' Id DVarSet)]
non_voids

            do_pushery :: ByteOff
-> [FieldOffOrPadding (AnnExpr' Id DVarSet)] -> BcM BCInstrList
do_pushery !ByteOff
d (FieldOffOrPadding (AnnExpr' Id DVarSet)
arg : [FieldOffOrPadding (AnnExpr' Id DVarSet)]
args) = do
                (BCInstrList
push, ByteOff
arg_bytes) <- case FieldOffOrPadding (AnnExpr' Id DVarSet)
arg of
                    (Padding Int
l Int
_) -> (BCInstrList, ByteOff) -> BcM (BCInstrList, ByteOff)
forall (m :: * -> *) a. Monad m => a -> m a
return ((BCInstrList, ByteOff) -> BcM (BCInstrList, ByteOff))
-> (BCInstrList, ByteOff) -> BcM (BCInstrList, ByteOff)
forall a b. (a -> b) -> a -> b
$! Int -> (BCInstrList, ByteOff)
pushPadding Int
l
                    (FieldOff NonVoid (AnnExpr' Id DVarSet)
a Int
_) -> ByteOff
-> Map Id ByteOff
-> AnnExpr' Id DVarSet
-> BcM (BCInstrList, ByteOff)
pushConstrAtom ByteOff
d Map Id ByteOff
p (NonVoid (AnnExpr' Id DVarSet) -> AnnExpr' Id DVarSet
forall a. NonVoid a -> a
fromNonVoid NonVoid (AnnExpr' Id DVarSet)
a)
                BCInstrList
more_push_code <- ByteOff
-> [FieldOffOrPadding (AnnExpr' Id DVarSet)] -> BcM BCInstrList
do_pushery (ByteOff
d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ ByteOff
arg_bytes) [FieldOffOrPadding (AnnExpr' Id DVarSet)]
args
                BCInstrList -> BcM BCInstrList
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstrList
push BCInstrList -> BCInstrList -> BCInstrList
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` BCInstrList
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)
                BCInstrList -> BcM BCInstrList
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstr -> BCInstrList
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 (AnnExpr' Id DVarSet)] -> BcM BCInstrList
do_pushery ByteOff
orig_d ([FieldOffOrPadding (AnnExpr' Id DVarSet)]
-> [FieldOffOrPadding (AnnExpr' Id DVarSet)]
forall a. [a] -> [a]
reverse [FieldOffOrPadding (AnnExpr' Id DVarSet)]
args_offsets)


-- -----------------------------------------------------------------------------
-- Returning an unboxed tuple with one non-void component (the only
-- case we can handle).
--
-- Remember, we don't want to *evaluate* the component that is being
-- returned, even if it is a pointed type.  We always just return.

unboxedTupleReturn
    :: StackDepth -> Sequel -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList
unboxedTupleReturn :: ByteOff
-> ByteOff
-> Map Id ByteOff
-> AnnExpr' Id DVarSet
-> BcM BCInstrList
unboxedTupleReturn ByteOff
d ByteOff
s Map Id ByteOff
p AnnExpr' Id DVarSet
arg = ByteOff
-> ByteOff
-> Map Id ByteOff
-> AnnExpr' Id DVarSet
-> ArgRep
-> BcM BCInstrList
returnUnboxedAtom ByteOff
d ByteOff
s Map Id ByteOff
p AnnExpr' Id DVarSet
arg (AnnExpr' Id DVarSet -> ArgRep
forall ann. AnnExpr' Id ann -> ArgRep
atomRep AnnExpr' Id DVarSet
arg)

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

doTailCall
    :: StackDepth
    -> Sequel
    -> BCEnv
    -> Id
    -> [AnnExpr' Id DVarSet]
    -> BcM BCInstrList
doTailCall :: ByteOff
-> ByteOff
-> Map Id ByteOff
-> Id
-> [AnnExpr' Id DVarSet]
-> BcM BCInstrList
doTailCall ByteOff
init_d ByteOff
s Map Id ByteOff
p Id
fn [AnnExpr' Id DVarSet]
args = ByteOff -> [AnnExpr' Id DVarSet] -> [ArgRep] -> BcM BCInstrList
do_pushes ByteOff
init_d [AnnExpr' Id DVarSet]
args ((AnnExpr' Id DVarSet -> ArgRep)
-> [AnnExpr' Id DVarSet] -> [ArgRep]
forall a b. (a -> b) -> [a] -> [b]
map AnnExpr' Id DVarSet -> ArgRep
forall ann. AnnExpr' Id ann -> ArgRep
atomRep [AnnExpr' Id DVarSet]
args)
  where
  do_pushes :: ByteOff -> [AnnExpr' Id DVarSet] -> [ArgRep] -> BcM BCInstrList
do_pushes !ByteOff
d [] [ArgRep]
reps = do
        ASSERT( null reps ) return ()
        (BCInstrList
push_fn, ByteOff
sz) <- ByteOff
-> Map Id ByteOff
-> AnnExpr' Id DVarSet
-> BcM (BCInstrList, ByteOff)
pushAtom ByteOff
d Map Id ByteOff
p (Id -> AnnExpr' Id DVarSet
forall bndr annot. Id -> AnnExpr' bndr annot
AnnVar Id
fn)
        DynFlags
dflags <- BcM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
        let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
        ASSERT( sz == wordSize platform ) return ()
        let slide :: BCInstrList
slide = Platform -> ByteOff -> ByteOff -> BCInstrList
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)
        BCInstrList -> BcM BCInstrList
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstrList
push_fn BCInstrList -> BCInstrList -> BCInstrList
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` (BCInstrList
slide BCInstrList -> BCInstrList -> BCInstrList
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` BCInstr -> BCInstrList
forall a. a -> OrdList a
unitOL BCInstr
ENTER))
  do_pushes !ByteOff
d [AnnExpr' Id DVarSet]
args [ArgRep]
reps = do
      let (BCInstr
push_apply, Int
n, [ArgRep]
rest_of_reps) = [ArgRep] -> (BCInstr, Int, [ArgRep])
findPushSeq [ArgRep]
reps
          ([AnnExpr' Id DVarSet]
these_args, [AnnExpr' Id DVarSet]
rest_of_args) = Int
-> [AnnExpr' Id DVarSet]
-> ([AnnExpr' Id DVarSet], [AnnExpr' Id DVarSet])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n [AnnExpr' Id DVarSet]
args
      (ByteOff
next_d, BCInstrList
push_code) <- ByteOff -> [AnnExpr' Id DVarSet] -> BcM (ByteOff, BCInstrList)
push_seq ByteOff
d [AnnExpr' Id DVarSet]
these_args
      DynFlags
dflags <- BcM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
      let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
      BCInstrList
instrs <- ByteOff -> [AnnExpr' Id DVarSet] -> [ArgRep] -> BcM BCInstrList
do_pushes (ByteOff
next_d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ Platform -> ByteOff
wordSize Platform
platform) [AnnExpr' Id DVarSet]
rest_of_args [ArgRep]
rest_of_reps
      --                          ^^^ for the PUSH_APPLY_ instruction
      BCInstrList -> BcM BCInstrList
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstrList
push_code BCInstrList -> BCInstrList -> BCInstrList
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` (BCInstr
push_apply BCInstr -> BCInstrList -> BCInstrList
forall a. a -> OrdList a -> OrdList a
`consOL` BCInstrList
instrs))

  push_seq :: ByteOff -> [AnnExpr' Id DVarSet] -> BcM (ByteOff, BCInstrList)
push_seq ByteOff
d [] = (ByteOff, BCInstrList) -> BcM (ByteOff, BCInstrList)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteOff
d, BCInstrList
forall a. OrdList a
nilOL)
  push_seq ByteOff
d (AnnExpr' Id DVarSet
arg:[AnnExpr' Id DVarSet]
args) = do
    (BCInstrList
push_code, ByteOff
sz) <- ByteOff
-> Map Id ByteOff
-> AnnExpr' Id DVarSet
-> BcM (BCInstrList, ByteOff)
pushAtom ByteOff
d Map Id ByteOff
p AnnExpr' Id DVarSet
arg
    (ByteOff
final_d, BCInstrList
more_push_code) <- ByteOff -> [AnnExpr' Id DVarSet] -> BcM (ByteOff, BCInstrList)
push_seq (ByteOff
d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ ByteOff
sz) [AnnExpr' Id DVarSet]
args
    (ByteOff, BCInstrList) -> BcM (ByteOff, BCInstrList)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteOff
final_d, BCInstrList
push_code BCInstrList -> BCInstrList -> BCInstrList
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` BCInstrList
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.CoreToByteCode.findPushSeq"

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

doCase
    :: StackDepth
    -> Sequel
    -> BCEnv
    -> AnnExpr Id DVarSet
    -> Id
    -> [AnnAlt Id DVarSet]
    -> Maybe Id  -- Just x <=> is an unboxed tuple case with scrut binder,
                 -- don't enter the result
    -> BcM BCInstrList
doCase :: ByteOff
-> ByteOff
-> Map Id ByteOff
-> AnnExpr Id DVarSet
-> Id
-> [AnnAlt Id DVarSet]
-> Maybe Id
-> BcM BCInstrList
doCase ByteOff
d ByteOff
s Map Id ByteOff
p (DVarSet
_,AnnExpr' Id DVarSet
scrut) Id
bndr [AnnAlt Id DVarSet]
alts Maybe Id
is_unboxed_tuple
  | HasDebugCallStack => Kind -> [PrimRep]
Kind -> [PrimRep]
typePrimRep (Id -> Kind
idType Id
bndr) [PrimRep] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthExceeds` Int
1
  = BcM BCInstrList
forall a. a
multiValException

  | Bool
otherwise
  = do
     DynFlags
dflags <- BcM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
     HscEnv
hsc_env <- BcM HscEnv
getHscEnv
     let
        platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
        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 = ByteOff
2 ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
* Platform -> ByteOff
wordSize Platform
platform

        -- The extra frame we push to save/restore the CCCS when profiling
        save_ccs_size_b :: ByteOff
save_ccs_size_b | Bool
profiling = 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
isAlgCase = ByteOff
0
                             | Bool
otherwise = Platform -> ByteOff
wordSize Platform
platform

        -- 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
+ Platform -> WordOff -> ByteOff
wordsToBytes Platform
platform (Platform -> Id -> WordOff
idSizeW Platform
platform Id
bndr)

        -- depth of stack after the extra info table for an unboxed return
        -- has been pushed, if any.  This is the stack depth at the
        -- continuation.
        d_alts :: ByteOff
d_alts = ByteOff
d_bndr 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_alts0 :: Map Id ByteOff
p_alts0 = 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

        p_alts :: Map Id ByteOff
p_alts = case Maybe Id
is_unboxed_tuple of
                   Just Id
ubx_bndr -> Id -> ByteOff -> Map Id ByteOff -> Map Id ByteOff
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Id
ubx_bndr ByteOff
d_bndr Map Id ByteOff
p_alts0
                   Maybe Id
Nothing       -> Map Id ByteOff
p_alts0

        bndr_ty :: Kind
bndr_ty = Id -> Kind
idType Id
bndr
        isAlgCase :: Bool
isAlgCase = Bool -> Bool
not (HasDebugCallStack => Kind -> Bool
Kind -> Bool
isUnliftedType Kind
bndr_ty) Bool -> Bool -> Bool
&& Maybe Id -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Id
is_unboxed_tuple

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

        codeAlt alt :: (AltCon, [Id], (a, AnnExpr' Id DVarSet))
alt@(AltCon
_, [Id]
bndrs, (a
_,AnnExpr' Id DVarSet
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
                BCInstrList
rhs_code <- ByteOff
-> ByteOff
-> Map Id ByteOff
-> AnnExpr' Id DVarSet
-> BcM BCInstrList
schemeE ByteOff
d_alts ByteOff
s Map Id ByteOff
p_alts AnnExpr' Id DVarSet
rhs
                (Discr, BCInstrList) -> BcM (Discr, BCInstrList)
forall (m :: * -> *) a. Monad m => a -> m a
return ((AltCon, [Id], (a, AnnExpr' Id DVarSet)) -> Discr
forall {b} {c}. (AltCon, b, c) -> Discr
my_discr (AltCon, [Id], (a, AnnExpr' Id DVarSet))
alt, BCInstrList
rhs_code)
           -- If an alt attempts to match on an unboxed tuple or sum, we must
           -- bail out, as the bytecode compiler can't handle them.
           -- (See #14608.)
           | (Id -> Bool) -> [Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Id
bndr -> HasDebugCallStack => Kind -> [PrimRep]
Kind -> [PrimRep]
typePrimRep (Id -> Kind
idType Id
bndr) [PrimRep] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthExceeds` Int
1) [Id]
bndrs
           = BcM (Discr, BCInstrList)
forall a. a
multiValException
           -- algebraic alt with some binders
           | Bool
otherwise =
             let (Int
tot_wds, Int
_ptrs_wds, [(NonVoid Id, Int)]
args_offsets) =
                     DynFlags
-> ClosureHeader
-> [NonVoid (PrimRep, Id)]
-> (Int, Int, [(NonVoid Id, Int)])
forall a.
DynFlags
-> ClosureHeader
-> [NonVoid (PrimRep, a)]
-> (Int, Int, [(NonVoid a, Int)])
mkVirtHeapOffsets DynFlags
dflags 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
             in do
             MASSERT(isAlgCase)
             BCInstrList
rhs_code <- ByteOff
-> ByteOff
-> Map Id ByteOff
-> AnnExpr' Id DVarSet
-> BcM BCInstrList
schemeE ByteOff
stack_bot ByteOff
s Map Id ByteOff
p' AnnExpr' Id DVarSet
rhs
             (Discr, BCInstrList) -> BcM (Discr, BCInstrList)
forall (m :: * -> *) a. Monad m => a -> m a
return ((AltCon, [Id], (a, AnnExpr' Id DVarSet)) -> Discr
forall {b} {c}. (AltCon, b, c) -> Discr
my_discr (AltCon, [Id], (a, AnnExpr' Id DVarSet))
alt,
                     BCInstr -> BCInstrList
forall a. a -> OrdList a
unitOL (Word16 -> BCInstr
UNPACK (WordOff -> Word16
trunc16W WordOff
size)) BCInstrList -> BCInstrList -> BCInstrList
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` BCInstrList
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
isUnboxedTupleCon DataCon
dc Bool -> Bool -> Bool
|| DataCon -> Bool
isUnboxedSumCon DataCon
dc
           = Discr
forall a. a
multiValException
           | 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(AnnCase).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]
_, AnnExpr Id DVarSet
_) <- [AnnAlt Id DVarSet]
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.
        bitmap_size :: Word16
bitmap_size = 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
s)
        bitmap_size' :: Int
        bitmap_size' :: Int
bitmap_size' = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
bitmap_size
        bitmap :: [StgWord]
bitmap = Platform -> Int -> [Int] -> [StgWord]
intsToReverseBitmap Platform
platform Int
bitmap_size'{-size-}
                        ([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]
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) | ArgRep -> Bool
isFollowableArg (Id -> ArgRep
bcIdArgRep 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)

     [(Discr, BCInstrList)]
alt_stuff <- (AnnAlt Id DVarSet -> BcM (Discr, BCInstrList))
-> [AnnAlt Id DVarSet] -> BcM [(Discr, BCInstrList)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM AnnAlt Id DVarSet -> BcM (Discr, BCInstrList)
forall {a}.
(AltCon, [Id], (a, AnnExpr' Id DVarSet))
-> BcM (Discr, BCInstrList)
codeAlt [AnnAlt Id DVarSet]
alts
     BCInstrList
alt_final <- Maybe Int -> [(Discr, BCInstrList)] -> BcM BCInstrList
mkMultiBranch Maybe Int
maybe_ncons [(Discr, BCInstrList)]
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 = DynFlags
-> Name
-> BCInstrList
-> Either [AnnAlt Id DVarSet] (AnnExpr Id DVarSet)
-> Int
-> Word16
-> [StgWord]
-> Bool
-> [FFIInfo]
-> ProtoBCO Name
forall name.
DynFlags
-> name
-> BCInstrList
-> Either [AnnAlt Id DVarSet] (AnnExpr Id DVarSet)
-> Int
-> Word16
-> [StgWord]
-> Bool
-> [FFIInfo]
-> ProtoBCO name
mkProtoBCO DynFlags
dflags Name
alt_bco_name BCInstrList
alt_final ([AnnAlt Id DVarSet]
-> Either [AnnAlt Id DVarSet] (AnnExpr Id DVarSet)
forall a b. a -> Either a b
Left [AnnAlt Id DVarSet]
alts)
                       Int
0{-no arity-} Word16
bitmap_size [StgWord]
bitmap Bool
True{-is alts-}
--     trace ("case: bndr = " ++ showSDocDebug (ppr bndr) ++ "\ndepth = " ++ show d ++ "\nenv = \n" ++ showSDocDebug (ppBCEnv p) ++
--            "\n      bitmap = " ++ show bitmap) $ do

     BCInstrList
scrut_code <- ByteOff
-> ByteOff
-> Map Id ByteOff
-> AnnExpr' Id DVarSet
-> BcM BCInstrList
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 AnnExpr' Id DVarSet
scrut
     ProtoBCO Name
alt_bco' <- ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
emitBc [FFIInfo] -> ProtoBCO Name
alt_bco
     let push_alts :: BCInstr
push_alts
            | Bool
isAlgCase = ProtoBCO Name -> BCInstr
PUSH_ALTS ProtoBCO Name
alt_bco'
            | Bool
otherwise = ProtoBCO Name -> ArgRep -> BCInstr
PUSH_ALTS_UNLIFTED ProtoBCO Name
alt_bco' (Kind -> ArgRep
typeArgRep Kind
bndr_ty)
     BCInstrList -> BcM BCInstrList
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstr
push_alts BCInstr -> BCInstrList -> BCInstrList
forall a. a -> OrdList a -> OrdList a
`consOL` BCInstrList
scrut_code)


-- -----------------------------------------------------------------------------
-- 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
    -> Id                      -- of target, for type info
    -> [AnnExpr' Id DVarSet]   -- args (atoms)
    -> BcM BCInstrList
generateCCall :: ByteOff
-> ByteOff
-> Map Id ByteOff
-> CCallSpec
-> Id
-> [AnnExpr' Id DVarSet]
-> BcM BCInstrList
generateCCall ByteOff
d0 ByteOff
s Map Id ByteOff
p (CCallSpec CCallTarget
target CCallConv
cconv Safety
safety) Id
fn [AnnExpr' Id DVarSet]
args_r_to_l
 = do
     DynFlags
dflags <- BcM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags

     let
         platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
         -- useful constants
         addr_size_b :: ByteOff
         addr_size_b :: ByteOff
addr_size_b = Platform -> ByteOff
wordSize Platform
platform

         -- 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 -> [AnnExpr' Id DVarSet] -> BcM [(BCInstrList, PrimRep)]
         pargs :: ByteOff -> [AnnExpr' Id DVarSet] -> BcM [(BCInstrList, PrimRep)]
pargs ByteOff
_ [] = [(BCInstrList, PrimRep)] -> BcM [(BCInstrList, PrimRep)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
         pargs ByteOff
d (AnnExpr' Id DVarSet
a:[AnnExpr' Id DVarSet]
az)
            = let arg_ty :: Kind
arg_ty = Kind -> Kind
unwrapType (Expr Id -> Kind
exprType (AnnExpr' Id DVarSet -> Expr Id
forall bndr annot. AnnExpr' bndr annot -> Expr bndr
deAnnotate' AnnExpr' Id DVarSet
a))

              in case Kind -> Maybe TyCon
tyConAppTyCon_maybe Kind
arg_ty of
                    -- Don't push the FO; instead push the Addr# it
                    -- contains.
                    Just 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
                       -> do [(BCInstrList, PrimRep)]
rest <- ByteOff -> [AnnExpr' Id DVarSet] -> BcM [(BCInstrList, PrimRep)]
pargs (ByteOff
d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ ByteOff
addr_size_b) [AnnExpr' Id DVarSet]
az
                             BCInstrList
code <- Word16
-> ByteOff
-> Map Id ByteOff
-> AnnExpr' Id DVarSet
-> BcM BCInstrList
parg_ArrayishRep (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (DynFlags -> Int
arrPtrsHdrSize DynFlags
dflags)) ByteOff
d Map Id ByteOff
p AnnExpr' Id DVarSet
a
                             [(BCInstrList, PrimRep)] -> BcM [(BCInstrList, PrimRep)]
forall (m :: * -> *) a. Monad m => a -> m a
return ((BCInstrList
code,PrimRep
AddrRep)(BCInstrList, PrimRep)
-> [(BCInstrList, PrimRep)] -> [(BCInstrList, PrimRep)]
forall a. a -> [a] -> [a]
:[(BCInstrList, PrimRep)]
rest)

                     | 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
                       -> do [(BCInstrList, PrimRep)]
rest <- ByteOff -> [AnnExpr' Id DVarSet] -> BcM [(BCInstrList, PrimRep)]
pargs (ByteOff
d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ ByteOff
addr_size_b) [AnnExpr' Id DVarSet]
az
                             BCInstrList
code <- Word16
-> ByteOff
-> Map Id ByteOff
-> AnnExpr' Id DVarSet
-> BcM BCInstrList
parg_ArrayishRep (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (DynFlags -> Int
smallArrPtrsHdrSize DynFlags
dflags)) ByteOff
d Map Id ByteOff
p AnnExpr' Id DVarSet
a
                             [(BCInstrList, PrimRep)] -> BcM [(BCInstrList, PrimRep)]
forall (m :: * -> *) a. Monad m => a -> m a
return ((BCInstrList
code,PrimRep
AddrRep)(BCInstrList, PrimRep)
-> [(BCInstrList, PrimRep)] -> [(BCInstrList, PrimRep)]
forall a. a -> [a] -> [a]
:[(BCInstrList, PrimRep)]
rest)

                     | 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
                       -> do [(BCInstrList, PrimRep)]
rest <- ByteOff -> [AnnExpr' Id DVarSet] -> BcM [(BCInstrList, PrimRep)]
pargs (ByteOff
d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ ByteOff
addr_size_b) [AnnExpr' Id DVarSet]
az
                             BCInstrList
code <- Word16
-> ByteOff
-> Map Id ByteOff
-> AnnExpr' Id DVarSet
-> BcM BCInstrList
parg_ArrayishRep (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (DynFlags -> Int
arrWordsHdrSize DynFlags
dflags)) ByteOff
d Map Id ByteOff
p AnnExpr' Id DVarSet
a
                             [(BCInstrList, PrimRep)] -> BcM [(BCInstrList, PrimRep)]
forall (m :: * -> *) a. Monad m => a -> m a
return ((BCInstrList
code,PrimRep
AddrRep)(BCInstrList, PrimRep)
-> [(BCInstrList, PrimRep)] -> [(BCInstrList, PrimRep)]
forall a. a -> [a] -> [a]
:[(BCInstrList, PrimRep)]
rest)

                    -- Default case: push taggedly, but otherwise intact.
                    Maybe TyCon
_
                       -> do (BCInstrList
code_a, ByteOff
sz_a) <- ByteOff
-> Map Id ByteOff
-> AnnExpr' Id DVarSet
-> BcM (BCInstrList, ByteOff)
pushAtom ByteOff
d Map Id ByteOff
p AnnExpr' Id DVarSet
a
                             [(BCInstrList, PrimRep)]
rest <- ByteOff -> [AnnExpr' Id DVarSet] -> BcM [(BCInstrList, PrimRep)]
pargs (ByteOff
d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ ByteOff
sz_a) [AnnExpr' Id DVarSet]
az
                             [(BCInstrList, PrimRep)] -> BcM [(BCInstrList, PrimRep)]
forall (m :: * -> *) a. Monad m => a -> m a
return ((BCInstrList
code_a, AnnExpr' Id DVarSet -> PrimRep
forall ann. AnnExpr' Id ann -> PrimRep
atomPrimRep AnnExpr' Id DVarSet
a) (BCInstrList, PrimRep)
-> [(BCInstrList, PrimRep)] -> [(BCInstrList, PrimRep)]
forall a. a -> [a] -> [a]
: [(BCInstrList, PrimRep)]
rest)

         -- 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.
         parg_ArrayishRep
             :: Word16
             -> StackDepth
             -> BCEnv
             -> AnnExpr' Id DVarSet
             -> BcM BCInstrList
         parg_ArrayishRep :: Word16
-> ByteOff
-> Map Id ByteOff
-> AnnExpr' Id DVarSet
-> BcM BCInstrList
parg_ArrayishRep Word16
hdrSize ByteOff
d Map Id ByteOff
p AnnExpr' Id DVarSet
a
            = do (BCInstrList
push_fo, ByteOff
_) <- ByteOff
-> Map Id ByteOff
-> AnnExpr' Id DVarSet
-> BcM (BCInstrList, ByteOff)
pushAtom ByteOff
d Map Id ByteOff
p AnnExpr' Id DVarSet
a
                 -- The ptr points at the header.  Advance it over the
                 -- header and then pretend this is an Addr#.
                 BCInstrList -> BcM BCInstrList
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstrList
push_fo BCInstrList -> BCInstr -> BCInstrList
forall a. OrdList a -> a -> OrdList a
`snocOL` Word16 -> Word16 -> BCInstr
SWIZZLE Word16
0 Word16
hdrSize)

     [(BCInstrList, PrimRep)]
code_n_reps <- ByteOff -> [AnnExpr' Id DVarSet] -> BcM [(BCInstrList, PrimRep)]
pargs ByteOff
d0 [AnnExpr' Id DVarSet]
args_r_to_l
     let
         ([BCInstrList]
pushs_arg, [PrimRep]
a_reps_pushed_r_to_l) = [(BCInstrList, PrimRep)] -> ([BCInstrList], [PrimRep])
forall a b. [(a, b)] -> ([a], [b])
unzip [(BCInstrList, 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 :: BCInstrList
push_args    = [BCInstrList] -> BCInstrList
forall a. [OrdList a] -> OrdList a
concatOL [BCInstrList]
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.CoreToByteCode.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 (Id -> Kind
idType Id
fn) 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.CoreToByteCode.generateCCall: dyn with no args"
                              else [PrimRep] -> [PrimRep]
forall a. [a] -> [a]
tail [PrimRep]
a_reps_pushed_RAW

         -- push the Addr#
         (BCInstrList
push_Addr, ByteOff
d_after_Addr)
            | Just Literal
machlabel <- Maybe Literal
maybe_static_target
            = ([BCInstr] -> BCInstrList
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
            = (BCInstrList
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 :: BCInstrList
push_r =
             if Bool
returns_void
                then BCInstrList
forall a. OrdList a
nilOL
                else BCInstr -> BCInstrList
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.CoreToByteCode: 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
     HscEnv
hsc_env <- 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
$ HscEnv -> Message (RemotePtr C_ffi_cif) -> IO (RemotePtr C_ffi_cif)
forall a. Binary a => HscEnv -> Message a -> IO a
iservCmd HscEnv
hsc_env (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 :: BCInstrList
do_call      = BCInstr -> BCInstrList
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 :: BCInstrList
wrapup       = Word16 -> WordOff -> BCInstrList
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)
                        BCInstrList -> BCInstr -> BCInstrList
forall a. OrdList a -> a -> OrdList a
`snocOL` ArgRep -> BCInstr
RETURN_UBX (PrimRep -> ArgRep
toArgRep PrimRep
r_rep)
         --trace (show (arg1_offW, args_offW  ,  (map argRepSizeW a_reps) )) $
     BCInstrList -> BcM BCInstrList
forall (m :: * -> *) a. Monad m => a -> m a
return (
         BCInstrList
push_args BCInstrList -> BCInstrList -> BCInstrList
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
         BCInstrList
push_Addr BCInstrList -> BCInstrList -> BCInstrList
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` BCInstrList
push_r BCInstrList -> BCInstrList -> BCInstrList
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` BCInstrList
do_call BCInstrList -> BCInstrList -> BCInstrList
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` BCInstrList
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
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
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 :: AnnExpr' Id DVarSet -> Maybe (AnnExpr' Id DVarSet, [Name])
-- Detect and extract relevant info for the tagToEnum kludge.
maybe_is_tagToEnum_call :: AnnExpr' Id DVarSet -> Maybe (AnnExpr' Id DVarSet, [Name])
maybe_is_tagToEnum_call AnnExpr' Id DVarSet
app
  | AnnApp (DVarSet
_, AnnApp (DVarSet
_, AnnVar Id
v) (DVarSet
_, AnnType Kind
t)) AnnExpr Id DVarSet
arg <- AnnExpr' Id DVarSet
app
  , Just PrimOp
TagToEnumOp <- Id -> Maybe PrimOp
isPrimOpId_maybe Id
v
  = (AnnExpr' Id DVarSet, [Name])
-> Maybe (AnnExpr' Id DVarSet, [Name])
forall a. a -> Maybe a
Just (AnnExpr Id DVarSet -> AnnExpr' Id DVarSet
forall a b. (a, b) -> b
snd AnnExpr Id DVarSet
arg, Kind -> [Name]
extract_constr_Names Kind
t)
  | Bool
otherwise
  = Maybe (AnnExpr' Id DVarSet, [Name])
forall a. Maybe a
Nothing
  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)

{- -----------------------------------------------------------------------------
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
    -> AnnExpr' Id DVarSet
    -> [Name]
    -> BcM BCInstrList
-- See Note [Implementing tagToEnum#]
implement_tagToId :: ByteOff
-> ByteOff
-> Map Id ByteOff
-> AnnExpr' Id DVarSet
-> [Name]
-> BcM BCInstrList
implement_tagToId ByteOff
d ByteOff
s Map Id ByteOff
p AnnExpr' Id DVarSet
arg [Name]
names
  = ASSERT( notNull names )
    do (BCInstrList
push_arg, ByteOff
arg_bytes) <- ByteOff
-> Map Id ByteOff
-> AnnExpr' Id DVarSet
-> BcM (BCInstrList, ByteOff)
pushAtom ByteOff
d Map Id ByteOff
p AnnExpr' Id DVarSet
arg
       [Word16]
labels <- Word16 -> BcM [Word16]
getLabelsBc ([Name] -> Word16
forall i a. Num i => [a] -> i
genericLength [Name]
names)
       Word16
label_fail <- BcM Word16
getLabelBc
       Word16
label_exit <- BcM Word16
getLabelBc
       DynFlags
dflags <- BcM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       let infos :: [(Word16, Word16, Int, Name)]
infos = [Word16]
-> [Word16] -> [Int] -> [Name] -> [(Word16, Word16, Int, Name)]
forall a b c d. [a] -> [b] -> [c] -> [d] -> [(a, b, c, d)]
zip4 [Word16]
labels ([Word16] -> [Word16]
forall a. [a] -> [a]
tail [Word16]
labels [Word16] -> [Word16] -> [Word16]
forall a. [a] -> [a] -> [a]
++ [Word16
label_fail])
                               [Int
0 ..] [Name]
names
           platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
           steps :: [BCInstrList]
steps = ((Word16, Word16, Int, Name) -> BCInstrList)
-> [(Word16, Word16, Int, Name)] -> [BCInstrList]
forall a b. (a -> b) -> [a] -> [b]
map (Word16 -> (Word16, Word16, Int, Name) -> BCInstrList
mkStep Word16
label_exit) [(Word16, Word16, 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)

       BCInstrList -> BcM BCInstrList
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstrList
push_arg
               BCInstrList -> BCInstrList -> BCInstrList
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` BCInstr -> BCInstrList
forall a. a -> OrdList a
unitOL (Literal -> Word16 -> BCInstr
PUSH_UBX Literal
LitNullAddr Word16
1)
                   -- Push bogus word (see Note [Implementing tagToEnum#])
               BCInstrList -> BCInstrList -> BCInstrList
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [BCInstrList] -> BCInstrList
forall a. [OrdList a] -> OrdList a
concatOL [BCInstrList]
steps
               BCInstrList -> BCInstrList -> BCInstrList
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [BCInstr] -> BCInstrList
forall a. [a] -> OrdList a
toOL [ Word16 -> BCInstr
LABEL Word16
label_fail, BCInstr
CASEFAIL,
                              Word16 -> BCInstr
LABEL Word16
label_exit ]
               BCInstrList -> BCInstrList -> BCInstrList
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Word16 -> WordOff -> BCInstrList
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#])
               BCInstrList -> BCInstrList -> BCInstrList
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` BCInstr -> BCInstrList
forall a. a -> OrdList a
unitOL BCInstr
ENTER)
  where
        mkStep :: Word16 -> (Word16, Word16, Int, Name) -> BCInstrList
mkStep Word16
l_exit (Word16
my_label, Word16
next_label, Int
n, Name
name_for_n)
           = [BCInstr] -> BCInstrList
forall a. [a] -> OrdList a
toOL [Word16 -> BCInstr
LABEL Word16
my_label,
                   Int -> Word16 -> BCInstr
TESTEQ_I Int
n Word16
next_label,
                   Name -> BCInstr
PUSH_G Name
name_for_n,
                   Word16 -> BCInstr
JMP Word16
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 -> AnnExpr' Id DVarSet -> BcM (BCInstrList, ByteOff)
pushAtom :: ByteOff
-> Map Id ByteOff
-> AnnExpr' Id DVarSet
-> BcM (BCInstrList, ByteOff)
pushAtom ByteOff
d Map Id ByteOff
p AnnExpr' Id DVarSet
e
   | Just AnnExpr' Id DVarSet
e' <- AnnExpr' Id DVarSet -> Maybe (AnnExpr' Id DVarSet)
forall ann. AnnExpr' Id ann -> Maybe (AnnExpr' Id ann)
bcView AnnExpr' Id DVarSet
e
   = ByteOff
-> Map Id ByteOff
-> AnnExpr' Id DVarSet
-> BcM (BCInstrList, ByteOff)
pushAtom ByteOff
d Map Id ByteOff
p AnnExpr' Id DVarSet
e'

pushAtom ByteOff
_ Map Id ByteOff
_ (AnnCoercion {})   -- Coercions are zero-width things,
   = (BCInstrList, ByteOff) -> BcM (BCInstrList, ByteOff)
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstrList
forall a. OrdList a
nilOL, ByteOff
0)          -- treated just like a variable V

-- 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
d Map Id ByteOff
p (AnnCase (DVarSet
_, AnnExpr' Id DVarSet
a) Id
_ Kind
_ []) -- trac #12128
   = ByteOff
-> Map Id ByteOff
-> AnnExpr' Id DVarSet
-> BcM (BCInstrList, ByteOff)
pushAtom ByteOff
d Map Id ByteOff
p AnnExpr' Id DVarSet
a

pushAtom ByteOff
d Map Id ByteOff
p (AnnVar Id
var)
   | [] <- HasDebugCallStack => Kind -> [PrimRep]
Kind -> [PrimRep]
typePrimRep (Id -> Kind
idType Id
var)
   = (BCInstrList, ByteOff) -> BcM (BCInstrList, ByteOff)
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstrList
forall a. OrdList a
nilOL, ByteOff
0)

   | Id -> Bool
isFCallId Id
var
   = String -> SDoc -> BcM (BCInstrList, 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
       (BCInstrList, ByteOff) -> BcM (BCInstrList, ByteOff)
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstr -> BCInstrList
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 -> a) -> m (OrdList a, ByteOff)
with_instr Word16 -> a
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 a, ByteOff) -> m (OrdList a, ByteOff)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> OrdList a
forall a. a -> OrdList a
unitOL (Word16 -> a
instr Word16
off_b), Platform -> ByteOff
wordSize Platform
platform)

        case ByteOff
szb of
            ByteOff
1 -> (Word16 -> BCInstr) -> BcM (BCInstrList, ByteOff)
forall {m :: * -> *} {a}.
Monad m =>
(Word16 -> a) -> m (OrdList a, ByteOff)
with_instr Word16 -> BCInstr
PUSH8_W
            ByteOff
2 -> (Word16 -> BCInstr) -> BcM (BCInstrList, ByteOff)
forall {m :: * -> *} {a}.
Monad m =>
(Word16 -> a) -> m (OrdList a, ByteOff)
with_instr Word16 -> BCInstr
PUSH16_W
            ByteOff
4 -> (Word16 -> BCInstr) -> BcM (BCInstrList, ByteOff)
forall {m :: * -> *} {a}.
Monad m =>
(Word16 -> a) -> m (OrdList a, 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
                (BCInstrList, ByteOff) -> BcM (BCInstrList, ByteOff)
forall (m :: * -> *) a. Monad m => a -> m a
return ([BCInstr] -> BCInstrList
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)), ByteOff
szb)
        -- 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
-> AnnExpr' Id DVarSet
-> BcM (BCInstrList, ByteOff)
pushAtom ByteOff
d Map Id ByteOff
p (AnnExpr' Id DVarSet -> BcM (BCInstrList, ByteOff))
-> AnnExpr' Id DVarSet -> BcM (BCInstrList, ByteOff)
forall a b. (a -> b) -> a -> b
$ Literal -> AnnExpr' Id DVarSet
forall bndr annot. Literal -> AnnExpr' bndr annot
AnnLit (Literal -> AnnExpr' Id DVarSet) -> Literal -> AnnExpr' Id DVarSet
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 )
                (BCInstrList, ByteOff) -> BcM (BCInstrList, ByteOff)
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstr -> BCInstrList
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
_ (AnnLit 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 :: ArgRep -> m (BCInstrList, ByteOff)
code ArgRep
rep
             = let size_words :: WordOff
size_words = Int -> WordOff
WordOff (Platform -> ArgRep -> Int
argRepSizeW Platform
platform ArgRep
rep)
               in  (BCInstrList, ByteOff) -> m (BCInstrList, ByteOff)
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstr -> BCInstrList
forall a. a -> OrdList a
unitOL (Literal -> Word16 -> BCInstr
PUSH_UBX Literal
lit (WordOff -> Word16
trunc16W WordOff
size_words)),
                           Platform -> WordOff -> ByteOff
wordsToBytes Platform
platform WordOff
size_words)

     case Literal
lit of
        LitLabel FastString
_ Maybe Int
_ FunctionOrData
_  -> ArgRep -> BcM (BCInstrList, ByteOff)
forall {m :: * -> *}. Monad m => ArgRep -> m (BCInstrList, ByteOff)
code ArgRep
N
        LitFloat Rational
_      -> ArgRep -> BcM (BCInstrList, ByteOff)
forall {m :: * -> *}. Monad m => ArgRep -> m (BCInstrList, ByteOff)
code ArgRep
F
        LitDouble Rational
_     -> ArgRep -> BcM (BCInstrList, ByteOff)
forall {m :: * -> *}. Monad m => ArgRep -> m (BCInstrList, ByteOff)
code ArgRep
D
        LitChar Char
_       -> ArgRep -> BcM (BCInstrList, ByteOff)
forall {m :: * -> *}. Monad m => ArgRep -> m (BCInstrList, ByteOff)
code ArgRep
N
        Literal
LitNullAddr     -> ArgRep -> BcM (BCInstrList, ByteOff)
forall {m :: * -> *}. Monad m => ArgRep -> m (BCInstrList, ByteOff)
code ArgRep
N
        LitString ByteString
_     -> ArgRep -> BcM (BCInstrList, ByteOff)
forall {m :: * -> *}. Monad m => ArgRep -> m (BCInstrList, ByteOff)
code ArgRep
N
        Literal
LitRubbish      -> ArgRep -> BcM (BCInstrList, ByteOff)
forall {m :: * -> *}. Monad m => ArgRep -> m (BCInstrList, ByteOff)
code ArgRep
N
        LitNumber LitNumType
nt Integer
_  -> case LitNumType
nt of
          LitNumType
LitNumInt     -> ArgRep -> BcM (BCInstrList, ByteOff)
forall {m :: * -> *}. Monad m => ArgRep -> m (BCInstrList, ByteOff)
code ArgRep
N
          LitNumType
LitNumWord    -> ArgRep -> BcM (BCInstrList, ByteOff)
forall {m :: * -> *}. Monad m => ArgRep -> m (BCInstrList, ByteOff)
code ArgRep
N
          LitNumType
LitNumInt64   -> ArgRep -> BcM (BCInstrList, ByteOff)
forall {m :: * -> *}. Monad m => ArgRep -> m (BCInstrList, ByteOff)
code ArgRep
L
          LitNumType
LitNumWord64  -> ArgRep -> BcM (BCInstrList, ByteOff)
forall {m :: * -> *}. Monad m => ArgRep -> m (BCInstrList, ByteOff)
code ArgRep
L
          -- 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 (BCInstrList, ByteOff)
forall a. String -> a
panic String
"pushAtom: LitInteger"
          LitNumType
LitNumNatural -> String -> BcM (BCInstrList, ByteOff)
forall a. String -> a
panic String
"pushAtom: LitNatural"

pushAtom ByteOff
_ Map Id ByteOff
_ AnnExpr' Id DVarSet
expr
   = String -> SDoc -> BcM (BCInstrList, ByteOff)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"GHC.CoreToByteCode.pushAtom"
              (Expr Id -> SDoc
forall b. OutputableBndr b => Expr b -> SDoc
pprCoreExpr (AnnExpr' Id DVarSet -> Expr Id
forall bndr annot. AnnExpr' bndr annot -> Expr bndr
deAnnotate' AnnExpr' Id DVarSet
expr))


-- | 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 -> AnnExpr' Id DVarSet -> BcM (BCInstrList, ByteOff)

pushConstrAtom :: ByteOff
-> Map Id ByteOff
-> AnnExpr' Id DVarSet
-> BcM (BCInstrList, ByteOff)
pushConstrAtom ByteOff
_ Map Id ByteOff
_ (AnnLit lit :: Literal
lit@(LitFloat Rational
_)) =
    (BCInstrList, ByteOff) -> BcM (BCInstrList, ByteOff)
forall (m :: * -> *) a. Monad m => a -> m a
return (BCInstr -> BCInstrList
forall a. a -> OrdList a
unitOL (Literal -> BCInstr
PUSH_UBX32 Literal
lit), ByteOff
4)

pushConstrAtom ByteOff
d Map Id ByteOff
p (AnnVar 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 -> a) -> m (OrdList a, ByteOff)
done Word16 -> a
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 a, ByteOff) -> m (OrdList a, ByteOff)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> OrdList a
forall a. a -> OrdList a
unitOL (Word16 -> a
instr Word16
off), ByteOff
szb)
        case ByteOff
szb of
            ByteOff
1 -> (Word16 -> BCInstr) -> BcM (BCInstrList, ByteOff)
forall {m :: * -> *} {a}.
Monad m =>
(Word16 -> a) -> m (OrdList a, ByteOff)
done Word16 -> BCInstr
PUSH8
            ByteOff
2 -> (Word16 -> BCInstr) -> BcM (BCInstrList, ByteOff)
forall {m :: * -> *} {a}.
Monad m =>
(Word16 -> a) -> m (OrdList a, ByteOff)
done Word16 -> BCInstr
PUSH16
            ByteOff
4 -> (Word16 -> BCInstr) -> BcM (BCInstrList, ByteOff)
forall {m :: * -> *} {a}.
Monad m =>
(Word16 -> a) -> m (OrdList a, ByteOff)
done Word16 -> BCInstr
PUSH32
            ByteOff
_ -> ByteOff
-> Map Id ByteOff
-> AnnExpr' Id DVarSet
-> BcM (BCInstrList, ByteOff)
pushAtom ByteOff
d Map Id ByteOff
p (Id -> AnnExpr' Id DVarSet
forall bndr annot. Id -> AnnExpr' bndr annot
AnnVar Id
v)

pushConstrAtom ByteOff
d Map Id ByteOff
p AnnExpr' Id DVarSet
expr = ByteOff
-> Map Id ByteOff
-> AnnExpr' Id DVarSet
-> BcM (BCInstrList, ByteOff)
pushAtom ByteOff
d Map Id ByteOff
p AnnExpr' Id DVarSet
expr

pushPadding :: Int -> (BCInstrList, ByteOff)
pushPadding :: Int -> (BCInstrList, ByteOff)
pushPadding !Int
n = Int -> (BCInstrList, ByteOff) -> (BCInstrList, ByteOff)
forall {t} {a}.
(Eq t, Num t, Num a) =>
t -> (BCInstrList, a) -> (BCInstrList, a)
go Int
n (BCInstrList
forall a. OrdList a
nilOL, ByteOff
0)
  where
    go :: t -> (BCInstrList, a) -> (BCInstrList, a)
go t
n acc :: (BCInstrList, a)
acc@(!BCInstrList
instrs, !a
off) = case t
n of
        t
0 -> (BCInstrList, a)
acc
        t
1 -> (BCInstrList
instrs BCInstrList -> BCInstrList -> BCInstrList
forall a. Monoid a => a -> a -> a
`mappend` BCInstr -> BCInstrList
forall a. a -> OrdList a
unitOL BCInstr
PUSH_PAD8, a
off a -> a -> a
forall a. Num a => a -> a -> a
+ a
1)
        t
2 -> (BCInstrList
instrs BCInstrList -> BCInstrList -> BCInstrList
forall a. Monoid a => a -> a -> a
`mappend` BCInstr -> BCInstrList
forall a. a -> OrdList a
unitOL BCInstr
PUSH_PAD16, a
off a -> a -> a
forall a. Num a => a -> a -> a
+ a
2)
        t
3 -> t -> (BCInstrList, a) -> (BCInstrList, a)
go t
1 (t -> (BCInstrList, a) -> (BCInstrList, a)
go t
2 (BCInstrList, a)
acc)
        t
4 -> (BCInstrList
instrs BCInstrList -> BCInstrList -> BCInstrList
forall a. Monoid a => a -> a -> a
`mappend` BCInstr -> BCInstrList
forall a. a -> OrdList a
unitOL BCInstr
PUSH_PAD32, a
off a -> a -> a
forall a. Num a => a -> a -> a
+ a
4)
        t
_ -> t -> (BCInstrList, a) -> (BCInstrList, a)
go (t
n t -> t -> t
forall a. Num a => a -> a -> a
- t
4) (t -> (BCInstrList, a) -> (BCInstrList, a)
go t
4 (BCInstrList, a)
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, BCInstrList)] -> BcM BCInstrList
mkMultiBranch Maybe Int
maybe_ncons [(Discr, BCInstrList)]
raw_ways = do
     Word16
lbl_default <- BcM Word16
getLabelBc

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

         mkTree [(Discr, BCInstrList)
val] Discr
range_lo Discr
range_hi
            | Discr
range_lo Discr -> Discr -> Bool
forall a. Eq a => a -> a -> Bool
== Discr
range_hi
            = BCInstrList -> BcM BCInstrList
forall (m :: * -> *) a. Monad m => a -> m a
return ((Discr, BCInstrList) -> BCInstrList
forall a b. (a, b) -> b
snd (Discr, BCInstrList)
val)
            | [(Discr, BCInstrList)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Discr, BCInstrList)]
defaults -- Note [CASEFAIL]
            = do Word16
lbl <- BcM Word16
getLabelBc
                 BCInstrList -> BcM BCInstrList
forall (m :: * -> *) a. Monad m => a -> m a
return (Discr -> Word16 -> BCInstr
testEQ ((Discr, BCInstrList) -> Discr
forall a b. (a, b) -> a
fst (Discr, BCInstrList)
val) Word16
lbl
                            BCInstr -> BCInstrList -> BCInstrList
forall a. a -> OrdList a -> OrdList a
`consOL` ((Discr, BCInstrList) -> BCInstrList
forall a b. (a, b) -> b
snd (Discr, BCInstrList)
val
                            BCInstrList -> BCInstrList -> BCInstrList
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`  (Word16 -> BCInstr
LABEL Word16
lbl BCInstr -> BCInstrList -> BCInstrList
forall a. a -> OrdList a -> OrdList a
`consOL` BCInstr -> BCInstrList
forall a. a -> OrdList a
unitOL BCInstr
CASEFAIL)))
            | Bool
otherwise
            = BCInstrList -> BcM BCInstrList
forall (m :: * -> *) a. Monad m => a -> m a
return (Discr -> Word16 -> BCInstr
testEQ ((Discr, BCInstrList) -> Discr
forall a b. (a, b) -> a
fst (Discr, BCInstrList)
val) Word16
lbl_default BCInstr -> BCInstrList -> BCInstrList
forall a. a -> OrdList a -> OrdList a
`consOL` (Discr, BCInstrList) -> BCInstrList
forall a b. (a, b) -> b
snd (Discr, BCInstrList)
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, BCInstrList)]
vals Discr
range_lo Discr
range_hi
            = let n :: Int
n = [(Discr, BCInstrList)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Discr, BCInstrList)]
vals Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
                  vals_lo :: [(Discr, BCInstrList)]
vals_lo = Int -> [(Discr, BCInstrList)] -> [(Discr, BCInstrList)]
forall a. Int -> [a] -> [a]
take Int
n [(Discr, BCInstrList)]
vals
                  vals_hi :: [(Discr, BCInstrList)]
vals_hi = Int -> [(Discr, BCInstrList)] -> [(Discr, BCInstrList)]
forall a. Int -> [a] -> [a]
drop Int
n [(Discr, BCInstrList)]
vals
                  v_mid :: Discr
v_mid = (Discr, BCInstrList) -> Discr
forall a b. (a, b) -> a
fst ([(Discr, BCInstrList)] -> (Discr, BCInstrList)
forall a. [a] -> a
head [(Discr, BCInstrList)]
vals_hi)
              in do
              Word16
label_geq <- BcM Word16
getLabelBc
              BCInstrList
code_lo <- [(Discr, BCInstrList)] -> Discr -> Discr -> BcM BCInstrList
mkTree [(Discr, BCInstrList)]
vals_lo Discr
range_lo (Discr -> Discr
dec Discr
v_mid)
              BCInstrList
code_hi <- [(Discr, BCInstrList)] -> Discr -> Discr -> BcM BCInstrList
mkTree [(Discr, BCInstrList)]
vals_hi Discr
v_mid Discr
range_hi
              BCInstrList -> BcM BCInstrList
forall (m :: * -> *) a. Monad m => a -> m a
return (Discr -> Word16 -> BCInstr
testLT Discr
v_mid Word16
label_geq
                      BCInstr -> BCInstrList -> BCInstrList
forall a. a -> OrdList a -> OrdList a
`consOL` (BCInstrList
code_lo
                      BCInstrList -> BCInstrList -> BCInstrList
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`   BCInstr -> BCInstrList
forall a. a -> OrdList a
unitOL (Word16 -> BCInstr
LABEL Word16
label_geq)
                      BCInstrList -> BCInstrList -> BCInstrList
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`   BCInstrList
code_hi))

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

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

         testEQ :: Discr -> Word16 -> BCInstr
testEQ (DiscrI Int
i) Word16
fail_label = Int -> Word16 -> BCInstr
TESTEQ_I Int
i Word16
fail_label
         testEQ (DiscrW Word
i) Word16
fail_label = Word -> Word16 -> BCInstr
TESTEQ_W Word
i Word16
fail_label
         testEQ (DiscrF Float
i) Word16
fail_label = Float -> Word16 -> BCInstr
TESTEQ_F Float
i Word16
fail_label
         testEQ (DiscrD Double
i) Word16
fail_label = Double -> Word16 -> BCInstr
TESTEQ_D Double
i Word16
fail_label
         testEQ (DiscrP Word16
i) Word16
fail_label = Word16 -> Word16 -> BCInstr
TESTEQ_P Word16
i Word16
fail_label
         testEQ Discr
NoDiscr    Word16
_          = 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, BCInstrList)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Discr, BCInstrList)]
notd_ways
            = String -> (Discr, Discr)
forall a. String -> a
panic String
"mkMultiBranch: awesome foursome"
            | Bool
otherwise
            = case (Discr, BCInstrList) -> Discr
forall a b. (a, b) -> a
fst ([(Discr, BCInstrList)] -> (Discr, BCInstrList)
forall a. [a] -> a
head [(Discr, BCInstrList)]
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
. Id -> ArgRep
bcIdArgRep

idSizeCon :: Platform -> Id -> ByteOff
idSizeCon :: Platform -> Id -> ByteOff
idSizeCon Platform
platform = Int -> ByteOff
ByteOff (Int -> ByteOff) -> (Id -> Int) -> Id -> ByteOff
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Platform -> PrimRep -> Int
primRepSizeB Platform
platform (PrimRep -> Int) -> (Id -> PrimRep) -> Id -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> PrimRep
bcIdPrimRep

bcIdArgRep :: Id -> ArgRep
bcIdArgRep :: Id -> ArgRep
bcIdArgRep = PrimRep -> ArgRep
toArgRep (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))

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 (PrimRep -> ArgRep
toArgRep PrimRep
rep)

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

isVoidArg :: ArgRep -> Bool
isVoidArg :: ArgRep -> Bool
isVoidArg ArgRep
V = Bool
True
isVoidArg ArgRep
_ = Bool
False

-- See bug #1257
multiValException :: a
multiValException :: forall a. a
multiValException = GhcException -> a
forall a. GhcException -> a
throwGhcException (String -> GhcException
ProgramError
  (String
"Error: bytecode compiler can't handle unboxed tuples and sums.\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++
   String
"  Possibly due to foreign import/export decls in source.\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++
   String
"  Workaround: use -fobject-code, or compile this module to .o separately."))

-- | 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 -> BCInstrList
mkSlideB Platform
platform !ByteOff
nb !ByteOff
db = Word16 -> WordOff -> BCInstrList
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 -> BCInstrList
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 -> BCInstrList -> BCInstrList
forall a. a -> OrdList a -> OrdList a
`consOL` Word16 -> WordOff -> BCInstrList
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
    = BCInstrList
forall a. OrdList a
nilOL
    | Bool
otherwise
    = BCInstr -> BCInstrList
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

splitApp :: AnnExpr' Var ann -> (AnnExpr' Var ann, [AnnExpr' Var ann])
        -- The arguments are returned in *right-to-left* order
splitApp :: forall ann. AnnExpr' Id ann -> (AnnExpr' Id ann, [AnnExpr' Id ann])
splitApp AnnExpr' Id ann
e | Just AnnExpr' Id ann
e' <- AnnExpr' Id ann -> Maybe (AnnExpr' Id ann)
forall ann. AnnExpr' Id ann -> Maybe (AnnExpr' Id ann)
bcView AnnExpr' Id ann
e = AnnExpr' Id ann -> (AnnExpr' Id ann, [AnnExpr' Id ann])
forall ann. AnnExpr' Id ann -> (AnnExpr' Id ann, [AnnExpr' Id ann])
splitApp AnnExpr' Id ann
e'
splitApp (AnnApp (ann
_,AnnExpr' Id ann
f) (ann
_,AnnExpr' Id ann
a))    = case AnnExpr' Id ann -> (AnnExpr' Id ann, [AnnExpr' Id ann])
forall ann. AnnExpr' Id ann -> (AnnExpr' Id ann, [AnnExpr' Id ann])
splitApp AnnExpr' Id ann
f of
                                      (AnnExpr' Id ann
f', [AnnExpr' Id ann]
as) -> (AnnExpr' Id ann
f', AnnExpr' Id ann
aAnnExpr' Id ann -> [AnnExpr' Id ann] -> [AnnExpr' Id ann]
forall a. a -> [a] -> [a]
:[AnnExpr' Id ann]
as)
splitApp AnnExpr' Id ann
e                       = (AnnExpr' Id ann
e, [])


bcView :: AnnExpr' Var ann -> Maybe (AnnExpr' Var ann)
-- The "bytecode view" of a term discards
--  a) type abstractions
--  b) type applications
--  c) casts
--  d) ticks (but not breakpoints)
--  e) case unsafeEqualityProof of UnsafeRefl -> e  ==> e
-- Type lambdas *can* occur in random expressions,
-- whereas value lambdas cannot; that is why they are nuked here
bcView :: forall ann. AnnExpr' Id ann -> Maybe (AnnExpr' Id ann)
bcView (AnnCast (ann
_,AnnExpr' Id ann
e) (ann, Coercion)
_)             = AnnExpr' Id ann -> Maybe (AnnExpr' Id ann)
forall a. a -> Maybe a
Just AnnExpr' Id ann
e
bcView (AnnLam Id
v (ann
_,AnnExpr' Id ann
e)) | Id -> Bool
isTyVar Id
v  = AnnExpr' Id ann -> Maybe (AnnExpr' Id ann)
forall a. a -> Maybe a
Just AnnExpr' Id ann
e
bcView (AnnApp (ann
_,AnnExpr' Id ann
e) (ann
_, AnnType Kind
_)) = AnnExpr' Id ann -> Maybe (AnnExpr' Id ann)
forall a. a -> Maybe a
Just AnnExpr' Id ann
e
bcView (AnnTick Breakpoint{} (ann, AnnExpr' Id ann)
_)      = Maybe (AnnExpr' Id ann)
forall a. Maybe a
Nothing
bcView (AnnTick Tickish Id
_other_tick (ann
_,AnnExpr' Id ann
e))   = AnnExpr' Id ann -> Maybe (AnnExpr' Id ann)
forall a. a -> Maybe a
Just AnnExpr' Id ann
e
bcView (AnnCase (ann
_,AnnExpr' Id ann
e) Id
_ Kind
_ [AnnAlt Id ann]
alts)  -- Handle unsafe equality proof
  | AnnVar Id
id <- AnnExpr' Id ann -> AnnExpr' Id ann
forall ann. AnnExpr' Id ann -> AnnExpr' Id ann
bcViewLoop AnnExpr' Id ann
e
  , Id -> Name
idName Id
id Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
unsafeEqualityProofName
  , [(AltCon
_, [Id]
_, (ann
_, AnnExpr' Id ann
rhs))] <- [AnnAlt Id ann]
alts
  = AnnExpr' Id ann -> Maybe (AnnExpr' Id ann)
forall a. a -> Maybe a
Just AnnExpr' Id ann
rhs
bcView AnnExpr' Id ann
_                             = Maybe (AnnExpr' Id ann)
forall a. Maybe a
Nothing

bcViewLoop :: AnnExpr' Var ann -> AnnExpr' Var ann
bcViewLoop :: forall ann. AnnExpr' Id ann -> AnnExpr' Id ann
bcViewLoop AnnExpr' Id ann
e =
    case AnnExpr' Id ann -> Maybe (AnnExpr' Id ann)
forall ann. AnnExpr' Id ann -> Maybe (AnnExpr' Id ann)
bcView AnnExpr' Id ann
e of
      Maybe (AnnExpr' Id ann)
Nothing -> AnnExpr' Id ann
e
      Just AnnExpr' Id ann
e' -> AnnExpr' Id ann -> AnnExpr' Id ann
forall ann. AnnExpr' Id ann -> AnnExpr' Id ann
bcViewLoop AnnExpr' Id ann
e'

isVAtom :: AnnExpr' Var ann -> Bool
isVAtom :: forall ann. AnnExpr' Id ann -> Bool
isVAtom AnnExpr' Id ann
e | Just AnnExpr' Id ann
e' <- AnnExpr' Id ann -> Maybe (AnnExpr' Id ann)
forall ann. AnnExpr' Id ann -> Maybe (AnnExpr' Id ann)
bcView AnnExpr' Id ann
e = AnnExpr' Id ann -> Bool
forall ann. AnnExpr' Id ann -> Bool
isVAtom AnnExpr' Id ann
e'
isVAtom (AnnVar Id
v)              = ArgRep -> Bool
isVoidArg (Id -> ArgRep
bcIdArgRep Id
v)
isVAtom (AnnCoercion {})        = Bool
True
isVAtom AnnExpr' Id ann
_                     = Bool
False

atomPrimRep :: AnnExpr' Id ann -> PrimRep
atomPrimRep :: forall ann. AnnExpr' Id ann -> PrimRep
atomPrimRep AnnExpr' Id ann
e | Just AnnExpr' Id ann
e' <- AnnExpr' Id ann -> Maybe (AnnExpr' Id ann)
forall ann. AnnExpr' Id ann -> Maybe (AnnExpr' Id ann)
bcView AnnExpr' Id ann
e = AnnExpr' Id ann -> PrimRep
forall ann. AnnExpr' Id ann -> PrimRep
atomPrimRep AnnExpr' Id ann
e'
atomPrimRep (AnnVar Id
v)              = Id -> PrimRep
bcIdPrimRep Id
v
atomPrimRep (AnnLit Literal
l)              = HasDebugCallStack => Kind -> PrimRep
Kind -> PrimRep
typePrimRep1 (Literal -> Kind
literalType Literal
l)

-- #12128:
-- A case expression can be an atom because empty cases evaluate to bottom.
-- See Note [Empty case alternatives] in GHC.Core
atomPrimRep (AnnCase AnnExpr Id ann
_ Id
_ Kind
ty [AnnAlt Id ann]
_)      =
  ASSERT(case typePrimRep ty of [LiftedRep] -> True; _ -> False) LiftedRep
atomPrimRep (AnnCoercion {})        = PrimRep
VoidRep
atomPrimRep AnnExpr' Id ann
other = String -> SDoc -> PrimRep
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"atomPrimRep" (Expr Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr (AnnExpr' Id ann -> Expr Id
forall bndr annot. AnnExpr' bndr annot -> Expr bndr
deAnnotate' AnnExpr' Id ann
other))

atomRep :: AnnExpr' Id ann -> ArgRep
atomRep :: forall ann. AnnExpr' Id ann -> ArgRep
atomRep AnnExpr' Id ann
e = PrimRep -> ArgRep
toArgRep (AnnExpr' Id ann -> PrimRep
forall ann. AnnExpr' Id ann -> PrimRep
atomPrimRep AnnExpr' Id ann
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)

typeArgRep :: Type -> ArgRep
typeArgRep :: Kind -> ArgRep
typeArgRep = PrimRep -> ArgRep
toArgRep (PrimRep -> ArgRep) -> (Kind -> PrimRep) -> Kind -> ArgRep
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack => Kind -> PrimRep
Kind -> PrimRep
typePrimRep1

-- -----------------------------------------------------------------------------
-- 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 -> Word16
nextlabel   :: Word16          -- 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
-> Word16
-> [FFIInfo]
-> Maybe ModBreaks
-> IntMap CgBreakInfo
-> IdEnv (RemotePtr ())
-> BcM_State
BcM_State HscEnv
hsc_env UniqSupply
us Module
this_mod Word16
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)

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 Word16
getLabelBc :: BcM Word16
getLabelBc
  = (BcM_State -> IO (BcM_State, Word16)) -> BcM Word16
forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
BcM ((BcM_State -> IO (BcM_State, Word16)) -> BcM Word16)
-> (BcM_State -> IO (BcM_State, Word16)) -> BcM Word16
forall a b. (a -> b) -> a -> b
$ \BcM_State
st -> do let nl :: Word16
nl = BcM_State -> Word16
nextlabel BcM_State
st
                    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word16
nl Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Word16
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, Word16) -> IO (BcM_State, Word16)
forall (m :: * -> *) a. Monad m => a -> m a
return (BcM_State
st{nextlabel :: Word16
nextlabel = Word16
nl Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
+ Word16
1}, Word16
nl)

getLabelsBc :: Word16 -> BcM [Word16]
getLabelsBc :: Word16 -> BcM [Word16]
getLabelsBc Word16
n
  = (BcM_State -> IO (BcM_State, [Word16])) -> BcM [Word16]
forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
BcM ((BcM_State -> IO (BcM_State, [Word16])) -> BcM [Word16])
-> (BcM_State -> IO (BcM_State, [Word16])) -> BcM [Word16]
forall a b. (a -> b) -> a -> b
$ \BcM_State
st -> let ctr :: Word16
ctr = BcM_State -> Word16
nextlabel BcM_State
st
                 in (BcM_State, [Word16]) -> IO (BcM_State, [Word16])
forall (m :: * -> *) a. Monad m => a -> m a
return (BcM_State
st{nextlabel :: Word16
nextlabel = Word16
ctrWord16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
+Word16
n}, [Word16
ctr .. Word16
ctrWord16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
+Word16
nWord16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
-Word16
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.CoreToByteCode.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"