Commit e4caa74b authored by dias@cs.tufts.edu's avatar dias@cs.tufts.edu

Fixed calling convention for unboxed tuples

Apparently, the arguments should be sorted by pointerhood.
While we're at it, I rewrote the code that assigns registers
and stack space to function call and return parameters.
parent e4622dac
......@@ -13,6 +13,7 @@ import SMRep
import ZipCfgCmmRep (Convention(..))
import Constants
import qualified Data.List as L
import StaticFlags (opt_Unregisterised)
import Outputable
......@@ -31,7 +32,7 @@ type ArgumentFormat a b = [(a, ParamLocation b)]
-- Stack parameters are returned as word offsets.
assignArguments :: (a -> CmmType) -> [a] -> ArgumentFormat a WordOff
assignArguments f reps = assignments
assignArguments f reps = panic "assignArguments only used in dead codegen" -- assignments
where
availRegs = getRegsWithNode
(sizes, assignments) = unzip $ assignArguments' reps (negate (sum sizes)) availRegs
......@@ -47,7 +48,7 @@ assignArguments f reps = assignments
-- Also, I want byte offsets, not word offsets.
assignArgumentsPos :: (Outputable a) => Convention -> (a -> CmmType) -> [a] ->
ArgumentFormat a ByteOff
assignArgumentsPos conv arg_ty reps = map cvt assignments
assignArgumentsPos conv arg_ty reps = assignments -- old_assts'
where -- The calling conventions (CgCallConv.hs) are complicated, to say the least
regs = case (reps, conv) of
(_, NativeNodeCall) -> getRegsWithNode
......@@ -60,7 +61,52 @@ assignArgumentsPos conv arg_ty reps = map cvt assignments
(_, PrimOpReturn) -> getRegsWithNode
(_, Slow) -> noRegs
_ -> pprPanic "Unknown calling convention" (ppr conv)
(sizes, assignments) = unzip $ assignArguments' reps (sum sizes) regs
-- The calling conventions first assign arguments to registers,
-- then switch to the stack when we first run out of registers
-- (even if there are still available registers for args of a
-- different type).
-- When returning an unboxed tuple, we also separate the stack
-- arguments by pointerhood.
(reg_assts, stk_args) = assign_regs [] reps regs
stk_args' = case conv of NativeReturn -> part
PrimOpReturn -> part
_ -> stk_args
where part = uncurry (++)
(L.partition (not . isGcPtrType . arg_ty) stk_args)
stk_assts = assign_stk 0 [] (reverse stk_args')
assignments = reg_assts ++ stk_assts
assign_regs assts [] _ = (assts, [])
assign_regs assts (r:rs) regs = if isFloatType ty then float else int
where float = case (w, regs) of
(W32, (vs, f:fs, ds, ls)) -> k (RegisterParam f, (vs, fs, ds, ls))
(W64, (vs, fs, d:ds, ls)) -> k (RegisterParam d, (vs, fs, ds, ls))
(W80, _) -> panic "F80 unsupported register type"
_ -> (assts, (r:rs))
int = case (w, regs) of
(W128, _) -> panic "W128 unsupported register type"
(_, (v:vs, fs, ds, ls)) | widthInBits w <= widthInBits wordWidth
-> k (RegisterParam (v gcp), (vs, fs, ds, ls))
(_, (vs, fs, ds, l:ls)) | widthInBits w > widthInBits wordWidth
-> k (RegisterParam l, (vs, fs, ds, ls))
_ -> (assts, (r:rs))
k (asst, regs') = assign_regs ((r, asst) : assts) rs regs'
ty = arg_ty r
w = typeWidth ty
gcp | isGcPtrType ty = VGcPtr
| otherwise = VNonGcPtr
assign_stk offset assts [] = assts
assign_stk offset assts (r:rs) = assign_stk off' ((r, StackParam off') : assts) rs
where w = typeWidth (arg_ty r)
size = (((widthInBytes w - 1) `div` wORD_SIZE) + 1) * wORD_SIZE
off' = offset + size
-- DEAD CODE:
(old_sizes, old_assignments) = unzip $ assignArguments' reps (sum old_sizes) regs
old_assts' = map cvt old_assignments
assignArguments' [] _ _ = []
assignArguments' (r:rs) offset avails =
(size, (r,assignment)):assignArguments' rs new_offset remaining
......@@ -153,7 +199,7 @@ assign_reg slot ty off avails
-- Assigning a slot using negative offsets from the stack pointer.
-- JD: I don't know why this convention stops using all the registers
-- after running out of one class of registers.
-- after running out of one class of registers, but that's how it is.
assign_slot_neg :: SlotAssigner
assign_slot_neg width off _regs =
(StackParam $ off, off + size, size, ([], [], [], [])) where size = slot_size' width
......
......@@ -329,7 +329,8 @@ cgDataCon data_con
(dyn_cl_info, arg_things) = layOutDynConstr data_con arg_reps
emit_info cl_info ticky_code
= emitClosureAndInfoTable cl_info [] $ mk_code ticky_code
= emitClosureAndInfoTable cl_info NativeDirectCall []
$ mk_code ticky_code
mk_code ticky_code
= -- NB: We don't set CC when entering data (WDP 94/06)
......
......@@ -474,17 +474,18 @@ emitClosureProcAndInfoTable top_lvl bndr cl_info args body
; let node_points = nodeMustPointToIt lf_info
; arg_regs <- bindArgsToRegs args
; let args' = if node_points then (node : arg_regs) else arg_regs
; emitClosureAndInfoTable cl_info args' $ body (node, arg_regs)
conv = if nodeMustPointToIt lf_info
then NativeNodeCall else NativeDirectCall
; emitClosureAndInfoTable cl_info conv args' $ body (node, arg_regs)
}
-- Data constructors need closures, but not with all the argument handling
-- needed for functions. The shared part goes here.
emitClosureAndInfoTable :: ClosureInfo -> [LocalReg] -> FCode () -> FCode ()
emitClosureAndInfoTable cl_info args body
emitClosureAndInfoTable ::
ClosureInfo -> Convention -> [LocalReg] -> FCode () -> FCode ()
emitClosureAndInfoTable cl_info conv args body
= do { info <- mkCmmInfo cl_info
; blks <- getCode body
; let conv = if nodeMustPointToIt (closureLFInfo cl_info) then NativeNodeCall
else NativeDirectCall
; emitProcWithConvention conv info (infoLblToEntryLbl info_lbl) args blks
}
where
......
......@@ -500,7 +500,7 @@ newTemp rep = do { uniq <- newUnique
newUnboxedTupleRegs :: Type -> FCode ([LocalReg], [ForeignHint])
-- Choose suitable local regs to use for the components
-- of an unboxed tuple that we are about to return to
-- the Sequel. If the Sequel is a joint point, using the
-- the Sequel. If the Sequel is a join point, using the
-- regs it wants will save later assignments.
newUnboxedTupleRegs res_ty
= ASSERT( isUnboxedTupleType res_ty )
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment