From 0cc54eac4ab05b44ddab78d1531ccb9edc5d7e6c Mon Sep 17 00:00:00 2001 From: sewardj Date: Thu, 20 Dec 2001 15:20:38 +0000 Subject: [PATCH] [project @ 2001-12-20 15:20:37 by sewardj] Generate floating-point comparisons on x86 which deal with NaNs in what I assume is an IEEE854 compliant fashion. For == >= > <= < if either arg is a NaN, produce False, and for /= if either arg is a NaN, produce True. This is the behaviour that gcc has, by default. Requires some ultramagical x86 code frags to be emitted. A big comment in PprMach explains how it works. --- ghc/compiler/nativeGen/MachCode.lhs | 27 ++++------- ghc/compiler/nativeGen/MachMisc.lhs | 6 ++- ghc/compiler/nativeGen/PprMach.lhs | 87 ++++++++++++++++++++++++++++++++--- 3 files changed, 95 insertions(+), 25 deletions(-) diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs index 249ebc8..a31c91d 100644 --- a/ghc/compiler/nativeGen/MachCode.lhs +++ b/ghc/compiler/nativeGen/MachCode.lhs @@ -1677,9 +1677,9 @@ Condition codes passed up the tree. \begin{code} data CondCode = CondCode Bool Cond InstrBlock -condName (CondCode _ cond _) = cond +condName (CondCode _ cond _) = cond condFloat (CondCode is_float _ _) = is_float -condCode (CondCode _ _ code) = code +condCode (CondCode _ _ code) = code \end{code} Set up a condition code for a conditional branch. @@ -1870,7 +1870,8 @@ condIntCode cond x y ----------- condFltCode cond x y - = getRegister x `thenNat` \ register1 -> + = ASSERT(cond `elem` ([EQQ, NE, LE, LTT, GE, GTT])) + getRegister x `thenNat` \ register1 -> getRegister y `thenNat` \ register2 -> getNewRegNCG (registerRep register1) `thenNat` \ tmp1 -> @@ -1878,7 +1879,6 @@ condFltCode cond x y `thenNat` \ tmp2 -> getNewRegNCG DoubleRep `thenNat` \ tmp -> let - pk1 = registerRep register1 code1 = registerCode register1 tmp1 src1 = registerName register1 tmp1 @@ -1888,26 +1888,17 @@ condFltCode cond x y code__2 | isAny register1 = code1 `appOL` -- result in tmp1 code2 `snocOL` - GCMP (primRepToSize pk1) tmp1 src2 + GCMP cond tmp1 src2 | otherwise = code1 `snocOL` GMOV src1 tmp1 `appOL` code2 `snocOL` - GCMP (primRepToSize pk1) tmp1 src2 - - {- On the 486, the flags set by FP compare are the unsigned ones! - (This looks like a HACK to me. WDP 96/03) - -} - fix_FP_cond :: Cond -> Cond - - fix_FP_cond GE = GEU - fix_FP_cond GTT = GU - fix_FP_cond LTT = LU - fix_FP_cond LE = LEU - fix_FP_cond any = any + GCMP cond tmp1 src2 in - returnNat (CondCode True (fix_FP_cond cond) code__2) + -- The GCMP insn does the test and sets the zero flag if comparable + -- and true. Hence we always supply EQQ as the condition to test. + returnNat (CondCode True EQQ code__2) #endif {- i386_TARGET_ARCH -} diff --git a/ghc/compiler/nativeGen/MachMisc.lhs b/ghc/compiler/nativeGen/MachMisc.lhs index ed5737f..ee9d934 100644 --- a/ghc/compiler/nativeGen/MachMisc.lhs +++ b/ghc/compiler/nativeGen/MachMisc.lhs @@ -544,7 +544,11 @@ but we don't care, since it doesn't get used much. We hope. | GSUB Size Reg Reg Reg -- src1, src2, dst | GMUL Size Reg Reg Reg -- src1, src2, dst - | GCMP Size Reg Reg -- src1, src2 + -- FP compare. Cond must be `elem` [EQQ, NE, LE, LTT, GE, GTT] + -- Compare src1 with src2; set the Zero flag iff the numbers are + -- comparable and the comparison is True. Subsequent code must + -- test the %eflags zero flag regardless of the supplied Cond. + | GCMP Cond Reg Reg -- src1, src2 | GABS Size Reg Reg -- src, dst | GNEG Size Reg Reg -- src, dst diff --git a/ghc/compiler/nativeGen/PprMach.lhs b/ghc/compiler/nativeGen/PprMach.lhs index 13b1759..e65a6a3 100644 --- a/ghc/compiler/nativeGen/PprMach.lhs +++ b/ghc/compiler/nativeGen/PprMach.lhs @@ -1030,11 +1030,74 @@ pprInstr g@(GITOD src dst) text " ; ffree %st(7); fildl (%esp) ; ", gpop dst 1, text " ; addl $4,%esp"]) -pprInstr g@(GCMP sz src1 src2) - = pprG g (hcat [gtab, text "pushl %eax ; ",gpush src1 0] - $$ - hcat [gtab, text "fcomp ", greg src2 1, - text "; fstsw %ax ; sahf ; popl %eax"]) +{- Gruesome swamp follows. If you're unfortunate enough to have ventured + this far into the jungle AND you give a Rat's Ass (tm) what's going + on, here's the deal. Generate code to do a floating point comparison + of src1 and src2, of kind cond, and set the Zero flag if true. + + The complications are to do with handling NaNs correctly. We want the + property that if either argument is NaN, then the result of the + comparison is False ... except if we're comparing for inequality, + in which case the answer is True. + + Here's how the general (non-inequality) case works. As an + example, consider generating the an equality test: + + pushl %eax -- we need to mess with this + + fcomp and pop pushed src1 + -- Result of comparison is in FPU Status Register bits + -- C3 C2 and C0 + fstsw %ax -- Move FPU Status Reg to %ax + sahf -- move C3 C2 C0 from %ax to integer flag reg + -- now the serious magic begins + setpo %ah -- %ah = if comparable(neither arg was NaN) then 1 else 0 + sete %al -- %al = if arg1 == arg2 then 1 else 0 + andb %ah,%al -- %al &= %ah + -- so %al == 1 iff (comparable && same); else it holds 0 + decb %al -- %al == 0, ZeroFlag=1 iff (comparable && same); + else %al == 0xFF, ZeroFlag=0 + -- the zero flag is now set as we desire. + popl %eax + + The special case of inequality differs thusly: + + setpe %ah -- %ah = if incomparable(either arg was NaN) then 1 else 0 + setne %al -- %al = if arg1 /= arg2 then 1 else 0 + orb %ah,%al -- %al = if (incomparable || different) then 1 else 0 + decb %al -- if (incomparable || different) then (%al == 0, ZF=1) + else (%al == 0xFF, ZF=0) +-} +pprInstr g@(GCMP cond src1 src2) + | case cond of { NE -> True; other -> False } + = pprG g (vcat [ + hcat [gtab, text "pushl %eax ; ",gpush src1 0], + hcat [gtab, text "fcomp ", greg src2 1, + text "; fstsw %ax ; sahf ; setpe %ah"], + hcat [gtab, text "setne %al ; ", + text "orb %ah,%al ; decb %al ; popl %eax"] + ]) + | otherwise + = pprG g (vcat [ + hcat [gtab, text "pushl %eax ; ",gpush src1 0], + hcat [gtab, text "fcomp ", greg src2 1, + text "; fstsw %ax ; sahf ; setpo %ah"], + hcat [gtab, text "set", pprCond (fix_FP_cond cond), text " %al ; ", + text "andb %ah,%al ; decb %al ; popl %eax"] + ]) + where + {- On the 486, the flags set by FP compare are the unsigned ones! + (This looks like a HACK to me. WDP 96/03) + -} + fix_FP_cond :: Cond -> Cond + fix_FP_cond GE = GEU + fix_FP_cond GTT = GU + fix_FP_cond LTT = LU + fix_FP_cond LE = LEU + fix_FP_cond EQQ = EQQ + fix_FP_cond NE = NE + -- there should be no others + pprInstr g@(GABS sz src dst) = pprG g (hcat [gtab, gpush src 0, text " ; fabs ; ", gpop dst 1]) @@ -1204,7 +1267,7 @@ pprGInstr (GDTOI src dst) = pprSizeSizeRegReg SLIT("gdtoi") DF L src dst pprGInstr (GITOF src dst) = pprSizeSizeRegReg SLIT("gitof") L F src dst pprGInstr (GITOD src dst) = pprSizeSizeRegReg SLIT("gitod") L DF src dst -pprGInstr (GCMP sz src dst) = pprSizeRegReg SLIT("gcmp") sz src dst +pprGInstr (GCMP co src dst) = pprCondRegReg SLIT("gcmp_") DF co src dst pprGInstr (GABS sz src dst) = pprSizeRegReg SLIT("gabs") sz src dst pprGInstr (GNEG sz src dst) = pprSizeRegReg SLIT("gneg") sz src dst pprGInstr (GSQRT sz src dst) = pprSizeRegReg SLIT("gsqrt") sz src dst @@ -1310,6 +1373,18 @@ pprSizeRegReg name size reg1 reg2 pprReg size reg2 ] +pprCondRegReg :: FAST_STRING -> Size -> Cond -> Reg -> Reg -> Doc +pprCondRegReg name size cond reg1 reg2 + = hcat [ + char '\t', + ptext name, + pprCond cond, + space, + pprReg size reg1, + comma, + pprReg size reg2 + ] + pprSizeSizeRegReg :: FAST_STRING -> Size -> Size -> Reg -> Reg -> Doc pprSizeSizeRegReg name size1 size2 reg1 reg2 = hcat [ -- 1.7.10.4