From: dias@cs.tufts.edu Date: Fri, 18 Sep 2009 18:34:15 +0000 (+0000) Subject: Fixed calling convention for unboxed tuples X-Git-Tag: 2009-11-15~18 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=e4caa74b6c809cd17c5d1f7d472b9a47b2ea6f1c 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. --- diff --git a/compiler/cmm/CmmCallConv.hs b/compiler/cmm/CmmCallConv.hs index a49fa65..210bcb2 100644 --- a/compiler/cmm/CmmCallConv.hs +++ b/compiler/cmm/CmmCallConv.hs @@ -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 diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs index 84edcce..52809da 100644 --- a/compiler/codeGen/StgCmm.hs +++ b/compiler/codeGen/StgCmm.hs @@ -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) diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs index 0e98e14..3b69061 100644 --- a/compiler/codeGen/StgCmmLayout.hs +++ b/compiler/codeGen/StgCmmLayout.hs @@ -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 diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs index a9532e5..73b3052 100644 --- a/compiler/codeGen/StgCmmUtils.hs +++ b/compiler/codeGen/StgCmmUtils.hs @@ -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 )