Ticket #5598: 0001-Implement-quotRemInt-primop.patch

compiler/cmm/CmmLint.hs

@@ -129 +129 @@
             if (erep `cmmEqType_ignoring_ptrhood` reg_ty)
                 then return ()
                 else cmmLintAssignErr platform stmt erep reg_ty
+          lint stmt@(CmmAssign2 reg1 reg2 expr) = do
+            erep <- lintCmmExpr platform expr
+            let reg1_ty = cmmRegType reg1
+                reg2_ty = cmmRegType reg2
+                reg_tys = cmmTypes [reg1_ty, reg2_ty]
+            if (erep `cmmEqType_ignoring_ptrhood` reg_tys)
+                then return ()
+                else cmmLintAssignErr platform stmt erep reg_tys
           lint (CmmStore l r) = do
             _ <- lintCmmExpr platform l
             _ <- lintCmmExpr platform r

compiler/cmm/CmmMachOp.hs

@@ -51 +51 @@
   | MO_S_MulMayOflo Width       -- nonzero if signed multiply overflows
   | MO_S_Quot Width             -- signed / (same semantics as IntQuotOp)
   | MO_S_Rem  Width             -- signed % (same semantics as IntRemOp)
+  | MO_S_QuotRem Width -- signed / % (same semantics as IntQuotOp and IntRemOp)
   | MO_S_Neg  Width             -- unary -
 
   -- Unsigned multiply/divide
@@ -295 +296 @@
     MO_S_MulMayOflo r   -> cmmBits r
     MO_S_Quot r         -> cmmBits r
     MO_S_Rem  r         -> cmmBits r
+    MO_S_QuotRem r      -> cmmTypes [cmmBits r, cmmBits r]
     MO_S_Neg  r         -> cmmBits r
     MO_U_MulMayOflo r   -> cmmBits r
     MO_U_Quot r         -> cmmBits r
@@ -363 +365 @@
     MO_S_MulMayOflo r   -> [r,r]
     MO_S_Quot r         -> [r,r]
     MO_S_Rem  r         -> [r,r]
+    MO_S_QuotRem  r     -> [r,r]
     MO_S_Neg  r         -> [r]
     MO_U_MulMayOflo r   -> [r,r]
     MO_U_Quot r         -> [r,r]

compiler/cmm/CmmOpt.hs

@@ -58 +58 @@
                 stmt m CmmNop = m
                 stmt m (CmmComment _) = m
                 stmt m (CmmAssign _ e) = expr m e
+                stmt m (CmmAssign2 _ _ e) = expr m e
                 stmt m (CmmStore e1 e2) = expr (expr m e1) e2
                 stmt m (CmmCall c _ as _) = f (actuals m as) c
                     where f m (CmmCallee e _) = expr m e

compiler/cmm/CmmType.hs

