Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : master
http://hackage.haskell.org/trac/ghc/changeset/3bdc739ebfb6a081b1ae9e537b9fe25bdd4bd91c >--------------------------------------------------------------- commit 3bdc739ebfb6a081b1ae9e537b9fe25bdd4bd91c Author: Ian Lynagh <[email protected]> Date: Wed Mar 21 14:38:53 2012 +0000 Fixes for the calling convention on Win64 In particular, fixes for FP arguments >--------------------------------------------------------------- compiler/nativeGen/X86/CodeGen.hs | 49 +++++++++++++++++++++++++++++++----- compiler/nativeGen/X86/Regs.hs | 32 +++++++++++++++--------- 2 files changed, 62 insertions(+), 19 deletions(-) diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index 1478bff..8e66bff 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -1962,16 +1962,25 @@ genCCall64' :: Platform -> NatM InstrBlock genCCall64' platform target dest_regs args = do -- load up the register arguments - (stack_args, aregs, fregs, load_args_code) - <- load_args args allIntArgRegs allFPArgRegs nilOL + (stack_args, int_regs_used, fp_regs_used, load_args_code) + <- + if platformOS platform == OSMinGW32 + then load_args_win args [] [] allArgRegs nilOL + else do (stack_args, aregs, fregs, load_args_code) + <- load_args args allIntArgRegs allFPArgRegs nilOL + let fp_regs_used = reverse (drop (length fregs) (reverse allFPArgRegs)) + int_regs_used = reverse (drop (length aregs) (reverse allIntArgRegs)) + return (stack_args, int_regs_used, fp_regs_used, load_args_code) let - fp_regs_used = reverse (drop (length fregs) (reverse allFPArgRegs)) - int_regs_used = reverse (drop (length aregs) (reverse allIntArgRegs)) - arg_regs = [eax] ++ int_regs_used ++ fp_regs_used + arg_regs_used = int_regs_used ++ fp_regs_used + arg_regs = [eax] ++ arg_regs_used -- for annotating the call instruction with sse_regs = length fp_regs_used - tot_arg_size = arg_size * (length stack_args + length int_regs_used) + arg_stack_slots = if platformOS platform == OSMinGW32 + then length stack_args + length allArgRegs + else length stack_args + tot_arg_size = arg_size * arg_stack_slots -- Align stack to 16n for calls, assuming a starting stack @@ -1992,7 +2001,7 @@ genCCall64' platform target dest_regs args = do -- On Win64, we also have to leave stack space for the arguments -- that we are passing in registers lss_code <- if platformOS platform == OSMinGW32 - then leaveStackSpace (length int_regs_used) + then leaveStackSpace (length allArgRegs) else return nilOL delta <- getDeltaNat @@ -2086,6 +2095,32 @@ genCCall64' platform target dest_regs args = do (args',ars,frs,code') <- load_args rest aregs fregs code return ((CmmHinted arg hint):args', ars, frs, code') + load_args_win :: [CmmHinted CmmExpr] + -> [Reg] -- used int regs + -> [Reg] -- used FP regs + -> [(Reg, Reg)] -- (int, FP) regs avail for args + -> InstrBlock + -> NatM ([CmmHinted CmmExpr],[Reg],[Reg],InstrBlock) + load_args_win args usedInt usedFP [] code + = return (args, usedInt, usedFP, code) + -- no more regs to use + load_args_win [] usedInt usedFP _ code + = return ([], usedInt, usedFP, code) + -- no more args to push + load_args_win ((CmmHinted arg _) : rest) usedInt usedFP + ((ireg, freg) : regs) code + | isFloatType arg_rep = do + -- XXX Should also set ireg? + arg_code <- getAnyReg arg + load_args_win rest (ireg : usedInt) (freg : usedFP) regs + (code `appOL` arg_code freg) + | otherwise = do + arg_code <- getAnyReg arg + load_args_win rest (ireg : usedInt) usedFP regs + (code `appOL` arg_code ireg) + where + arg_rep = cmmExprType arg + push_args [] code = return code push_args ((CmmHinted arg _):rest) code | isFloatType arg_rep = do diff --git a/compiler/nativeGen/X86/Regs.hs b/compiler/nativeGen/X86/Regs.hs index e0ddfc4..6abf1e2 100644 --- a/compiler/nativeGen/X86/Regs.hs +++ b/compiler/nativeGen/X86/Regs.hs @@ -15,6 +15,7 @@ module X86.Regs ( -- registers spRel, argRegs, + allArgRegs, allIntArgRegs, callClobberedRegs, allMachRegNos, @@ -378,9 +379,6 @@ xmm13 = regSingle 37 xmm14 = regSingle 38 xmm15 = regSingle 39 -allFPArgRegs :: [Reg] -allFPArgRegs = map regSingle [firstxmm .. firstxmm+7] - ripRel :: Displacement -> AddrMode ripRel imm = AddrBaseIndex EABaseRip EAIndexNone imm @@ -406,7 +404,9 @@ xmm n = regSingle (firstxmm+n) -- horror show ----------------------------------------------------------------- freeReg :: RegNo -> FastBool globalRegMaybe :: GlobalReg -> Maybe RealReg +allArgRegs :: [(Reg, Reg)] allIntArgRegs :: [Reg] +allFPArgRegs :: [Reg] callClobberedRegs :: [Reg] #if defined(i386_TARGET_ARCH) || defined(x86_64_TARGET_ARCH) @@ -625,20 +625,28 @@ globalRegMaybe _ = Nothing -- -#if i386_TARGET_ARCH -allIntArgRegs = panic "X86.Regs.allIntArgRegs: should not be used!" +#if defined(mingw32_HOST_OS) && x86_64_TARGET_ARCH + +allArgRegs = zip (map regSingle [rcx,rdx,r8,r9]) + (map regSingle [firstxmm ..]) +allIntArgRegs = panic "X86.Regs.allIntArgRegs: not defined for this platform" +allFPArgRegs = panic "X86.Regs.allFPArgRegs: not defined for this platform" -#elif x86_64_TARGET_ARCH -#if defined(mingw32_HOST_OS) -allIntArgRegs = map regSingle [rcx,rdx,r8,r9] #else + +allArgRegs = panic "X86.Regs.allArgRegs: not defined for this arch" + +# if i386_TARGET_ARCH +allIntArgRegs = panic "X86.Regs.allIntArgRegs: should not be used!" +# elif x86_64_TARGET_ARCH allIntArgRegs = map regSingle [rdi,rsi,rdx,rcx,r8,r9] -#endif +# else +allIntArgRegs = panic "X86.Regs.allIntArgRegs: not defined for this arch" +# endif -#else -allIntArgRegs = panic "X86.Regs.allIntArgRegs: not defined for this architecture" -#endif +allFPArgRegs = map regSingle [firstxmm .. firstxmm+7] +#endif -- | these are the regs which we cannot assume stay alive over a C call. _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
