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

-- | ByteCodeGen: Generate bytecode from Core
module ByteCodeGen ( UnlinkedBCO, byteCodeGen, coreExprToBCOs ) where

#include "HsVersions.h"

import GhcPrelude

import ByteCodeInstr
import ByteCodeAsm
import ByteCodeTypes

import GHCi
import GHCi.FFI
import GHCi.RemoteTypes
import BasicTypes
import DynFlags
import Outputable
import Platform
import Name
import MkId
import Id
import Var             ( updateVarType )
import ForeignCall
import HscTypes
import CoreUtils
import CoreSyn
import PprCore
import Literal
import PrimOp
import CoreFVs
import Type
import RepType
import Kind            ( isLiftedTypeKind )
import DataCon
import TyCon
import Util
import VarSet
import TysPrim
import ErrUtils
import Unique
import FastString
import Panic
import StgCmmClosure    ( NonVoid(..), fromNonVoid, nonVoidIds )
import StgCmmLayout
import SMRep hiding (WordOff, ByteOff, wordsToBytes)
import Bitmap
import OrdList
import Maybes
import VarEnv

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

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

        UniqSupply
us <- Char -> IO UniqSupply
mkSplitUniqSupply 'y'
        (BcM_State{..}, proto_bcos :: [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 ([(CoreBndr, RemotePtr ())] -> IdEnv (RemotePtr ())
forall a. [(CoreBndr, a)] -> VarEnv a
mkVarEnv [(CoreBndr, 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
$
             ((CoreBndr, AnnExpr CoreBndr DVarSet) -> BcM (ProtoBCO Name))
-> [(CoreBndr, AnnExpr CoreBndr DVarSet)] -> BcM [ProtoBCO Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (CoreBndr, AnnExpr CoreBndr DVarSet) -> BcM (ProtoBCO Name)
schemeTopBind [(CoreBndr, AnnExpr CoreBndr 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 "ByteCodeGen.byteCodeGen: missing final emitBc?")

        DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags DumpFlag
Opt_D_dump_BCOs
           "Proto-BCOs" ([SDoc] -> SDoc
vcat (SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
intersperse (Char -> SDoc
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 (((CoreBndr, RemotePtr ()) -> RemotePtr ())
-> [(CoreBndr, RemotePtr ())] -> [RemotePtr ()]
forall a b. (a -> b) -> [a] -> [b]
map (CoreBndr, RemotePtr ()) -> RemotePtr ()
forall a b. (a, b) -> b
snd [(CoreBndr, RemotePtr ())]
stringPtrs)
          (case Maybe ModBreaks
modBreaks of
             Nothing -> Maybe ModBreaks
forall a. Maybe a
Nothing
             Just mb :: 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 -> [(CoreBndr, ByteString)] -> IO [(CoreBndr, RemotePtr ())]
allocateTopStrings hsc_env :: HscEnv
hsc_env topStrings :: [(CoreBndr, ByteString)]
topStrings = do
  let !(bndrs :: [CoreBndr]
bndrs, strings :: [ByteString]
strings) = [(CoreBndr, ByteString)] -> ([CoreBndr], [ByteString])
forall a b. [(a, b)] -> ([a], [b])
unzip [(CoreBndr, 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
  [(CoreBndr, RemotePtr ())] -> IO [(CoreBndr, RemotePtr ())]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(CoreBndr, RemotePtr ())] -> IO [(CoreBndr, RemotePtr ())])
-> [(CoreBndr, RemotePtr ())] -> IO [(CoreBndr, RemotePtr ())]
forall a b. (a -> b) -> a -> b
$ [CoreBndr] -> [RemotePtr ()] -> [(CoreBndr, RemotePtr ())]
forall a b. [a] -> [b] -> [(a, b)]
zip [CoreBndr]
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 CoreBndr -> IO UnlinkedBCO
coreExprToBCOs hsc_env :: HscEnv
hsc_env this_mod :: Module
this_mod expr :: Expr CoreBndr
expr
 = IO DynFlags
-> SDoc -> (UnlinkedBCO -> ()) -> IO UnlinkedBCO -> IO UnlinkedBCO
forall (m :: * -> *) a.
MonadIO m =>
m DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTiming (DynFlags -> IO DynFlags
forall (f :: * -> *) a. Applicative f => a -> f a
pure DynFlags
dflags)
              (String -> SDoc
text "ByteCodeGen"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 0) (String -> FastString
fsLit "ExprTopLevel")
          invented_id :: CoreBndr
invented_id    = Name -> Type -> CoreBndr
Id.mkLocalId Name
invented_name (String -> Type
forall a. String -> a
panic "invented_id's type")

      -- the uniques are needed to generate fresh variables when we introduce new
      -- let bindings for ticked expressions
      UniqSupply
us <- Char -> IO UniqSupply
mkSplitUniqSupply 'y'
      (BcM_State _dflags :: HscEnv
_dflags _us :: UniqSupply
_us _this_mod :: Module
_this_mod _final_ctr :: Word16
_final_ctr mallocd :: [FFIInfo]
mallocd _ _ _, proto_bco :: 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
$
              (CoreBndr, AnnExpr CoreBndr DVarSet) -> BcM (ProtoBCO Name)
schemeTopBind (CoreBndr
invented_id, Expr CoreBndr -> AnnExpr CoreBndr DVarSet
simpleFreeVars Expr CoreBndr
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 "ByteCodeGen.coreExprToBCOs: missing final emitBc?")

      DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags DumpFlag
Opt_D_dump_BCOs "Proto-BCOs" (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 CoreBndr -> AnnExpr CoreBndr DVarSet
simpleFreeVars = Expr CoreBndr -> AnnExpr CoreBndr 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
$cp2Integral :: Enum ByteOff
$cp1Integral :: Real 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
$cp1Ord :: Eq ByteOff
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
$cp2Real :: Ord ByteOff
$cp1Real :: Num ByteOff
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
$cp2Integral :: Enum WordOff
$cp1Integral :: Real 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
$cp1Ord :: Eq WordOff
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
$cp2Real :: Ord WordOff
$cp1Real :: Num WordOff
Real)

wordsToBytes :: DynFlags -> WordOff -> ByteOff
wordsToBytes :: DynFlags -> WordOff -> ByteOff
wordsToBytes dflags :: DynFlags
dflags = 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
* DynFlags -> Int
wORD_SIZE DynFlags
dflags) (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 :: DynFlags -> ByteOff -> WordOff
bytesToWords :: DynFlags -> ByteOff -> WordOff
bytesToWords dflags :: DynFlags
dflags (ByteOff bytes :: Int
bytes) =
    let (q :: Int
q, r :: Int
r) = Int
bytes Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`quotRem` (DynFlags -> Int
wORD_SIZE DynFlags
dflags)
    in if Int
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 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
$ "ByteCodeGen.bytesToWords: bytes=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
bytes

wordSize :: DynFlags -> ByteOff
wordSize :: DynFlags -> ByteOff
wordSize dflags :: DynFlags
dflags = Int -> ByteOff
ByteOff (DynFlags -> Int
wORD_SIZE DynFlags
dflags)

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 :: DynFlags
-> name
-> BCInstrList
-> Either [AnnAlt CoreBndr DVarSet] (AnnExpr CoreBndr DVarSet)
-> Int
-> Word16
-> [StgWord]
-> Bool
-> [FFIInfo]
-> ProtoBCO name
mkProtoBCO dflags :: DynFlags
dflags nm :: name
nm instrs_ordlist :: BCInstrList
instrs_ordlist origin :: Either [AnnAlt CoreBndr DVarSet] (AnnExpr CoreBndr DVarSet)
origin arity :: Int
arity bitmap_size :: Word16
bitmap_size bitmap :: [StgWord]
bitmap is_ret :: Bool
is_ret ffis :: [FFIInfo]
ffis
   = ProtoBCO :: forall a.
a
-> [BCInstr]
-> [StgWord]
-> Word16
-> Int
-> Either [AnnAlt CoreBndr DVarSet] (AnnExpr CoreBndr 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 CoreBndr DVarSet] (AnnExpr CoreBndr DVarSet)
protoBCOExpr = Either [AnnAlt CoreBndr DVarSet] (AnnExpr CoreBndr 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 off1 :: Word16
off1 : PUSH_L off2 :: Word16
off2 : PUSH_L off3 :: Word16
off3 : rest :: [BCInstr]
rest)
           = Word16 -> Word16 -> Word16 -> BCInstr
PUSH_LLL Word16
off1 (Word16
off2Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
-1) (Word16
off3Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
-2) BCInstr -> [BCInstr] -> [BCInstr]
forall a. a -> [a] -> [a]
: [BCInstr] -> [BCInstr]
peep [BCInstr]
rest
        peep (PUSH_L off1 :: Word16
off1 : PUSH_L off2 :: Word16
off2 : rest :: [BCInstr]
rest)
           = Word16 -> Word16 -> BCInstr
PUSH_LL Word16
off1 (Word16
off2Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
-1) BCInstr -> [BCInstr] -> [BCInstr]
forall a. a -> [a] -> [a]
: [BCInstr] -> [BCInstr]
peep [BCInstr]
rest
        peep (i :: BCInstr
i:rest :: [BCInstr]
rest)
           = BCInstr
i BCInstr -> [BCInstr] -> [BCInstr]
forall a. a -> [a] -> [a]
: [BCInstr] -> [BCInstr]
peep [BCInstr]
rest
        peep []
           = []

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

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

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

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

  | Bool
otherwise
  = [CoreBndr]
-> (CoreBndr, AnnExpr CoreBndr DVarSet) -> BcM (ProtoBCO Name)
schemeR [{- No free variables -}] (CoreBndr
id, AnnExpr CoreBndr 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
-- 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.
        -> (Id, AnnExpr Id DVarSet)
        -> BcM (ProtoBCO Name)
schemeR :: [CoreBndr]
-> (CoreBndr, AnnExpr CoreBndr DVarSet) -> BcM (ProtoBCO Name)
schemeR fvs :: [CoreBndr]
fvs (nm :: CoreBndr
nm, rhs :: AnnExpr CoreBndr DVarSet
rhs)
{-
   | trace (showSDoc (
              (char ' '
               $$ (ppr.filter (not.isTyVar).dVarSetElems.fst) rhs
               $$ pprCoreExpr (deAnnotate rhs)
               $$ char ' '
              ))) False
   = undefined
   | otherwise
-}
   = [CoreBndr]
-> CoreBndr
-> AnnExpr CoreBndr DVarSet
-> ([CoreBndr], AnnExpr' CoreBndr DVarSet)
-> BcM (ProtoBCO Name)
schemeR_wrk [CoreBndr]
fvs CoreBndr
nm AnnExpr CoreBndr DVarSet
rhs (AnnExpr CoreBndr DVarSet -> ([CoreBndr], AnnExpr' CoreBndr DVarSet)
collect AnnExpr CoreBndr DVarSet
rhs)

-- If an expression is a lambda (after apply bcView), 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 CoreBndr DVarSet -> ([CoreBndr], AnnExpr' CoreBndr DVarSet)
collect (_, e :: AnnExpr' CoreBndr DVarSet
e) = [CoreBndr]
-> AnnExpr' CoreBndr DVarSet
-> ([CoreBndr], AnnExpr' CoreBndr DVarSet)
forall ann.
[CoreBndr]
-> AnnExpr' CoreBndr ann -> ([CoreBndr], AnnExpr' CoreBndr ann)
go [] AnnExpr' CoreBndr DVarSet
e
  where
    go :: [CoreBndr]
-> AnnExpr' CoreBndr ann -> ([CoreBndr], AnnExpr' CoreBndr ann)
go xs :: [CoreBndr]
xs e :: AnnExpr' CoreBndr ann
e | Just e' :: AnnExpr' CoreBndr ann
e' <- AnnExpr' CoreBndr ann -> Maybe (AnnExpr' CoreBndr ann)
forall ann. AnnExpr' CoreBndr ann -> Maybe (AnnExpr' CoreBndr ann)
bcView AnnExpr' CoreBndr ann
e = [CoreBndr]
-> AnnExpr' CoreBndr ann -> ([CoreBndr], AnnExpr' CoreBndr ann)
go [CoreBndr]
xs AnnExpr' CoreBndr ann
e'
    go xs :: [CoreBndr]
xs (AnnLam x :: CoreBndr
x (_,e :: AnnExpr' CoreBndr ann
e))
      | HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep (CoreBndr -> Type
idType CoreBndr
x) [PrimRep] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthExceeds` 1
      = ([CoreBndr], AnnExpr' CoreBndr ann)
forall a. a
multiValException
      | Bool
otherwise
      = [CoreBndr]
-> AnnExpr' CoreBndr ann -> ([CoreBndr], AnnExpr' CoreBndr ann)
go (CoreBndr
xCoreBndr -> [CoreBndr] -> [CoreBndr]
forall a. a -> [a] -> [a]
:[CoreBndr]
xs) AnnExpr' CoreBndr ann
e
    go xs :: [CoreBndr]
xs not_lambda :: AnnExpr' CoreBndr ann
not_lambda = ([CoreBndr] -> [CoreBndr]
forall a. [a] -> [a]
reverse [CoreBndr]
xs, AnnExpr' CoreBndr ann
not_lambda)

schemeR_wrk
    :: [Id]
    -> Id
    -> AnnExpr Id DVarSet             -- expression e, for debugging only
    -> ([Var], AnnExpr' Var DVarSet)  -- result of collect on e
    -> BcM (ProtoBCO Name)
schemeR_wrk :: [CoreBndr]
-> CoreBndr
-> AnnExpr CoreBndr DVarSet
-> ([CoreBndr], AnnExpr' CoreBndr DVarSet)
-> BcM (ProtoBCO Name)
schemeR_wrk fvs :: [CoreBndr]
fvs nm :: CoreBndr
nm original_body :: AnnExpr CoreBndr DVarSet
original_body (args :: [CoreBndr]
args, body :: AnnExpr' CoreBndr DVarSet
body)
   = do
     DynFlags
dflags <- BcM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
     let
         all_args :: [CoreBndr]
all_args  = [CoreBndr] -> [CoreBndr]
forall a. [a] -> [a]
reverse [CoreBndr]
args [CoreBndr] -> [CoreBndr] -> [CoreBndr]
forall a. [a] -> [a] -> [a]
++ [CoreBndr]
fvs
         arity :: Int
arity     = [CoreBndr] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CoreBndr]
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 = (CoreBndr -> ByteOff) -> [CoreBndr] -> [ByteOff]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> WordOff -> ByteOff
wordsToBytes DynFlags
dflags (WordOff -> ByteOff)
-> (CoreBndr -> WordOff) -> CoreBndr -> ByteOff
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> CoreBndr -> WordOff
idSizeW DynFlags
dflags) [CoreBndr]
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 CoreBndr ByteOff
p_init    = [(CoreBndr, ByteOff)] -> Map CoreBndr ByteOff
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([CoreBndr] -> [ByteOff] -> [(CoreBndr, ByteOff)]
forall a b. [a] -> [b] -> [(a, b)]
zip [CoreBndr]
all_args (ByteOff -> [ByteOff] -> [ByteOff]
mkStackOffsets 0 [ByteOff]
szsb_args))

         -- make the arg bitmap
         bits :: [Bool]
bits = DynFlags -> [ArgRep] -> [Bool]
argBits DynFlags
dflags ([ArgRep] -> [ArgRep]
forall a. [a] -> [a]
reverse ((CoreBndr -> ArgRep) -> [CoreBndr] -> [ArgRep]
forall a b. (a -> b) -> [a] -> [b]
map CoreBndr -> ArgRep
bcIdArgRep [CoreBndr]
all_args))
         bitmap_size :: Word16
bitmap_size = [Bool] -> Word16
forall i a. Num i => [a] -> i
genericLength [Bool]
bits
         bitmap :: [StgWord]
bitmap = DynFlags -> [Bool] -> [StgWord]
mkBitmap DynFlags
dflags [Bool]
bits
     BCInstrList
body_code <- ByteOff
-> Map CoreBndr ByteOff
-> AnnExpr' CoreBndr DVarSet
-> BcM BCInstrList
schemeER_wrk ByteOff
sum_szsb_args Map CoreBndr ByteOff
p_init AnnExpr' CoreBndr DVarSet
body

     ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
emitBc (DynFlags
-> Name
-> BCInstrList
-> Either [AnnAlt CoreBndr DVarSet] (AnnExpr CoreBndr DVarSet)
-> Int
-> Word16
-> [StgWord]
-> Bool
-> [FFIInfo]
-> ProtoBCO Name
forall name.
DynFlags
-> name
-> BCInstrList
-> Either [AnnAlt CoreBndr DVarSet] (AnnExpr CoreBndr DVarSet)
-> Int
-> Word16
-> [StgWord]
-> Bool
-> [FFIInfo]
-> ProtoBCO name
mkProtoBCO DynFlags
dflags (CoreBndr -> Name
forall a. NamedThing a => a -> Name
getName CoreBndr
nm) BCInstrList
body_code (AnnExpr CoreBndr DVarSet
-> Either [AnnAlt CoreBndr DVarSet] (AnnExpr CoreBndr DVarSet)
forall a b. b -> Either a b
Right AnnExpr CoreBndr 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 CoreBndr ByteOff
-> AnnExpr' CoreBndr DVarSet
-> BcM BCInstrList
schemeER_wrk d :: ByteOff
d p :: Map CoreBndr ByteOff
p rhs :: AnnExpr' CoreBndr DVarSet
rhs
  | AnnTick (Breakpoint tick_no :: Int
tick_no fvs :: [CoreBndr]
fvs) (_annot :: DVarSet
_annot, newRhs :: AnnExpr' CoreBndr DVarSet
newRhs) <- AnnExpr' CoreBndr DVarSet
rhs
  = do  BCInstrList
code <- ByteOff
-> ByteOff
-> Map CoreBndr ByteOff
-> AnnExpr' CoreBndr DVarSet
-> BcM BCInstrList
schemeE ByteOff
d 0 Map CoreBndr ByteOff
p AnnExpr' CoreBndr DVarSet
newRhs
        Array Int (RemotePtr CostCentre)
cc_arr <- BcM (Array Int (RemotePtr CostCentre))
getCCArray
        ModuleName
this_mod <- Module -> 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 idOffSets :: [Maybe (CoreBndr, Word16)]
idOffSets = DynFlags
-> ByteOff
-> Map CoreBndr ByteOff
-> [CoreBndr]
-> [Maybe (CoreBndr, Word16)]
getVarOffSets DynFlags
dflags ByteOff
d Map CoreBndr ByteOff
p [CoreBndr]
fvs
        let breakInfo :: CgBreakInfo
breakInfo = CgBreakInfo :: [Maybe (CoreBndr, Word16)] -> Type -> CgBreakInfo
CgBreakInfo
                        { cgb_vars :: [Maybe (CoreBndr, Word16)]
cgb_vars = [Maybe (CoreBndr, Word16)]
idOffSets
                        , cgb_resty :: Type
cgb_resty = Expr CoreBndr -> Type
exprType (AnnExpr' CoreBndr DVarSet -> Expr CoreBndr
forall bndr annot. AnnExpr' bndr annot -> Expr bndr
deAnnotate' AnnExpr' CoreBndr DVarSet
newRhs)
                        }
        Int -> CgBreakInfo -> BcM ()
newBreakInfo Int
tick_no CgBreakInfo
breakInfo
        DynFlags
dflags <- BcM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
        let cc :: RemotePtr CostCentre
cc | DynFlags -> Bool
interpreterProfiled DynFlags
dflags = 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 CoreBndr ByteOff
-> AnnExpr' CoreBndr DVarSet
-> BcM BCInstrList
schemeE ByteOff
d 0 Map CoreBndr ByteOff
p AnnExpr' CoreBndr DVarSet
rhs

getVarOffSets :: DynFlags -> StackDepth -> BCEnv -> [Id] -> [Maybe (Id, Word16)]
getVarOffSets :: DynFlags
-> ByteOff
-> Map CoreBndr ByteOff
-> [CoreBndr]
-> [Maybe (CoreBndr, Word16)]
getVarOffSets dflags :: DynFlags
dflags depth :: ByteOff
depth env :: Map CoreBndr ByteOff
env = (CoreBndr -> Maybe (CoreBndr, Word16))
-> [CoreBndr] -> [Maybe (CoreBndr, Word16)]
forall a b. (a -> b) -> [a] -> [b]
map CoreBndr -> Maybe (CoreBndr, Word16)
getOffSet
  where
    getOffSet :: CoreBndr -> Maybe (CoreBndr, Word16)
getOffSet id :: CoreBndr
id = case CoreBndr -> Map CoreBndr ByteOff -> Maybe ByteOff
lookupBCEnv_maybe CoreBndr
id Map CoreBndr ByteOff
env of
        Nothing     -> Maybe (CoreBndr, Word16)
forall a. Maybe a
Nothing
        Just offset :: 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
$ DynFlags -> ByteOff -> WordOff
bytesToWords DynFlags
dflags (ByteOff
depth ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
- ByteOff
offset) WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
+ 2
            in (CoreBndr, Word16) -> Maybe (CoreBndr, Word16)
forall a. a -> Maybe a
Just (CoreBndr
id, Word16
var_depth_ws)

truncIntegral16 :: Integral a => a -> Word16
truncIntegral16 :: a -> Word16
truncIntegral16 w :: 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 "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 CoreBndr ByteOff -> DVarSet -> [CoreBndr]
fvsToEnv p :: Map CoreBndr ByteOff
p fvs :: DVarSet
fvs = [CoreBndr
v | CoreBndr
v <- DVarSet -> [CoreBndr]
dVarSetElems DVarSet
fvs,
                      CoreBndr -> Bool
isId CoreBndr
v,           -- Could be a type variable
                      CoreBndr
v CoreBndr -> Map CoreBndr ByteOff -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map CoreBndr 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 CoreBndr ByteOff
-> AnnExpr' CoreBndr DVarSet
-> ArgRep
-> BcM BCInstrList
returnUnboxedAtom d :: ByteOff
d s :: ByteOff
s p :: Map CoreBndr ByteOff
p e :: AnnExpr' CoreBndr DVarSet
e e_rep :: ArgRep
e_rep = do
    DynFlags
dflags <- BcM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    (push :: BCInstrList
push, szb :: ByteOff
szb) <- ByteOff
-> Map CoreBndr ByteOff
-> AnnExpr' CoreBndr DVarSet
-> BcM (BCInstrList, ByteOff)
pushAtom ByteOff
d Map CoreBndr ByteOff
p AnnExpr' CoreBndr 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`  DynFlags -> ByteOff -> ByteOff -> BCInstrList
mkSlideB DynFlags
dflags 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 CoreBndr ByteOff
-> AnnExpr' CoreBndr DVarSet
-> BcM BCInstrList
schemeE d :: ByteOff
d s :: ByteOff
s p :: Map CoreBndr ByteOff
p e :: AnnExpr' CoreBndr DVarSet
e
   | Just e' :: AnnExpr' CoreBndr DVarSet
e' <- AnnExpr' CoreBndr DVarSet -> Maybe (AnnExpr' CoreBndr DVarSet)
forall ann. AnnExpr' CoreBndr ann -> Maybe (AnnExpr' CoreBndr ann)
bcView AnnExpr' CoreBndr DVarSet
e
   = ByteOff
-> ByteOff
-> Map CoreBndr ByteOff
-> AnnExpr' CoreBndr DVarSet
-> BcM BCInstrList
schemeE ByteOff
d ByteOff
s Map CoreBndr ByteOff
p AnnExpr' CoreBndr DVarSet
e'

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

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

schemeE d :: ByteOff
d s :: ByteOff
s p :: Map CoreBndr ByteOff
p e :: AnnExpr' CoreBndr DVarSet
e@(AnnVar v :: CoreBndr
v)
      -- See Note [Levity-polymorphic join points], step 3.
    | CoreBndr -> Bool
isLPJoinPoint CoreBndr
v           = ByteOff
-> ByteOff
-> Map CoreBndr ByteOff
-> AnnExpr' CoreBndr DVarSet
-> BcM BCInstrList
schemeT ByteOff
d ByteOff
s Map CoreBndr ByteOff
p (AnnExpr' CoreBndr DVarSet -> BcM BCInstrList)
-> AnnExpr' CoreBndr DVarSet -> BcM BCInstrList
forall a b. (a -> b) -> a -> b
$
                                  AnnExpr CoreBndr DVarSet
-> AnnExpr CoreBndr DVarSet -> AnnExpr' CoreBndr DVarSet
forall bndr annot.
AnnExpr bndr annot -> AnnExpr bndr annot -> AnnExpr' bndr annot
AnnApp (DVarSet
forall a. a
bogus_fvs, CoreBndr -> AnnExpr' CoreBndr DVarSet
forall bndr annot. CoreBndr -> AnnExpr' bndr annot
AnnVar (CoreBndr -> CoreBndr
protectLPJoinPointId CoreBndr
v))
                                         (DVarSet
forall a. a
bogus_fvs, CoreBndr -> AnnExpr' CoreBndr DVarSet
forall bndr annot. CoreBndr -> AnnExpr' bndr annot
AnnVar CoreBndr
voidPrimId)
                         -- schemeT will call splitApp, dropping the fvs.

    | HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType (CoreBndr -> Type
idType CoreBndr
v) = ByteOff
-> ByteOff
-> Map CoreBndr ByteOff
-> AnnExpr' CoreBndr DVarSet
-> ArgRep
-> BcM BCInstrList
returnUnboxedAtom ByteOff
d ByteOff
s Map CoreBndr ByteOff
p AnnExpr' CoreBndr DVarSet
e (CoreBndr -> ArgRep
bcIdArgRep CoreBndr
v)
    | Bool
otherwise                 = ByteOff
-> ByteOff
-> Map CoreBndr ByteOff
-> AnnExpr' CoreBndr DVarSet
-> BcM BCInstrList
schemeT ByteOff
d ByteOff
s Map CoreBndr ByteOff
p AnnExpr' CoreBndr DVarSet
e
    where
      bogus_fvs :: a
bogus_fvs = String -> SDoc -> a
forall a. HasCallStack => String -> SDoc -> a
pprPanic "schemeE bogus_fvs" (CoreBndr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreBndr
v)

schemeE d :: ByteOff
d s :: ByteOff
s p :: Map CoreBndr ByteOff
p (AnnLet (AnnNonRec x :: CoreBndr
x (_,rhs :: AnnExpr' CoreBndr DVarSet
rhs)) (_,body :: AnnExpr' CoreBndr DVarSet
body))
   | (AnnVar v :: CoreBndr
v, args_r_to_l :: [AnnExpr' CoreBndr DVarSet]
args_r_to_l) <- AnnExpr' CoreBndr DVarSet
-> (AnnExpr' CoreBndr DVarSet, [AnnExpr' CoreBndr DVarSet])
forall ann.
AnnExpr' CoreBndr ann
-> (AnnExpr' CoreBndr ann, [AnnExpr' CoreBndr ann])
splitApp AnnExpr' CoreBndr DVarSet
rhs,
     Just data_con :: DataCon
data_con <- CoreBndr -> Maybe DataCon
isDataConWorkId_maybe CoreBndr
v,
     DataCon -> Int
dataConRepArity DataCon
data_con Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [AnnExpr' CoreBndr DVarSet] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [AnnExpr' CoreBndr 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 CoreBndr ByteOff
-> DataCon
-> [AnnExpr' CoreBndr DVarSet]
-> BcM BCInstrList
mkConAppCode ByteOff
d ByteOff
s Map CoreBndr ByteOff
p DataCon
data_con [AnnExpr' CoreBndr DVarSet]
args_r_to_l
        DynFlags
dflags <- 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
+ DynFlags -> ByteOff
wordSize DynFlags
dflags
        BCInstrList
body_code <- ByteOff
-> ByteOff
-> Map CoreBndr ByteOff
-> AnnExpr' CoreBndr DVarSet
-> BcM BCInstrList
schemeE ByteOff
d2 ByteOff
s (CoreBndr -> ByteOff -> Map CoreBndr ByteOff -> Map CoreBndr ByteOff
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert CoreBndr
x ByteOff
d2 Map CoreBndr ByteOff
p) AnnExpr' CoreBndr 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 d :: ByteOff
d s :: ByteOff
s p :: Map CoreBndr ByteOff
p (AnnLet binds :: AnnBind CoreBndr DVarSet
binds (_,body :: AnnExpr' CoreBndr DVarSet
body)) = do
     DynFlags
dflags <- BcM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
     let (xs :: [CoreBndr]
xs,rhss :: [AnnExpr CoreBndr DVarSet]
rhss) = case AnnBind CoreBndr DVarSet
binds of AnnNonRec x :: CoreBndr
x rhs :: AnnExpr CoreBndr DVarSet
rhs  -> ([CoreBndr
x],[AnnExpr CoreBndr DVarSet
rhs])
                                   AnnRec xs_n_rhss :: [(CoreBndr, AnnExpr CoreBndr DVarSet)]
xs_n_rhss -> [(CoreBndr, AnnExpr CoreBndr DVarSet)]
-> ([CoreBndr], [AnnExpr CoreBndr DVarSet])
forall a b. [(a, b)] -> ([a], [b])
unzip [(CoreBndr, AnnExpr CoreBndr DVarSet)]
xs_n_rhss
         n_binds :: WordOff
n_binds = [CoreBndr] -> WordOff
forall i a. Num i => [a] -> i
genericLength [CoreBndr]
xs

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

           -- See Note [Levity-polymorphic join points], step 2.
         (xs' :: [CoreBndr]
xs',rhss' :: [AnnExpr CoreBndr DVarSet]
rhss') = (CoreBndr
 -> AnnExpr CoreBndr DVarSet
 -> (CoreBndr, AnnExpr CoreBndr DVarSet))
-> [CoreBndr]
-> [AnnExpr CoreBndr DVarSet]
-> ([CoreBndr], [AnnExpr CoreBndr DVarSet])
forall a b c d. (a -> b -> (c, d)) -> [a] -> [b] -> ([c], [d])
zipWithAndUnzip CoreBndr
-> AnnExpr CoreBndr DVarSet -> (CoreBndr, AnnExpr CoreBndr DVarSet)
protectLPJoinPointBind [CoreBndr]
xs [AnnExpr CoreBndr DVarSet]
rhss

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

         -- the arity of each rhs
         arities :: [Word16]
arities = (AnnExpr CoreBndr DVarSet -> Word16)
-> [AnnExpr CoreBndr DVarSet] -> [Word16]
forall a b. (a -> b) -> [a] -> [b]
map ([CoreBndr] -> Word16
forall i a. Num i => [a] -> i
genericLength ([CoreBndr] -> Word16)
-> (AnnExpr CoreBndr DVarSet -> [CoreBndr])
-> AnnExpr CoreBndr DVarSet
-> Word16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([CoreBndr], AnnExpr' CoreBndr DVarSet) -> [CoreBndr]
forall a b. (a, b) -> a
fst (([CoreBndr], AnnExpr' CoreBndr DVarSet) -> [CoreBndr])
-> (AnnExpr CoreBndr DVarSet
    -> ([CoreBndr], AnnExpr' CoreBndr DVarSet))
-> AnnExpr CoreBndr DVarSet
-> [CoreBndr]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnnExpr CoreBndr DVarSet -> ([CoreBndr], AnnExpr' CoreBndr DVarSet)
collect) [AnnExpr CoreBndr 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 (DynFlags -> ByteOff
wordSize DynFlags
dflags))
         p' :: Map CoreBndr ByteOff
p' = [(CoreBndr, ByteOff)]
-> Map CoreBndr ByteOff -> Map CoreBndr ByteOff
forall key elt.
Ord key =>
[(key, elt)] -> Map key elt -> Map key elt
Map.insertList ([CoreBndr] -> [ByteOff] -> [(CoreBndr, ByteOff)]
forall a b. [a] -> [b] -> [(a, b)]
zipE [CoreBndr]
xs' [ByteOff]
offsets) Map CoreBndr ByteOff
p
         d' :: ByteOff
d' = ByteOff
d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ DynFlags -> WordOff -> ByteOff
wordsToBytes DynFlags
dflags WordOff
n_binds
         zipE :: [a] -> [b] -> [(a, b)]
zipE = String -> [a] -> [b] -> [(a, b)]
forall a b. String -> [a] -> [b] -> [(a, b)]
zipEqual "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
-> [CoreBndr]
-> Word16
-> ProtoBCO Name
-> Word16
-> Word16
-> BcM BCInstrList
build_thunk _ [] size :: Word16
size bco :: ProtoBCO Name
bco off :: Word16
off arity :: 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
== 0 = Word16 -> Word16 -> BCInstr
MKAP
                     | Bool
otherwise  = Word16 -> Word16 -> BCInstr
MKPAP
         build_thunk dd :: ByteOff
dd (fv :: CoreBndr
fv:fvs :: [CoreBndr]
fvs) size :: Word16
size bco :: ProtoBCO Name
bco off :: Word16
off arity :: Word16
arity = do
              (push_code :: BCInstrList
push_code, pushed_szb :: ByteOff
pushed_szb) <- ByteOff
-> Map CoreBndr ByteOff
-> AnnExpr' CoreBndr DVarSet
-> BcM (BCInstrList, ByteOff)
pushAtom ByteOff
dd Map CoreBndr ByteOff
p' (CoreBndr -> AnnExpr' CoreBndr DVarSet
forall bndr annot. CoreBndr -> AnnExpr' bndr annot
AnnVar CoreBndr
fv)
              BCInstrList
more_push_code <-
                  ByteOff
-> [CoreBndr]
-> Word16
-> ProtoBCO Name
-> Word16
-> Word16
-> BcM BCInstrList
build_thunk (ByteOff
dd ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ ByteOff
pushed_szb) [CoreBndr]
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 sz :: Word16
sz 0
                    | Bool
is_tick     = Word16 -> BCInstr
ALLOC_AP_NOUPD Word16
sz
                    | Bool
otherwise   = Word16 -> BCInstr
ALLOC_AP Word16
sz
                 mkAlloc sz :: Word16
sz arity :: Word16
arity = Word16 -> Word16 -> BCInstr
ALLOC_PAP Word16
arity Word16
sz

         is_tick :: Bool
is_tick = case AnnBind CoreBndr DVarSet
binds of
                     AnnNonRec id :: CoreBndr
id _ -> OccName -> FastString
occNameFS (CoreBndr -> OccName
forall a. NamedThing a => a -> OccName
getOccName CoreBndr
id) FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
== FastString
tickFS
                     _other :: AnnBind CoreBndr DVarSet
_other -> Bool
False

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

         compile_binds :: [BcM BCInstrList]
compile_binds =
            [ ByteOff
-> [CoreBndr]
-> CoreBndr
-> AnnExpr CoreBndr DVarSet
-> Word16
-> Word16
-> Word16
-> BcM BCInstrList
compile_bind ByteOff
d' [CoreBndr]
fvs CoreBndr
x AnnExpr CoreBndr DVarSet
rhs Word16
size Word16
arity (WordOff -> Word16
trunc16W WordOff
n)
            | (fvs :: [CoreBndr]
fvs, x :: CoreBndr
x, rhs :: AnnExpr CoreBndr DVarSet
rhs, size :: Word16
size, arity :: Word16
arity, n :: WordOff
n) <-
                [[CoreBndr]]
-> [CoreBndr]
-> [AnnExpr CoreBndr DVarSet]
-> [Word16]
-> [Word16]
-> [WordOff]
-> [([CoreBndr], CoreBndr, AnnExpr CoreBndr DVarSet, Word16,
     Word16, WordOff)]
forall a b c d e f.
[a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [(a, b, c, d, e, f)]
zip6 [[CoreBndr]]
fvss [CoreBndr]
xs' [AnnExpr CoreBndr DVarSet]
rhss' [Word16]
sizes [Word16]
arities [WordOff
n_binds, WordOff
n_bindsWordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
-1 .. 1]
            ]
     BCInstrList
body_code <- ByteOff
-> ByteOff
-> Map CoreBndr ByteOff
-> AnnExpr' CoreBndr DVarSet
-> BcM BCInstrList
schemeE ByteOff
d' ByteOff
s Map CoreBndr ByteOff
p' AnnExpr' CoreBndr 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 d :: ByteOff
d s :: ByteOff
s p :: Map CoreBndr ByteOff
p exp :: AnnExpr' CoreBndr DVarSet
exp@(AnnTick (Breakpoint _id :: Int
_id _fvs :: [CoreBndr]
_fvs) _rhs :: AnnExpr CoreBndr DVarSet
_rhs)
   | Type -> Bool
isLiftedTypeKind (HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
ty)
   = do   CoreBndr
id <- Type -> BcM CoreBndr
newId Type
ty
          -- Todo: is emptyVarSet correct on the next line?
          let letExp :: AnnExpr' CoreBndr DVarSet
letExp = AnnBind CoreBndr DVarSet
-> AnnExpr CoreBndr DVarSet -> AnnExpr' CoreBndr DVarSet
forall bndr annot.
AnnBind bndr annot -> AnnExpr bndr annot -> AnnExpr' bndr annot
AnnLet (CoreBndr -> AnnExpr CoreBndr DVarSet -> AnnBind CoreBndr DVarSet
forall bndr annot. bndr -> AnnExpr bndr annot -> AnnBind bndr annot
AnnNonRec CoreBndr
id (DVarSet
fvs, AnnExpr' CoreBndr DVarSet
exp)) (DVarSet
emptyDVarSet, CoreBndr -> AnnExpr' CoreBndr DVarSet
forall bndr annot. CoreBndr -> AnnExpr' bndr annot
AnnVar CoreBndr
id)
          ByteOff
-> ByteOff
-> Map CoreBndr ByteOff
-> AnnExpr' CoreBndr DVarSet
-> BcM BCInstrList
schemeE ByteOff
d ByteOff
s Map CoreBndr ByteOff
p AnnExpr' CoreBndr 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 (Trac #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.

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

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

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

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

schemeE d :: ByteOff
d s :: ByteOff
s p :: Map CoreBndr ByteOff
p (AnnCase scrut :: AnnExpr CoreBndr DVarSet
scrut bndr :: CoreBndr
bndr _ [(DataAlt dc :: DataCon
dc, [bind1 :: CoreBndr
bind1, bind2 :: CoreBndr
bind2], rhs :: AnnExpr CoreBndr DVarSet
rhs)])
   | DataCon -> Bool
isUnboxedTupleCon DataCon
dc -- handles pairs with one void argument (e.g. state token)
        -- 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 res :: BcM BCInstrList
res <- case (HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep (CoreBndr -> Type
idType CoreBndr
bind1), HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep (CoreBndr -> Type
idType CoreBndr
bind2)) of
                   ([], [_])
                     -> 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 CoreBndr ByteOff
-> AnnExpr CoreBndr DVarSet
-> CoreBndr
-> [AnnAlt CoreBndr DVarSet]
-> Maybe CoreBndr
-> BcM BCInstrList
doCase ByteOff
d ByteOff
s Map CoreBndr ByteOff
p AnnExpr CoreBndr DVarSet
scrut CoreBndr
bind2 [(AltCon
DEFAULT, [], AnnExpr CoreBndr DVarSet
rhs)] (CoreBndr -> Maybe CoreBndr
forall a. a -> Maybe a
Just CoreBndr
bndr)
                   ([_], [])
                     -> 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 CoreBndr ByteOff
-> AnnExpr CoreBndr DVarSet
-> CoreBndr
-> [AnnAlt CoreBndr DVarSet]
-> Maybe CoreBndr
-> BcM BCInstrList
doCase ByteOff
d ByteOff
s Map CoreBndr ByteOff
p AnnExpr CoreBndr DVarSet
scrut CoreBndr
bind1 [(AltCon
DEFAULT, [], AnnExpr CoreBndr DVarSet
rhs)] (CoreBndr -> Maybe CoreBndr
forall a. a -> Maybe a
Just CoreBndr
bndr)
                   _ -> Maybe (BcM BCInstrList)
forall a. Maybe a
Nothing
   = BcM BCInstrList
res

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

schemeE d :: ByteOff
d s :: ByteOff
s p :: Map CoreBndr ByteOff
p (AnnCase scrut :: AnnExpr CoreBndr DVarSet
scrut bndr :: CoreBndr
bndr _ alt :: [AnnAlt CoreBndr DVarSet]
alt@[(DEFAULT, [], _)])
   | Type -> Bool
isUnboxedTupleType (CoreBndr -> Type
idType CoreBndr
bndr)
   , Just ty :: Type
ty <- case HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep (CoreBndr -> Type
idType CoreBndr
bndr) of
       [_]  -> Type -> Maybe Type
forall a. a -> Maybe a
Just (Type -> Type
unwrapType (CoreBndr -> Type
idType CoreBndr
bndr))
       []   -> Type -> Maybe Type
forall a. a -> Maybe a
Just Type
voidPrimTy
       _    -> Maybe Type
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 CoreBndr ByteOff
-> AnnExpr CoreBndr DVarSet
-> CoreBndr
-> [AnnAlt CoreBndr DVarSet]
-> Maybe CoreBndr
-> BcM BCInstrList
doCase ByteOff
d ByteOff
s Map CoreBndr ByteOff
p AnnExpr CoreBndr DVarSet
scrut (CoreBndr
bndr CoreBndr -> Type -> CoreBndr
`setIdType` Type
ty) [AnnAlt CoreBndr DVarSet]
alt (CoreBndr -> Maybe CoreBndr
forall a. a -> Maybe a
Just CoreBndr
bndr)

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

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

-- Is this Id a levity-polymorphic join point?
-- See Note [Levity-polymorphic join points], step 1
isLPJoinPoint :: Id -> Bool
isLPJoinPoint :: CoreBndr -> Bool
isLPJoinPoint x :: CoreBndr
x = CoreBndr -> Bool
isJoinId CoreBndr
x Bool -> Bool -> Bool
&&
                  Maybe Bool -> Bool
forall a. Maybe a -> Bool
isNothing (HasDebugCallStack => Type -> Maybe Bool
Type -> Maybe Bool
isLiftedType_maybe (CoreBndr -> Type
idType CoreBndr
x))

-- If necessary, modify this Id and body to protect levity-polymorphic join points.
-- See Note [Levity-polymorphic join points], step 2.
protectLPJoinPointBind :: Id -> AnnExpr Id DVarSet -> (Id, AnnExpr Id DVarSet)
protectLPJoinPointBind :: CoreBndr
-> AnnExpr CoreBndr DVarSet -> (CoreBndr, AnnExpr CoreBndr DVarSet)
protectLPJoinPointBind x :: CoreBndr
x rhs :: AnnExpr CoreBndr DVarSet
rhs@(fvs :: DVarSet
fvs, _)
  | CoreBndr -> Bool
isLPJoinPoint CoreBndr
x
  = (CoreBndr -> CoreBndr
protectLPJoinPointId CoreBndr
x, (DVarSet
fvs, CoreBndr -> AnnExpr CoreBndr DVarSet -> AnnExpr' CoreBndr DVarSet
forall bndr annot.
bndr -> AnnExpr bndr annot -> AnnExpr' bndr annot
AnnLam CoreBndr
voidArgId AnnExpr CoreBndr DVarSet
rhs))

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

-- Update an Id's type to take a Void# argument.
-- Precondition: the Id is a levity-polymorphic join point.
-- See Note [Levity-polymorphic join points]
protectLPJoinPointId :: Id -> Id
protectLPJoinPointId :: CoreBndr -> CoreBndr
protectLPJoinPointId x :: CoreBndr
x
  = ASSERT( isLPJoinPoint x )
    (Type -> Type) -> CoreBndr -> CoreBndr
updateVarType (Type
voidPrimTy Type -> Type -> Type
`mkFunTy`) CoreBndr
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 [Levity-polymorphic 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 CoreSyn. 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 CoreSyn.)

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 join
points (LPJPs), because we cannot have a levity-polymorphic variable.
(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 LPJPs. This is done in isLPJoinPoint.

2. When binding an LPJP, 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 LPJP to a non-levity-polymorphic join point. This is done
   in protectLPJoinPointBind, called from the AnnLet case of schemeE.

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

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 CoreBndr ByteOff
-> AnnExpr' CoreBndr DVarSet
-> BcM BCInstrList
schemeT d :: ByteOff
d s :: ByteOff
s p :: Map CoreBndr ByteOff
p app :: AnnExpr' CoreBndr DVarSet
app

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

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


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

   -- Case 3: Ordinary data constructor
   | Just con :: DataCon
con <- Maybe DataCon
maybe_saturated_dcon
   = do BCInstrList
alloc_con <- ByteOff
-> ByteOff
-> Map CoreBndr ByteOff
-> DataCon
-> [AnnExpr' CoreBndr DVarSet]
-> BcM BCInstrList
mkConAppCode ByteOff
d ByteOff
s Map CoreBndr ByteOff
p DataCon
con [AnnExpr' CoreBndr DVarSet]
args_r_to_l
        DynFlags
dflags <- BcM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
        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 1 (DynFlags -> ByteOff -> WordOff
bytesToWords DynFlags
dflags (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 CoreBndr ByteOff
-> CoreBndr
-> [AnnExpr' CoreBndr DVarSet]
-> BcM BCInstrList
doTailCall ByteOff
d ByteOff
s Map CoreBndr ByteOff
p CoreBndr
fn [AnnExpr' CoreBndr 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 fn :: CoreBndr
fn, args_r_to_l :: [AnnExpr' CoreBndr DVarSet]
args_r_to_l) = AnnExpr' CoreBndr DVarSet
-> (AnnExpr' CoreBndr DVarSet, [AnnExpr' CoreBndr DVarSet])
forall ann.
AnnExpr' CoreBndr ann
-> (AnnExpr' CoreBndr ann, [AnnExpr' CoreBndr ann])
splitApp AnnExpr' CoreBndr 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' CoreBndr DVarSet] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [AnnExpr' CoreBndr DVarSet]
args_r_to_l
      maybe_saturated_dcon :: Maybe DataCon
maybe_saturated_dcon
        = case CoreBndr -> Maybe DataCon
isDataConWorkId_maybe CoreBndr
fn of
                Just con :: 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
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 CoreBndr ByteOff
-> DataCon
-> [AnnExpr' CoreBndr DVarSet]
-> BcM BCInstrList
mkConAppCode _ _ _ con :: 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 (CoreBndr -> Name
forall a. NamedThing a => a -> Name
getName (DataCon -> CoreBndr
dataConWorkId DataCon
con))))
        -- Instead of doing a PACK, which would allocate a fresh
        -- copy of this constructor, use the single shared version.

mkConAppCode orig_d :: ByteOff
orig_d _ p :: Map CoreBndr ByteOff
p con :: DataCon
con args_r_to_l :: [AnnExpr' CoreBndr 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

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

            do_pushery :: ByteOff
-> [FieldOffOrPadding (AnnExpr' CoreBndr DVarSet)]
-> BcM BCInstrList
do_pushery !ByteOff
d (arg :: FieldOffOrPadding (AnnExpr' CoreBndr DVarSet)
arg : args :: [FieldOffOrPadding (AnnExpr' CoreBndr DVarSet)]
args) = do
                (push :: BCInstrList
push, arg_bytes :: ByteOff
arg_bytes) <- case FieldOffOrPadding (AnnExpr' CoreBndr DVarSet)
arg of
                    (Padding l :: Int
l _) -> (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 a :: NonVoid (AnnExpr' CoreBndr DVarSet)
a _) -> ByteOff
-> Map CoreBndr ByteOff
-> AnnExpr' CoreBndr DVarSet
-> BcM (BCInstrList, ByteOff)
pushConstrAtom ByteOff
d Map CoreBndr ByteOff
p (NonVoid (AnnExpr' CoreBndr DVarSet) -> AnnExpr' CoreBndr DVarSet
forall a. NonVoid a -> a
fromNonVoid NonVoid (AnnExpr' CoreBndr DVarSet)
a)
                BCInstrList
more_push_code <- ByteOff
-> [FieldOffOrPadding (AnnExpr' CoreBndr DVarSet)]
-> BcM BCInstrList
do_pushery (ByteOff
d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ ByteOff
arg_bytes) [FieldOffOrPadding (AnnExpr' CoreBndr 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
$ DynFlags -> ByteOff -> WordOff
bytesToWords DynFlags
dflags (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' CoreBndr DVarSet)]
-> BcM BCInstrList
do_pushery ByteOff
orig_d ([FieldOffOrPadding (AnnExpr' CoreBndr DVarSet)]
-> [FieldOffOrPadding (AnnExpr' CoreBndr DVarSet)]
forall a. [a] -> [a]
reverse [FieldOffOrPadding (AnnExpr' CoreBndr 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 CoreBndr ByteOff
-> AnnExpr' CoreBndr DVarSet
-> BcM BCInstrList
unboxedTupleReturn d :: ByteOff
d s :: ByteOff
s p :: Map CoreBndr ByteOff
p arg :: AnnExpr' CoreBndr DVarSet
arg = ByteOff
-> ByteOff
-> Map CoreBndr ByteOff
-> AnnExpr' CoreBndr DVarSet
-> ArgRep
-> BcM BCInstrList
returnUnboxedAtom ByteOff
d ByteOff
s Map CoreBndr ByteOff
p AnnExpr' CoreBndr DVarSet
arg (AnnExpr' CoreBndr DVarSet -> ArgRep
forall ann. AnnExpr' CoreBndr ann -> ArgRep
atomRep AnnExpr' CoreBndr DVarSet
arg)

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

doTailCall
    :: StackDepth
    -> Sequel
    -> BCEnv
    -> Id
    -> [AnnExpr' Id DVarSet]
    -> BcM BCInstrList
doTailCall :: ByteOff
-> ByteOff
-> Map CoreBndr ByteOff
-> CoreBndr
-> [AnnExpr' CoreBndr DVarSet]
-> BcM BCInstrList
doTailCall init_d :: ByteOff
init_d s :: ByteOff
s p :: Map CoreBndr ByteOff
p fn :: CoreBndr
fn args :: [AnnExpr' CoreBndr DVarSet]
args = ByteOff
-> [AnnExpr' CoreBndr DVarSet] -> [ArgRep] -> BcM BCInstrList
do_pushes ByteOff
init_d [AnnExpr' CoreBndr DVarSet]
args ((AnnExpr' CoreBndr DVarSet -> ArgRep)
-> [AnnExpr' CoreBndr DVarSet] -> [ArgRep]
forall a b. (a -> b) -> [a] -> [b]
map AnnExpr' CoreBndr DVarSet -> ArgRep
forall ann. AnnExpr' CoreBndr ann -> ArgRep
atomRep [AnnExpr' CoreBndr DVarSet]
args)
  where
  do_pushes :: ByteOff
-> [AnnExpr' CoreBndr DVarSet] -> [ArgRep] -> BcM BCInstrList
do_pushes !ByteOff
d [] reps :: [ArgRep]
reps = do
        ASSERT( null reps ) return ()
        (push_fn :: BCInstrList
push_fn, sz :: ByteOff
sz) <- ByteOff
-> Map CoreBndr ByteOff
-> AnnExpr' CoreBndr DVarSet
-> BcM (BCInstrList, ByteOff)
pushAtom ByteOff
d Map CoreBndr ByteOff
p (CoreBndr -> AnnExpr' CoreBndr DVarSet
forall bndr annot. CoreBndr -> AnnExpr' bndr annot
AnnVar CoreBndr
fn)
        DynFlags
dflags <- BcM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
        ASSERT( sz == wordSize dflags ) return ()
        let slide :: BCInstrList
slide = DynFlags -> ByteOff -> ByteOff -> BCInstrList
mkSlideB DynFlags
dflags (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
+ DynFlags -> ByteOff
wordSize DynFlags
dflags) (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 args :: [AnnExpr' CoreBndr DVarSet]
args reps :: [ArgRep]
reps = do
      let (push_apply :: BCInstr
push_apply, n :: Int
n, rest_of_reps :: [ArgRep]
rest_of_reps) = [ArgRep] -> (BCInstr, Int, [ArgRep])
findPushSeq [ArgRep]
reps
          (these_args :: [AnnExpr' CoreBndr DVarSet]
these_args, rest_of_args :: [AnnExpr' CoreBndr DVarSet]
rest_of_args) = Int
-> [AnnExpr' CoreBndr DVarSet]
-> ([AnnExpr' CoreBndr DVarSet], [AnnExpr' CoreBndr DVarSet])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n [AnnExpr' CoreBndr DVarSet]
args
      (next_d :: ByteOff
next_d, push_code :: BCInstrList
push_code) <- ByteOff
-> [AnnExpr' CoreBndr DVarSet] -> BcM (ByteOff, BCInstrList)
push_seq ByteOff
d [AnnExpr' CoreBndr DVarSet]
these_args
      DynFlags
dflags <- BcM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
      BCInstrList
instrs <- ByteOff
-> [AnnExpr' CoreBndr DVarSet] -> [ArgRep] -> BcM BCInstrList
do_pushes (ByteOff
next_d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ DynFlags -> ByteOff
wordSize DynFlags
dflags) [AnnExpr' CoreBndr 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' CoreBndr DVarSet] -> BcM (ByteOff, BCInstrList)
push_seq d :: 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 d :: ByteOff
d (arg :: AnnExpr' CoreBndr DVarSet
arg:args :: [AnnExpr' CoreBndr DVarSet]
args) = do
    (push_code :: BCInstrList
push_code, sz :: ByteOff
sz) <- ByteOff
-> Map CoreBndr ByteOff
-> AnnExpr' CoreBndr DVarSet
-> BcM (BCInstrList, ByteOff)
pushAtom ByteOff
d Map CoreBndr ByteOff
p AnnExpr' CoreBndr DVarSet
arg
    (final_d :: ByteOff
final_d, more_push_code :: BCInstrList
more_push_code) <- ByteOff
-> [AnnExpr' CoreBndr DVarSet] -> BcM (ByteOff, BCInstrList)
push_seq (ByteOff
d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ ByteOff
sz) [AnnExpr' CoreBndr 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 (P: P: P: P: P: P: rest :: [ArgRep]
rest)
  = (BCInstr
PUSH_APPLY_PPPPPP, 6, [ArgRep]
rest)
findPushSeq (P: P: P: P: P: rest :: [ArgRep]
rest)
  = (BCInstr
PUSH_APPLY_PPPPP, 5, [ArgRep]
rest)
findPushSeq (P: P: P: P: rest :: [ArgRep]
rest)
  = (BCInstr
PUSH_APPLY_PPPP, 4, [ArgRep]
rest)
findPushSeq (P: P: P: rest :: [ArgRep]
rest)
  = (BCInstr
PUSH_APPLY_PPP, 3, [ArgRep]
rest)
findPushSeq (P: P: rest :: [ArgRep]
rest)
  = (BCInstr
PUSH_APPLY_PP, 2, [ArgRep]
rest)
findPushSeq (P: rest :: [ArgRep]
rest)
  = (BCInstr
PUSH_APPLY_P, 1, [ArgRep]
rest)
findPushSeq (V: rest :: [ArgRep]
rest)
  = (BCInstr
PUSH_APPLY_V, 1, [ArgRep]
rest)
findPushSeq (N: rest :: [ArgRep]
rest)
  = (BCInstr
PUSH_APPLY_N, 1, [ArgRep]
rest)
findPushSeq (F: rest :: [ArgRep]
rest)
  = (BCInstr
PUSH_APPLY_F, 1, [ArgRep]
rest)
findPushSeq (D: rest :: [ArgRep]
rest)
  = (BCInstr
PUSH_APPLY_D, 1, [ArgRep]
rest)
findPushSeq (L: rest :: [ArgRep]
rest)
  = (BCInstr
PUSH_APPLY_L, 1, [ArgRep]
rest)
findPushSeq _
  = String -> (BCInstr, Int, [ArgRep])
forall a. String -> a
panic "ByteCodeGen.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 CoreBndr ByteOff
-> AnnExpr CoreBndr DVarSet
-> CoreBndr
-> [AnnAlt CoreBndr DVarSet]
-> Maybe CoreBndr
-> BcM BCInstrList
doCase d :: ByteOff
d s :: ByteOff
s p :: Map CoreBndr ByteOff
p (_,scrut :: AnnExpr' CoreBndr DVarSet
scrut) bndr :: CoreBndr
bndr alts :: [AnnAlt CoreBndr DVarSet]
alts is_unboxed_tuple :: Maybe CoreBndr
is_unboxed_tuple
  | HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep (CoreBndr -> Type
idType CoreBndr
bndr) [PrimRep] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthExceeds` 1
  = BcM BCInstrList
forall a. a
multiValException
  | Bool
otherwise
  = do
     DynFlags
dflags <- BcM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
     let
        profiling :: Bool
profiling
          | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ExternalInterpreter DynFlags
dflags = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SccProfilingOn DynFlags
dflags
          | Bool
otherwise = Bool
rtsIsProfiled

        -- 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 = 2 ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
* DynFlags -> ByteOff
wordSize DynFlags
dflags

        -- The extra frame we push to save/restor the CCCS when profiling
        save_ccs_size_b :: ByteOff
save_ccs_size_b | Bool
profiling = 2 ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
* DynFlags -> ByteOff
wordSize DynFlags
dflags
                        | Bool
otherwise = 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 = 0
                            | Bool
otherwise = DynFlags -> ByteOff
wordSize DynFlags
dflags

        -- 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
+ DynFlags -> WordOff -> ByteOff
wordsToBytes DynFlags
dflags (DynFlags -> CoreBndr -> WordOff
idSizeW DynFlags
dflags CoreBndr
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 CoreBndr ByteOff
p_alts0 = CoreBndr -> ByteOff -> Map CoreBndr ByteOff -> Map CoreBndr ByteOff
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert CoreBndr
bndr ByteOff
d_bndr Map CoreBndr ByteOff
p

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

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

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

        codeAlt alt :: (AltCon, [CoreBndr], (a, AnnExpr' CoreBndr DVarSet))
alt@(_, bndrs :: [CoreBndr]
bndrs, (_,rhs :: AnnExpr' CoreBndr DVarSet
rhs))
           -- primitive or nullary constructor alt: no need to UNPACK
           | [CoreBndr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CoreBndr]
real_bndrs = do
                BCInstrList
rhs_code <- ByteOff
-> ByteOff
-> Map CoreBndr ByteOff
-> AnnExpr' CoreBndr DVarSet
-> BcM BCInstrList
schemeE ByteOff
d_alts ByteOff
s Map CoreBndr ByteOff
p_alts AnnExpr' CoreBndr DVarSet
rhs
                (Discr, BCInstrList) -> BcM (Discr, BCInstrList)
forall (m :: * -> *) a. Monad m => a -> m a
return ((AltCon, [CoreBndr], (a, AnnExpr' CoreBndr DVarSet)) -> Discr
forall b c. (AltCon, b, c) -> Discr
my_discr (AltCon, [CoreBndr], (a, AnnExpr' CoreBndr 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 Trac #14608.)
           | (CoreBndr -> Bool) -> [CoreBndr] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\bndr :: CoreBndr
bndr -> HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep (CoreBndr -> Type
idType CoreBndr
bndr) [PrimRep] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthExceeds` 1) [CoreBndr]
bndrs
           = BcM (Discr, BCInstrList)
forall a. a
multiValException
           -- algebraic alt with some binders
           | Bool
otherwise =
             let (tot_wds :: Int
tot_wds, _ptrs_wds :: Int
_ptrs_wds, args_offsets :: [(NonVoid CoreBndr, Int)]
args_offsets) =
                     DynFlags
-> ClosureHeader
-> [NonVoid (PrimRep, CoreBndr)]
-> (Int, Int, [(NonVoid CoreBndr, Int)])
forall a.
DynFlags
-> ClosureHeader
-> [NonVoid (PrimRep, a)]
-> (Int, Int, [(NonVoid a, Int)])
mkVirtHeapOffsets DynFlags
dflags ClosureHeader
NoHeader
                         [ (PrimRep, CoreBndr) -> NonVoid (PrimRep, CoreBndr)
forall a. a -> NonVoid a
NonVoid (CoreBndr -> PrimRep
bcIdPrimRep CoreBndr
id, CoreBndr
id)
                         | NonVoid id :: CoreBndr
id <- [CoreBndr] -> [NonVoid CoreBndr]
nonVoidIds [CoreBndr]
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
+ DynFlags -> WordOff -> ByteOff
wordsToBytes DynFlags
dflags WordOff
size

                 -- convert offsets from Sp into offsets into the virtual stack
                 p' :: Map CoreBndr ByteOff
p' = [(CoreBndr, ByteOff)]
-> Map CoreBndr ByteOff -> Map CoreBndr ByteOff
forall key elt.
Ord key =>
[(key, elt)] -> Map key elt -> Map key elt
Map.insertList
                        [ (CoreBndr
arg, ByteOff
stack_bot ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
- Int -> ByteOff
ByteOff Int
offset)
                        | (NonVoid arg :: CoreBndr
arg, offset :: Int
offset) <- [(NonVoid CoreBndr, Int)]
args_offsets ]
                        Map CoreBndr ByteOff
p_alts
             in do
             MASSERT(isAlgCase)
             BCInstrList
rhs_code <- ByteOff
-> ByteOff
-> Map CoreBndr ByteOff
-> AnnExpr' CoreBndr DVarSet
-> BcM BCInstrList
schemeE ByteOff
stack_bot ByteOff
s Map CoreBndr ByteOff
p' AnnExpr' CoreBndr DVarSet
rhs
             (Discr, BCInstrList) -> BcM (Discr, BCInstrList)
forall (m :: * -> *) a. Monad m => a -> m a
return ((AltCon, [CoreBndr], (a, AnnExpr' CoreBndr DVarSet)) -> Discr
forall b c. (AltCon, b, c) -> Discr
my_discr (AltCon, [CoreBndr], (a, AnnExpr' CoreBndr 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 :: [CoreBndr]
real_bndrs = (CoreBndr -> Bool) -> [CoreBndr] -> [CoreBndr]
forall a. (a -> Bool) -> [a] -> [a]
filterOut CoreBndr -> Bool
isTyVar [CoreBndr]
bndrs

        my_discr :: (AltCon, b, c) -> Discr
my_discr (DEFAULT, _, _) = Discr
NoDiscr {-shouldn't really happen-}
        my_discr (DataAlt dc :: DataCon
dc, _, _)
           | 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 l :: Literal
l, _, _)
           = case Literal
l of LitNumber LitNumInt i :: Integer
i  _  -> Int -> Discr
DiscrI (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
i)
                       LitNumber LitNumWord w :: Integer
w _  -> Word -> Discr
DiscrW (Integer -> Word
forall a. Num a => Integer -> a
fromInteger Integer
w)
                       LitFloat r :: Rational
r   -> Float -> Discr
DiscrF (Rational -> Float
forall a. Fractional a => Rational -> a
fromRational Rational
r)
                       LitDouble r :: Rational
r  -> Double -> Discr
DiscrD (Rational -> Double
forall a. Fractional a => Rational -> a
fromRational Rational
r)
                       LitChar i :: Char
i    -> Int -> Discr
DiscrI (Char -> Int
ord Char
i)
                       _ -> String -> SDoc -> Discr
forall a. HasCallStack => String -> SDoc -> a
pprPanic "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 dc :: DataCon
dc, _, _) <- [AnnAlt CoreBndr DVarSet]
alts] of
                []     -> Maybe Int
forall a. Maybe a
Nothing
                (dc :: DataCon
dc:_) -> 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
$ DynFlags -> ByteOff -> WordOff
bytesToWords DynFlags
dflags (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 = DynFlags -> Int -> [Int] -> [StgWord]
intsToReverseBitmap DynFlags
dflags 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 :: [(CoreBndr, ByteOff)]
binds = Map CoreBndr ByteOff -> [(CoreBndr, ByteOff)]
forall k a. Map k a -> [(k, a)]
Map.toList Map CoreBndr 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
$ [[Word16]] -> [Word16]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (((CoreBndr, ByteOff) -> [Word16])
-> [(CoreBndr, ByteOff)] -> [[Word16]]
forall a b. (a -> b) -> [a] -> [b]
map (CoreBndr, ByteOff) -> [Word16]
spread [(CoreBndr, ByteOff)]
binds)
          spread :: (CoreBndr, ByteOff) -> [Word16]
spread (id :: CoreBndr
id, offset :: ByteOff
offset) | ArgRep -> Bool
isFollowableArg (CoreBndr -> ArgRep
bcIdArgRep CoreBndr
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
$ DynFlags -> ByteOff -> WordOff
bytesToWords DynFlags
dflags (ByteOff
d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
- ByteOff
offset)

     [(Discr, BCInstrList)]
alt_stuff <- (AnnAlt CoreBndr DVarSet -> BcM (Discr, BCInstrList))
-> [AnnAlt CoreBndr DVarSet] -> BcM [(Discr, BCInstrList)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM AnnAlt CoreBndr DVarSet -> BcM (Discr, BCInstrList)
forall a.
(AltCon, [CoreBndr], (a, AnnExpr' CoreBndr DVarSet))
-> BcM (Discr, BCInstrList)
codeAlt [AnnAlt CoreBndr 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 = CoreBndr -> Name
forall a. NamedThing a => a -> Name
getName CoreBndr
bndr
         alt_bco :: [FFIInfo] -> ProtoBCO Name
alt_bco = DynFlags
-> Name
-> BCInstrList
-> Either [AnnAlt CoreBndr DVarSet] (AnnExpr CoreBndr DVarSet)
-> Int
-> Word16
-> [StgWord]
-> Bool
-> [FFIInfo]
-> ProtoBCO Name
forall name.
DynFlags
-> name
-> BCInstrList
-> Either [AnnAlt CoreBndr DVarSet] (AnnExpr CoreBndr DVarSet)
-> Int
-> Word16
-> [StgWord]
-> Bool
-> [FFIInfo]
-> ProtoBCO name
mkProtoBCO DynFlags
dflags Name
alt_bco_name BCInstrList
alt_final ([AnnAlt CoreBndr DVarSet]
-> Either [AnnAlt CoreBndr DVarSet] (AnnExpr CoreBndr DVarSet)
forall a b. a -> Either a b
Left [AnnAlt CoreBndr DVarSet]
alts)
                       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 CoreBndr ByteOff
-> AnnExpr' CoreBndr 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 CoreBndr ByteOff
p AnnExpr' CoreBndr 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' (Type -> ArgRep
typeArgRep Type
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 CoreBndr ByteOff
-> CCallSpec
-> CoreBndr
-> [AnnExpr' CoreBndr DVarSet]
-> BcM BCInstrList
generateCCall d0 :: ByteOff
d0 s :: ByteOff
s p :: Map CoreBndr ByteOff
p (CCallSpec target :: CCallTarget
target cconv :: CCallConv
cconv safety :: Safety
safety) fn :: CoreBndr
fn args_r_to_l :: [AnnExpr' CoreBndr DVarSet]
args_r_to_l
 = do
     DynFlags
dflags <- BcM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags

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

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

              in case Type -> Maybe TyCon
tyConAppTyCon_maybe Type
arg_ty of
                    -- Don't push the FO; instead push the Addr# it
                    -- contains.
                    Just t :: 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' CoreBndr DVarSet] -> BcM [(BCInstrList, PrimRep)]
pargs (ByteOff
d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ ByteOff
addr_size_b) [AnnExpr' CoreBndr DVarSet]
az
                             BCInstrList
code <- Word16
-> ByteOff
-> Map CoreBndr ByteOff
-> AnnExpr' CoreBndr 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 CoreBndr ByteOff
p AnnExpr' CoreBndr 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' CoreBndr DVarSet] -> BcM [(BCInstrList, PrimRep)]
pargs (ByteOff
d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ ByteOff
addr_size_b) [AnnExpr' CoreBndr DVarSet]
az
                             BCInstrList
code <- Word16
-> ByteOff
-> Map CoreBndr ByteOff
-> AnnExpr' CoreBndr 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 CoreBndr ByteOff
p AnnExpr' CoreBndr 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' CoreBndr DVarSet] -> BcM [(BCInstrList, PrimRep)]
pargs (ByteOff
d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ ByteOff
addr_size_b) [AnnExpr' CoreBndr DVarSet]
az
                             BCInstrList
code <- Word16
-> ByteOff
-> Map CoreBndr ByteOff
-> AnnExpr' CoreBndr 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 CoreBndr ByteOff
p AnnExpr' CoreBndr 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.
                    _
                       -> do (code_a :: BCInstrList
code_a, sz_a :: ByteOff
sz_a) <- ByteOff
-> Map CoreBndr ByteOff
-> AnnExpr' CoreBndr DVarSet
-> BcM (BCInstrList, ByteOff)
pushAtom ByteOff
d Map CoreBndr ByteOff
p AnnExpr' CoreBndr DVarSet
a
                             [(BCInstrList, PrimRep)]
rest <- ByteOff
-> [AnnExpr' CoreBndr DVarSet] -> BcM [(BCInstrList, PrimRep)]
pargs (ByteOff
d ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ ByteOff
sz_a) [AnnExpr' CoreBndr DVarSet]
az
                             [(BCInstrList, PrimRep)] -> BcM [(BCInstrList, PrimRep)]
forall (m :: * -> *) a. Monad m => a -> m a
return ((BCInstrList
code_a, AnnExpr' CoreBndr DVarSet -> PrimRep
forall ann. AnnExpr' CoreBndr ann -> PrimRep
atomPrimRep AnnExpr' CoreBndr 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 CoreBndr ByteOff
-> AnnExpr' CoreBndr DVarSet
-> BcM BCInstrList
parg_ArrayishRep hdrSize :: Word16
hdrSize d :: ByteOff
d p :: Map CoreBndr ByteOff
p a :: AnnExpr' CoreBndr DVarSet
a
            = do (push_fo :: BCInstrList
push_fo, _) <- ByteOff
-> Map CoreBndr ByteOff
-> AnnExpr' CoreBndr DVarSet
-> BcM (BCInstrList, ByteOff)
pushAtom ByteOff
d Map CoreBndr ByteOff
p AnnExpr' CoreBndr 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 0 Word16
hdrSize)

     [(BCInstrList, PrimRep)]
code_n_reps <- ByteOff
-> [AnnExpr' CoreBndr DVarSet] -> BcM [(BCInstrList, PrimRep)]
pargs ByteOff
d0 [AnnExpr' CoreBndr DVarSet]
args_r_to_l
     let
         (pushs_arg :: [BCInstrList]
pushs_arg, a_reps_pushed_r_to_l :: [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 (DynFlags -> PrimRep -> WordOff
repSizeWords DynFlags
dflags) [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
+ DynFlags -> WordOff -> ByteOff
wordsToBytes DynFlags
dflags 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
|| [PrimRep] -> PrimRep
forall a. [a] -> a
head [PrimRep]
a_reps_pushed_r_to_l PrimRep -> PrimRep -> Bool
forall a. Eq a => a -> a -> Bool
/= PrimRep
VoidRep
            = String -> [PrimRep]
forall a. String -> a
panic "ByteCodeGen.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.
         (returns_void :: Bool
returns_void, r_rep :: PrimRep
r_rep)
            = case Type -> Maybe PrimRep
maybe_getCCallReturnRep (CoreBndr -> Type
idType CoreBndr
fn) of
                 Nothing -> (Bool
True,  PrimRep
VoidRep)
                 Just rr :: 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
                 DynamicTarget -> Maybe Literal
forall a. Maybe a
Nothing
                 StaticTarget _ _ _ False ->
                   String -> Maybe Literal
forall a. String -> a
panic "generateCCall: unexpected FFI value import"
                 StaticTarget _ target :: FastString
target _ 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 (DynFlags -> Platform
targetPlatform DynFlags
dflags)
                          , 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
* DynFlags -> Int
wORD_SIZE DynFlags
dflags)
                          | 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 "ByteCodeGen.generateCCall: dyn with no args"
                              else [PrimRep] -> [PrimRep]
forall a. [a] -> [a]
tail [PrimRep]
a_reps_pushed_RAW

         -- push the Addr#
         (push_Addr :: BCInstrList
push_Addr, d_after_Addr :: ByteOff
d_after_Addr)
            | Just machlabel :: Literal
machlabel <- Maybe Literal
maybe_static_target
            = ([BCInstr] -> BCInstrList
forall a. [a] -> OrdList a
toOL [Literal -> Word16 -> BCInstr
PUSH_UBX Literal
machlabel 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   = DynFlags -> PrimRep -> WordOff
repSizeWords DynFlags
dflags PrimRep
r_rep
         d_after_r :: ByteOff
d_after_r = ByteOff
d_after_Addr ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ DynFlags -> WordOff -> ByteOff
wordsToBytes DynFlags
dflags 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 (DynFlags -> PrimRep -> Literal
mkDummyLiteral DynFlags
dflags 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
$ DynFlags -> ByteOff -> WordOff
bytesToWords DynFlags
dflags (ByteOff
d_after_r ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
- ByteOff
s)

         conv :: FFIConv
conv = case CCallConv
cconv of
           CCallConv -> FFIConv
FFICCall
           StdCallConv -> FFIConv
FFIStdCall
           _ -> String -> FFIConv
forall a. String -> a
panic "ByteCodeGen: 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 = DynFlags -> PrimRep -> FFIType
primRepToFFIType DynFlags
dflags PrimRep
r_rep
         ffiargs :: [FFIType]
ffiargs = (PrimRep -> FFIType) -> [PrimRep] -> [FFIType]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> PrimRep -> FFIType
primRepToFFIType DynFlags
dflags) [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
                           PlaySafe          -> 0x0
                           PlayInterruptible -> 0x1
                           PlayRisky         -> 0x2

         -- slide and return
         d_after_r_min_s :: WordOff
d_after_r_min_s = DynFlags -> ByteOff -> WordOff
bytesToWords DynFlags
dflags (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 :: DynFlags -> PrimRep -> FFIType
primRepToFFIType :: DynFlags -> PrimRep -> FFIType
primRepToFFIType dflags :: DynFlags
dflags r :: PrimRep
r
  = case PrimRep
r of
     VoidRep     -> FFIType
FFIVoid
     IntRep      -> FFIType
signed_word
     WordRep     -> FFIType
unsigned_word
     Int64Rep    -> FFIType
FFISInt64
     Word64Rep   -> FFIType
FFIUInt64
     AddrRep     -> FFIType
FFIPointer
     FloatRep    -> FFIType
FFIFloat
     DoubleRep   -> FFIType
FFIDouble
     _           -> String -> FFIType
forall a. String -> a
panic "primRepToFFIType"
  where
    (signed_word :: FFIType
signed_word, unsigned_word :: FFIType
unsigned_word)
       | DynFlags -> Int
wORD_SIZE DynFlags
dflags Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 4  = (FFIType
FFISInt32, FFIType
FFIUInt32)
       | DynFlags -> Int
wORD_SIZE DynFlags
dflags Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 8  = (FFIType
FFISInt64, FFIType
FFIUInt64)
       | Bool
otherwise              = String -> (FFIType, FFIType)
forall a. String -> a
panic "primTyDescChar"

-- Make a dummy literal, to be used as a placeholder for FFI return
-- values on the stack.
mkDummyLiteral :: DynFlags -> PrimRep -> Literal
mkDummyLiteral :: DynFlags -> PrimRep -> Literal
mkDummyLiteral dflags :: DynFlags
dflags pr :: PrimRep
pr
   = case PrimRep
pr of
        IntRep    -> DynFlags -> Integer -> Literal
mkLitInt DynFlags
dflags 0
        WordRep   -> DynFlags -> Integer -> Literal
mkLitWord DynFlags
dflags 0
        Int64Rep  -> Integer -> Literal
mkLitInt64 0
        Word64Rep -> Integer -> Literal
mkLitWord64 0
        AddrRep   -> Literal
LitNullAddr
        DoubleRep -> Rational -> Literal
LitDouble 0
        FloatRep  -> Rational -> Literal
LitFloat 0
        _         -> String -> SDoc -> Literal
forall a. HasCallStack => String -> SDoc -> a
pprPanic "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 :: Type -> Maybe PrimRep
maybe_getCCallReturnRep fn_ty :: Type
fn_ty
   = let
       (_a_tys :: [Type]
_a_tys, r_ty :: Type
r_ty) = Type -> ([Type], Type)
splitFunTys (Type -> Type
dropForAlls Type
fn_ty)
       r_reps :: [PrimRep]
r_reps = HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRepArgs Type
r_ty

       blargh :: a -- Used at more than one type
       blargh :: a
blargh = String -> SDoc -> a
forall a. HasCallStack => String -> SDoc -> a
pprPanic "maybe_getCCallReturn: can't handle:"
                         (Type -> SDoc
pprType Type
fn_ty)
     in
       case [PrimRep]
r_reps of
         []            -> String -> Maybe PrimRep
forall a. String -> a
panic "empty typePrimRepArgs"
         [VoidRep]     -> Maybe PrimRep
forall a. Maybe a
Nothing
         [rep :: 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
         _             -> 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' CoreBndr DVarSet
-> Maybe (AnnExpr' CoreBndr DVarSet, [Name])
maybe_is_tagToEnum_call app :: AnnExpr' CoreBndr DVarSet
app
  | AnnApp (_, AnnApp (_, AnnVar v :: CoreBndr
v) (_, AnnType t :: Type
t)) arg :: AnnExpr CoreBndr DVarSet
arg <- AnnExpr' CoreBndr DVarSet
app
  , Just TagToEnumOp <- CoreBndr -> Maybe PrimOp
isPrimOpId_maybe CoreBndr
v
  = (AnnExpr' CoreBndr DVarSet, [Name])
-> Maybe (AnnExpr' CoreBndr DVarSet, [Name])
forall a. a -> Maybe a
Just (AnnExpr CoreBndr DVarSet -> AnnExpr' CoreBndr DVarSet
forall a b. (a, b) -> b
snd AnnExpr CoreBndr DVarSet
arg, Type -> [Name]
extract_constr_Names Type
t)
  | Bool
otherwise
  = Maybe (AnnExpr' CoreBndr DVarSet, [Name])
forall a. Maybe a
Nothing
  where
    extract_constr_Names :: Type -> [Name]
extract_constr_Names ty :: Type
ty
           | Type
rep_ty <- Type -> Type
unwrapType Type
ty
           , Just tyc :: TyCon
tyc <- Type -> Maybe TyCon
tyConAppTyCon_maybe Type
rep_ty
           , TyCon -> Bool
isDataTyCon TyCon
tyc
           = (DataCon -> Name) -> [DataCon] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (CoreBndr -> Name
forall a. NamedThing a => a -> Name
getName (CoreBndr -> Name) -> (DataCon -> CoreBndr) -> DataCon -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataCon -> CoreBndr
dataConWorkId) (TyCon -> [DataCon]
tyConDataCons TyCon
tyc)
           -- NOTE: use the worker name, not the source name of
           -- the DataCon.  See DataCon.hs for details.
           | Bool
otherwise
           = String -> SDoc -> [Name]
forall a. HasCallStack => String -> SDoc -> a
pprPanic "maybe_is_tagToEnum_call.extract_constr_Ids" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
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 acutally 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 Trac #8383.
-}


implement_tagToId
    :: StackDepth
    -> Sequel
    -> BCEnv
    -> AnnExpr' Id DVarSet
    -> [Name]
    -> BcM BCInstrList
-- See Note [Implementing tagToEnum#]
implement_tagToId :: ByteOff
-> ByteOff
-> Map CoreBndr ByteOff
-> AnnExpr' CoreBndr DVarSet
-> [Name]
-> BcM BCInstrList
implement_tagToId d :: ByteOff
d s :: ByteOff
s p :: Map CoreBndr ByteOff
p arg :: AnnExpr' CoreBndr DVarSet
arg names :: [Name]
names
  = ASSERT( notNull names )
    do (push_arg :: BCInstrList
push_arg, arg_bytes :: ByteOff
arg_bytes) <- ByteOff
-> Map CoreBndr ByteOff
-> AnnExpr' CoreBndr DVarSet
-> BcM (BCInstrList, ByteOff)
pushAtom ByteOff
d Map CoreBndr ByteOff
p AnnExpr' CoreBndr 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])
                               [0 ..] [Name]
names
           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 = DynFlags -> ByteOff -> WordOff
bytesToWords DynFlags
dflags (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 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 1 (WordOff
slide_ws WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
+ 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 l_exit :: Word16
l_exit (my_label :: Word16
my_label, next_label :: Word16
next_label, n :: Int
n, name_for_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 CoreBndr ByteOff
-> AnnExpr' CoreBndr DVarSet
-> BcM (BCInstrList, ByteOff)
pushAtom d :: ByteOff
d p :: Map CoreBndr ByteOff
p e :: AnnExpr' CoreBndr DVarSet
e
   | Just e' :: AnnExpr' CoreBndr DVarSet
e' <- AnnExpr' CoreBndr DVarSet -> Maybe (AnnExpr' CoreBndr DVarSet)
forall ann. AnnExpr' CoreBndr ann -> Maybe (AnnExpr' CoreBndr ann)
bcView AnnExpr' CoreBndr DVarSet
e
   = ByteOff
-> Map CoreBndr ByteOff
-> AnnExpr' CoreBndr DVarSet
-> BcM (BCInstrList, ByteOff)
pushAtom ByteOff
d Map CoreBndr ByteOff
p AnnExpr' CoreBndr DVarSet
e'

pushAtom _ _ (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, 0)          -- treated just like a variable V

-- See Note [Empty case alternatives] in coreSyn/CoreSyn.hs
-- and Note [Bottoming expressions] in coreSyn/CoreUtils.hs:
-- The scrutinee of an empty case evaluates to bottom
pushAtom d :: ByteOff
d p :: Map CoreBndr ByteOff
p (AnnCase (_, a :: AnnExpr' CoreBndr DVarSet
a) _ _ []) -- trac #12128
   = ByteOff
-> Map CoreBndr ByteOff
-> AnnExpr' CoreBndr DVarSet
-> BcM (BCInstrList, ByteOff)
pushAtom ByteOff
d Map CoreBndr ByteOff
p AnnExpr' CoreBndr DVarSet
a

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

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

   | Just primop :: PrimOp
primop <- CoreBndr -> Maybe PrimOp
isPrimOpId_maybe CoreBndr
var
   = do
       DynFlags
dflags <-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), DynFlags -> ByteOff
wordSize DynFlags
dflags)

   | Just d_v :: ByteOff
d_v <- CoreBndr -> Map CoreBndr ByteOff -> Maybe ByteOff
lookupBCEnv_maybe CoreBndr
var Map CoreBndr ByteOff
p  -- var is a local variable
   = do DynFlags
dflags <- BcM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags

        let !szb :: ByteOff
szb = DynFlags -> CoreBndr -> ByteOff
idSizeCon DynFlags
dflags CoreBndr
var
            with_instr :: (Word16 -> a) -> m (OrdList a, ByteOff)
with_instr 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), DynFlags -> ByteOff
wordSize DynFlags
dflags)

        case ByteOff
szb of
            1 -> (Word16 -> BCInstr) -> BcM (BCInstrList, ByteOff)
forall (m :: * -> *) a.
Monad m =>
(Word16 -> a) -> m (OrdList a, ByteOff)
with_instr Word16 -> BCInstr
PUSH8_W
            2 -> (Word16 -> BCInstr) -> BcM (BCInstrList, ByteOff)
forall (m :: * -> *) a.
Monad m =>
(Word16 -> a) -> m (OrdList a, ByteOff)
with_instr Word16 -> BCInstr
PUSH16_W
            4 -> (Word16 -> BCInstr) -> BcM (BCInstrList, ByteOff)
forall (m :: * -> *) a.
Monad m =>
(Word16 -> a) -> m (OrdList a, ByteOff)
with_instr Word16 -> BCInstr
PUSH32_W
            _ -> do
                let !szw :: WordOff
szw = DynFlags -> ByteOff -> WordOff
bytesToWords DynFlags
dflags ByteOff
szb
                    !off_w :: Word16
off_w = WordOff -> Word16
trunc16W (WordOff -> Word16) -> WordOff -> Word16
forall a b. (a -> b) -> a -> b
$ DynFlags -> ByteOff -> WordOff
bytesToWords DynFlags
dflags (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
- 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
        DynFlags
dflags <- BcM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
        case IdEnv (RemotePtr ()) -> CoreBndr -> Maybe (RemotePtr ())
forall a. VarEnv a -> CoreBndr -> Maybe a
lookupVarEnv IdEnv (RemotePtr ())
topStrings CoreBndr
var of
            Just ptr :: RemotePtr ()
ptr -> ByteOff
-> Map CoreBndr ByteOff
-> AnnExpr' CoreBndr DVarSet
-> BcM (BCInstrList, ByteOff)
pushAtom ByteOff
d Map CoreBndr ByteOff
p (AnnExpr' CoreBndr DVarSet -> BcM (BCInstrList, ByteOff))
-> AnnExpr' CoreBndr DVarSet -> BcM (BCInstrList, ByteOff)
forall a b. (a -> b) -> a -> b
$ Literal -> AnnExpr' CoreBndr DVarSet
forall bndr annot. Literal -> AnnExpr' bndr annot
AnnLit (Literal -> AnnExpr' CoreBndr DVarSet)
-> Literal -> AnnExpr' CoreBndr DVarSet
forall a b. (a -> b) -> a -> b
$ DynFlags -> Integer -> Literal
mkLitWord DynFlags
dflags (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
            Nothing -> do
                let sz :: ByteOff
sz = DynFlags -> CoreBndr -> ByteOff
idSizeCon DynFlags
dflags CoreBndr
var
                MASSERT( sz == wordSize dflags )
                (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 (CoreBndr -> Name
forall a. NamedThing a => a -> Name
getName CoreBndr
var)), ByteOff
sz)


pushAtom _ _ (AnnLit lit :: Literal
lit) = do
     DynFlags
dflags <- BcM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
     let code :: ArgRep -> m (BCInstrList, ByteOff)
code rep :: ArgRep
rep
             = let size_words :: WordOff
size_words = Int -> WordOff
WordOff (DynFlags -> ArgRep -> Int
argRepSizeW DynFlags
dflags 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)),
                           DynFlags -> WordOff -> ByteOff
wordsToBytes DynFlags
dflags WordOff
size_words)

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

pushAtom _ _ expr :: AnnExpr' CoreBndr DVarSet
expr
   = String -> SDoc -> BcM (BCInstrList, ByteOff)
forall a. HasCallStack => String -> SDoc -> a
pprPanic "ByteCodeGen.pushAtom"
              (Expr CoreBndr -> SDoc
forall b. OutputableBndr b => Expr b -> SDoc
pprCoreExpr (AnnExpr' CoreBndr DVarSet -> Expr CoreBndr
forall bndr annot. AnnExpr' bndr annot -> Expr bndr
deAnnotate' AnnExpr' CoreBndr 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 CoreBndr ByteOff
-> AnnExpr' CoreBndr DVarSet
-> BcM (BCInstrList, ByteOff)
pushConstrAtom _ _ (AnnLit lit :: Literal
lit@(LitFloat _)) =
    (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), 4)

pushConstrAtom d :: ByteOff
d p :: Map CoreBndr ByteOff
p (AnnVar v :: CoreBndr
v)
    | Just d_v :: ByteOff
d_v <- CoreBndr -> Map CoreBndr ByteOff -> Maybe ByteOff
lookupBCEnv_maybe CoreBndr
v Map CoreBndr ByteOff
p = do  -- v is a local variable
        DynFlags
dflags <- BcM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
        let !szb :: ByteOff
szb = DynFlags -> CoreBndr -> ByteOff
idSizeCon DynFlags
dflags CoreBndr
v
            done :: (Word16 -> a) -> m (OrdList a, ByteOff)
done instr :: 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
            1 -> (Word16 -> BCInstr) -> BcM (BCInstrList, ByteOff)
forall (m :: * -> *) a.
Monad m =>
(Word16 -> a) -> m (OrdList a, ByteOff)
done Word16 -> BCInstr
PUSH8
            2 -> (Word16 -> BCInstr) -> BcM (BCInstrList, ByteOff)
forall (m :: * -> *) a.
Monad m =>
(Word16 -> a) -> m (OrdList a, ByteOff)
done Word16 -> BCInstr
PUSH16
            4 -> (Word16 -> BCInstr) -> BcM (BCInstrList, ByteOff)
forall (m :: * -> *) a.
Monad m =>
(Word16 -> a) -> m (OrdList a, ByteOff)
done Word16 -> BCInstr
PUSH32
            _ -> ByteOff
-> Map CoreBndr ByteOff
-> AnnExpr' CoreBndr DVarSet
-> BcM (BCInstrList, ByteOff)
pushAtom ByteOff
d Map CoreBndr ByteOff
p (CoreBndr -> AnnExpr' CoreBndr DVarSet
forall bndr annot. CoreBndr -> AnnExpr' bndr annot
AnnVar CoreBndr
v)

pushConstrAtom d :: ByteOff
d p :: Map CoreBndr ByteOff
p expr :: AnnExpr' CoreBndr DVarSet
expr = ByteOff
-> Map CoreBndr ByteOff
-> AnnExpr' CoreBndr DVarSet
-> BcM (BCInstrList, ByteOff)
pushAtom ByteOff
d Map CoreBndr ByteOff
p AnnExpr' CoreBndr 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, 0)
  where
    go :: t -> (BCInstrList, a) -> (BCInstrList, a)
go n :: t
n acc :: (BCInstrList, a)
acc@(!BCInstrList
instrs, !a
off) = case t
n of
        0 -> (BCInstrList, a)
acc
        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
+ 1)
        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
+ 2)
        3 -> t -> (BCInstrList, a) -> (BCInstrList, a)
go 1 (t -> (BCInstrList, a) -> (BCInstrList, a)
go 2 (BCInstrList, a)
acc)
        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
+ 4)
        _ -> t -> (BCInstrList, a) -> (BCInstrList, a)
go (t
n t -> t -> t
forall a. Num a => a -> a -> a
- 4) (t -> (BCInstrList, a) -> (BCInstrList, a)
go 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_ncons :: Maybe Int
maybe_ncons raw_ways :: [(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 [] _range_lo :: Discr
_range_lo _range_hi :: 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 [val :: (Discr, BCInstrList)
val] range_lo :: Discr
range_lo range_hi :: 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 vals :: [(Discr, BCInstrList)]
vals range_lo :: Discr
range_lo range_hi :: 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` 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
                [(_, def :: BCInstrList
def)] -> Word16 -> BCInstr
LABEL Word16
lbl_default BCInstr -> BCInstrList -> BCInstrList
forall a. a -> OrdList a -> OrdList a
`consOL` BCInstrList
def
                _          -> String -> BCInstrList
forall a. String -> a
panic "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
         (defaults :: [(Discr, BCInstrList)]
defaults, not_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 i :: Int
i) fail_label :: Word16
fail_label = Int -> Word16 -> BCInstr
TESTLT_I Int
i Word16
fail_label
         testLT (DiscrW i :: Word
i) fail_label :: Word16
fail_label = Word -> Word16 -> BCInstr
TESTLT_W Word
i Word16
fail_label
         testLT (DiscrF i :: Float
i) fail_label :: Word16
fail_label = Float -> Word16 -> BCInstr
TESTLT_F Float
i Word16
fail_label
         testLT (DiscrD i :: Double
i) fail_label :: Word16
fail_label = Double -> Word16 -> BCInstr
TESTLT_D Double
i Word16
fail_label
         testLT (DiscrP i :: Word16
i) fail_label :: Word16
fail_label = Word16 -> Word16 -> BCInstr
TESTLT_P Word16
i Word16
fail_label
         testLT NoDiscr    _          = String -> BCInstr
forall a. String -> a
panic "mkMultiBranch NoDiscr"

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

         -- None of these will be needed if there are no non-default alts
         (init_lo :: Discr
init_lo, init_hi :: 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 "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 -> Discr
DiscrI Int
forall a. Bounded a => a
minBound,  Int -> Discr
DiscrI Int
forall a. Bounded a => a
maxBound )
                DiscrW _ -> ( Word -> Discr
DiscrW Word
forall a. Bounded a => a
minBound,  Word -> Discr
DiscrW Word
forall a. Bounded a => a
maxBound )
                DiscrF _ -> ( Float -> Discr
DiscrF Float
minF,      Float -> Discr
DiscrF Float
maxF )
                DiscrD _ -> ( Double -> Discr
DiscrD Double
minD,      Double -> Discr
DiscrD Double
maxD )
                DiscrP _ -> ( Word16 -> Discr
DiscrP Word16
algMinBound, Word16 -> Discr
DiscrP Word16
algMaxBound )
                NoDiscr -> String -> (Discr, Discr)
forall a. String -> a
panic "mkMultiBranch NoDiscr"

         (algMinBound :: Word16
algMinBound, algMaxBound :: Word16
algMaxBound)
            = case Maybe Int
maybe_ncons of
                 -- XXX What happens when n == 0?
                 Just n :: Int
n  -> (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
- 1)
                 Nothing -> (Word16
forall a. Bounded a => a
minBound, Word16
forall a. Bounded a => a
maxBound)

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

         dec :: Discr -> Discr
dec (DiscrI i :: Int
i) = Int -> Discr
DiscrI (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-1)
         dec (DiscrW w :: Word
w) = Word -> Discr
DiscrW (Word
wWord -> Word -> Word
forall a. Num a => a -> a -> a
-1)
         dec (DiscrP i :: Word16
i) = Word16 -> Discr
DiscrP (Word16
iWord16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
-1)
         dec other :: 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 = -1.0e37
         maxF :: Float
maxF =  1.0e37
         minD :: Double
minD = -1.0e308
         maxD :: Double
maxD =  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
$cp1Ord :: Eq Discr
Ord)

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


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

idSizeW :: DynFlags -> Id -> WordOff
idSizeW :: DynFlags -> CoreBndr -> WordOff
idSizeW dflags :: DynFlags
dflags = Int -> WordOff
WordOff (Int -> WordOff) -> (CoreBndr -> Int) -> CoreBndr -> WordOff
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> ArgRep -> Int
argRepSizeW DynFlags
dflags (ArgRep -> Int) -> (CoreBndr -> ArgRep) -> CoreBndr -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreBndr -> ArgRep
bcIdArgRep

idSizeCon :: DynFlags -> Id -> ByteOff
idSizeCon :: DynFlags -> CoreBndr -> ByteOff
idSizeCon dflags :: DynFlags
dflags = Int -> ByteOff
ByteOff (Int -> ByteOff) -> (CoreBndr -> Int) -> CoreBndr -> ByteOff
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> PrimRep -> Int
primRepSizeB DynFlags
dflags (PrimRep -> Int) -> (CoreBndr -> PrimRep) -> CoreBndr -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreBndr -> PrimRep
bcIdPrimRep

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

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

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

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

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

-- See bug #1257
multiValException :: a
multiValException :: a
multiValException = GhcException -> a
forall a. GhcException -> a
throwGhcException (String -> GhcException
ProgramError
  ("Error: bytecode compiler can't handle unboxed tuples and sums.\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++
   "  Possibly due to foreign import/export decls in source.\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++
   "  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 _ cconv :: CCallConv
cconv _) = case CCallConv
cconv of
   CCallConv            -> Bool
True     -- we explicitly pattern match on every
   StdCallConv          -> Bool
True     -- convention to ensure that a warning
   PrimCallConv         -> Bool
False    -- is triggered when a new one is added
   JavaScriptCallConv   -> Bool
False
   CApiConv             -> Bool
False

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

mkSlideB :: DynFlags -> ByteOff -> ByteOff -> OrdList BCInstr
mkSlideB :: DynFlags -> ByteOff -> ByteOff -> BCInstrList
mkSlideB dflags :: DynFlags
dflags !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
$ DynFlags -> ByteOff -> WordOff
bytesToWords DynFlags
dflags ByteOff
nb
    !d :: WordOff
d = DynFlags -> ByteOff -> WordOff
bytesToWords DynFlags
dflags 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
== 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 :: AnnExpr' CoreBndr ann
-> (AnnExpr' CoreBndr ann, [AnnExpr' CoreBndr ann])
splitApp e :: AnnExpr' CoreBndr ann
e | Just e' :: AnnExpr' CoreBndr ann
e' <- AnnExpr' CoreBndr ann -> Maybe (AnnExpr' CoreBndr ann)
forall ann. AnnExpr' CoreBndr ann -> Maybe (AnnExpr' CoreBndr ann)
bcView AnnExpr' CoreBndr ann
e = AnnExpr' CoreBndr ann
-> (AnnExpr' CoreBndr ann, [AnnExpr' CoreBndr ann])
forall ann.
AnnExpr' CoreBndr ann
-> (AnnExpr' CoreBndr ann, [AnnExpr' CoreBndr ann])
splitApp AnnExpr' CoreBndr ann
e'
splitApp (AnnApp (_,f :: AnnExpr' CoreBndr ann
f) (_,a :: AnnExpr' CoreBndr ann
a))    = case AnnExpr' CoreBndr ann
-> (AnnExpr' CoreBndr ann, [AnnExpr' CoreBndr ann])
forall ann.
AnnExpr' CoreBndr ann
-> (AnnExpr' CoreBndr ann, [AnnExpr' CoreBndr ann])
splitApp AnnExpr' CoreBndr ann
f of
                                      (f' :: AnnExpr' CoreBndr ann
f', as :: [AnnExpr' CoreBndr ann]
as) -> (AnnExpr' CoreBndr ann
f', AnnExpr' CoreBndr ann
aAnnExpr' CoreBndr ann
-> [AnnExpr' CoreBndr ann] -> [AnnExpr' CoreBndr ann]
forall a. a -> [a] -> [a]
:[AnnExpr' CoreBndr ann]
as)
splitApp e :: AnnExpr' CoreBndr ann
e                       = (AnnExpr' CoreBndr 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)
-- Type lambdas *can* occur in random expressions,
-- whereas value lambdas cannot; that is why they are nuked here
bcView :: AnnExpr' CoreBndr ann -> Maybe (AnnExpr' CoreBndr ann)
bcView (AnnCast (_,e :: AnnExpr' CoreBndr ann
e) _)             = AnnExpr' CoreBndr ann -> Maybe (AnnExpr' CoreBndr ann)
forall a. a -> Maybe a
Just AnnExpr' CoreBndr ann
e
bcView (AnnLam v :: CoreBndr
v (_,e :: AnnExpr' CoreBndr ann
e)) | CoreBndr -> Bool
isTyVar CoreBndr
v  = AnnExpr' CoreBndr ann -> Maybe (AnnExpr' CoreBndr ann)
forall a. a -> Maybe a
Just AnnExpr' CoreBndr ann
e
bcView (AnnApp (_,e :: AnnExpr' CoreBndr ann
e) (_, AnnType _)) = AnnExpr' CoreBndr ann -> Maybe (AnnExpr' CoreBndr ann)
forall a. a -> Maybe a
Just AnnExpr' CoreBndr ann
e
bcView (AnnTick Breakpoint{} _)      = Maybe (AnnExpr' CoreBndr ann)
forall a. Maybe a
Nothing
bcView (AnnTick _other_tick :: Tickish CoreBndr
_other_tick (_,e :: AnnExpr' CoreBndr ann
e))   = AnnExpr' CoreBndr ann -> Maybe (AnnExpr' CoreBndr ann)
forall a. a -> Maybe a
Just AnnExpr' CoreBndr ann
e
bcView _                             = Maybe (AnnExpr' CoreBndr ann)
forall a. Maybe a
Nothing

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

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

-- Trac #12128:
-- A case expression can be an atom because empty cases evaluate to bottom.
-- See Note [Empty case alternatives] in coreSyn/CoreSyn.hs
atomPrimRep (AnnCase _ _ ty :: Type
ty _)      = ASSERT(typePrimRep ty == [LiftedRep]) LiftedRep
atomPrimRep (AnnCoercion {})        = PrimRep
VoidRep
atomPrimRep other :: AnnExpr' CoreBndr ann
other = String -> SDoc -> PrimRep
forall a. HasCallStack => String -> SDoc -> a
pprPanic "atomPrimRep" (Expr CoreBndr -> SDoc
forall a. Outputable a => a -> SDoc
ppr (AnnExpr' CoreBndr ann -> Expr CoreBndr
forall bndr annot. AnnExpr' bndr annot -> Expr bndr
deAnnotate' AnnExpr' CoreBndr ann
other))

atomRep :: AnnExpr' Id ann -> ArgRep
atomRep :: AnnExpr' CoreBndr ann -> ArgRep
atomRep e :: AnnExpr' CoreBndr ann
e = PrimRep -> ArgRep
toArgRep (AnnExpr' CoreBndr ann -> PrimRep
forall ann. AnnExpr' CoreBndr ann -> PrimRep
atomPrimRep AnnExpr' CoreBndr 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 original_depth :: ByteOff
original_depth szsb :: [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 :: Type -> ArgRep
typeArgRep = PrimRep -> ArgRep
toArgRep (PrimRep -> ArgRep) -> (Type -> PrimRep) -> Type -> ArgRep
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack => Type -> PrimRep
Type -> 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))

ioToBc :: IO a -> BcM a
ioToBc :: IO a -> BcM a
ioToBc io :: 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
$ \st :: 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 :: HscEnv
-> UniqSupply
-> Module
-> Maybe ModBreaks
-> IdEnv (RemotePtr ())
-> BcM r
-> IO (BcM_State, r)
runBc hsc_env :: HscEnv
hsc_env us :: UniqSupply
us this_mod :: Module
this_mod modBreaks :: Maybe ModBreaks
modBreaks topStrings :: IdEnv (RemotePtr ())
topStrings (BcM m :: 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 0 [] Maybe ModBreaks
modBreaks IntMap CgBreakInfo
forall a. IntMap a
IntMap.empty IdEnv (RemotePtr ())
topStrings)

thenBc :: BcM a -> (a -> BcM b) -> BcM b
thenBc :: BcM a -> (a -> BcM b) -> BcM b
thenBc (BcM expr :: BcM_State -> IO (BcM_State, a)
expr) cont :: 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
$ \st0 :: BcM_State
st0 -> do
  (st1 :: BcM_State
st1, q :: a
q) <- BcM_State -> IO (BcM_State, a)
expr BcM_State
st0
  let BcM k :: BcM_State -> IO (BcM_State, b)
k = a -> BcM b
cont a
q
  (st2 :: BcM_State
st2, r :: 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_ :: BcM a -> BcM b -> BcM b
thenBc_ (BcM expr :: BcM_State -> IO (BcM_State, a)
expr) (BcM cont :: 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
$ \st0 :: BcM_State
st0 -> do
  (st1 :: BcM_State
st1, _) <- BcM_State -> IO (BcM_State, a)
expr BcM_State
st0
  (st2 :: BcM_State
st2, r :: 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 :: a -> BcM a
returnBc result :: 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
$ \st :: 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 Functor BcM where
    fmap :: (a -> b) -> BcM a -> BcM b
fmap = (a -> b) -> BcM a -> BcM b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

instance Applicative BcM where
    pure :: a -> BcM a
pure = a -> BcM a
forall a. a -> BcM a
returnBc
    <*> :: 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
    *> :: 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
  >>= :: 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
  >> :: 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
$ \st :: 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
$ \st :: 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 bco :: [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
$ \st :: 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 a :: 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
$ \st :: 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
$ \st :: 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 "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
+ 1}, Word16
nl)

getLabelsBc :: Word16 -> BcM [Word16]
getLabelsBc :: Word16 -> BcM [Word16]
getLabelsBc n :: 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
$ \st :: 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
-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
$ \st :: BcM_State
st ->
  let breaks :: ModBreaks
breaks = String -> Maybe ModBreaks -> ModBreaks
forall a. HasCallStack => String -> Maybe a -> a
expectJust "ByteCodeGen.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 ix :: Int
ix info :: 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
$ \st :: 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
$
   \st :: BcM_State
st -> case UniqSupply -> (Unique, UniqSupply)
takeUniqFromSupply (BcM_State -> UniqSupply
uniqSupply BcM_State
st) of
             (uniq :: Unique
uniq, us :: 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
$ \st :: 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
$ \st :: 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 :: Type -> BcM CoreBndr
newId ty :: Type
ty = do
    Unique
uniq <- BcM Unique
newUnique
    CoreBndr -> BcM CoreBndr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreBndr -> BcM CoreBndr) -> CoreBndr -> BcM CoreBndr
forall a b. (a -> b) -> a -> b
$ FastString -> Unique -> Type -> CoreBndr
mkSysLocal FastString
tickFS Unique
uniq Type
ty

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