@@ -3 +3 @@
     ( CmmType   -- Abstract
     , b8, b16, b32, b64, f32, f64, bWord, bHalfWord, gcWord
     , cInt, cLong
-    , cmmBits, cmmFloat
+    , cmmTypes, cmmBits, cmmFloat
     , typeWidth, cmmEqType, cmmEqType_ignoring_ptrhood
     , isFloatType, isGcPtrType, isWord32, isWord64, isFloat64, isFloat32
 
@@ -35 +35 @@
 
 data CmmType    -- The important one!
   = CmmType CmmCat Width
+  | CmmTypes [CmmType]
 
 data CmmCat     -- "Category" (not exported)
    = GcPtrCat   -- GC pointer
@@ -45 +46 @@
 
 instance Outputable CmmType where
   ppr (CmmType cat wid) = ppr cat <> ppr (widthInBits wid)
+  ppr (CmmTypes ts) = parens (ptext (sLit "CmmTypes") <+> sep (map ppr ts))
 
 instance Outputable CmmCat where
   ppr FloatCat  = ptext $ sLit("F")
@@ -63 +65 @@
 -- So we use an explicit function to force you to think about it
 cmmEqType :: CmmType -> CmmType -> Bool -- Exact equality
 cmmEqType (CmmType c1 w1) (CmmType c2 w2) = c1==c2 && w1==w2
+cmmEqType (CmmTypes ts1) (CmmTypes ts2) = and $ zipWith cmmEqType ts1 ts2
+cmmEqType (CmmType {}) (CmmTypes {}) = False
+cmmEqType (CmmTypes {}) (CmmType {}) = False
 
 cmmEqType_ignoring_ptrhood :: CmmType -> CmmType -> Bool
   -- This equality is temporary; used in CmmLint
@@ -74 +79 @@
       FloatCat `weak_eq` _other   = False
       _other   `weak_eq` FloatCat = False
       _word1   `weak_eq` _word2   = True        -- Ignores GcPtr
+cmmEqType_ignoring_ptrhood (CmmTypes ts1) (CmmTypes ts2)
+    = and $ zipWith cmmEqType_ignoring_ptrhood ts1 ts2
+cmmEqType_ignoring_ptrhood (CmmType {}) (CmmTypes {}) = False
+cmmEqType_ignoring_ptrhood (CmmTypes {}) (CmmType {}) = False
 
 --- Simple operations on CmmType -----
 typeWidth :: CmmType -> Width
 typeWidth (CmmType _ w) = w
+typeWidth _ = panic "XXX typeWidth"
+
+cmmTypes :: [CmmType] -> CmmType
+cmmTypes = CmmTypes
 
 cmmBits, cmmFloat :: Width -> CmmType
 cmmBits  = CmmType BitsCat

compiler/cmm/OldCmm.hs

@@ -147 +147 @@
   | CmmComment FastString
 
   | CmmAssign CmmReg CmmExpr      -- Assign to register
+  | CmmAssign2 CmmReg CmmReg CmmExpr      -- Assign to 2 registers
 
   | CmmStore CmmExpr CmmExpr      -- Assign to memory location. Size is
                                   -- given by cmmExprType of the rhs.
@@ -210 +211 @@
       stmt (CmmNop)                  = id
       stmt (CmmComment {})           = id
       stmt (CmmAssign _ e)           = gen e
+      stmt (CmmAssign2 _ _ e)        = gen e
       stmt (CmmStore e1 e2)          = gen e1 . gen e2
       stmt (CmmCall target _ es _)   = gen target . gen es
       stmt (CmmBranch _)             = id

compiler/cmm/OldPprCmm.hs

@@ -113 +113 @@
     -- reg = expr;
     CmmAssign reg expr -> ppr reg <+> equals <+> pprPlatform platform expr <> semi
 
+    -- reg1, reg2 = expr;
+    CmmAssign2 reg1 reg2 expr -> ppr reg1 <> comma <+> ppr reg2 <+> equals <+> pprPlatform platform expr <> semi
+
     -- rep[lv] = expr;
     CmmStore lv expr -> rep <> brackets(pprPlatform platform lv) <+> equals <+> pprPlatform platform expr <> semi
         where

compiler/cmm/PprC.hs

@@ -181 +181 @@
                           -- large.
 
     CmmAssign dest src -> pprAssign platform dest src
+    CmmAssign2 dest1 dest2 src -> pprAssign2 platform dest1 dest2 src
 
     CmmStore  dest src
         | typeWidth rep == W64 && wordWidth /= W64
@@ -527 +528 @@
 
         MO_S_Quot       _ -> char '/'
         MO_S_Rem        _ -> char '%'
+        MO_S_QuotRem    _ -> panic "XXX pprMachOp_for_C"
         MO_S_Neg        _ -> char '-'
 
         MO_U_Quot       _ -> char '/'
@@ -717 +719 @@
                        then ptext (sLit "ASSIGN_BaseReg") <> parens x <> semi
                        else pprReg r1 <> ptext (sLit " = ") <> x <> semi
 
+pprAssign2 :: Platform -> CmmReg -> CmmReg -> CmmExpr -> SDoc
+pprAssign2 = panic "XXX pprAssign2"
+
 -- ---------------------------------------------------------------------
 -- Registers
 

compiler/codeGen/CgPrimOp.hs

@@ -440 +440 @@
    = let stmt = CmmAssign (CmmLocal res) (CmmMachOp mop args) in
      stmtC stmt
 
+emitPrimOp [res_q, res_r] IntQuotRemOp args _
+    = let stmt = CmmAssign2 (CmmLocal res_q) (CmmLocal res_r)
+                            (CmmMachOp (MO_S_QuotRem wordWidth) args)
+      in stmtC stmt
+
 emitPrimOp _ op _ _
  = pprPanic "emitPrimOp: can't translate PrimOp" (ppr op)
 

compiler/llvmGen/LlvmCodeGen/CodeGen.hs

@@ -117 +117 @@
     CmmComment _         -> return (env, nilOL, []) -- nuke comments
 
     CmmAssign reg src    -> genAssign env reg src
+    CmmAssign2 _ _ _     -> panic "XXX stmtToInstrs"
     CmmStore addr src    -> genStore env addr src
 
     CmmBranch id         -> genBranch env id
@@ -458 +459 @@
 
     (MO_PopCnt w) -> fsLit $ "llvm.ctpop."  ++ show (widthToLlvmInt w)
 
+    -- MO_S_QuotRem _ -> panic "XXX LLVM MO_S_QuotRem"
+
     MO_WriteBarrier ->
         panic $ "cmmPrimOpFunctions: MO_WriteBarrier not supported here"
     MO_Touch ->
@@ -766 +769 @@
     MO_S_MulMayOflo _ -> panicOp
     MO_S_Quot _       -> panicOp
     MO_S_Rem _        -> panicOp
+    MO_S_QuotRem _    -> panic "XXX genMachOp"
     MO_U_MulMayOflo _ -> panicOp
     MO_U_Quot _       -> panicOp
     MO_U_Rem _        -> panicOp
@@ -886 +890 @@
 
     MO_S_Quot _ -> genBinMach LM_MO_SDiv
     MO_S_Rem  _ -> genBinMach LM_MO_SRem
+    MO_S_QuotRem _ -> panic "XXX genMachOp_slow"
 
     MO_U_Quot _ -> genBinMach LM_MO_UDiv
     MO_U_Rem  _ -> genBinMach LM_MO_URem

compiler/nativeGen/PPC/CodeGen.hs

@@ -127 +127 @@
         where ty = cmmRegType reg
               size = cmmTypeSize ty
 
+    CmmAssign2 _ _ _ -> panic "XXX PPC stmtToInstrs"
+
     CmmStore addr src
       | isFloatType ty -> assignMem_FltCode size addr src
       | target32Bit (targetPlatform dflags) &&

compiler/nativeGen/SPARC/CodeGen.hs

@@ -128 +128 @@
         where ty = cmmRegType reg
               size = cmmTypeSize ty
 
+    CmmAssign2 _ _ _ -> panic "XXX SPARC stmtToInstrs"
+
     CmmStore addr src
       | isFloatType ty  -> assignMem_FltCode size addr src
       | isWord64 ty     -> assignMem_I64Code      addr src

compiler/nativeGen/X86/CodeGen.hs

@@ -153 +153 @@
         where ty = cmmRegType reg
               size = cmmTypeSize ty
 
+    CmmAssign2 reg1 reg2 src
+      -- XXX Should probably mirror the CmmAssign tests
+      | otherwise              -> assign2Reg_IntCode reg1 reg2 src
+
+
     CmmStore addr src
       | isFloatType ty         -> assignMem_FltCode size addr src
       | is32Bit && isWord64 ty -> assignMem_I64Code      addr src
@@ -208 +213 @@
         = Fixed Size Reg InstrBlock
         | Any   Size (Reg -> InstrBlock)
 
+data Register2
+        = Fixed2 Size Reg Reg InstrBlock
+        | Any2   Size (Reg -> Reg -> InstrBlock)
+
 
 swizzleRegisterRep :: Register -> Size -> Register
 swizzleRegisterRep (Fixed _ reg code) size = Fixed size reg code
@@ -890 +899 @@
 getRegister' _ other = do dflags <- getDynFlags
                           pprPanic "getRegister(x86)" (pprPlatform (targetPlatform dflags) other)
 
+get2Register :: CmmExpr -> NatM Register2
+get2Register (CmmMachOp (MO_S_QuotRem rep) [x, y]) = do
+  div_code rep True x y
+ where
+    div_code width signed x y = do
+           (y_op, y_code) <- getRegOrMem y -- cannot be clobbered
+           x_code <- getAnyReg x
+           let
+             size = intSize width
+             widen | signed    = CLTD size
+                   | otherwise = XOR size (OpReg edx) (OpReg edx)
+
+             instr | signed    = IDIV
+                   | otherwise = DIV
+
+             code = y_code `appOL`
+                    x_code eax `appOL`
+                    toOL [widen, instr size y_op]
+
+           return (Fixed2 size eax edx code)
+get2Register _ = panic "XXX X86 get2Register"
+
 
 intLoadCode :: (Operand -> Operand -> Instr) -> CmmExpr
    -> NatM (Reg -> InstrBlock)
@@ -904 +935 @@
   r <- getRegister expr
   anyReg r
 
+getAny2Reg :: CmmExpr -> NatM (Reg -> Reg -> InstrBlock)
+getAny2Reg expr = do
+  r2 <- get2Register expr
+  any2Reg r2
+
 anyReg :: Register -> NatM (Reg -> InstrBlock)
 anyReg (Any _ code)          = return code
 anyReg (Fixed rep reg fcode) = return (\dst -> fcode `snocOL` reg2reg rep reg dst)
 
+any2Reg :: Register2 -> NatM (Reg -> Reg -> InstrBlock)
+any2Reg (Any2 _ code)                = return code
+any2Reg (Fixed2 rep reg1 reg2 fcode) = return (\dst1 dst2 -> fcode `snocOL` reg2reg rep reg1 dst1 `snocOL` reg2reg rep reg2 dst2)
+
 -- A bit like getSomeReg, but we want a reg that can be byte-addressed.
 -- Fixed registers might not be byte-addressable, so we make sure we've
 -- got a temporary, inserting an extra reg copy if necessary.
@@ -1406 +1446 @@
   code <- getAnyReg src
   return (code (getRegisterReg False{-no sse2-} reg))
 
+assign2Reg_IntCode :: CmmReg -> CmmReg -> CmmExpr -> NatM InstrBlock
+-- dsts are regs, but src could be anything
+assign2Reg_IntCode reg1 reg2 src = do
+  code <- getAny2Reg src
+  return (code (getRegisterReg False{-no sse2-} reg1)
+               (getRegisterReg False{-no sse2-} reg2))
+
 
 -- Floating point assignment to memory
 assignMem_FltCode pk addr src = do

compiler/prelude/primops.txt.pp

@@ -210 +210 @@
    {Satisfies \texttt{(quotInt\# x y) *\# y +\# (remInt\# x y) == x}.}
    with can_fail = True
 
+primop   IntQuotRemOp "quotRemInt#"    GenPrimOp
+   Int# -> Int# -> (# Int#, Int# #)
+   {Rounds towards zero.}
+   with can_fail = True
+
 primop   IntNegOp    "negateInt#"    Monadic   Int# -> Int#
 primop   IntAddCOp   "addIntC#"    GenPrimOp   Int# -> Int# -> (# Int#, Int# #)
          {Add with carry.  First member of result is (wrapped) sum;