never executed always true always false
    1 -- | Evaluation of 32 bit values.
    2 module GHC.CmmToAsm.SPARC.CodeGen.Gen32 (
    3         getSomeReg,
    4         getRegister
    5 )
    6 
    7 where
    8 
    9 import GHC.Prelude
   10 
   11 import GHC.CmmToAsm.SPARC.CodeGen.CondCode
   12 import GHC.CmmToAsm.SPARC.CodeGen.Amode
   13 import GHC.CmmToAsm.SPARC.CodeGen.Gen64
   14 import GHC.CmmToAsm.SPARC.CodeGen.Base
   15 import GHC.CmmToAsm.SPARC.Stack
   16 import GHC.CmmToAsm.SPARC.Instr
   17 import GHC.CmmToAsm.SPARC.Cond
   18 import GHC.CmmToAsm.SPARC.AddrMode
   19 import GHC.CmmToAsm.SPARC.Imm
   20 import GHC.CmmToAsm.SPARC.Regs
   21 import GHC.CmmToAsm.SPARC.Base
   22 import GHC.CmmToAsm.Monad
   23 import GHC.CmmToAsm.Format
   24 import GHC.Platform.Reg
   25 
   26 import GHC.Cmm
   27 
   28 import Control.Monad (liftM)
   29 import GHC.Data.OrdList
   30 import GHC.Utils.Panic
   31 
   32 -- | The dual to getAnyReg: compute an expression into a register, but
   33 --      we don't mind which one it is.
   34 getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock)
   35 getSomeReg expr = do
   36   r <- getRegister expr
   37   case r of
   38     Any rep code -> do
   39         tmp <- getNewRegNat rep
   40         return (tmp, code tmp)
   41     Fixed _ reg code ->
   42         return (reg, code)
   43 
   44 
   45 
   46 -- | Make code to evaluate a 32 bit expression.
   47 --
   48 getRegister :: CmmExpr -> NatM Register
   49 
   50 getRegister (CmmReg reg)
   51   = do platform <- getPlatform
   52        return (Fixed (cmmTypeFormat (cmmRegType platform reg))
   53                      (getRegisterReg platform reg) nilOL)
   54 
   55 getRegister tree@(CmmRegOff _ _)
   56   = do platform <- getPlatform
   57        getRegister (mangleIndexTree platform tree)
   58 
   59 getRegister (CmmMachOp (MO_UU_Conv W64 W32)
   60              [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do
   61   ChildCode64 code rlo <- iselExpr64 x
   62   return $ Fixed II32 (getHiVRegFromLo rlo) code
   63 
   64 getRegister (CmmMachOp (MO_SS_Conv W64 W32)
   65              [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do
   66   ChildCode64 code rlo <- iselExpr64 x
   67   return $ Fixed II32 (getHiVRegFromLo rlo) code
   68 
   69 getRegister (CmmMachOp (MO_UU_Conv W64 W32) [x]) = do
   70   ChildCode64 code rlo <- iselExpr64 x
   71   return $ Fixed II32 rlo code
   72 
   73 getRegister (CmmMachOp (MO_SS_Conv W64 W32) [x]) = do
   74   ChildCode64 code rlo <- iselExpr64 x
   75   return $ Fixed II32 rlo code
   76 
   77 
   78 -- Load a literal float into a float register.
   79 --      The actual literal is stored in a new data area, and we load it
   80 --      at runtime.
   81 getRegister (CmmLit (CmmFloat f W32)) = do
   82 
   83     -- a label for the new data area
   84     lbl <- getNewLabelNat
   85     tmp <- getNewRegNat II32
   86 
   87     let code dst = toOL [
   88             -- the data area
   89             LDATA (Section ReadOnlyData lbl) $ CmmStaticsRaw lbl
   90                          [CmmStaticLit (CmmFloat f W32)],
   91 
   92             -- load the literal
   93             SETHI (HI (ImmCLbl lbl)) tmp,
   94             LD II32 (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
   95 
   96     return (Any FF32 code)
   97 
   98 getRegister (CmmLit (CmmFloat d W64)) = do
   99     lbl <- getNewLabelNat
  100     tmp <- getNewRegNat II32
  101     let code dst = toOL [
  102             LDATA (Section ReadOnlyData lbl) $ CmmStaticsRaw lbl
  103                          [CmmStaticLit (CmmFloat d W64)],
  104             SETHI (HI (ImmCLbl lbl)) tmp,
  105             LD II64 (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
  106     return (Any FF64 code)
  107 
  108 
  109 -- Unary machine ops
  110 getRegister (CmmMachOp mop [x])
  111   = case mop of
  112         -- Floating point negation -------------------------
  113         MO_F_Neg W32            -> trivialUFCode FF32 (FNEG FF32) x
  114         MO_F_Neg W64            -> trivialUFCode FF64 (FNEG FF64) x
  115 
  116 
  117         -- Integer negation --------------------------------
  118         MO_S_Neg rep            -> trivialUCode (intFormat rep) (SUB False False g0) x
  119         MO_Not rep              -> trivialUCode (intFormat rep) (XNOR False g0) x
  120 
  121 
  122         -- Float word size conversion ----------------------
  123         MO_FF_Conv W64 W32      -> coerceDbl2Flt x
  124         MO_FF_Conv W32 W64      -> coerceFlt2Dbl x
  125 
  126 
  127         -- Float <-> Signed Int conversion -----------------
  128         MO_FS_Conv from to      -> coerceFP2Int from to x
  129         MO_SF_Conv from to      -> coerceInt2FP from to x
  130 
  131 
  132         -- Unsigned integer word size conversions ----------
  133 
  134         -- If it's the same size, then nothing needs to be done.
  135         MO_UU_Conv from to
  136          | from == to           -> conversionNop (intFormat to)  x
  137 
  138         -- To narrow an unsigned word, mask out the high bits to simulate what would
  139         --      happen if we copied the value into a smaller register.
  140         MO_UU_Conv W16 W8       -> trivialCode W8  (AND False) x (CmmLit (CmmInt 255 W8))
  141         MO_UU_Conv W32 W8       -> trivialCode W8  (AND False) x (CmmLit (CmmInt 255 W8))
  142 
  143         -- for narrowing 32 bit to 16 bit, don't use a literal mask value like the W16->W8
  144         --      case because the only way we can load it is via SETHI, which needs 2 ops.
  145         --      Do some shifts to chop out the high bits instead.
  146         MO_UU_Conv W32 W16
  147          -> do  tmpReg          <- getNewRegNat II32
  148                 (xReg, xCode)   <- getSomeReg x
  149                 let code dst
  150                         =       xCode
  151                         `appOL` toOL
  152                                 [ SLL xReg   (RIImm $ ImmInt 16) tmpReg
  153                                 , SRL tmpReg (RIImm $ ImmInt 16) dst]
  154 
  155                 return  $ Any II32 code
  156 
  157                 --       trivialCode W16 (AND False) x (CmmLit (CmmInt 65535 W16))
  158 
  159         -- To widen an unsigned word we don't have to do anything.
  160         --      Just leave it in the same register and mark the result as the new size.
  161         MO_UU_Conv W8  W16      -> conversionNop (intFormat W16)  x
  162         MO_UU_Conv W8  W32      -> conversionNop (intFormat W32)  x
  163         MO_UU_Conv W16 W32      -> conversionNop (intFormat W32)  x
  164 
  165 
  166         -- Signed integer word size conversions ------------
  167 
  168         -- Mask out high bits when narrowing them
  169         MO_SS_Conv W16 W8       -> trivialCode W8  (AND False) x (CmmLit (CmmInt 255 W8))
  170         MO_SS_Conv W32 W8       -> trivialCode W8  (AND False) x (CmmLit (CmmInt 255 W8))
  171         MO_SS_Conv W32 W16      -> trivialCode W16 (AND False) x (CmmLit (CmmInt 65535 W16))
  172 
  173         -- Sign extend signed words when widening them.
  174         MO_SS_Conv W8  W16      -> integerExtend W8  W16 x
  175         MO_SS_Conv W8  W32      -> integerExtend W8  W32 x
  176         MO_SS_Conv W16 W32      -> integerExtend W16 W32 x
  177 
  178         _                       -> panic ("Unknown unary mach op: " ++ show mop)
  179 
  180 
  181 -- Binary machine ops
  182 getRegister (CmmMachOp mop [x, y])
  183   = case mop of
  184       MO_Eq _           -> condIntReg EQQ x y
  185       MO_Ne _           -> condIntReg NE x y
  186 
  187       MO_S_Gt _         -> condIntReg GTT x y
  188       MO_S_Ge _         -> condIntReg GE x y
  189       MO_S_Lt _         -> condIntReg LTT x y
  190       MO_S_Le _         -> condIntReg LE x y
  191 
  192       MO_U_Gt W32       -> condIntReg GU  x y
  193       MO_U_Ge W32       -> condIntReg GEU x y
  194       MO_U_Lt W32       -> condIntReg LU  x y
  195       MO_U_Le W32       -> condIntReg LEU x y
  196 
  197       MO_U_Gt W16       -> condIntReg GU  x y
  198       MO_U_Ge W16       -> condIntReg GEU x y
  199       MO_U_Lt W16       -> condIntReg LU  x y
  200       MO_U_Le W16       -> condIntReg LEU x y
  201 
  202       MO_Add W32        -> trivialCode W32 (ADD False False) x y
  203       MO_Sub W32        -> trivialCode W32 (SUB False False) x y
  204 
  205       MO_S_MulMayOflo rep -> imulMayOflo rep x y
  206 
  207       MO_S_Quot W32     -> idiv True  False x y
  208       MO_U_Quot W32     -> idiv False False x y
  209 
  210       MO_S_Rem  W32     -> irem True  x y
  211       MO_U_Rem  W32     -> irem False x y
  212 
  213       MO_F_Eq _         -> condFltReg EQQ x y
  214       MO_F_Ne _         -> condFltReg NE x y
  215 
  216       MO_F_Gt _         -> condFltReg GTT x y
  217       MO_F_Ge _         -> condFltReg GE x y
  218       MO_F_Lt _         -> condFltReg LTT x y
  219       MO_F_Le _         -> condFltReg LE x y
  220 
  221       MO_F_Add  w       -> trivialFCode w FADD x y
  222       MO_F_Sub  w       -> trivialFCode w FSUB x y
  223       MO_F_Mul  w       -> trivialFCode w FMUL x y
  224       MO_F_Quot w       -> trivialFCode w FDIV x y
  225 
  226       MO_And rep        -> trivialCode rep (AND False) x y
  227       MO_Or  rep        -> trivialCode rep (OR  False) x y
  228       MO_Xor rep        -> trivialCode rep (XOR False) x y
  229 
  230       MO_Mul rep        -> trivialCode rep (SMUL False) x y
  231 
  232       MO_Shl rep        -> trivialCode rep SLL  x y
  233       MO_U_Shr rep      -> trivialCode rep SRL x y
  234       MO_S_Shr rep      -> trivialCode rep SRA x y
  235 
  236       _                 -> pprPanic "getRegister(sparc) - binary CmmMachOp (1)" (pprMachOp mop)
  237 
  238 getRegister (CmmLoad mem pk) = do
  239     Amode src code <- getAmode mem
  240     let
  241         code__2 dst     = code `snocOL` LD (cmmTypeFormat pk) src dst
  242     return (Any (cmmTypeFormat pk) code__2)
  243 
  244 getRegister (CmmLit (CmmInt i _))
  245   | fits13Bits i
  246   = let
  247         src = ImmInt (fromInteger i)
  248         code dst = unitOL (OR False g0 (RIImm src) dst)
  249     in
  250         return (Any II32 code)
  251 
  252 getRegister (CmmLit lit)
  253   = let imm = litToImm lit
  254         code dst = toOL [
  255             SETHI (HI imm) dst,
  256             OR False dst (RIImm (LO imm)) dst]
  257     in return (Any II32 code)
  258 
  259 
  260 getRegister _
  261         = panic "SPARC.CodeGen.Gen32.getRegister: no match"
  262 
  263 
  264 -- | sign extend and widen
  265 integerExtend
  266         :: Width                -- ^ width of source expression
  267         -> Width                -- ^ width of result
  268         -> CmmExpr              -- ^ source expression
  269         -> NatM Register
  270 
  271 integerExtend from to expr
  272  = do   -- load the expr into some register
  273         (reg, e_code)   <- getSomeReg expr
  274         tmp             <- getNewRegNat II32
  275         let bitCount
  276                 = case (from, to) of
  277                         (W8,  W32)      -> 24
  278                         (W16, W32)      -> 16
  279                         (W8,  W16)      -> 24
  280                         _               -> panic "SPARC.CodeGen.Gen32: no match"
  281         let code dst
  282                 = e_code
  283 
  284                 -- local shift word left to load the sign bit
  285                 `snocOL`  SLL reg (RIImm (ImmInt bitCount)) tmp
  286 
  287                 -- arithmetic shift right to sign extend
  288                 `snocOL`  SRA tmp (RIImm (ImmInt bitCount)) dst
  289 
  290         return (Any (intFormat to) code)
  291 
  292 
  293 -- | For nop word format conversions we set the resulting value to have the
  294 --      required size, but don't need to generate any actual code.
  295 --
  296 conversionNop
  297         :: Format -> CmmExpr -> NatM Register
  298 
  299 conversionNop new_rep expr
  300  = do   e_code <- getRegister expr
  301         return (setFormatOfRegister e_code new_rep)
  302 
  303 
  304 
  305 -- | Generate an integer division instruction.
  306 idiv :: Bool -> Bool -> CmmExpr -> CmmExpr -> NatM Register
  307 
  308 -- For unsigned division with a 32 bit numerator,
  309 --              we can just clear the Y register.
  310 idiv False cc x y
  311  = do
  312         (a_reg, a_code)         <- getSomeReg x
  313         (b_reg, b_code)         <- getSomeReg y
  314 
  315         let code dst
  316                 =       a_code
  317                 `appOL` b_code
  318                 `appOL` toOL
  319                         [ WRY  g0 g0
  320                         , UDIV cc a_reg (RIReg b_reg) dst]
  321 
  322         return (Any II32 code)
  323 
  324 
  325 -- For _signed_ division with a 32 bit numerator,
  326 --              we have to sign extend the numerator into the Y register.
  327 idiv True cc x y
  328  = do
  329         (a_reg, a_code)         <- getSomeReg x
  330         (b_reg, b_code)         <- getSomeReg y
  331 
  332         tmp                     <- getNewRegNat II32
  333 
  334         let code dst
  335                 =       a_code
  336                 `appOL` b_code
  337                 `appOL` toOL
  338                         [ SRA  a_reg (RIImm (ImmInt 16)) tmp            -- sign extend
  339                         , SRA  tmp   (RIImm (ImmInt 16)) tmp
  340 
  341                         , WRY  tmp g0
  342                         , SDIV cc a_reg (RIReg b_reg) dst]
  343 
  344         return (Any II32 code)
  345 
  346 
  347 -- | Do an integer remainder.
  348 --
  349 --       NOTE:  The SPARC v8 architecture manual says that integer division
  350 --              instructions _may_ generate a remainder, depending on the implementation.
  351 --              If so it is _recommended_ that the remainder is placed in the Y register.
  352 --
  353 --          The UltraSparc 2007 manual says Y is _undefined_ after division.
  354 --
  355 --              The SPARC T2 doesn't store the remainder, not sure about the others.
  356 --              It's probably best not to worry about it, and just generate our own
  357 --              remainders.
  358 --
  359 irem :: Bool -> CmmExpr -> CmmExpr -> NatM Register
  360 
  361 -- For unsigned operands:
  362 --              Division is between a 64 bit numerator and a 32 bit denominator,
  363 --              so we still have to clear the Y register.
  364 irem False x y
  365  = do
  366         (a_reg, a_code) <- getSomeReg x
  367         (b_reg, b_code) <- getSomeReg y
  368 
  369         tmp_reg         <- getNewRegNat II32
  370 
  371         let code dst
  372                 =       a_code
  373                 `appOL` b_code
  374                 `appOL` toOL
  375                         [ WRY   g0 g0
  376                         , UDIV  False         a_reg (RIReg b_reg) tmp_reg
  377                         , UMUL  False       tmp_reg (RIReg b_reg) tmp_reg
  378                         , SUB   False False   a_reg (RIReg tmp_reg) dst]
  379 
  380         return  (Any II32 code)
  381 
  382 
  383 
  384 -- For signed operands:
  385 --              Make sure to sign extend into the Y register, or the remainder
  386 --              will have the wrong sign when the numerator is negative.
  387 --
  388 --      TODO:   When sign extending, GCC only shifts the a_reg right by 17 bits,
  389 --              not the full 32. Not sure why this is, something to do with overflow?
  390 --              If anyone cares enough about the speed of signed remainder they
  391 --              can work it out themselves (then tell me). -- BL 2009/01/20
  392 irem True x y
  393  = do
  394         (a_reg, a_code) <- getSomeReg x
  395         (b_reg, b_code) <- getSomeReg y
  396 
  397         tmp1_reg        <- getNewRegNat II32
  398         tmp2_reg        <- getNewRegNat II32
  399 
  400         let code dst
  401                 =       a_code
  402                 `appOL` b_code
  403                 `appOL` toOL
  404                         [ SRA   a_reg      (RIImm (ImmInt 16)) tmp1_reg -- sign extend
  405                         , SRA   tmp1_reg   (RIImm (ImmInt 16)) tmp1_reg -- sign extend
  406                         , WRY   tmp1_reg g0
  407 
  408                         , SDIV  False          a_reg (RIReg b_reg)    tmp2_reg
  409                         , SMUL  False       tmp2_reg (RIReg b_reg)    tmp2_reg
  410                         , SUB   False False    a_reg (RIReg tmp2_reg) dst]
  411 
  412         return (Any II32 code)
  413 
  414 
  415 imulMayOflo :: Width -> CmmExpr -> CmmExpr -> NatM Register
  416 imulMayOflo rep a b
  417  = do
  418         (a_reg, a_code) <- getSomeReg a
  419         (b_reg, b_code) <- getSomeReg b
  420         res_lo <- getNewRegNat II32
  421         res_hi <- getNewRegNat II32
  422 
  423         let shift_amt  = case rep of
  424                           W32 -> 31
  425                           W64 -> 63
  426                           _ -> panic "shift_amt"
  427 
  428         let code dst = a_code `appOL` b_code `appOL`
  429                        toOL [
  430                            SMUL False a_reg (RIReg b_reg) res_lo,
  431                            RDY res_hi,
  432                            SRA res_lo (RIImm (ImmInt shift_amt)) res_lo,
  433                            SUB False False res_lo (RIReg res_hi) dst
  434                         ]
  435         return (Any II32 code)
  436 
  437 
  438 -- -----------------------------------------------------------------------------
  439 -- 'trivial*Code': deal with trivial instructions
  440 
  441 -- Trivial (dyadic: 'trivialCode', floating-point: 'trivialFCode',
  442 -- unary: 'trivialUCode', unary fl-pt:'trivialUFCode') instructions.
  443 -- Only look for constants on the right hand side, because that's
  444 -- where the generic optimizer will have put them.
  445 
  446 -- Similarly, for unary instructions, we don't have to worry about
  447 -- matching an StInt as the argument, because genericOpt will already
  448 -- have handled the constant-folding.
  449 
  450 trivialCode
  451         :: Width
  452         -> (Reg -> RI -> Reg -> Instr)
  453         -> CmmExpr
  454         -> CmmExpr
  455         -> NatM Register
  456 
  457 trivialCode _ instr x (CmmLit (CmmInt y _))
  458   | fits13Bits y
  459   = do
  460       (src1, code) <- getSomeReg x
  461       let
  462         src2 = ImmInt (fromInteger y)
  463         code__2 dst = code `snocOL` instr src1 (RIImm src2) dst
  464       return (Any II32 code__2)
  465 
  466 
  467 trivialCode _ instr x y = do
  468     (src1, code1) <- getSomeReg x
  469     (src2, code2) <- getSomeReg y
  470     let
  471         code__2 dst = code1 `appOL` code2 `snocOL`
  472                       instr src1 (RIReg src2) dst
  473     return (Any II32 code__2)
  474 
  475 
  476 trivialFCode
  477         :: Width
  478         -> (Format -> Reg -> Reg -> Reg -> Instr)
  479         -> CmmExpr
  480         -> CmmExpr
  481         -> NatM Register
  482 
  483 trivialFCode pk instr x y = do
  484     platform <- getPlatform
  485     (src1, code1) <- getSomeReg x
  486     (src2, code2) <- getSomeReg y
  487     tmp <- getNewRegNat FF64
  488     let
  489         promote x = FxTOy FF32 FF64 x tmp
  490 
  491         pk1   = cmmExprType platform x
  492         pk2   = cmmExprType platform y
  493 
  494         code__2 dst =
  495                 if pk1 `cmmEqType` pk2 then
  496                     code1 `appOL` code2 `snocOL`
  497                     instr (floatFormat pk) src1 src2 dst
  498                 else if typeWidth pk1 == W32 then
  499                     code1 `snocOL` promote src1 `appOL` code2 `snocOL`
  500                     instr FF64 tmp src2 dst
  501                 else
  502                     code1 `appOL` code2 `snocOL` promote src2 `snocOL`
  503                     instr FF64 src1 tmp dst
  504     return (Any (cmmTypeFormat $ if pk1 `cmmEqType` pk2 then pk1 else cmmFloat W64)
  505                 code__2)
  506 
  507 
  508 
  509 trivialUCode
  510         :: Format
  511         -> (RI -> Reg -> Instr)
  512         -> CmmExpr
  513         -> NatM Register
  514 
  515 trivialUCode format instr x = do
  516     (src, code) <- getSomeReg x
  517     let
  518         code__2 dst = code `snocOL` instr (RIReg src) dst
  519     return (Any format code__2)
  520 
  521 
  522 trivialUFCode
  523         :: Format
  524         -> (Reg -> Reg -> Instr)
  525         -> CmmExpr
  526         -> NatM Register
  527 
  528 trivialUFCode pk instr x = do
  529     (src, code) <- getSomeReg x
  530     let
  531         code__2 dst = code `snocOL` instr src dst
  532     return (Any pk code__2)
  533 
  534 
  535 
  536 
  537 -- Coercions -------------------------------------------------------------------
  538 
  539 -- | Coerce a integer value to floating point
  540 coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register
  541 coerceInt2FP width1 width2 x = do
  542     (src, code) <- getSomeReg x
  543     let
  544         code__2 dst = code `appOL` toOL [
  545             ST (intFormat width1) src (spRel (-2)),
  546             LD (intFormat width1) (spRel (-2)) dst,
  547             FxTOy (intFormat width1) (floatFormat width2) dst dst]
  548     return (Any (floatFormat $ width2) code__2)
  549 
  550 
  551 
  552 -- | Coerce a floating point value to integer
  553 --
  554 --   NOTE: On sparc v9 there are no instructions to move a value from an
  555 --         FP register directly to an int register, so we have to use a load/store.
  556 --
  557 coerceFP2Int :: Width -> Width -> CmmExpr -> NatM Register
  558 coerceFP2Int width1 width2 x
  559  = do   let fformat1      = floatFormat width1
  560             fformat2      = floatFormat width2
  561 
  562             iformat2      = intFormat   width2
  563 
  564         (fsrc, code)    <- getSomeReg x
  565         fdst            <- getNewRegNat fformat2
  566 
  567         let code2 dst
  568                 =       code
  569                 `appOL` toOL
  570                         -- convert float to int format, leaving it in a float reg.
  571                         [ FxTOy fformat1 iformat2 fsrc fdst
  572 
  573                         -- store the int into mem, then load it back to move
  574                         --      it into an actual int reg.
  575                         , ST    fformat2 fdst (spRel (-2))
  576                         , LD    iformat2 (spRel (-2)) dst]
  577 
  578         return (Any iformat2 code2)
  579 
  580 
  581 -- | Coerce a double precision floating point value to single precision.
  582 coerceDbl2Flt :: CmmExpr -> NatM Register
  583 coerceDbl2Flt x = do
  584     (src, code) <- getSomeReg x
  585     return (Any FF32 (\dst -> code `snocOL` FxTOy FF64 FF32 src dst))
  586 
  587 
  588 -- | Coerce a single precision floating point value to double precision
  589 coerceFlt2Dbl :: CmmExpr -> NatM Register
  590 coerceFlt2Dbl x = do
  591     (src, code) <- getSomeReg x
  592     return (Any FF64 (\dst -> code `snocOL` FxTOy FF32 FF64 src dst))
  593 
  594 
  595 
  596 
  597 -- Condition Codes -------------------------------------------------------------
  598 --
  599 -- Evaluate a comparison, and get the result into a register.
  600 --
  601 -- Do not fill the delay slots here. you will confuse the register allocator.
  602 --
  603 condIntReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register
  604 condIntReg EQQ x (CmmLit (CmmInt 0 _)) = do
  605     (src, code) <- getSomeReg x
  606     let
  607         code__2 dst = code `appOL` toOL [
  608             SUB False True g0 (RIReg src) g0,
  609             SUB True False g0 (RIImm (ImmInt (-1))) dst]
  610     return (Any II32 code__2)
  611 
  612 condIntReg EQQ x y = do
  613     (src1, code1) <- getSomeReg x
  614     (src2, code2) <- getSomeReg y
  615     let
  616         code__2 dst = code1 `appOL` code2 `appOL` toOL [
  617             XOR False src1 (RIReg src2) dst,
  618             SUB False True g0 (RIReg dst) g0,
  619             SUB True False g0 (RIImm (ImmInt (-1))) dst]
  620     return (Any II32 code__2)
  621 
  622 condIntReg NE x (CmmLit (CmmInt 0 _)) = do
  623     (src, code) <- getSomeReg x
  624     let
  625         code__2 dst = code `appOL` toOL [
  626             SUB False True g0 (RIReg src) g0,
  627             ADD True False g0 (RIImm (ImmInt 0)) dst]
  628     return (Any II32 code__2)
  629 
  630 condIntReg NE x y = do
  631     (src1, code1) <- getSomeReg x
  632     (src2, code2) <- getSomeReg y
  633     let
  634         code__2 dst = code1 `appOL` code2 `appOL` toOL [
  635             XOR False src1 (RIReg src2) dst,
  636             SUB False True g0 (RIReg dst) g0,
  637             ADD True False g0 (RIImm (ImmInt 0)) dst]
  638     return (Any II32 code__2)
  639 
  640 condIntReg cond x y = do
  641     bid1 <- liftM (\a -> seq a a) getBlockIdNat
  642     bid2 <- liftM (\a -> seq a a) getBlockIdNat
  643     CondCode _ cond cond_code <- condIntCode cond x y
  644     let
  645         code__2 dst
  646          =      cond_code
  647           `appOL` toOL
  648                 [ BI cond False bid1
  649                 , NOP
  650 
  651                 , OR False g0 (RIImm (ImmInt 0)) dst
  652                 , BI ALWAYS False bid2
  653                 , NOP
  654 
  655                 , NEWBLOCK bid1
  656                 , OR False g0 (RIImm (ImmInt 1)) dst
  657                 , BI ALWAYS False bid2
  658                 , NOP
  659 
  660                 , NEWBLOCK bid2]
  661 
  662     return (Any II32 code__2)
  663 
  664 
  665 condFltReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register
  666 condFltReg cond x y = do
  667     bid1 <- liftM (\a -> seq a a) getBlockIdNat
  668     bid2 <- liftM (\a -> seq a a) getBlockIdNat
  669 
  670     CondCode _ cond cond_code <- condFltCode cond x y
  671     let
  672         code__2 dst
  673          =      cond_code
  674           `appOL` toOL
  675                 [ NOP
  676                 , BF cond False bid1
  677                 , NOP
  678 
  679                 , OR False g0 (RIImm (ImmInt 0)) dst
  680                 , BI ALWAYS False bid2
  681                 , NOP
  682 
  683                 , NEWBLOCK bid1
  684                 , OR False g0 (RIImm (ImmInt 1)) dst
  685                 , BI ALWAYS False bid2
  686                 , NOP
  687 
  688                 , NEWBLOCK bid2 ]
  689 
  690     return (Any II32 code__2)