mirror of
https://github.com/tweag/asterius.git
synced 2024-09-21 13:59:06 +03:00
1072 lines
35 KiB
Haskell
1072 lines
35 KiB
Haskell
{-# LANGUAGE CPP #-}
|
|
{-# OPTIONS_GHC -fno-warn-unused-matches #-}
|
|
{-# OPTIONS_GHC -fno-warn-unused-binds #-}
|
|
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
|
|
{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}
|
|
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
|
|
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
|
|
-- The above warning suppression flags are a temporary kludge.
|
|
-- While working on this module you are encouraged to remove it and fix
|
|
-- any warnings in the module. See
|
|
-- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
|
|
-- for details
|
|
module Main(main) where
|
|
|
|
#include "ghcconfig.h"
|
|
#include "stg/HaskellMachRegs.h"
|
|
#include "rts/Constants.h"
|
|
|
|
-- Needed for TAG_BITS
|
|
#include "MachDeps.h"
|
|
|
|
#if MIN_VERSION_base(4,11,0)
|
|
import Prelude hiding ((<>))
|
|
#endif
|
|
|
|
import Text.PrettyPrint
|
|
import Data.Word
|
|
import Data.Bits
|
|
import Data.List ( intersperse, nub, sort )
|
|
import System.Exit
|
|
import System.Environment
|
|
import System.IO
|
|
import Control.Arrow ((***))
|
|
|
|
-- -----------------------------------------------------------------------------
|
|
-- Argument kinds (rougly equivalent to PrimRep)
|
|
|
|
data ArgRep
|
|
= N -- non-ptr
|
|
| P -- ptr
|
|
| V -- void
|
|
| F -- float
|
|
| D -- double
|
|
| L -- long (64-bit)
|
|
| V16 -- 16-byte (128-bit) vectors
|
|
| V32 -- 32-byte (256-bit) vectors
|
|
| V64 -- 64-byte (512-bit) vectors
|
|
|
|
-- size of a value in *words*
|
|
argSize :: ArgRep -> Int
|
|
argSize N = 1
|
|
argSize P = 1
|
|
argSize V = 0
|
|
argSize F = 1
|
|
argSize D = (SIZEOF_DOUBLE `quot` SIZEOF_VOID_P :: Int)
|
|
argSize L = (8 `quot` SIZEOF_VOID_P :: Int)
|
|
argSize V16 = (16 `quot` SIZEOF_VOID_P :: Int)
|
|
argSize V32 = (32 `quot` SIZEOF_VOID_P :: Int)
|
|
argSize V64 = (64 `quot` SIZEOF_VOID_P :: Int)
|
|
|
|
showArg :: ArgRep -> String
|
|
showArg N = "n"
|
|
showArg P = "p"
|
|
showArg V = "v"
|
|
showArg F = "f"
|
|
showArg D = "d"
|
|
showArg L = "l"
|
|
showArg V16 = "v16"
|
|
showArg V32 = "v32"
|
|
showArg V64 = "v64"
|
|
|
|
-- is a value a pointer?
|
|
isPtr :: ArgRep -> Bool
|
|
isPtr P = True
|
|
isPtr _ = False
|
|
|
|
-- -----------------------------------------------------------------------------
|
|
-- Registers
|
|
|
|
data RegStatus = Registerised | Unregisterised
|
|
|
|
type Reg = String
|
|
|
|
availableRegs :: RegStatus -> ([Reg],[Reg],[Reg],[Reg])
|
|
availableRegs Unregisterised = ([],[],[],[])
|
|
availableRegs Registerised =
|
|
( vanillaRegs MAX_REAL_VANILLA_REG,
|
|
floatRegs MAX_REAL_FLOAT_REG,
|
|
doubleRegs MAX_REAL_DOUBLE_REG,
|
|
longRegs MAX_REAL_LONG_REG
|
|
)
|
|
|
|
vanillaRegs, floatRegs, doubleRegs, longRegs :: Int -> [Reg]
|
|
vanillaRegs n = [ "R" ++ show m | m <- [2..n] ] -- never use R1
|
|
floatRegs n = [ "F" ++ show m | m <- [1..n] ]
|
|
doubleRegs n = [ "D" ++ show m | m <- [1..n] ]
|
|
longRegs n = [ "L" ++ show m | m <- [1..n] ]
|
|
|
|
-- -----------------------------------------------------------------------------
|
|
-- Loading/saving register arguments to the stack
|
|
|
|
loadRegArgs :: RegStatus -> Int -> [ArgRep] -> (Doc,Int)
|
|
loadRegArgs regstatus sp args
|
|
= (loadRegOffs reg_locs, sp')
|
|
where (reg_locs, _, sp') = assignRegs regstatus sp args
|
|
|
|
loadRegOffs :: [(Reg,Int)] -> Doc
|
|
loadRegOffs = vcat . map (uncurry assign_stk_to_reg)
|
|
|
|
saveRegOffs :: [(Reg,Int)] -> Doc
|
|
saveRegOffs = vcat . map (uncurry assign_reg_to_stk)
|
|
|
|
assignRegs
|
|
:: RegStatus -- are we registerised?
|
|
-> Int -- Sp of first arg
|
|
-> [ArgRep] -- args
|
|
-> ([(Reg,Int)], -- regs and offsets to load
|
|
[ArgRep], -- left-over args
|
|
Int) -- Sp of left-over args
|
|
assignRegs regstatus sp args = assign sp args (availableRegs regstatus) []
|
|
|
|
assign sp [] regs doc = (doc, [], sp)
|
|
assign sp (V : args) regs doc = assign sp args regs doc
|
|
assign sp (arg : args) regs doc
|
|
= case findAvailableReg arg regs of
|
|
Just (reg, regs') -> assign (sp + argSize arg) args regs'
|
|
((reg, sp) : doc)
|
|
Nothing -> (doc, (arg:args), sp)
|
|
|
|
findAvailableReg N (vreg:vregs, fregs, dregs, lregs) =
|
|
Just (vreg, (vregs,fregs,dregs,lregs))
|
|
findAvailableReg P (vreg:vregs, fregs, dregs, lregs) =
|
|
Just (vreg, (vregs,fregs,dregs,lregs))
|
|
findAvailableReg F (vregs, freg:fregs, dregs, lregs) =
|
|
Just (freg, (vregs,fregs,dregs,lregs))
|
|
findAvailableReg D (vregs, fregs, dreg:dregs, lregs) =
|
|
Just (dreg, (vregs,fregs,dregs,lregs))
|
|
findAvailableReg L (vregs, fregs, dregs, lreg:lregs) =
|
|
Just (lreg, (vregs,fregs,dregs,lregs))
|
|
findAvailableReg _ _ = Nothing
|
|
|
|
assign_reg_to_stk reg sp
|
|
= loadSpWordOff (regRep reg) sp <> text " = " <> text reg <> semi
|
|
|
|
assign_stk_to_reg reg sp
|
|
= text reg <> text " = " <> loadSpWordOff (regRep reg) sp <> semi
|
|
|
|
regRep ('F':_) = "F_"
|
|
regRep ('D':_) = "D_"
|
|
regRep ('L':_) = "L_"
|
|
regRep _ = "W_"
|
|
|
|
loadSpWordOff :: String -> Int -> Doc
|
|
loadSpWordOff rep off = text rep <> text "[Sp+WDS(" <> int off <> text ")]"
|
|
|
|
-- Make a jump
|
|
mkJump :: RegStatus -- Registerised status
|
|
-> Doc -- Jump target
|
|
-> [Reg] -- Registers that are definitely live
|
|
-> [ArgRep] -- Jump arguments
|
|
-> Doc
|
|
mkJump regstatus jump live args =
|
|
text "jump" <+> jump <+> brackets (hcat (punctuate comma liveRegs))
|
|
where
|
|
liveRegs = mkJumpLiveRegs regstatus live args
|
|
|
|
-- Make a jump, saving CCCS and restoring it on return
|
|
mkJumpSaveCCCS :: RegStatus -- Registerised status
|
|
-> Doc -- Jump target
|
|
-> [Reg] -- Registers that are definitely live
|
|
-> [ArgRep] -- Jump arguments
|
|
-> Doc
|
|
mkJumpSaveCCCS regstatus jump live args =
|
|
text "jump_SAVE_CCCS" <> parens (hcat (punctuate comma (jump : liveRegs)))
|
|
where
|
|
liveRegs = mkJumpLiveRegs regstatus live args
|
|
|
|
-- Calculate live registers for a jump
|
|
mkJumpLiveRegs :: RegStatus -- Registerised status
|
|
-> [Reg] -- Registers that are definitely live
|
|
-> [ArgRep] -- Jump arguments
|
|
-> [Doc]
|
|
mkJumpLiveRegs regstatus live args =
|
|
map text regs
|
|
where
|
|
(reg_locs, _, _) = assignRegs regstatus 0 args
|
|
regs = (nub . sort) (live ++ map fst reg_locs)
|
|
|
|
-- make a ptr/non-ptr bitmap from a list of argument types
|
|
mkBitmap :: [ArgRep] -> Word32
|
|
mkBitmap args = foldr f 0 args
|
|
where f arg bm | isPtr arg = bm `shiftL` 1
|
|
| otherwise = (bm `shiftL` size) .|. ((1 `shiftL` size) - 1)
|
|
where size = argSize arg
|
|
|
|
-- -----------------------------------------------------------------------------
|
|
-- Generating the application functions
|
|
|
|
-- A SUBTLE POINT about stg_ap functions (can't think of a better
|
|
-- place to put this comment --SDM):
|
|
--
|
|
-- The entry convention to an stg_ap_ function is as follows: all the
|
|
-- arguments are on the stack (we might revisit this at some point,
|
|
-- but it doesn't make any difference on x86), and THERE IS AN EXTRA
|
|
-- EMPTY STACK SLOT at the top of the stack.
|
|
--
|
|
-- Why? Because in several cases, stg_ap_* will need an extra stack
|
|
-- slot, eg. to push a return address in the THUNK case, and this is a
|
|
-- way of pushing the stack check up into the caller which is probably
|
|
-- doing one anyway. Allocating the extra stack slot in the caller is
|
|
-- also probably free, because it will be adjusting Sp after pushing
|
|
-- the args anyway (this might not be true of register-rich machines
|
|
-- when we start passing args to stg_ap_* in regs).
|
|
|
|
mkApplyName args
|
|
= text "stg_ap_" <> text (concatMap showArg args)
|
|
|
|
mkApplyRetName args
|
|
= mkApplyName args <> text "_ret"
|
|
|
|
mkApplyFastName args
|
|
= mkApplyName args <> text "_fast"
|
|
|
|
mkApplyInfoName args
|
|
= mkApplyName args <> text "_info"
|
|
|
|
mb_tag_node arity | Just tag <- tagForArity arity = mkTagStmt tag <> semi
|
|
| otherwise = empty
|
|
|
|
mkTagStmt tag = text ("R1 = R1 + "++ show tag)
|
|
|
|
type StackUsage = (Int, Int) -- PROFILING, normal
|
|
|
|
maxStack :: [StackUsage] -> StackUsage
|
|
maxStack = (maximum *** maximum) . unzip
|
|
|
|
stackCheck
|
|
:: RegStatus -- Registerised status
|
|
-> [ArgRep]
|
|
-> Bool -- args in regs?
|
|
-> Doc -- fun_info_label
|
|
-> StackUsage
|
|
-> Doc
|
|
stackCheck regstatus args args_in_regs fun_info_label (prof_sp, norm_sp) =
|
|
let
|
|
(reg_locs, leftovers, sp_offset) = assignRegs regstatus 1 args
|
|
|
|
cmp_sp n
|
|
| n > 0 =
|
|
text "if (Sp - WDS(" <> int n <> text ") < SpLim) {" $$
|
|
nest 4 (vcat [
|
|
if args_in_regs
|
|
then
|
|
text "Sp_adj" <> parens (int (-sp_offset)) <> semi $$
|
|
saveRegOffs reg_locs
|
|
else
|
|
empty,
|
|
text "Sp(0) = " <> fun_info_label <> char ';',
|
|
mkJump regstatus (text "__stg_gc_enter_1") ["R1"] [] <> semi
|
|
]) $$
|
|
char '}'
|
|
| otherwise = empty
|
|
in
|
|
vcat [ text "#if defined(PROFILING)",
|
|
cmp_sp prof_sp,
|
|
text "#else",
|
|
cmp_sp norm_sp,
|
|
text "#endif"
|
|
]
|
|
|
|
genMkPAP :: RegStatus -- Register status
|
|
-> String -- Macro
|
|
-> String -- Jump target
|
|
-> [Reg] -- Registers that are definitely live
|
|
-> String -- Ticker
|
|
-> String -- Disamb
|
|
-> Bool -- Don't load argument registers before jump if True
|
|
-> Bool -- Arguments already in registers if True
|
|
-> Bool -- Is a PAP if True
|
|
-> [ArgRep] -- Arguments
|
|
-> Int -- Size of all arguments
|
|
-> Doc -- info label
|
|
-> Bool -- Is a function
|
|
-> (Doc, StackUsage)
|
|
genMkPAP regstatus macro jump live ticker disamb
|
|
no_load_regs -- don't load argument regs before jumping
|
|
args_in_regs -- arguments are already in regs
|
|
is_pap args all_args_size fun_info_label
|
|
is_fun_case
|
|
= (doc, stack_usage)
|
|
|
|
where
|
|
doc = vcat smaller_arity_doc $$ exact_arity_case $$ larger_arity_doc
|
|
|
|
stack_usage = maxStack (larger_arity_stack : smaller_arity_stack)
|
|
|
|
n_args = length args
|
|
|
|
-- offset of arguments on the stack at slow apply calls.
|
|
stk_args_slow_offset = 1
|
|
|
|
stk_args_offset
|
|
| args_in_regs = 0
|
|
| otherwise = stk_args_slow_offset
|
|
|
|
-- The SMALLER ARITY cases:
|
|
-- if (arity == 1) {
|
|
-- Sp[0] = Sp[1];
|
|
-- Sp[1] = (W_)&stg_ap_1_info;
|
|
-- JMP_(GET_ENTRY(R1.cl));
|
|
(smaller_arity_doc, smaller_arity_stack)
|
|
= unzip [ smaller_arity i | i <- [1..n_args-1] ]
|
|
|
|
smaller_arity arity = (doc, stack_usage)
|
|
where
|
|
(save_regs, stack_usage)
|
|
| overflow_regs = save_extra_regs
|
|
| otherwise = shuffle_extra_args
|
|
|
|
doc =
|
|
text "if (arity == " <> int arity <> text ") {" $$
|
|
nest 4 (vcat [
|
|
-- text "TICK_SLOW_CALL_" <> text ticker <> text "_TOO_MANY();",
|
|
|
|
-- load up regs for the call, if necessary
|
|
load_regs,
|
|
|
|
-- If we have more args in registers than are required
|
|
-- for the call, then we must save some on the stack,
|
|
-- and set up the stack for the follow-up call.
|
|
-- If the extra arguments are on the stack, then we must
|
|
-- instead shuffle them down to make room for the info
|
|
-- table for the follow-on call.
|
|
save_regs,
|
|
|
|
-- for a PAP, we have to arrange that the stack contains a
|
|
-- return address in the event that stg_PAP_entry fails its
|
|
-- heap check. See stg_PAP_entry in Apply.cmm for details.
|
|
if is_pap
|
|
then text "R2 = " <> mkApplyInfoName this_call_args <> semi
|
|
|
|
else empty,
|
|
if is_fun_case then mb_tag_node arity else empty,
|
|
if overflow_regs
|
|
then mkJumpSaveCCCS
|
|
regstatus (text jump) live (take arity args) <> semi
|
|
else mkJump regstatus (text jump) live (if no_load_regs then [] else args) <> semi
|
|
]) $$
|
|
text "}"
|
|
|
|
-- offsets in case we need to save regs:
|
|
(reg_locs, _, _)
|
|
= assignRegs regstatus stk_args_offset args
|
|
|
|
-- register assignment for *this function call*
|
|
(reg_locs', reg_call_leftovers, reg_call_sp_stk_args)
|
|
= assignRegs regstatus stk_args_offset (take arity args)
|
|
|
|
load_regs
|
|
| no_load_regs || args_in_regs = empty
|
|
| otherwise = loadRegOffs reg_locs'
|
|
|
|
(this_call_args, rest_args) = splitAt arity args
|
|
|
|
-- the offset of the stack args from initial Sp
|
|
sp_stk_args
|
|
| args_in_regs = stk_args_offset
|
|
| no_load_regs = stk_args_offset
|
|
| otherwise = reg_call_sp_stk_args
|
|
|
|
-- the stack args themselves
|
|
this_call_stack_args
|
|
| args_in_regs = reg_call_leftovers -- sp offsets are wrong
|
|
| no_load_regs = this_call_args
|
|
| otherwise = reg_call_leftovers
|
|
|
|
stack_args_size = sum (map argSize this_call_stack_args)
|
|
|
|
overflow_regs = args_in_regs && length reg_locs > length reg_locs'
|
|
|
|
save_extra_regs = (doc, (size,size))
|
|
where
|
|
-- we have extra arguments in registers to save
|
|
extra_reg_locs = drop (length reg_locs') (reverse reg_locs)
|
|
adj_reg_locs = [ (reg, off - adj + 1) |
|
|
(reg,off) <- extra_reg_locs ]
|
|
adj = case extra_reg_locs of
|
|
(reg, fst_off):_ -> fst_off
|
|
size = snd (last adj_reg_locs) + 1
|
|
|
|
doc =
|
|
text "Sp_adj(" <> int (-size) <> text ");" $$
|
|
saveRegOffs adj_reg_locs $$
|
|
loadSpWordOff "W_" 0 <> text " = " <>
|
|
mkApplyInfoName rest_args <> semi
|
|
|
|
shuffle_extra_args = (doc, (shuffle_prof_stack, shuffle_norm_stack))
|
|
where
|
|
doc = vcat [ text "#if defined(PROFILING)",
|
|
shuffle_prof_doc,
|
|
text "#else",
|
|
shuffle_norm_doc,
|
|
text "#endif"]
|
|
|
|
(shuffle_prof_doc, shuffle_prof_stack) = shuffle True
|
|
(shuffle_norm_doc, shuffle_norm_stack) = shuffle False
|
|
|
|
-- Sadly here we have to insert an stg_restore_cccs frame
|
|
-- just underneath the stg_ap_*_info frame if we're
|
|
-- profiling; see Note [jump_SAVE_CCCS]
|
|
shuffle prof = (doc, -sp_adj)
|
|
where
|
|
sp_adj = sp_stk_args - 1 - offset
|
|
offset = if prof then 2 else 0
|
|
doc =
|
|
vcat (map (shuffle_down (offset+1))
|
|
[sp_stk_args .. sp_stk_args+stack_args_size-1]) $$
|
|
(if prof
|
|
then
|
|
loadSpWordOff "W_" (sp_stk_args+stack_args_size-3)
|
|
<> text " = stg_restore_cccs_info;" $$
|
|
loadSpWordOff "W_" (sp_stk_args+stack_args_size-2)
|
|
<> text " = CCCS;"
|
|
else empty) $$
|
|
loadSpWordOff "W_" (sp_stk_args+stack_args_size-1)
|
|
<> text " = "
|
|
<> mkApplyInfoName rest_args <> semi $$
|
|
text "Sp_adj(" <> int sp_adj <> text ");"
|
|
|
|
shuffle_down j i =
|
|
loadSpWordOff "W_" (i-j) <> text " = " <>
|
|
loadSpWordOff "W_" i <> semi
|
|
|
|
|
|
-- The EXACT ARITY case
|
|
--
|
|
-- if (arity == 1) {
|
|
-- Sp++;
|
|
-- JMP_(GET_ENTRY(R1.cl));
|
|
|
|
exact_arity_case
|
|
= text "if (arity == " <> int n_args <> text ") {" $$
|
|
let
|
|
(reg_doc, sp')
|
|
| no_load_regs || args_in_regs = (empty, stk_args_offset)
|
|
| otherwise = loadRegArgs regstatus stk_args_offset args
|
|
in
|
|
nest 4 (vcat [
|
|
-- text "TICK_SLOW_CALL_" <> text ticker <> text "_CORRECT();",
|
|
reg_doc,
|
|
text "Sp_adj(" <> int sp' <> text ");",
|
|
if is_pap
|
|
then text "R2 = " <> fun_info_label <> semi
|
|
else empty,
|
|
if is_fun_case then mb_tag_node n_args else empty,
|
|
mkJump regstatus (text jump) live (if no_load_regs then [] else args) <> semi
|
|
])
|
|
|
|
-- The LARGER ARITY cases:
|
|
--
|
|
-- } else /* arity > 1 */ {
|
|
-- BUILD_PAP(1,0,(W_)&stg_ap_v_info);
|
|
-- }
|
|
|
|
(larger_arity_doc, larger_arity_stack) = (doc, stack)
|
|
where
|
|
-- offsets in case we need to save regs:
|
|
(reg_locs, leftovers, sp_offset)
|
|
= assignRegs regstatus stk_args_slow_offset args
|
|
-- BUILD_PAP assumes args start at offset 1
|
|
|
|
stack | args_in_regs = (sp_offset, sp_offset)
|
|
| otherwise = (0,0)
|
|
|
|
doc =
|
|
text "} else {" $$
|
|
let
|
|
save_regs
|
|
| args_in_regs =
|
|
text "Sp_adj(" <> int (-sp_offset) <> text ");" $$
|
|
saveRegOffs reg_locs
|
|
| otherwise =
|
|
empty
|
|
in
|
|
nest 4 (vcat [
|
|
-- text "TICK_SLOW_CALL_" <> text ticker <> text "_TOO_FEW();",
|
|
save_regs,
|
|
-- Before building the PAP, tag the function closure pointer
|
|
if is_fun_case then
|
|
vcat [
|
|
text "if (arity < " <> int tAG_BITS_MAX <> text ") {",
|
|
text " R1 = R1 + arity" <> semi,
|
|
text "}"
|
|
]
|
|
else empty
|
|
,
|
|
text macro <> char '(' <> int n_args <> comma <>
|
|
int all_args_size <>
|
|
text "," <> fun_info_label <>
|
|
text "," <> text disamb <>
|
|
text ");"
|
|
]) $$
|
|
char '}'
|
|
|
|
|
|
-- Note [jump_SAVE_CCCS]
|
|
|
|
-- when profiling, if we have some extra arguments to apply that we
|
|
-- save to the stack, we must also save the current cost centre stack
|
|
-- and restore it when applying the extra arguments. This is all
|
|
-- handled by the macro jump_SAVE_CCCS(target), defined in
|
|
-- rts/AutoApply.h.
|
|
--
|
|
-- At the jump, the stack will look like this:
|
|
--
|
|
-- ... extra args ...
|
|
-- stg_ap_pp_info
|
|
-- CCCS
|
|
-- stg_restore_cccs_info
|
|
|
|
-- --------------------------------------
|
|
-- Examine tag bits of function pointer and enter it
|
|
-- directly if needed.
|
|
-- TODO: remove the redundant case in the original code.
|
|
enterFastPath regstatus no_load_regs args_in_regs args
|
|
| Just tag <- tagForArity (length args)
|
|
= enterFastPathHelper tag regstatus no_load_regs args_in_regs args
|
|
enterFastPath _ _ _ _ = empty
|
|
|
|
-- Copied from Constants.hs & CgUtils.hs, i'd rather have this imported:
|
|
-- (arity,tag)
|
|
tAG_BITS = (TAG_BITS :: Int)
|
|
tAG_BITS_MAX = ((1 `shiftL` tAG_BITS) :: Int)
|
|
|
|
tagForArity :: Int -> Maybe Int
|
|
tagForArity i | i < tAG_BITS_MAX = Just i
|
|
| otherwise = Nothing
|
|
|
|
enterFastPathHelper :: Int
|
|
-> RegStatus
|
|
-> Bool
|
|
-> Bool
|
|
-> [ArgRep]
|
|
-> Doc
|
|
enterFastPathHelper tag regstatus no_load_regs args_in_regs args =
|
|
text "if (GETTAG(R1)==" <> int tag <> text ") {" $$
|
|
nest 4 (vcat [
|
|
reg_doc,
|
|
text "Sp_adj(" <> int sp' <> text ");",
|
|
-- enter, but adjust offset with tag
|
|
mkJump regstatus (text "%GET_ENTRY(R1-" <> int tag <> text ")") ["R1"] args <> semi
|
|
]) $$
|
|
text "}"
|
|
-- I don't totally understand this code, I copied it from
|
|
-- exact_arity_case
|
|
-- TODO: refactor
|
|
where
|
|
-- offset of arguments on the stack at slow apply calls.
|
|
stk_args_slow_offset = 1
|
|
|
|
stk_args_offset
|
|
| args_in_regs = 0
|
|
| otherwise = stk_args_slow_offset
|
|
|
|
(reg_doc, sp')
|
|
| no_load_regs || args_in_regs = (empty, stk_args_offset)
|
|
| otherwise = loadRegArgs regstatus stk_args_offset args
|
|
|
|
tickForArity arity
|
|
| True
|
|
= empty
|
|
| Just tag <- tagForArity arity
|
|
= vcat [
|
|
text "W_[TOTAL_CALLS] = W_[TOTAL_CALLS] + 1;",
|
|
text "W_[SLOW_CALLS_" <> int arity <> text "] = W_[SLOW_CALLS_" <> int arity <> text "] + 1;",
|
|
text "if (TO_W_(StgFunInfoExtra_arity(%FUN_INFO(%INFO_PTR(UNTAG(R1))))) == " <> int arity <> text " ) {",
|
|
text " W_[RIGHT_ARITY_" <> int arity <> text "] = W_[RIGHT_ARITY_" <> int arity <> text "] + 1;",
|
|
text " if (GETTAG(R1)==" <> int tag <> text ") {",
|
|
text " W_[TAGGED_PTR_" <> int arity <> text "] = W_[TAGGED_PTR_" <> int arity <> text "] + 1;",
|
|
text " } else {",
|
|
-- force a halt when not tagged!
|
|
-- text " W_[0]=0;",
|
|
text " }",
|
|
text "}"
|
|
]
|
|
tickForArity _ = text "W_[TOTAL_CALLS] = W_[TOTAL_CALLS] + 1;"
|
|
|
|
-- -----------------------------------------------------------------------------
|
|
-- generate an apply function
|
|
|
|
-- args is a list of 'p', 'n', 'f', 'd' or 'l'
|
|
formalParam :: ArgRep -> Int -> Doc
|
|
formalParam V _ = empty
|
|
formalParam arg n =
|
|
formalParamType arg <> space <>
|
|
text "arg" <> int n <> text ", "
|
|
formalParamType arg = argRep arg
|
|
|
|
argRep F = text "F_"
|
|
argRep D = text "D_"
|
|
argRep L = text "L_"
|
|
argRep P = text "gcptr"
|
|
argRep V16 = text "V16_"
|
|
argRep V32 = text "V32_"
|
|
argRep V64 = text "V64_"
|
|
argRep _ = text "W_"
|
|
|
|
genApply :: RegStatus -> [ArgRep] -> Doc
|
|
genApply regstatus args =
|
|
let
|
|
fun_ret_label = mkApplyRetName args
|
|
fun_info_label = mkApplyInfoName args
|
|
all_args_size = sum (map argSize args)
|
|
|
|
(bco_doc, bco_stack) =
|
|
genMkPAP regstatus "BUILD_PAP" "ENTRY_LBL(stg_BCO)" ["R1"] "FUN" "BCO"
|
|
True{-stack apply-} False{-args on stack-} False{-not a PAP-}
|
|
args all_args_size fun_info_label {- tag stmt -}False
|
|
|
|
(fun_doc, fun_stack) =
|
|
genMkPAP regstatus "BUILD_PAP" "%GET_ENTRY(UNTAG(R1))" ["R1"] "FUN" "FUN"
|
|
False{-reg apply-} False{-args on stack-} False{-not a PAP-}
|
|
args all_args_size fun_info_label {- tag stmt -}True
|
|
|
|
(pap_doc, pap_stack) =
|
|
genMkPAP regstatus "NEW_PAP" "stg_PAP_apply" ["R1", "R2"] "PAP" "PAP"
|
|
True{-stack apply-} False{-args on stack-} True{-is a PAP-}
|
|
args all_args_size fun_info_label {- tag stmt -}False
|
|
|
|
stack_usage = maxStack [bco_stack, fun_stack, pap_stack]
|
|
in
|
|
vcat [
|
|
text "INFO_TABLE_RET(" <> mkApplyName args <> text ", " <>
|
|
text "RET_SMALL, W_ info_ptr, " <> (cat $ zipWith formalParam args [1..]) <>
|
|
text ")\n{",
|
|
nest 4 (vcat [
|
|
text "W_ info;",
|
|
text "W_ arity;",
|
|
text "unwind Sp = Sp + WDS(" <> int (1+all_args_size) <> text ");",
|
|
|
|
-- if fast == 1:
|
|
-- print "static void *lbls[] ="
|
|
-- print " { [FUN] &&fun_lbl,"
|
|
-- print " [FUN_1_0] &&fun_lbl,"
|
|
-- print " [FUN_0_1] &&fun_lbl,"
|
|
-- print " [FUN_2_0] &&fun_lbl,"
|
|
-- print " [FUN_1_1] &&fun_lbl,"
|
|
-- print " [FUN_0_2] &&fun_lbl,"
|
|
-- print " [FUN_STATIC] &&fun_lbl,"
|
|
-- print " [PAP] &&pap_lbl,"
|
|
-- print " [THUNK] &&thunk_lbl,"
|
|
-- print " [THUNK_1_0] &&thunk_lbl,"
|
|
-- print " [THUNK_0_1] &&thunk_lbl,"
|
|
-- print " [THUNK_2_0] &&thunk_lbl,"
|
|
-- print " [THUNK_1_1] &&thunk_lbl,"
|
|
-- print " [THUNK_0_2] &&thunk_lbl,"
|
|
-- print " [THUNK_STATIC] &&thunk_lbl,"
|
|
-- print " [THUNK_SELECTOR] &&thunk_lbl,"
|
|
-- print " [IND] &&ind_lbl,"
|
|
-- print " [IND_STATIC] &&ind_lbl,"
|
|
-- print " };"
|
|
|
|
tickForArity (length args),
|
|
text "",
|
|
text "IF_DEBUG(apply,foreign \"C\" debugBelch(\"" <> fun_ret_label <>
|
|
text "... \"); foreign \"C\" printClosure(R1 \"ptr\"));",
|
|
|
|
text "IF_DEBUG(sanity,foreign \"C\" checkStackFrame(Sp+WDS(" <> int (1 + all_args_size)
|
|
<> text ")\"ptr\"));",
|
|
|
|
-- text "IF_DEBUG(sanity,checkStackChunk(Sp+" <> int (1 + all_args_size) <>
|
|
-- text ", CurrentTSO->stack + CurrentTSO->stack_size));",
|
|
|
|
-- text "TICK_SLOW_CALL(" <> int (length args) <> text ");",
|
|
|
|
let do_assert [] _ = []
|
|
do_assert (arg:args) offset
|
|
| isPtr arg = this : rest
|
|
| otherwise = rest
|
|
where this = text "ASSERT(LOOKS_LIKE_CLOSURE_PTR(Sp("
|
|
<> int offset <> text ")));"
|
|
rest = do_assert args (offset + argSize arg)
|
|
in
|
|
vcat (do_assert args 1),
|
|
|
|
text "again:",
|
|
|
|
-- if pointer is tagged enter it fast!
|
|
enterFastPath regstatus False False args,
|
|
|
|
stackCheck regstatus args False{-args on stack-}
|
|
fun_info_label stack_usage,
|
|
|
|
-- Functions can be tagged, so we untag them!
|
|
text "R1 = UNTAG(R1);",
|
|
text "info = %INFO_PTR(R1);",
|
|
|
|
-- if fast == 1:
|
|
-- print " goto *lbls[info->type];";
|
|
-- else:
|
|
text "switch [INVALID_OBJECT .. N_CLOSURE_TYPES] (TO_W_(%INFO_TYPE(%STD_INFO(info)))) {",
|
|
nest 4 (vcat [
|
|
|
|
-- if fast == 1:
|
|
-- print " bco_lbl:"
|
|
-- else:
|
|
text "case BCO: {",
|
|
nest 4 (vcat [
|
|
text "arity = TO_W_(StgBCO_arity(R1));",
|
|
text "ASSERT(arity > 0);",
|
|
bco_doc
|
|
]),
|
|
text "}",
|
|
|
|
-- if fast == 1:
|
|
-- print " fun_lbl:"
|
|
-- else:
|
|
text "case FUN,",
|
|
text " FUN_1_0,",
|
|
text " FUN_0_1,",
|
|
text " FUN_2_0,",
|
|
text " FUN_1_1,",
|
|
text " FUN_0_2,",
|
|
text " FUN_STATIC: {",
|
|
nest 4 (vcat [
|
|
text "arity = TO_W_(StgFunInfoExtra_arity(%FUN_INFO(info)));",
|
|
text "ASSERT(arity > 0);",
|
|
fun_doc
|
|
]),
|
|
text "}",
|
|
|
|
-- if fast == 1:
|
|
-- print " pap_lbl:"
|
|
-- else:
|
|
|
|
text "case PAP: {",
|
|
nest 4 (vcat [
|
|
text "arity = TO_W_(StgPAP_arity(R1));",
|
|
text "ASSERT(arity > 0);",
|
|
pap_doc
|
|
]),
|
|
text "}",
|
|
|
|
text "",
|
|
|
|
-- if fast == 1:
|
|
-- print " thunk_lbl:"
|
|
-- else:
|
|
text "case AP,",
|
|
text " AP_STACK,",
|
|
text " BLACKHOLE,",
|
|
text " WHITEHOLE,",
|
|
text " THUNK,",
|
|
text " THUNK_1_0,",
|
|
text " THUNK_0_1,",
|
|
text " THUNK_2_0,",
|
|
text " THUNK_1_1,",
|
|
text " THUNK_0_2,",
|
|
text " THUNK_STATIC,",
|
|
text " THUNK_SELECTOR: {",
|
|
nest 4 (vcat [
|
|
-- text "TICK_SLOW_CALL_UNEVALD(" <> int (length args) <> text ");",
|
|
text "Sp(0) = " <> fun_info_label <> text ";",
|
|
-- CAREFUL! in SMP mode, the info table may already have been
|
|
-- overwritten by an indirection, so we must enter the original
|
|
-- info pointer we read, don't read it again, because it might
|
|
-- not be enterable any more.
|
|
mkJumpSaveCCCS
|
|
regstatus (text "%ENTRY_CODE(info)") ["R1"] args <> semi,
|
|
-- see Note [jump_SAVE_CCCS]
|
|
text ""
|
|
]),
|
|
text "}",
|
|
|
|
-- if fast == 1:
|
|
-- print " ind_lbl:"
|
|
-- else:
|
|
text "case IND,",
|
|
text " IND_STATIC: {",
|
|
nest 4 (vcat [
|
|
text "R1 = StgInd_indirectee(R1);",
|
|
-- An indirection node might contain a tagged pointer
|
|
text "goto again;"
|
|
]),
|
|
text "}",
|
|
text "",
|
|
|
|
-- if fast == 0:
|
|
|
|
text "default: {",
|
|
nest 4 (
|
|
text "foreign \"C\" barf(\"" <> fun_ret_label <> text "\") never returns;"
|
|
),
|
|
text "}"
|
|
|
|
]),
|
|
text "}"
|
|
]),
|
|
|
|
text "}"
|
|
]
|
|
|
|
-- -----------------------------------------------------------------------------
|
|
-- Making a fast unknown application, args are in regs
|
|
|
|
genApplyFast :: RegStatus -> [ArgRep] -> Doc
|
|
genApplyFast regstatus args =
|
|
let
|
|
fun_fast_label = mkApplyFastName args
|
|
fun_ret_label = text "RET_LBL" <> parens (mkApplyName args)
|
|
fun_info_label = mkApplyInfoName args
|
|
all_args_size = sum (map argSize args)
|
|
|
|
(fun_doc, fun_stack) =
|
|
genMkPAP regstatus "BUILD_PAP" "%GET_ENTRY(UNTAG(R1))" ["R1"] "FUN" "FUN"
|
|
False{-reg apply-} True{-args in regs-} False{-not a PAP-}
|
|
args all_args_size fun_info_label {- tag stmt -}True
|
|
|
|
(reg_locs, leftovers, sp_offset) = assignRegs regstatus 1 args
|
|
|
|
stack_usage = maxStack [fun_stack, (sp_offset,sp_offset)]
|
|
in
|
|
vcat [
|
|
fun_fast_label,
|
|
char '{',
|
|
nest 4 (vcat [
|
|
text "W_ info;",
|
|
text "W_ arity;",
|
|
|
|
tickForArity (length args),
|
|
|
|
-- if pointer is tagged enter it fast!
|
|
enterFastPath regstatus False True args,
|
|
|
|
stackCheck regstatus args True{-args in regs-}
|
|
fun_info_label stack_usage,
|
|
|
|
-- Functions can be tagged, so we untag them!
|
|
text "R1 = UNTAG(R1);",
|
|
text "info = %GET_STD_INFO(R1);",
|
|
text "switch [INVALID_OBJECT .. N_CLOSURE_TYPES] (TO_W_(%INFO_TYPE(info))) {",
|
|
nest 4 (vcat [
|
|
text "case FUN,",
|
|
text " FUN_1_0,",
|
|
text " FUN_0_1,",
|
|
text " FUN_2_0,",
|
|
text " FUN_1_1,",
|
|
text " FUN_0_2,",
|
|
text " FUN_STATIC: {",
|
|
nest 4 (vcat [
|
|
text "arity = TO_W_(StgFunInfoExtra_arity(%GET_FUN_INFO(R1)));",
|
|
text "ASSERT(arity > 0);",
|
|
fun_doc
|
|
]),
|
|
char '}',
|
|
|
|
text "default: {",
|
|
nest 4 (vcat [
|
|
text "Sp_adj" <> parens (int (-sp_offset)) <> semi,
|
|
saveRegOffs reg_locs,
|
|
mkJump regstatus fun_ret_label [] args <> semi
|
|
]),
|
|
char '}'
|
|
]),
|
|
|
|
char '}'
|
|
]),
|
|
char '}'
|
|
]
|
|
|
|
-- -----------------------------------------------------------------------------
|
|
-- Making a stack apply
|
|
|
|
-- These little functions are like slow entry points. They provide
|
|
-- the layer between the PAP entry code and the function's fast entry
|
|
-- point: namely they load arguments off the stack into registers (if
|
|
-- available) and jump to the function's entry code.
|
|
--
|
|
-- On entry: R1 points to the function closure
|
|
-- arguments are on the stack starting at Sp
|
|
--
|
|
-- Invariant: the list of arguments never contains void. Since we're only
|
|
-- interested in loading arguments off the stack here, we can ignore
|
|
-- void arguments.
|
|
|
|
mkStackApplyEntryLabel:: [ArgRep] -> Doc
|
|
mkStackApplyEntryLabel args = text "stg_ap_stk_" <> text (concatMap showArg args)
|
|
|
|
genStackApply :: RegStatus -> [ArgRep] -> Doc
|
|
genStackApply regstatus args =
|
|
let fn_entry_label = mkStackApplyEntryLabel args in
|
|
vcat [
|
|
fn_entry_label,
|
|
text "{", nest 4 body, text "}"
|
|
]
|
|
where
|
|
(assign_regs, sp') = loadRegArgs regstatus 0 args
|
|
body = vcat [assign_regs,
|
|
text "Sp_adj" <> parens (int sp') <> semi,
|
|
mkJump regstatus (text "%GET_ENTRY(UNTAG(R1))") ["R1"] args <> semi
|
|
]
|
|
|
|
-- -----------------------------------------------------------------------------
|
|
-- Stack save entry points.
|
|
--
|
|
-- These code fragments are used to save registers on the stack at a heap
|
|
-- check failure in the entry code for a function. We also have to save R1
|
|
-- and the return address (stg_gc_fun_info) on the stack. See stg_gc_fun_gen
|
|
-- in HeapStackCheck.cmm for more details.
|
|
|
|
mkStackSaveEntryLabel :: [ArgRep] -> Doc
|
|
mkStackSaveEntryLabel args = text "stg_stk_save_" <> text (concatMap showArg args)
|
|
|
|
genStackSave :: RegStatus -> [ArgRep] -> Doc
|
|
genStackSave regstatus args =
|
|
let fn_entry_label= mkStackSaveEntryLabel args in
|
|
vcat [
|
|
fn_entry_label,
|
|
text "{", nest 4 body, text "}"
|
|
]
|
|
where
|
|
body = vcat [text "Sp_adj" <> parens (int (-sp_offset)) <> semi,
|
|
saveRegOffs reg_locs,
|
|
text "Sp(2) = R1;",
|
|
text "Sp(1) =" <+> int stk_args <> semi,
|
|
text "Sp(0) = stg_gc_fun_info;",
|
|
text "jump stg_gc_noregs [];"
|
|
]
|
|
|
|
std_frame_size = 3 -- the std bits of the frame. See StgRetFun in Closures.h,
|
|
-- and the comment on stg_fun_gc_gen
|
|
-- in HeapStackCheck.cmm.
|
|
(reg_locs, leftovers, sp_offset) = assignRegs regstatus std_frame_size args
|
|
|
|
-- number of words of arguments on the stack.
|
|
stk_args = sum (map argSize leftovers) + sp_offset - std_frame_size
|
|
|
|
-- -----------------------------------------------------------------------------
|
|
-- The prologue...
|
|
|
|
main = do
|
|
args <- getArgs
|
|
regstatus <- case args of
|
|
[] -> return Registerised
|
|
["-u"] -> return Unregisterised
|
|
_other -> do hPutStrLn stderr "syntax: genapply [-u]"
|
|
exitWith (ExitFailure 1)
|
|
let the_code = vcat [
|
|
text "// DO NOT EDIT!",
|
|
text "// Automatically generated by utils/genapply/Main.hs",
|
|
text "",
|
|
text "#include \"Cmm.h\"",
|
|
text "#include \"AutoApply.h\"",
|
|
text "",
|
|
|
|
vcat (intersperse (text "") $
|
|
map (genApply regstatus) applyTypes),
|
|
vcat (intersperse (text "") $
|
|
map (genStackFns regstatus) stackApplyTypes),
|
|
|
|
vcat (intersperse (text "") $
|
|
map (genApplyFast regstatus) applyTypes),
|
|
|
|
genStackApplyArray stackApplyTypes,
|
|
genStackSaveArray stackApplyTypes,
|
|
genBitmapArray stackApplyTypes,
|
|
|
|
text "" -- add a newline at the end of the file
|
|
]
|
|
-- in
|
|
putStr (render the_code)
|
|
|
|
-- These have been shown to cover about 99% of cases in practice...
|
|
applyTypes = [
|
|
[V],
|
|
[F],
|
|
[D],
|
|
[L],
|
|
[V16],
|
|
[V32],
|
|
[V64],
|
|
[N],
|
|
[P],
|
|
[P,V],
|
|
[P,P],
|
|
[P,P,V],
|
|
[P,P,P],
|
|
[P,P,P,V],
|
|
[P,P,P,P],
|
|
[P,P,P,P,P],
|
|
[P,P,P,P,P,P]
|
|
]
|
|
|
|
-- No need for V args in the stack apply cases.
|
|
-- ToDo: the stack apply and stack save code doesn't make a distinction
|
|
-- between N and P (they both live in the same register), only the bitmap
|
|
-- changes, so we could share the apply/save code between lots of cases.
|
|
--
|
|
-- NOTE: other places to change if you change stackApplyTypes:
|
|
-- - includes/rts/storage/FunTypes.h
|
|
-- - compiler/codeGen/StgCmmLayout.hs: stdPattern
|
|
stackApplyTypes = [
|
|
[],
|
|
[N],
|
|
[P],
|
|
[F],
|
|
[D],
|
|
[L],
|
|
[V16],
|
|
[V32],
|
|
[V64],
|
|
[N,N],
|
|
[N,P],
|
|
[P,N],
|
|
[P,P],
|
|
[N,N,N],
|
|
[N,N,P],
|
|
[N,P,N],
|
|
[N,P,P],
|
|
[P,N,N],
|
|
[P,N,P],
|
|
[P,P,N],
|
|
[P,P,P],
|
|
[P,P,P,P],
|
|
[P,P,P,P,P],
|
|
[P,P,P,P,P,P],
|
|
[P,P,P,P,P,P,P],
|
|
[P,P,P,P,P,P,P,P]
|
|
]
|
|
|
|
genStackFns regstatus args
|
|
= genStackApply regstatus args
|
|
$$ genStackSave regstatus args
|
|
|
|
|
|
genStackApplyArray types =
|
|
vcat [
|
|
text "section \"relrodata\" {",
|
|
text "stg_ap_stack_entries:",
|
|
text "W_ 0; W_ 0; W_ 0;", -- ARG_GEN, ARG_GEN_BIG, ARG_BCO
|
|
vcat (map arr_ent types),
|
|
text "}"
|
|
]
|
|
where
|
|
arr_ent ty = text "W_" <+> mkStackApplyEntryLabel ty <> semi
|
|
|
|
genStackSaveArray types =
|
|
vcat [
|
|
text "section \"relrodata\" {",
|
|
text "stg_stack_save_entries:",
|
|
text "W_ 0; W_ 0; W_ 0;", -- ARG_GEN, ARG_GEN_BIG, ARG_BCO
|
|
vcat (map arr_ent types),
|
|
text "}"
|
|
]
|
|
where
|
|
arr_ent ty = text "W_" <+> mkStackSaveEntryLabel ty <> semi
|
|
|
|
genBitmapArray :: [[ArgRep]] -> Doc
|
|
genBitmapArray types =
|
|
vcat [
|
|
text "section \"rodata\" {",
|
|
text "stg_arg_bitmaps:",
|
|
text "W_ 0; W_ 0; W_ 0;", -- ARG_GEN, ARG_GEN_BIG, ARG_BCO
|
|
vcat (map gen_bitmap types),
|
|
text "}"
|
|
]
|
|
where
|
|
gen_bitmap ty = text "W_" <+> int bitmap_val <> semi
|
|
where bitmap_val =
|
|
(fromIntegral (mkBitmap ty) `shiftL` BITMAP_BITS_SHIFT)
|
|
.|. sum (map argSize ty)
|