{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
module GHC.StgToCmm.Layout (
mkArgDescr,
emitCall, emitReturn, adjustHpBackwards,
emitClosureProcAndInfoTable,
emitClosureAndInfoTable,
slowCall, directCall,
FieldOffOrPadding(..),
ClosureHeader(..),
mkVirtHeapOffsets,
mkVirtHeapOffsetsWithPadding,
mkVirtConstrOffsets,
mkVirtConstrSizes,
getHpRelOffset,
ArgRep(..), toArgRep, argRepSizeW
) where
#include "HsVersions.h"
import GHC.Prelude hiding ((<*>))
import GHC.Driver.Session
import GHC.Driver.Ppr
import GHC.StgToCmm.Closure
import GHC.StgToCmm.Env
import GHC.StgToCmm.ArgRep
import GHC.StgToCmm.Ticky
import GHC.StgToCmm.Monad
import GHC.StgToCmm.Utils
import GHC.Cmm.Graph
import GHC.Runtime.Heap.Layout
import GHC.Cmm.BlockId
import GHC.Cmm
import GHC.Cmm.Utils
import GHC.Cmm.Info
import GHC.Cmm.CLabel
import GHC.Stg.Syntax
import GHC.Types.Id
import GHC.Core.TyCon ( PrimRep(..), primRepSizeB )
import GHC.Types.Basic ( RepArity )
import GHC.Platform
import GHC.Platform.Profile
import GHC.Unit
import GHC.Utils.Misc
import Data.List (mapAccumL, partition)
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Data.FastString
import Control.Monad
emitReturn :: [CmmExpr] -> FCode ReturnKind
emitReturn :: [CmmExpr] -> FCode ReturnKind
emitReturn [CmmExpr]
results
= do { Profile
profile <- FCode Profile
getProfile
; Platform
platform <- FCode Platform
getPlatform
; Sequel
sequel <- FCode Sequel
getSequel
; Int
updfr_off <- FCode Int
getUpdFrameOff
; case Sequel
sequel of
Sequel
Return ->
do { FCode ()
adjustHpBackwards
; let e :: CmmExpr
e = Platform -> CmmExpr -> CmmExpr
cmmLoadGCWord Platform
platform (Area -> Int -> CmmExpr
CmmStackSlot Area
Old Int
updfr_off)
; CmmAGraph -> FCode ()
emit (Profile -> CmmExpr -> [CmmExpr] -> Int -> CmmAGraph
mkReturn Profile
profile (Platform -> CmmExpr -> CmmExpr
entryCode Platform
platform CmmExpr
e) [CmmExpr]
results Int
updfr_off)
}
AssignTo [LocalReg]
regs Bool
adjust ->
do { forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
adjust FCode ()
adjustHpBackwards
; [LocalReg] -> [CmmExpr] -> FCode ()
emitMultiAssign [LocalReg]
regs [CmmExpr]
results }
; forall (m :: * -> *) a. Monad m => a -> m a
return ReturnKind
AssignedDirectly
}
emitCall :: (Convention, Convention) -> CmmExpr -> [CmmExpr] -> FCode ReturnKind
emitCall :: (Convention, Convention)
-> CmmExpr -> [CmmExpr] -> FCode ReturnKind
emitCall (Convention, Convention)
convs CmmExpr
fun [CmmExpr]
args
= (Convention, Convention)
-> CmmExpr -> [CmmExpr] -> [CmmExpr] -> FCode ReturnKind
emitCallWithExtraStack (Convention, Convention)
convs CmmExpr
fun [CmmExpr]
args [CmmExpr]
noExtraStack
emitCallWithExtraStack
:: (Convention, Convention) -> CmmExpr -> [CmmExpr]
-> [CmmExpr] -> FCode ReturnKind
(Convention
callConv, Convention
retConv) CmmExpr
fun [CmmExpr]
args [CmmExpr]
extra_stack
= do { Profile
profile <- FCode Profile
getProfile
; FCode ()
adjustHpBackwards
; Sequel
sequel <- FCode Sequel
getSequel
; Int
updfr_off <- FCode Int
getUpdFrameOff
; case Sequel
sequel of
Sequel
Return -> do
CmmAGraph -> FCode ()
emit forall a b. (a -> b) -> a -> b
$ Profile
-> Convention
-> CmmExpr
-> [CmmExpr]
-> Int
-> [CmmExpr]
-> CmmAGraph
mkJumpExtra Profile
profile Convention
callConv CmmExpr
fun [CmmExpr]
args Int
updfr_off [CmmExpr]
extra_stack
forall (m :: * -> *) a. Monad m => a -> m a
return ReturnKind
AssignedDirectly
AssignTo [LocalReg]
res_regs Bool
_ -> do
BlockId
k <- forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
let area :: Area
area = BlockId -> Area
Young BlockId
k
(Int
off, [GlobalReg]
_, CmmAGraph
copyin) = Profile
-> Convention
-> Area
-> [LocalReg]
-> [LocalReg]
-> (Int, [GlobalReg], CmmAGraph)
copyInOflow Profile
profile Convention
retConv Area
area [LocalReg]
res_regs []
copyout :: CmmAGraph
copyout = Profile
-> CmmExpr
-> Convention
-> [CmmExpr]
-> BlockId
-> Int
-> Int
-> [CmmExpr]
-> CmmAGraph
mkCallReturnsTo Profile
profile CmmExpr
fun Convention
callConv [CmmExpr]
args BlockId
k Int
off Int
updfr_off
[CmmExpr]
extra_stack
CmmTickScope
tscope <- FCode CmmTickScope
getTickScope
CmmAGraph -> FCode ()
emit (CmmAGraph
copyout CmmAGraph -> CmmAGraph -> CmmAGraph
<*> BlockId -> CmmTickScope -> CmmAGraph
mkLabel BlockId
k CmmTickScope
tscope CmmAGraph -> CmmAGraph -> CmmAGraph
<*> CmmAGraph
copyin)
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockId -> Int -> ReturnKind
ReturnedTo BlockId
k Int
off)
}
adjustHpBackwards :: FCode ()
adjustHpBackwards :: FCode ()
adjustHpBackwards
= do { HeapUsage
hp_usg <- FCode HeapUsage
getHpUsage
; let rHp :: Int
rHp = HeapUsage -> Int
realHp HeapUsage
hp_usg
vHp :: Int
vHp = HeapUsage -> Int
virtHp HeapUsage
hp_usg
adjust_words :: Int
adjust_words = Int
vHp forall a. Num a => a -> a -> a
-Int
rHp
; CmmExpr
new_hp <- Int -> FCode CmmExpr
getHpRelOffset Int
vHp
; CmmAGraph -> FCode ()
emit (if Int
adjust_words forall a. Eq a => a -> a -> Bool
== Int
0
then CmmAGraph
mkNop
else CmmReg -> CmmExpr -> CmmAGraph
mkAssign CmmReg
hpReg CmmExpr
new_hp)
; Bool -> Int -> FCode ()
tickyAllocHeap Bool
False Int
adjust_words
; Int -> FCode ()
setRealHp Int
vHp
}
directCall :: Convention -> CLabel -> RepArity -> [StgArg] -> FCode ReturnKind
directCall :: Convention -> CLabel -> Int -> [StgArg] -> FCode ReturnKind
directCall Convention
conv CLabel
lbl Int
arity [StgArg]
stg_args
= do { [(ArgRep, Maybe CmmExpr)]
argreps <- [StgArg] -> FCode [(ArgRep, Maybe CmmExpr)]
getArgRepsAmodes [StgArg]
stg_args
; String
-> Convention
-> CLabel
-> Int
-> [(ArgRep, Maybe CmmExpr)]
-> FCode ReturnKind
direct_call String
"directCall" Convention
conv CLabel
lbl Int
arity [(ArgRep, Maybe CmmExpr)]
argreps }
slowCall :: CmmExpr -> [StgArg] -> FCode ReturnKind
slowCall :: CmmExpr -> [StgArg] -> FCode ReturnKind
slowCall CmmExpr
fun [StgArg]
stg_args
= do DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
Profile
profile <- FCode Profile
getProfile
let platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile
[(ArgRep, Maybe CmmExpr)]
argsreps <- [StgArg] -> FCode [(ArgRep, Maybe CmmExpr)]
getArgRepsAmodes [StgArg]
stg_args
let (FastString
rts_fun, Int
arity) = [ArgRep] -> (FastString, Int)
slowCallPattern (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(ArgRep, Maybe CmmExpr)]
argsreps)
(ReturnKind
r, CmmAGraph
slow_code) <- forall a. FCode a -> FCode (a, CmmAGraph)
getCodeR forall a b. (a -> b) -> a -> b
$ do
ReturnKind
r <- String
-> Convention
-> CLabel
-> Int
-> [(ArgRep, Maybe CmmExpr)]
-> FCode ReturnKind
direct_call String
"slow_call" Convention
NativeNodeCall
(FastString -> CLabel
mkRtsApFastLabel FastString
rts_fun) Int
arity ((ArgRep
P,forall a. a -> Maybe a
Just CmmExpr
fun)forall a. a -> [a] -> [a]
:[(ArgRep, Maybe CmmExpr)]
argsreps)
FastString -> FCode ()
emitComment forall a b. (a -> b) -> a -> b
$ String -> FastString
mkFastString (String
"slow_call for " forall a. [a] -> [a] -> [a]
++
DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmExpr
fun) forall a. [a] -> [a] -> [a]
++
String
" with pat " forall a. [a] -> [a] -> [a]
++ FastString -> String
unpackFS FastString
rts_fun)
forall (m :: * -> *) a. Monad m => a -> m a
return ReturnKind
r
let n_args :: Int
n_args = forall (t :: * -> *) a. Foldable t => t a -> Int
length [StgArg]
stg_args
if Int
n_args forall a. Ord a => a -> a -> Bool
> Int
arity Bool -> Bool -> Bool
&& DynFlags -> Int
optLevel DynFlags
dflags forall a. Ord a => a -> a -> Bool
>= Int
2
then do
PtrOpts
ptr_opts <- FCode PtrOpts
getPtrOpts
CmmExpr
funv <- (CmmReg -> CmmExpr
CmmReg forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalReg -> CmmReg
CmmLocal) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` CmmExpr -> FCode LocalReg
assignTemp CmmExpr
fun
CmmExpr
fun_iptr <- (CmmReg -> CmmExpr
CmmReg forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalReg -> CmmReg
CmmLocal) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap`
CmmExpr -> FCode LocalReg
assignTemp (PtrOpts -> CmmExpr -> CmmExpr
closureInfoPtr PtrOpts
ptr_opts (Platform -> CmmExpr -> CmmExpr
cmmUntag Platform
platform CmmExpr
funv))
CmmAGraph
fast_code <- forall a. FCode a -> FCode CmmAGraph
getCode forall a b. (a -> b) -> a -> b
$
(Convention, Convention)
-> CmmExpr -> [CmmExpr] -> FCode ReturnKind
emitCall (Convention
NativeNodeCall, Convention
NativeReturn)
(Platform -> CmmExpr -> CmmExpr
entryCode Platform
platform CmmExpr
fun_iptr)
([(ArgRep, Maybe CmmExpr)] -> [CmmExpr]
nonVArgs ((ArgRep
P,forall a. a -> Maybe a
Just CmmExpr
funv)forall a. a -> [a] -> [a]
:[(ArgRep, Maybe CmmExpr)]
argsreps))
BlockId
slow_lbl <- forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
BlockId
fast_lbl <- forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
BlockId
is_tagged_lbl <- forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
BlockId
end_lbl <- forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
let correct_arity :: CmmExpr
correct_arity = Platform -> CmmExpr -> CmmExpr -> CmmExpr
cmmEqWord Platform
platform (Profile -> CmmExpr -> CmmExpr
funInfoArity Profile
profile CmmExpr
fun_iptr)
(Platform -> Int -> CmmExpr
mkIntExpr Platform
platform Int
n_args)
CmmTickScope
tscope <- FCode CmmTickScope
getTickScope
CmmAGraph -> FCode ()
emit (CmmExpr -> BlockId -> BlockId -> Maybe Bool -> CmmAGraph
mkCbranch (Platform -> CmmExpr -> CmmExpr
cmmIsTagged Platform
platform CmmExpr
funv)
BlockId
is_tagged_lbl BlockId
slow_lbl (forall a. a -> Maybe a
Just Bool
True)
CmmAGraph -> CmmAGraph -> CmmAGraph
<*> BlockId -> CmmTickScope -> CmmAGraph
mkLabel BlockId
is_tagged_lbl CmmTickScope
tscope
CmmAGraph -> CmmAGraph -> CmmAGraph
<*> CmmExpr -> BlockId -> BlockId -> Maybe Bool -> CmmAGraph
mkCbranch CmmExpr
correct_arity BlockId
fast_lbl BlockId
slow_lbl (forall a. a -> Maybe a
Just Bool
True)
CmmAGraph -> CmmAGraph -> CmmAGraph
<*> BlockId -> CmmTickScope -> CmmAGraph
mkLabel BlockId
fast_lbl CmmTickScope
tscope
CmmAGraph -> CmmAGraph -> CmmAGraph
<*> CmmAGraph
fast_code
CmmAGraph -> CmmAGraph -> CmmAGraph
<*> BlockId -> CmmAGraph
mkBranch BlockId
end_lbl
CmmAGraph -> CmmAGraph -> CmmAGraph
<*> BlockId -> CmmTickScope -> CmmAGraph
mkLabel BlockId
slow_lbl CmmTickScope
tscope
CmmAGraph -> CmmAGraph -> CmmAGraph
<*> CmmAGraph
slow_code
CmmAGraph -> CmmAGraph -> CmmAGraph
<*> BlockId -> CmmTickScope -> CmmAGraph
mkLabel BlockId
end_lbl CmmTickScope
tscope)
forall (m :: * -> *) a. Monad m => a -> m a
return ReturnKind
r
else do
CmmAGraph -> FCode ()
emit CmmAGraph
slow_code
forall (m :: * -> *) a. Monad m => a -> m a
return ReturnKind
r
direct_call :: String
-> Convention
-> CLabel -> RepArity
-> [(ArgRep,Maybe CmmExpr)] -> FCode ReturnKind
direct_call :: String
-> Convention
-> CLabel
-> Int
-> [(ArgRep, Maybe CmmExpr)]
-> FCode ReturnKind
direct_call String
caller Convention
call_conv CLabel
lbl Int
arity [(ArgRep, Maybe CmmExpr)]
args
| Bool
debugIsOn Bool -> Bool -> Bool
&& [(ArgRep, Maybe CmmExpr)]
args forall a. [a] -> Int -> Bool
`lengthLessThan` Int
real_arity
= do
Platform
platform <- FCode Platform
getPlatform
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"direct_call" forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
caller SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Int
arity SDoc -> SDoc -> SDoc
<+>
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CLabel
lbl SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (forall (t :: * -> *) a. Foldable t => t a -> Int
length [(ArgRep, Maybe CmmExpr)]
args) SDoc -> SDoc -> SDoc
<+>
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(ArgRep, Maybe CmmExpr)]
args) SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(ArgRep, Maybe CmmExpr)]
args)
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(ArgRep, Maybe CmmExpr)]
rest_args
= (Convention, Convention)
-> CmmExpr -> [CmmExpr] -> FCode ReturnKind
emitCall (Convention
call_conv, Convention
NativeReturn) CmmExpr
target ([(ArgRep, Maybe CmmExpr)] -> [CmmExpr]
nonVArgs [(ArgRep, Maybe CmmExpr)]
args)
| Bool
otherwise
= do DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
(Convention, Convention)
-> CmmExpr -> [CmmExpr] -> [CmmExpr] -> FCode ReturnKind
emitCallWithExtraStack (Convention
call_conv, Convention
NativeReturn)
CmmExpr
target
([(ArgRep, Maybe CmmExpr)] -> [CmmExpr]
nonVArgs [(ArgRep, Maybe CmmExpr)]
fast_args)
([(ArgRep, Maybe CmmExpr)] -> [CmmExpr]
nonVArgs (DynFlags -> [(ArgRep, Maybe CmmExpr)]
stack_args DynFlags
dflags))
where
target :: CmmExpr
target = CmmLit -> CmmExpr
CmmLit (CLabel -> CmmLit
CmmLabel CLabel
lbl)
([(ArgRep, Maybe CmmExpr)]
fast_args, [(ArgRep, Maybe CmmExpr)]
rest_args) = forall a. Int -> [a] -> ([a], [a])
splitAt Int
real_arity [(ArgRep, Maybe CmmExpr)]
args
stack_args :: DynFlags -> [(ArgRep, Maybe CmmExpr)]
stack_args DynFlags
dflags = DynFlags -> [(ArgRep, Maybe CmmExpr)] -> [(ArgRep, Maybe CmmExpr)]
slowArgs DynFlags
dflags [(ArgRep, Maybe CmmExpr)]
rest_args
real_arity :: Int
real_arity = case Convention
call_conv of
Convention
NativeNodeCall -> Int
arityforall a. Num a => a -> a -> a
+Int
1
Convention
_ -> Int
arity
getArgRepsAmodes :: [StgArg] -> FCode [(ArgRep, Maybe CmmExpr)]
getArgRepsAmodes :: [StgArg] -> FCode [(ArgRep, Maybe CmmExpr)]
getArgRepsAmodes [StgArg]
args = do
Platform
platform <- Profile -> Platform
profilePlatform forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FCode Profile
getProfile
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Platform -> StgArg -> FCode (ArgRep, Maybe CmmExpr)
getArgRepAmode Platform
platform) [StgArg]
args
where getArgRepAmode :: Platform -> StgArg -> FCode (ArgRep, Maybe CmmExpr)
getArgRepAmode Platform
platform StgArg
arg
| ArgRep
V <- ArgRep
rep = forall (m :: * -> *) a. Monad m => a -> m a
return (ArgRep
V, forall a. Maybe a
Nothing)
| Bool
otherwise = do CmmExpr
expr <- NonVoid StgArg -> FCode CmmExpr
getArgAmode (forall a. a -> NonVoid a
NonVoid StgArg
arg)
forall (m :: * -> *) a. Monad m => a -> m a
return (ArgRep
rep, forall a. a -> Maybe a
Just CmmExpr
expr)
where rep :: ArgRep
rep = Platform -> PrimRep -> ArgRep
toArgRep Platform
platform (StgArg -> PrimRep
argPrimRep StgArg
arg)
nonVArgs :: [(ArgRep, Maybe CmmExpr)] -> [CmmExpr]
nonVArgs :: [(ArgRep, Maybe CmmExpr)] -> [CmmExpr]
nonVArgs [] = []
nonVArgs ((ArgRep
_,Maybe CmmExpr
Nothing) : [(ArgRep, Maybe CmmExpr)]
args) = [(ArgRep, Maybe CmmExpr)] -> [CmmExpr]
nonVArgs [(ArgRep, Maybe CmmExpr)]
args
nonVArgs ((ArgRep
_,Just CmmExpr
arg) : [(ArgRep, Maybe CmmExpr)]
args) = CmmExpr
arg forall a. a -> [a] -> [a]
: [(ArgRep, Maybe CmmExpr)] -> [CmmExpr]
nonVArgs [(ArgRep, Maybe CmmExpr)]
args
slowArgs :: DynFlags -> [(ArgRep, Maybe CmmExpr)] -> [(ArgRep, Maybe CmmExpr)]
slowArgs :: DynFlags -> [(ArgRep, Maybe CmmExpr)] -> [(ArgRep, Maybe CmmExpr)]
slowArgs DynFlags
_ [] = []
slowArgs DynFlags
dflags [(ArgRep, Maybe CmmExpr)]
args
| DynFlags -> Bool
sccProfilingEnabled DynFlags
dflags
= [(ArgRep, Maybe CmmExpr)]
save_cccs forall a. [a] -> [a] -> [a]
++ [(ArgRep, Maybe CmmExpr)]
this_pat forall a. [a] -> [a] -> [a]
++ DynFlags -> [(ArgRep, Maybe CmmExpr)] -> [(ArgRep, Maybe CmmExpr)]
slowArgs DynFlags
dflags [(ArgRep, Maybe CmmExpr)]
rest_args
| Bool
otherwise = [(ArgRep, Maybe CmmExpr)]
this_pat forall a. [a] -> [a] -> [a]
++ DynFlags -> [(ArgRep, Maybe CmmExpr)] -> [(ArgRep, Maybe CmmExpr)]
slowArgs DynFlags
dflags [(ArgRep, Maybe CmmExpr)]
rest_args
where
(FastString
arg_pat, Int
n) = [ArgRep] -> (FastString, Int)
slowCallPattern (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(ArgRep, Maybe CmmExpr)]
args)
([(ArgRep, Maybe CmmExpr)]
call_args, [(ArgRep, Maybe CmmExpr)]
rest_args) = forall a. Int -> [a] -> ([a], [a])
splitAt Int
n [(ArgRep, Maybe CmmExpr)]
args
stg_ap_pat :: CLabel
stg_ap_pat = UnitId -> FastString -> CLabel
mkCmmRetInfoLabel UnitId
rtsUnitId FastString
arg_pat
this_pat :: [(ArgRep, Maybe CmmExpr)]
this_pat = (ArgRep
N, forall a. a -> Maybe a
Just (CLabel -> CmmExpr
mkLblExpr CLabel
stg_ap_pat)) forall a. a -> [a] -> [a]
: [(ArgRep, Maybe CmmExpr)]
call_args
save_cccs :: [(ArgRep, Maybe CmmExpr)]
save_cccs = [(ArgRep
N, forall a. a -> Maybe a
Just (CLabel -> CmmExpr
mkLblExpr CLabel
save_cccs_lbl)), (ArgRep
N, forall a. a -> Maybe a
Just CmmExpr
cccsExpr)]
save_cccs_lbl :: CLabel
save_cccs_lbl = UnitId -> FastString -> CLabel
mkCmmRetInfoLabel UnitId
rtsUnitId (String -> FastString
fsLit String
"stg_restore_cccs")
hpRel :: VirtualHpOffset
-> VirtualHpOffset
-> WordOff
hpRel :: Int -> Int -> Int
hpRel Int
hp Int
off = Int
off forall a. Num a => a -> a -> a
- Int
hp
getHpRelOffset :: VirtualHpOffset -> FCode CmmExpr
getHpRelOffset :: Int -> FCode CmmExpr
getHpRelOffset Int
virtual_offset
= do Platform
platform <- FCode Platform
getPlatform
HeapUsage
hp_usg <- FCode HeapUsage
getHpUsage
forall (m :: * -> *) a. Monad m => a -> m a
return (Platform -> CmmReg -> Int -> CmmExpr
cmmRegOffW Platform
platform CmmReg
hpReg (Int -> Int -> Int
hpRel (HeapUsage -> Int
realHp HeapUsage
hp_usg) Int
virtual_offset))
data FieldOffOrPadding a
= FieldOff (NonVoid a)
ByteOff
| Padding ByteOff
ByteOff
data
=
|
|
mkVirtHeapOffsetsWithPadding
:: Profile
-> ClosureHeader
-> [NonVoid (PrimRep, a)]
-> ( WordOff
, WordOff
, [FieldOffOrPadding a]
)
mkVirtHeapOffsetsWithPadding :: forall a.
Profile
-> ClosureHeader
-> [NonVoid (PrimRep, a)]
-> (Int, Int, [FieldOffOrPadding a])
mkVirtHeapOffsetsWithPadding Profile
profile ClosureHeader
header [NonVoid (PrimRep, a)]
things =
ASSERT(not (any (isVoidRep . fst . fromNonVoid) things))
( Int
tot_wds
, Platform -> Int -> Int
bytesToWordsRoundUp Platform
platform Int
bytes_of_ptrs
, forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[FieldOffOrPadding a]]
ptrs_w_offsets forall a. [a] -> [a] -> [a]
++ [[FieldOffOrPadding a]]
non_ptrs_w_offsets) forall a. [a] -> [a] -> [a]
++ [FieldOffOrPadding a]
final_pad
)
where
platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile
hdr_words :: Int
hdr_words = case ClosureHeader
header of
ClosureHeader
NoHeader -> Int
0
ClosureHeader
StdHeader -> Profile -> Int
fixedHdrSizeW Profile
profile
ClosureHeader
ThunkHeader -> Profile -> Int
thunkHdrSize Profile
profile
hdr_bytes :: Int
hdr_bytes = forall a. Num a => Platform -> a -> a
wordsToBytes Platform
platform Int
hdr_words
([NonVoid (PrimRep, a)]
ptrs, [NonVoid (PrimRep, a)]
non_ptrs) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (PrimRep -> Bool
isGcPtrRep forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonVoid a -> a
fromNonVoid) [NonVoid (PrimRep, a)]
things
(Int
bytes_of_ptrs, [[FieldOffOrPadding a]]
ptrs_w_offsets) =
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL Int -> NonVoid (PrimRep, a) -> (Int, [FieldOffOrPadding a])
computeOffset Int
0 [NonVoid (PrimRep, a)]
ptrs
(Int
tot_bytes, [[FieldOffOrPadding a]]
non_ptrs_w_offsets) =
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL Int -> NonVoid (PrimRep, a) -> (Int, [FieldOffOrPadding a])
computeOffset Int
bytes_of_ptrs [NonVoid (PrimRep, a)]
non_ptrs
tot_wds :: Int
tot_wds = Platform -> Int -> Int
bytesToWordsRoundUp Platform
platform Int
tot_bytes
final_pad_size :: Int
final_pad_size = Int
tot_wds forall a. Num a => a -> a -> a
* Int
word_size forall a. Num a => a -> a -> a
- Int
tot_bytes
final_pad :: [FieldOffOrPadding a]
final_pad
| Int
final_pad_size forall a. Ord a => a -> a -> Bool
> Int
0 = [(forall a. Int -> Int -> FieldOffOrPadding a
Padding Int
final_pad_size
(Int
hdr_bytes forall a. Num a => a -> a -> a
+ Int
tot_bytes))]
| Bool
otherwise = []
word_size :: Int
word_size = Platform -> Int
platformWordSizeInBytes Platform
platform
computeOffset :: Int -> NonVoid (PrimRep, a) -> (Int, [FieldOffOrPadding a])
computeOffset Int
bytes_so_far NonVoid (PrimRep, a)
nv_thing =
(Int
new_bytes_so_far, FieldOffOrPadding a -> [FieldOffOrPadding a]
with_padding FieldOffOrPadding a
field_off)
where
(PrimRep
rep, a
thing) = forall a. NonVoid a -> a
fromNonVoid NonVoid (PrimRep, a)
nv_thing
!sizeB :: Int
sizeB = Platform -> PrimRep -> Int
primRepSizeB Platform
platform PrimRep
rep
!align :: Int
align = forall a. Ord a => a -> a -> a
min Int
word_size Int
sizeB
!start :: Int
start = Int -> Int -> Int
roundUpTo Int
bytes_so_far Int
align
!padding :: Int
padding = Int
start forall a. Num a => a -> a -> a
- Int
bytes_so_far
!final_offset :: Int
final_offset = Int
hdr_bytes forall a. Num a => a -> a -> a
+ Int
bytes_so_far forall a. Num a => a -> a -> a
+ Int
padding
!new_bytes_so_far :: Int
new_bytes_so_far = Int
start forall a. Num a => a -> a -> a
+ Int
sizeB
field_off :: FieldOffOrPadding a
field_off = forall a. NonVoid a -> Int -> FieldOffOrPadding a
FieldOff (forall a. a -> NonVoid a
NonVoid a
thing) Int
final_offset
with_padding :: FieldOffOrPadding a -> [FieldOffOrPadding a]
with_padding FieldOffOrPadding a
field_off
| Int
padding forall a. Eq a => a -> a -> Bool
== Int
0 = [FieldOffOrPadding a
field_off]
| Bool
otherwise = [ forall a. Int -> Int -> FieldOffOrPadding a
Padding Int
padding (Int
hdr_bytes forall a. Num a => a -> a -> a
+ Int
bytes_so_far)
, FieldOffOrPadding a
field_off
]
mkVirtHeapOffsets
:: Profile
-> ClosureHeader
-> [NonVoid (PrimRep,a)]
-> (WordOff,
WordOff,
[(NonVoid a, ByteOff)])
mkVirtHeapOffsets :: forall a.
Profile
-> ClosureHeader
-> [NonVoid (PrimRep, a)]
-> (Int, Int, [(NonVoid a, Int)])
mkVirtHeapOffsets Profile
profile ClosureHeader
header [NonVoid (PrimRep, a)]
things =
( Int
tot_wds
, Int
ptr_wds
, [ (NonVoid a
field, Int
offset) | (FieldOff NonVoid a
field Int
offset) <- [FieldOffOrPadding a]
things_offsets ]
)
where
(Int
tot_wds, Int
ptr_wds, [FieldOffOrPadding a]
things_offsets) =
forall a.
Profile
-> ClosureHeader
-> [NonVoid (PrimRep, a)]
-> (Int, Int, [FieldOffOrPadding a])
mkVirtHeapOffsetsWithPadding Profile
profile ClosureHeader
header [NonVoid (PrimRep, a)]
things
mkVirtConstrOffsets
:: Profile -> [NonVoid (PrimRep, a)]
-> (WordOff, WordOff, [(NonVoid a, ByteOff)])
mkVirtConstrOffsets :: forall a.
Profile -> [NonVoid (PrimRep, a)] -> (Int, Int, [(NonVoid a, Int)])
mkVirtConstrOffsets Profile
profile = forall a.
Profile
-> ClosureHeader
-> [NonVoid (PrimRep, a)]
-> (Int, Int, [(NonVoid a, Int)])
mkVirtHeapOffsets Profile
profile ClosureHeader
StdHeader
mkVirtConstrSizes :: Profile -> [NonVoid PrimRep] -> (WordOff, WordOff)
mkVirtConstrSizes :: Profile -> [NonVoid PrimRep] -> (Int, Int)
mkVirtConstrSizes Profile
profile [NonVoid PrimRep]
field_reps
= (Int
tot_wds, Int
ptr_wds)
where
(Int
tot_wds, Int
ptr_wds, [(NonVoid (), Int)]
_) =
forall a.
Profile -> [NonVoid (PrimRep, a)] -> (Int, Int, [(NonVoid a, Int)])
mkVirtConstrOffsets Profile
profile
(forall a b. (a -> b) -> [a] -> [b]
map (\NonVoid PrimRep
nv_rep -> forall a. a -> NonVoid a
NonVoid (forall a. NonVoid a -> a
fromNonVoid NonVoid PrimRep
nv_rep, ())) [NonVoid PrimRep]
field_reps)
#include "../includes/rts/storage/FunTypes.h"
mkArgDescr :: Platform -> [Id] -> ArgDescr
mkArgDescr :: Platform -> [Id] -> ArgDescr
mkArgDescr Platform
platform [Id]
args
= let arg_bits :: [Bool]
arg_bits = Platform -> [ArgRep] -> [Bool]
argBits Platform
platform [ArgRep]
arg_reps
arg_reps :: [ArgRep]
arg_reps = forall a. (a -> Bool) -> [a] -> [a]
filter ArgRep -> Bool
isNonV (forall a b. (a -> b) -> [a] -> [b]
map (Platform -> Id -> ArgRep
idArgRep Platform
platform) [Id]
args)
in case [ArgRep] -> Maybe Int
stdPattern [ArgRep]
arg_reps of
Just Int
spec_id -> Int -> ArgDescr
ArgSpec Int
spec_id
Maybe Int
Nothing -> [Bool] -> ArgDescr
ArgGen [Bool]
arg_bits
argBits :: Platform -> [ArgRep] -> [Bool]
argBits :: Platform -> [ArgRep] -> [Bool]
argBits Platform
_ [] = []
argBits Platform
platform (ArgRep
P : [ArgRep]
args) = Bool
False forall a. a -> [a] -> [a]
: Platform -> [ArgRep] -> [Bool]
argBits Platform
platform [ArgRep]
args
argBits Platform
platform (ArgRep
arg : [ArgRep]
args) = forall a. Int -> [a] -> [a]
take (Platform -> ArgRep -> Int
argRepSizeW Platform
platform ArgRep
arg) (forall a. a -> [a]
repeat Bool
True)
forall a. [a] -> [a] -> [a]
++ Platform -> [ArgRep] -> [Bool]
argBits Platform
platform [ArgRep]
args
stdPattern :: [ArgRep] -> Maybe Int
stdPattern :: [ArgRep] -> Maybe Int
stdPattern [ArgRep]
reps
= case [ArgRep]
reps of
[] -> forall a. a -> Maybe a
Just ARG_NONE
[ArgRep
N] -> forall a. a -> Maybe a
Just ARG_N
[ArgRep
P] -> forall a. a -> Maybe a
Just ARG_P
[ArgRep
F] -> forall a. a -> Maybe a
Just ARG_F
[ArgRep
D] -> forall a. a -> Maybe a
Just ARG_D
[ArgRep
L] -> forall a. a -> Maybe a
Just ARG_L
[ArgRep
V16] -> forall a. a -> Maybe a
Just ARG_V16
[ArgRep
V32] -> forall a. a -> Maybe a
Just ARG_V32
[ArgRep
V64] -> forall a. a -> Maybe a
Just ARG_V64
[ArgRep
N,ArgRep
N] -> forall a. a -> Maybe a
Just ARG_NN
[ArgRep
N,ArgRep
P] -> forall a. a -> Maybe a
Just ARG_NP
[ArgRep
P,ArgRep
N] -> forall a. a -> Maybe a
Just ARG_PN
[ArgRep
P,ArgRep
P] -> forall a. a -> Maybe a
Just ARG_PP
[ArgRep
N,ArgRep
N,ArgRep
N] -> forall a. a -> Maybe a
Just ARG_NNN
[ArgRep
N,ArgRep
N,ArgRep
P] -> forall a. a -> Maybe a
Just ARG_NNP
[ArgRep
N,ArgRep
P,ArgRep
N] -> forall a. a -> Maybe a
Just ARG_NPN
[ArgRep
N,ArgRep
P,ArgRep
P] -> forall a. a -> Maybe a
Just ARG_NPP
[ArgRep
P,ArgRep
N,ArgRep
N] -> forall a. a -> Maybe a
Just ARG_PNN
[ArgRep
P,ArgRep
N,ArgRep
P] -> forall a. a -> Maybe a
Just ARG_PNP
[ArgRep
P,ArgRep
P,ArgRep
N] -> forall a. a -> Maybe a
Just ARG_PPN
[ArgRep
P,ArgRep
P,ArgRep
P] -> forall a. a -> Maybe a
Just ARG_PPP
[ArgRep
P,ArgRep
P,ArgRep
P,ArgRep
P] -> forall a. a -> Maybe a
Just ARG_PPPP
[ArgRep
P,ArgRep
P,ArgRep
P,ArgRep
P,ArgRep
P] -> forall a. a -> Maybe a
Just ARG_PPPPP
[ArgRep
P,ArgRep
P,ArgRep
P,ArgRep
P,ArgRep
P,ArgRep
P] -> forall a. a -> Maybe a
Just ARG_PPPPPP
[ArgRep]
_ -> forall a. Maybe a
Nothing
emitClosureProcAndInfoTable :: Bool
-> Id
-> LambdaFormInfo
-> CmmInfoTable
-> [NonVoid Id]
-> ((Int, LocalReg, [LocalReg]) -> FCode ())
-> FCode ()
emitClosureProcAndInfoTable :: Bool
-> Id
-> LambdaFormInfo
-> CmmInfoTable
-> [NonVoid Id]
-> ((Int, LocalReg, [LocalReg]) -> FCode ())
-> FCode ()
emitClosureProcAndInfoTable Bool
top_lvl Id
bndr LambdaFormInfo
lf_info CmmInfoTable
info_tbl [NonVoid Id]
args (Int, LocalReg, [LocalReg]) -> FCode ()
body
= do { Profile
profile <- FCode Profile
getProfile
; Platform
platform <- FCode Platform
getPlatform
; LocalReg
node <- if Bool
top_lvl then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Platform -> NonVoid Id -> LocalReg
idToReg Platform
platform (forall a. a -> NonVoid a
NonVoid Id
bndr)
else NonVoid Id -> LambdaFormInfo -> FCode LocalReg
bindToReg (forall a. a -> NonVoid a
NonVoid Id
bndr) LambdaFormInfo
lf_info
; let node_points :: Bool
node_points = Profile -> LambdaFormInfo -> Bool
nodeMustPointToIt Profile
profile LambdaFormInfo
lf_info
; [LocalReg]
arg_regs <- [NonVoid Id] -> FCode [LocalReg]
bindArgsToRegs [NonVoid Id]
args
; let args' :: [LocalReg]
args' = if Bool
node_points then (LocalReg
node forall a. a -> [a] -> [a]
: [LocalReg]
arg_regs) else [LocalReg]
arg_regs
conv :: Convention
conv = if Profile -> LambdaFormInfo -> Bool
nodeMustPointToIt Profile
profile LambdaFormInfo
lf_info then Convention
NativeNodeCall
else Convention
NativeDirectCall
(Int
offset, [GlobalReg]
_, CmmAGraph
_) = Profile
-> Convention
-> [LocalReg]
-> [LocalReg]
-> (Int, [GlobalReg], CmmAGraph)
mkCallEntry Profile
profile Convention
conv [LocalReg]
args' []
; Platform
-> CmmInfoTable -> Convention -> [LocalReg] -> FCode () -> FCode ()
emitClosureAndInfoTable (Profile -> Platform
profilePlatform Profile
profile) CmmInfoTable
info_tbl Convention
conv [LocalReg]
args' forall a b. (a -> b) -> a -> b
$ (Int, LocalReg, [LocalReg]) -> FCode ()
body (Int
offset, LocalReg
node, [LocalReg]
arg_regs)
}
emitClosureAndInfoTable
:: Platform -> CmmInfoTable -> Convention -> [LocalReg] -> FCode () -> FCode ()
emitClosureAndInfoTable :: Platform
-> CmmInfoTable -> Convention -> [LocalReg] -> FCode () -> FCode ()
emitClosureAndInfoTable Platform
platform CmmInfoTable
info_tbl Convention
conv [LocalReg]
args FCode ()
body
= do { (()
_, CmmAGraphScoped
blks) <- forall a. FCode a -> FCode (a, CmmAGraphScoped)
getCodeScoped FCode ()
body
; let entry_lbl :: CLabel
entry_lbl = Platform -> CLabel -> CLabel
toEntryLbl Platform
platform (CmmInfoTable -> CLabel
cit_lbl CmmInfoTable
info_tbl)
; Convention
-> Maybe CmmInfoTable
-> CLabel
-> [LocalReg]
-> CmmAGraphScoped
-> FCode ()
emitProcWithConvention Convention
conv (forall a. a -> Maybe a
Just CmmInfoTable
info_tbl) CLabel
entry_lbl [LocalReg]
args CmmAGraphScoped
blks
}