{-# LANGUAGE CPP #-}
module GHC.StgToCmm.Layout (
mkArgDescr,
emitCall, emitReturn, adjustHpBackwards,
emitClosureProcAndInfoTable,
emitClosureAndInfoTable,
slowCall, directCall,
FieldOffOrPadding(..),
ClosureHeader(..),
mkVirtHeapOffsets,
mkVirtHeapOffsetsWithPadding,
mkVirtConstrOffsets,
mkVirtConstrSizes,
getHpRelOffset,
ArgRep(..), toArgRep, toArgRepOrV, idArgRep, argRepSizeW,
getArgAmode, getNonVoidArgAmodes
) where
import GHC.Prelude hiding ((<*>))
import GHC.StgToCmm.Closure
import GHC.StgToCmm.Env
import GHC.StgToCmm.ArgRep
import GHC.StgToCmm.Ticky
import GHC.StgToCmm.Monad
import GHC.StgToCmm.Lit
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(..), PrimOrVoidRep(..), 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.Utils.Constants (debugIsOn)
import GHC.Data.FastString
import Control.Monad
import GHC.StgToCmm.Config (stgToCmmPlatform)
import GHC.StgToCmm.Types
emitReturn :: [CmmExpr] -> FCode ReturnKind
emitReturn :: [CmmExpr] -> FCode ReturnKind
emitReturn [CmmExpr]
results
= do { profile <- FCode Profile
getProfile
; platform <- getPlatform
; sequel <- getSequel
; updfr_off <- getUpdFrameOff
; case 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 { Bool -> FCode () -> FCode ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
adjust FCode ()
adjustHpBackwards
; [LocalReg] -> [CmmExpr] -> FCode ()
emitMultiAssign [LocalReg]
regs [CmmExpr]
results }
; return 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 <- FCode Profile
getProfile
; adjustHpBackwards
; sequel <- getSequel
; updfr_off <- getUpdFrameOff
; case sequel of
Sequel
Return -> do
CmmAGraph -> FCode ()
emit (CmmAGraph -> FCode ()) -> CmmAGraph -> FCode ()
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
ReturnKind -> FCode ReturnKind
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return ReturnKind
AssignedDirectly
AssignTo [LocalReg]
res_regs Bool
_ -> do
k <- FCode BlockId
forall (m :: * -> *). MonadGetUnique m => m BlockId
newBlockId
let area = BlockId -> Area
Young BlockId
k
(off, _, copyin) = copyInOflow profile retConv area res_regs []
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
tscope <- getTickScope
emit (copyout <*> mkLabel k tscope <*> copyin)
return (ReturnedTo k off)
}
adjustHpBackwards :: FCode ()
adjustHpBackwards :: FCode ()
adjustHpBackwards
= do { hp_usg <- FCode HeapUsage
getHpUsage
; let rHp = HeapUsage -> Int
realHp HeapUsage
hp_usg
vHp = HeapUsage -> Int
virtHp HeapUsage
hp_usg
adjust_words = Int
vHp Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
rHp
; new_hp <- getHpRelOffset vHp
; platform <- getPlatform
; emit (if adjust_words == 0
then mkNop
else mkAssign (hpReg platform) new_hp)
; tickyAllocHeap False adjust_words
; setRealHp 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 { argreps <- [StgArg] -> FCode [(ArgRep, Maybe CmmExpr)]
getArgRepsAmodes [StgArg]
stg_args
; direct_call "directCall" conv lbl arity argreps }
slowCall :: CmmExpr -> [StgArg] -> FCode ReturnKind
slowCall :: CmmExpr -> [StgArg] -> FCode ReturnKind
slowCall CmmExpr
fun [StgArg]
stg_args
= do cfg <- FCode StgToCmmConfig
getStgToCmmConfig
let profile = StgToCmmConfig -> Profile
stgToCmmProfile StgToCmmConfig
cfg
platform = StgToCmmConfig -> Platform
stgToCmmPlatform StgToCmmConfig
cfg
ctx = StgToCmmConfig -> SDocContext
stgToCmmContext StgToCmmConfig
cfg
fast_pap = StgToCmmConfig -> Bool
stgToCmmFastPAPCalls StgToCmmConfig
cfg
align_sat = StgToCmmConfig -> Bool
stgToCmmAlignCheck StgToCmmConfig
cfg
argsreps <- getArgRepsAmodes stg_args
let (rts_fun, arity) = slowCallPattern (map fst argsreps)
(r, slow_code) <- getCodeR $ do
r <- direct_call "slow_call" NativeNodeCall
(mkRtsApFastLabel rts_fun) arity ((P,Just fun):argsreps)
emitComment $ mkFastString ("slow_call for " ++
showSDocOneLine ctx (pdoc platform fun) ++
" with pat " ++ unpackFS rts_fun)
return r
let n_args = [StgArg] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [StgArg]
stg_args
if n_args > arity && fast_pap
then do
funv <- (CmmReg . CmmLocal) `fmap` assignTemp fun
fun_iptr <- (CmmReg . CmmLocal) `fmap`
assignTemp (closureInfoPtr platform align_sat (cmmUntag platform funv))
fast_code <- getCode $
emitCall (NativeNodeCall, NativeReturn)
(entryCode platform fun_iptr)
(nonVArgs ((P,Just funv):argsreps))
slow_lbl <- newBlockId
fast_lbl <- newBlockId
is_tagged_lbl <- newBlockId
end_lbl <- newBlockId
let 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)
tscope <- getTickScope
emit (mkCbranch (cmmIsTagged platform funv)
is_tagged_lbl slow_lbl (Just True)
<*> mkLabel is_tagged_lbl tscope
<*> mkCbranch correct_arity fast_lbl slow_lbl (Just True)
<*> mkLabel fast_lbl tscope
<*> fast_code
<*> mkBranch end_lbl
<*> mkLabel slow_lbl tscope
<*> slow_code
<*> mkLabel end_lbl tscope)
return r
else do
emit slow_code
return 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 [(ArgRep, Maybe CmmExpr)] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthLessThan` Int
real_arity
= do
platform <- FCode Platform
getPlatform
pprPanic "direct_call" $
text caller <+> ppr arity <+>
pprDebugCLabel platform lbl <+> ppr (length args) <+>
pdoc platform (map snd args) <+> ppr (map fst args)
| [(ArgRep, Maybe CmmExpr)] -> Bool
forall a. [a] -> Bool
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 do_scc_prof <- StgToCmmConfig -> Bool
stgToCmmSCCProfiling (StgToCmmConfig -> Bool) -> FCode StgToCmmConfig -> FCode Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FCode StgToCmmConfig
getStgToCmmConfig
platform <- getPlatform
emitCallWithExtraStack (call_conv, NativeReturn)
target
(nonVArgs fast_args)
(nonVArgs (slowArgs platform rest_args do_scc_prof))
where
target :: CmmExpr
target = CmmLit -> CmmExpr
CmmLit (CLabel -> CmmLit
CmmLabel CLabel
lbl)
([(ArgRep, Maybe CmmExpr)]
fast_args, [(ArgRep, Maybe CmmExpr)]
rest_args) = Int
-> [(ArgRep, Maybe CmmExpr)]
-> ([(ArgRep, Maybe CmmExpr)], [(ArgRep, Maybe CmmExpr)])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
real_arity [(ArgRep, Maybe CmmExpr)]
args
real_arity :: Int
real_arity = case Convention
call_conv of
Convention
NativeNodeCall -> Int
arityInt -> Int -> Int
forall 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 <- Profile -> Platform
profilePlatform (Profile -> Platform) -> FCode Profile -> FCode Platform
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FCode Profile
getProfile
mapM (getArgRepAmode platform) args
where getArgRepAmode :: Platform -> StgArg -> FCode (ArgRep, Maybe CmmExpr)
getArgRepAmode Platform
platform StgArg
arg
= case StgArg -> PrimOrVoidRep
stgArgRep1 StgArg
arg of
PrimOrVoidRep
VoidRep -> (ArgRep, Maybe CmmExpr) -> FCode (ArgRep, Maybe CmmExpr)
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return (ArgRep
V, Maybe CmmExpr
forall a. Maybe a
Nothing)
NVRep PrimRep
rep -> do expr <- NonVoid StgArg -> FCode CmmExpr
getArgAmode (StgArg -> NonVoid StgArg
forall a. a -> NonVoid a
NonVoid StgArg
arg)
return (toArgRep platform rep, Just expr)
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 CmmExpr -> [CmmExpr] -> [CmmExpr]
forall a. a -> [a] -> [a]
: [(ArgRep, Maybe CmmExpr)] -> [CmmExpr]
nonVArgs [(ArgRep, Maybe CmmExpr)]
args
slowArgs :: Platform -> [(ArgRep, Maybe CmmExpr)] -> DoSCCProfiling -> [(ArgRep, Maybe CmmExpr)]
slowArgs :: Platform
-> [(ArgRep, Maybe CmmExpr)] -> Bool -> [(ArgRep, Maybe CmmExpr)]
slowArgs Platform
_ [] Bool
_ = [(ArgRep, Maybe CmmExpr)]
forall a. Monoid a => a
mempty
slowArgs Platform
platform [(ArgRep, Maybe CmmExpr)]
args Bool
sccProfilingEnabled
| Bool
sccProfilingEnabled = [(ArgRep, Maybe CmmExpr)]
save_cccs [(ArgRep, Maybe CmmExpr)]
-> [(ArgRep, Maybe CmmExpr)] -> [(ArgRep, Maybe CmmExpr)]
forall a. [a] -> [a] -> [a]
++ [(ArgRep, Maybe CmmExpr)]
this_pat [(ArgRep, Maybe CmmExpr)]
-> [(ArgRep, Maybe CmmExpr)] -> [(ArgRep, Maybe CmmExpr)]
forall a. [a] -> [a] -> [a]
++ Platform
-> [(ArgRep, Maybe CmmExpr)] -> Bool -> [(ArgRep, Maybe CmmExpr)]
slowArgs Platform
platform [(ArgRep, Maybe CmmExpr)]
rest_args Bool
sccProfilingEnabled
| Bool
otherwise = [(ArgRep, Maybe CmmExpr)]
this_pat [(ArgRep, Maybe CmmExpr)]
-> [(ArgRep, Maybe CmmExpr)] -> [(ArgRep, Maybe CmmExpr)]
forall a. [a] -> [a] -> [a]
++ Platform
-> [(ArgRep, Maybe CmmExpr)] -> Bool -> [(ArgRep, Maybe CmmExpr)]
slowArgs Platform
platform [(ArgRep, Maybe CmmExpr)]
rest_args Bool
sccProfilingEnabled
where
(FastString
arg_pat, Int
n) = [ArgRep] -> (FastString, Int)
slowCallPattern (((ArgRep, Maybe CmmExpr) -> ArgRep)
-> [(ArgRep, Maybe CmmExpr)] -> [ArgRep]
forall a b. (a -> b) -> [a] -> [b]
map (ArgRep, Maybe CmmExpr) -> ArgRep
forall a b. (a, b) -> a
fst [(ArgRep, Maybe CmmExpr)]
args)
([(ArgRep, Maybe CmmExpr)]
call_args, [(ArgRep, Maybe CmmExpr)]
rest_args) = Int
-> [(ArgRep, Maybe CmmExpr)]
-> ([(ArgRep, Maybe CmmExpr)], [(ArgRep, Maybe CmmExpr)])
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, CmmExpr -> Maybe CmmExpr
forall a. a -> Maybe a
Just (CLabel -> CmmExpr
mkLblExpr CLabel
stg_ap_pat)) (ArgRep, Maybe CmmExpr)
-> [(ArgRep, Maybe CmmExpr)] -> [(ArgRep, Maybe CmmExpr)]
forall a. a -> [a] -> [a]
: [(ArgRep, Maybe CmmExpr)]
call_args
save_cccs :: [(ArgRep, Maybe CmmExpr)]
save_cccs = [(ArgRep
N, CmmExpr -> Maybe CmmExpr
forall a. a -> Maybe a
Just (CLabel -> CmmExpr
mkLblExpr CLabel
save_cccs_lbl)), (ArgRep
N, CmmExpr -> Maybe CmmExpr
forall a. a -> Maybe a
Just (CmmExpr -> Maybe CmmExpr) -> CmmExpr -> Maybe CmmExpr
forall a b. (a -> b) -> a -> b
$ Platform -> CmmExpr
cccsExpr Platform
platform)]
save_cccs_lbl :: CLabel
save_cccs_lbl = UnitId -> FastString -> CLabel
mkCmmRetInfoLabel UnitId
rtsUnitId (String -> FastString
fsLit (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$ String
"stg_restore_cccs_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
arg_reps)
arg_reps :: String
arg_reps =
case [ArgRep] -> ArgRep
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (((ArgRep, Maybe CmmExpr) -> ArgRep)
-> [(ArgRep, Maybe CmmExpr)] -> [ArgRep]
forall a b. (a -> b) -> [a] -> [b]
map (ArgRep, Maybe CmmExpr) -> ArgRep
forall a b. (a, b) -> a
fst [(ArgRep, Maybe CmmExpr)]
args) of
ArgRep
V64 -> String
"v64"
ArgRep
V32 -> String
"v32"
ArgRep
V16 -> String
"v16"
ArgRep
_ -> String
"d"
hpRel :: VirtualHpOffset
-> VirtualHpOffset
-> WordOff
hpRel :: Int -> Int -> Int
hpRel Int
hp Int
off = Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
hp
getHpRelOffset :: VirtualHpOffset -> FCode CmmExpr
getHpRelOffset :: Int -> FCode CmmExpr
getHpRelOffset Int
virtual_offset
= do platform <- FCode Platform
getPlatform
hp_usg <- getHpUsage
return (cmmRegOffW platform (hpReg platform) (hpRel (realHp hp_usg) 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 =
( Int
tot_wds
, Platform -> Int -> Int
bytesToWordsRoundUp Platform
platform Int
bytes_of_ptrs
, [[FieldOffOrPadding a]] -> [FieldOffOrPadding a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[FieldOffOrPadding a]]
ptrs_w_offsets [[FieldOffOrPadding a]]
-> [[FieldOffOrPadding a]] -> [[FieldOffOrPadding a]]
forall a. [a] -> [a] -> [a]
++ [[FieldOffOrPadding a]]
non_ptrs_w_offsets) [FieldOffOrPadding a]
-> [FieldOffOrPadding a] -> [FieldOffOrPadding a]
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 = Platform -> Int -> Int
forall a. Num a => Platform -> a -> a
wordsToBytes Platform
platform Int
hdr_words
([NonVoid (PrimRep, a)]
ptrs, [NonVoid (PrimRep, a)]
non_ptrs) = (NonVoid (PrimRep, a) -> Bool)
-> [NonVoid (PrimRep, a)]
-> ([NonVoid (PrimRep, a)], [NonVoid (PrimRep, a)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (PrimRep -> Bool
isGcPtrRep (PrimRep -> Bool)
-> (NonVoid (PrimRep, a) -> PrimRep)
-> NonVoid (PrimRep, a)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PrimRep, a) -> PrimRep
forall a b. (a, b) -> a
fst ((PrimRep, a) -> PrimRep)
-> (NonVoid (PrimRep, a) -> (PrimRep, a))
-> NonVoid (PrimRep, a)
-> PrimRep
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonVoid (PrimRep, a) -> (PrimRep, a)
forall a. NonVoid a -> a
fromNonVoid) [NonVoid (PrimRep, a)]
things
(Int
bytes_of_ptrs, [[FieldOffOrPadding a]]
ptrs_w_offsets) =
(Int -> NonVoid (PrimRep, a) -> (Int, [FieldOffOrPadding a]))
-> Int -> [NonVoid (PrimRep, a)] -> (Int, [[FieldOffOrPadding a]])
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) =
(Int -> NonVoid (PrimRep, a) -> (Int, [FieldOffOrPadding a]))
-> Int -> [NonVoid (PrimRep, a)] -> (Int, [[FieldOffOrPadding a]])
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
word_size Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
tot_bytes
final_pad :: [FieldOffOrPadding a]
final_pad
| Int
final_pad_size Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 = [(Int -> Int -> FieldOffOrPadding a
forall a. Int -> Int -> FieldOffOrPadding a
Padding Int
final_pad_size
(Int
hdr_bytes Int -> Int -> Int
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) = NonVoid (PrimRep, a) -> (PrimRep, a)
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 = Int -> Int -> Int
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
bytes_so_far
!final_offset :: Int
final_offset = Int
hdr_bytes Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
bytes_so_far Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
padding
!new_bytes_so_far :: Int
new_bytes_so_far = Int
start Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
sizeB
field_off :: FieldOffOrPadding a
field_off = NonVoid a -> Int -> FieldOffOrPadding a
forall a. NonVoid a -> Int -> FieldOffOrPadding a
FieldOff (a -> NonVoid a
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 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = [FieldOffOrPadding a
field_off]
| Bool
otherwise = [ Int -> Int -> FieldOffOrPadding a
forall a. Int -> Int -> FieldOffOrPadding a
Padding Int
padding (Int
hdr_bytes Int -> Int -> Int
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) =
Profile
-> ClosureHeader
-> [NonVoid (PrimRep, a)]
-> (Int, Int, [FieldOffOrPadding a])
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 = Profile
-> ClosureHeader
-> [NonVoid (PrimRep, a)]
-> (Int, Int, [(NonVoid a, Int)])
forall a.
Profile
-> ClosureHeader
-> [NonVoid (PrimRep, a)]
-> (Int, Int, [(NonVoid a, Int)])
mkVirtHeapOffsets Profile
profile ClosureHeader
StdHeader
mkVirtConstrSizes :: Profile -> [PrimRep] -> (WordOff, WordOff)
mkVirtConstrSizes :: Profile -> [PrimRep] -> (Int, Int)
mkVirtConstrSizes Profile
profile [PrimRep]
field_reps
= (Int
tot_wds, Int
ptr_wds)
where
(Int
tot_wds, Int
ptr_wds, [(NonVoid (), Int)]
_) =
Profile
-> [NonVoid (PrimRep, ())] -> (Int, Int, [(NonVoid (), Int)])
forall a.
Profile -> [NonVoid (PrimRep, a)] -> (Int, Int, [(NonVoid a, Int)])
mkVirtConstrOffsets Profile
profile
((PrimRep -> NonVoid (PrimRep, ()))
-> [PrimRep] -> [NonVoid (PrimRep, ())]
forall a b. (a -> b) -> [a] -> [b]
map (\PrimRep
nv_rep -> (PrimRep, ()) -> NonVoid (PrimRep, ())
forall a. a -> NonVoid a
NonVoid (PrimRep
nv_rep, ())) [PrimRep]
field_reps)
#include "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 = (ArgRep -> Bool) -> [ArgRep] -> [ArgRep]
forall a. (a -> Bool) -> [a] -> [a]
filter ArgRep -> Bool
isNonV ((Id -> ArgRep) -> [Id] -> [ArgRep]
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 Bool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
: Platform -> [ArgRep] -> [Bool]
argBits Platform
platform [ArgRep]
args
argBits Platform
platform (ArgRep
arg : [ArgRep]
args) = Int -> Bool -> [Bool]
forall a. Int -> a -> [a]
replicate (Platform -> ArgRep -> Int
argRepSizeW Platform
platform ArgRep
arg) Bool
True
[Bool] -> [Bool] -> [Bool]
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
[] -> Int -> Maybe Int
forall a. a -> Maybe a
Just ARG_NONE
[ArgRep
N] -> Int -> Maybe Int
forall a. a -> Maybe a
Just ARG_N
[ArgRep
P] -> Int -> Maybe Int
forall a. a -> Maybe a
Just ARG_P
[ArgRep
F] -> Int -> Maybe Int
forall a. a -> Maybe a
Just ARG_F
[ArgRep
D] -> Int -> Maybe Int
forall a. a -> Maybe a
Just ARG_D
[ArgRep
L] -> Int -> Maybe Int
forall a. a -> Maybe a
Just ARG_L
[ArgRep
V16] -> Int -> Maybe Int
forall a. a -> Maybe a
Just ARG_V16
[ArgRep
V32] -> Int -> Maybe Int
forall a. a -> Maybe a
Just ARG_V32
[ArgRep
V64] -> Int -> Maybe Int
forall a. a -> Maybe a
Just ARG_V64
[ArgRep
N,ArgRep
N] -> Int -> Maybe Int
forall a. a -> Maybe a
Just ARG_NN
[ArgRep
N,ArgRep
P] -> Int -> Maybe Int
forall a. a -> Maybe a
Just ARG_NP
[ArgRep
P,ArgRep
N] -> Int -> Maybe Int
forall a. a -> Maybe a
Just ARG_PN
[ArgRep
P,ArgRep
P] -> Int -> Maybe Int
forall a. a -> Maybe a
Just ARG_PP
[ArgRep
N,ArgRep
N,ArgRep
N] -> Int -> Maybe Int
forall a. a -> Maybe a
Just ARG_NNN
[ArgRep
N,ArgRep
N,ArgRep
P] -> Int -> Maybe Int
forall a. a -> Maybe a
Just ARG_NNP
[ArgRep
N,ArgRep
P,ArgRep
N] -> Int -> Maybe Int
forall a. a -> Maybe a
Just ARG_NPN
[ArgRep
N,ArgRep
P,ArgRep
P] -> Int -> Maybe Int
forall a. a -> Maybe a
Just ARG_NPP
[ArgRep
P,ArgRep
N,ArgRep
N] -> Int -> Maybe Int
forall a. a -> Maybe a
Just ARG_PNN
[ArgRep
P,ArgRep
N,ArgRep
P] -> Int -> Maybe Int
forall a. a -> Maybe a
Just ARG_PNP
[ArgRep
P,ArgRep
P,ArgRep
N] -> Int -> Maybe Int
forall a. a -> Maybe a
Just ARG_PPN
[ArgRep
P,ArgRep
P,ArgRep
P] -> Int -> Maybe Int
forall a. a -> Maybe a
Just ARG_PPP
[ArgRep
P,ArgRep
P,ArgRep
P,ArgRep
P] -> Int -> Maybe Int
forall a. a -> Maybe a
Just ARG_PPPP
[ArgRep
P,ArgRep
P,ArgRep
P,ArgRep
P,ArgRep
P] -> Int -> Maybe Int
forall a. a -> Maybe a
Just ARG_PPPPP
[ArgRep
P,ArgRep
P,ArgRep
P,ArgRep
P,ArgRep
P,ArgRep
P] -> Int -> Maybe Int
forall a. a -> Maybe a
Just ARG_PPPPPP
[ArgRep]
_ -> Maybe Int
forall a. Maybe a
Nothing
getArgAmode :: NonVoid StgArg -> FCode CmmExpr
getArgAmode :: NonVoid StgArg -> FCode CmmExpr
getArgAmode (NonVoid (StgVarArg Id
var)) = CgIdInfo -> CmmExpr
idInfoToAmode (CgIdInfo -> CmmExpr) -> FCode CgIdInfo -> FCode CmmExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> FCode CgIdInfo
getCgIdInfo Id
var
getArgAmode (NonVoid (StgLitArg Literal
lit)) = Literal -> FCode CmmExpr
cgLit Literal
lit
getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr]
getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr]
getNonVoidArgAmodes [StgArg]
args = (NonVoid StgArg -> FCode CmmExpr)
-> [NonVoid StgArg] -> FCode [CmmExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM NonVoid StgArg -> FCode CmmExpr
getArgAmode ([StgArg] -> [NonVoid StgArg]
nonVoidStgArgs [StgArg]
args)
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 <- FCode Profile
getProfile
; platform <- getPlatform
; node <- if top_lvl then return $ idToReg platform (NonVoid bndr)
else bindToReg (NonVoid bndr) lf_info
; let node_points = Profile -> LambdaFormInfo -> Bool
nodeMustPointToIt Profile
profile LambdaFormInfo
lf_info
; arg_regs <- bindArgsToRegs args
; let args' = if Bool
node_points then (LocalReg
node LocalReg -> [LocalReg] -> [LocalReg]
forall a. a -> [a] -> [a]
: [LocalReg]
arg_regs) else [LocalReg]
arg_regs
conv = if Profile -> LambdaFormInfo -> Bool
nodeMustPointToIt Profile
profile LambdaFormInfo
lf_info then Convention
NativeNodeCall
else Convention
NativeDirectCall
(offset, _, _) = mkCallEntry profile conv args' []
; emitClosureAndInfoTable (profilePlatform profile) info_tbl conv args' $ body (offset, node, 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 { (_, blks) <- FCode () -> FCode ((), CmmAGraphScoped)
forall a. FCode a -> FCode (a, CmmAGraphScoped)
getCodeScoped FCode ()
body
; let entry_lbl = Platform -> CLabel -> CLabel
toEntryLbl Platform
platform (CmmInfoTable -> CLabel
cit_lbl CmmInfoTable
info_tbl)
; emitProcWithConvention conv (Just info_tbl) entry_lbl args blks
}