Add new mbmi and mbmi2 compiler flags
authorJohn Ky <newhoggy@gmail.com>
Wed, 15 Nov 2017 16:35:42 +0000 (11:35 -0500)
committerBen Gamari <ben@smart-cactus.org>
Wed, 15 Nov 2017 16:37:00 +0000 (11:37 -0500)
This adds support for the bit deposit and extraction operations provided
by the BMI and BMI2 instruction set extensions on modern amd64 machines.

Test Plan: Validate

Reviewers: austin, simonmar, bgamari, hvr, goldfire, erikd

Reviewed By: bgamari

Subscribers: goldfire, erikd, trommler, newhoggy, rwbarton, thomie

GHC Trac Issues: #14206

Differential Revision: https://phabricator.haskell.org/D4063

22 files changed:
compiler/cmm/CmmMachOp.hs
compiler/cmm/CmmParse.y
compiler/cmm/PprC.hs
compiler/codeGen/StgCmmPrim.hs
compiler/coreSyn/MkCore.hs
compiler/llvmGen/LlvmCodeGen/CodeGen.hs
compiler/main/DynFlags.hs
compiler/nativeGen/CPrim.hs
compiler/nativeGen/PPC/CodeGen.hs
compiler/nativeGen/SPARC/CodeGen.hs
compiler/nativeGen/X86/CodeGen.hs
compiler/nativeGen/X86/Instr.hs
compiler/nativeGen/X86/Ppr.hs
compiler/prelude/primops.txt.pp
libraries/ghc-prim/cbits/pdep.c [new file with mode: 0644]
libraries/ghc-prim/cbits/pext.c [new file with mode: 0644]
libraries/ghc-prim/ghc-prim.cabal
testsuite/tests/codeGen/should_run/all.T
testsuite/tests/codeGen/should_run/cgrun075.hs [new file with mode: 0644]
testsuite/tests/codeGen/should_run/cgrun075.stdout [new file with mode: 0644]
testsuite/tests/codeGen/should_run/cgrun076.hs [new file with mode: 0644]
testsuite/tests/codeGen/should_run/cgrun076.stdout [new file with mode: 0644]

index fdbfd6e..8ac4a6f 100644 (file)
@@ -587,6 +587,8 @@ data CallishMachOp
   | MO_Memcmp Int
 
   | MO_PopCnt Width
+  | MO_Pdep Width
+  | MO_Pext Width
   | MO_Clz Width
   | MO_Ctz Width
 
index 7ffb4fb..8afbd2f 100644 (file)
@@ -1006,6 +1006,16 @@ callishMachOps = listToUFM $
         ( "popcnt32", (,) $ MO_PopCnt W32 ),
         ( "popcnt64", (,) $ MO_PopCnt W64 ),
 
+        ( "pdep8",  (,) $ MO_Pdep W8  ),
+        ( "pdep16", (,) $ MO_Pdep W16 ),
+        ( "pdep32", (,) $ MO_Pdep W32 ),
+        ( "pdep64", (,) $ MO_Pdep W64 ),
+
+        ( "pext8",  (,) $ MO_Pext W8  ),
+        ( "pext16", (,) $ MO_Pext W16 ),
+        ( "pext32", (,) $ MO_Pext W32 ),
+        ( "pext64", (,) $ MO_Pext W64 ),
+
         ( "cmpxchg8",  (,) $ MO_Cmpxchg W8  ),
         ( "cmpxchg16", (,) $ MO_Cmpxchg W16 ),
         ( "cmpxchg32", (,) $ MO_Cmpxchg W32 ),
index 1ddd1cd..76e4d4c 100644 (file)
@@ -789,6 +789,8 @@ pprCallishMachOp_for_C mop
         MO_Memcmp _     -> text "memcmp"
         (MO_BSwap w)    -> ptext (sLit $ bSwapLabel w)
         (MO_PopCnt w)   -> ptext (sLit $ popCntLabel w)
+        (MO_Pext w)     -> ptext (sLit $ pextLabel w)
+        (MO_Pdep w)     -> ptext (sLit $ pdepLabel w)
         (MO_Clz w)      -> ptext (sLit $ clzLabel w)
         (MO_Ctz w)      -> ptext (sLit $ ctzLabel w)
         (MO_AtomicRMW w amop) -> ptext (sLit $ atomicRMWLabel w amop)
index da652bf..1807499 100644 (file)
@@ -584,6 +584,20 @@ emitPrimOp _      [res] PopCnt32Op [w] = emitPopCntCall res w W32
 emitPrimOp _      [res] PopCnt64Op [w] = emitPopCntCall res w W64
 emitPrimOp dflags [res] PopCntOp   [w] = emitPopCntCall res w (wordWidth dflags)
 
+-- Parallel bit deposit
+emitPrimOp _      [res] Pdep8Op  [src, mask] = emitPdepCall res src mask W8
+emitPrimOp _      [res] Pdep16Op [src, mask] = emitPdepCall res src mask W16
+emitPrimOp _      [res] Pdep32Op [src, mask] = emitPdepCall res src mask W32
+emitPrimOp _      [res] Pdep64Op [src, mask] = emitPdepCall res src mask W64
+emitPrimOp dflags [res] PdepOp   [src, mask] = emitPdepCall res src mask (wordWidth dflags)
+
+-- Parallel bit extract
+emitPrimOp _      [res] Pext8Op  [src, mask] = emitPextCall res src mask W8
+emitPrimOp _      [res] Pext16Op [src, mask] = emitPextCall res src mask W16
+emitPrimOp _      [res] Pext32Op [src, mask] = emitPextCall res src mask W32
+emitPrimOp _      [res] Pext64Op [src, mask] = emitPextCall res src mask W64
+emitPrimOp dflags [res] PextOp   [src, mask] = emitPextCall res src mask (wordWidth dflags)
+
 -- count leading zeros
 emitPrimOp _      [res] Clz8Op  [w] = emitClzCall res w W8
 emitPrimOp _      [res] Clz16Op [w] = emitClzCall res w W16
@@ -865,6 +879,56 @@ callishPrimOpSupported dflags op
                          || llvm      -> Left MO_F64_Fabs
                      | otherwise      -> Right $ genericFabsOp W64
 
+      -- Pdep8Op        | (ncg && (x86ish
+      --                           || ppc))
+      --                    || llvm      -> Left (MO_Pdep    (wordWidth dflags))
+      --                | otherwise      -> error "TODO: Implement (Right genericPdep8Op)"
+
+      -- Pdep16Op       | (ncg && (x86ish
+      --                           || ppc))
+      --                    || llvm      -> Left (MO_Pdep    (wordWidth dflags))
+      --                | otherwise      -> error "TODO: Implement (Right genericPdep16Op)"
+
+      -- Pdep32Op       | (ncg && (x86ish
+      --                           || ppc))
+      --                    || llvm      -> Left (MO_Pdep    (wordWidth dflags))
+
+      --                | otherwise      -> error "TODO: Implement (Right genericPdep32Op)"
+      -- Pdep64Op       | (ncg && (x86ish
+      --                           || ppc))
+      --                    || llvm      -> Left (MO_Pdep    (wordWidth dflags))
+      --                | otherwise      -> error "TODO: Implement (Right genericPdep64Op)"
+
+      -- PdepOp         | (ncg && (x86ish
+      --                           || ppc))
+      --                    || llvm      -> Left (MO_Pdep    (wordWidth dflags))
+      --                | otherwise      -> error "TODO: Implement (Right genericPdepOp)"
+
+      -- Pext8Op        | (ncg && (x86ish
+      --                           || ppc))
+      --                    || llvm      -> Left (MO_Pext    (wordWidth dflags))
+      --                | otherwise      -> error "TODO: Implement (Right genericPext8Op)"
+
+      -- Pext16Op       | (ncg && (x86ish
+      --                           || ppc))
+      --                    || llvm      -> Left (MO_Pext    (wordWidth dflags))
+      --                | otherwise      -> error "TODO: Implement (Right genericPext16Op)"
+
+      -- Pext32Op       | (ncg && (x86ish
+      --                           || ppc))
+      --                    || llvm      -> Left (MO_Pext    (wordWidth dflags))
+      --                | otherwise      -> error "TODO: Implement (Right genericPext32Op)"
+
+      -- Pext64Op       | (ncg && (x86ish
+      --                           || ppc))
+      --                    || llvm      -> Left (MO_Pext    (wordWidth dflags))
+      --                | otherwise      -> error "TODO: Implement (Right genericPext64Op)"
+
+      -- PextOp         | (ncg && (x86ish
+      --                           || ppc))
+      --                    || llvm      -> Left (MO_Pext    (wordWidth dflags))
+      --                | otherwise      -> error "TODO: Implement (Right genericPextOp)"
+
       _ -> pprPanic "emitPrimOp: can't translate PrimOp " (ppr op)
  where
   ncg = case hscTarget dflags of
@@ -2266,6 +2330,20 @@ emitPopCntCall res x width = do
         (MO_PopCnt width)
         [ x ]
 
+emitPdepCall :: LocalReg -> CmmExpr -> CmmExpr -> Width -> FCode ()
+emitPdepCall res x y width = do
+    emitPrimCall
+        [ res ]
+        (MO_Pdep width)
+        [ x, y ]
+
+emitPextCall :: LocalReg -> CmmExpr -> CmmExpr -> Width -> FCode ()
+emitPextCall res x y width = do
+    emitPrimCall
+        [ res ]
+        (MO_Pext width)
+        [ x, y ]
+
 emitClzCall :: LocalReg -> CmmExpr -> Width -> FCode ()
 emitClzCall res x width = do
     emitPrimCall
index c8f7366..93b767e 100644 (file)
@@ -870,4 +870,3 @@ mkAbsentErrorApp res_ty err_msg
   = mkApps (Var aBSENT_ERROR_ID) [ Type res_ty, err_string ]
   where
     err_string = Lit (mkMachString err_msg)
-
index a88642b..8ee9a67 100644 (file)
@@ -218,6 +218,10 @@ genCall t@(PrimTarget (MO_Prefetch_Data localityInt)) [] args
 -- and return types
 genCall t@(PrimTarget (MO_PopCnt w)) dsts args =
     genCallSimpleCast w t dsts args
+genCall t@(PrimTarget (MO_Pdep w)) dsts args =
+    genCallSimpleCast w t dsts args
+genCall t@(PrimTarget (MO_Pext w)) dsts args =
+    genCallSimpleCast w t dsts args
 genCall t@(PrimTarget (MO_Clz w)) dsts args =
     genCallSimpleCast w t dsts args
 genCall t@(PrimTarget (MO_Ctz w)) dsts args =
@@ -731,6 +735,8 @@ cmmPrimOpFunctions mop = do
     MO_Memcmp _   -> fsLit $ "memcmp"
 
     (MO_PopCnt w) -> fsLit $ "llvm.ctpop."  ++ showSDoc dflags (ppr $ widthToLlvmInt w)
+    (MO_Pdep w)   -> fsLit $ "llvm.pdep."   ++ showSDoc dflags (ppr $ widthToLlvmInt w)
+    (MO_Pext w)   -> fsLit $ "llvm.pext."   ++ showSDoc dflags (ppr $ widthToLlvmInt w)
     (MO_BSwap w)  -> fsLit $ "llvm.bswap."  ++ showSDoc dflags (ppr $ widthToLlvmInt w)
     (MO_Clz w)    -> fsLit $ "llvm.ctlz."   ++ showSDoc dflags (ppr $ widthToLlvmInt w)
     (MO_Ctz w)    -> fsLit $ "llvm.cttz."   ++ showSDoc dflags (ppr $ widthToLlvmInt w)
index 0e6310e..53a4033 100644 (file)
@@ -149,6 +149,8 @@ module DynFlags (
         isSseEnabled,
         isSse2Enabled,
         isSse4_2Enabled,
+        isBmiEnabled,
+        isBmi2Enabled,
         isAvxEnabled,
         isAvx2Enabled,
         isAvx512cdEnabled,
@@ -937,6 +939,7 @@ data DynFlags = DynFlags {
 
   -- | Machine dependent flags (-m<blah> stuff)
   sseVersion            :: Maybe SseVersion,
+  bmiVersion            :: Maybe BmiVersion,
   avx                   :: Bool,
   avx2                  :: Bool,
   avx512cd              :: Bool, -- Enable AVX-512 Conflict Detection Instructions.
@@ -1737,6 +1740,7 @@ defaultDynFlags mySettings myLlvmTargets =
         interactivePrint = Nothing,
         nextWrapperNum = panic "defaultDynFlags: No nextWrapperNum",
         sseVersion = Nothing,
+        bmiVersion = Nothing,
         avx = False,
         avx2 = False,
         avx512cd = False,
@@ -3126,6 +3130,10 @@ dynamic_flags_deps = [
                                                   d { sseVersion = Just SSE4 }))
   , make_ord_flag defGhcFlag "msse4.2"      (noArg (\d ->
                                                  d { sseVersion = Just SSE42 }))
+  , make_ord_flag defGhcFlag "mbmi"         (noArg (\d ->
+                                                 d { bmiVersion = Just BMI1 }))
+  , make_ord_flag defGhcFlag "mbmi2"        (noArg (\d ->
+                                                 d { bmiVersion = Just BMI2 }))
   , make_ord_flag defGhcFlag "mavx"         (noArg (\d -> d { avx = True }))
   , make_ord_flag defGhcFlag "mavx2"        (noArg (\d -> d { avx2 = True }))
   , make_ord_flag defGhcFlag "mavx512cd"    (noArg (\d ->
@@ -5368,6 +5376,25 @@ isAvx512pfEnabled :: DynFlags -> Bool
 isAvx512pfEnabled dflags = avx512pf dflags
 
 -- -----------------------------------------------------------------------------
+-- BMI2
+
+data BmiVersion = BMI1
+                | BMI2
+                deriving (Eq, Ord)
+
+isBmiEnabled :: DynFlags -> Bool
+isBmiEnabled dflags = case platformArch (targetPlatform dflags) of
+    ArchX86_64 -> bmiVersion dflags >= Just BMI1
+    ArchX86    -> bmiVersion dflags >= Just BMI1
+    _          -> False
+
+isBmi2Enabled :: DynFlags -> Bool
+isBmi2Enabled dflags = case platformArch (targetPlatform dflags) of
+    ArchX86_64 -> bmiVersion dflags >= Just BMI2
+    ArchX86    -> bmiVersion dflags >= Just BMI2
+    _          -> False
+
+-- -----------------------------------------------------------------------------
 -- Linker/compiler information
 
 -- LinkerInfo contains any extra options needed by the system linker.
index ad61a00..399d646 100644 (file)
@@ -5,6 +5,8 @@ module CPrim
     , atomicRMWLabel
     , cmpxchgLabel
     , popCntLabel
+    , pdepLabel
+    , pextLabel
     , bSwapLabel
     , clzLabel
     , ctzLabel
@@ -26,6 +28,24 @@ popCntLabel w = "hs_popcnt" ++ pprWidth w
     pprWidth W64 = "64"
     pprWidth w   = pprPanic "popCntLabel: Unsupported word width " (ppr w)
 
+pdepLabel :: Width -> String
+pdepLabel w = "hs_pdep" ++ pprWidth w
+  where
+    pprWidth W8  = "8"
+    pprWidth W16 = "16"
+    pprWidth W32 = "32"
+    pprWidth W64 = "64"
+    pprWidth w   = pprPanic "pdepLabel: Unsupported word width " (ppr w)
+
+pextLabel :: Width -> String
+pextLabel w = "hs_pext" ++ pprWidth w
+  where
+    pprWidth W8  = "8"
+    pprWidth W16 = "16"
+    pprWidth W32 = "32"
+    pprWidth W64 = "64"
+    pprWidth w   = pprPanic "pextLabel: Unsupported word width " (ppr w)
+
 bSwapLabel :: Width -> String
 bSwapLabel w = "hs_bswap" ++ pprWidth w
   where
index 898a31a..e2c568c 100644 (file)
@@ -2004,6 +2004,8 @@ genCCall' dflags gcp target dest_regs args
 
                     MO_BSwap w   -> (fsLit $ bSwapLabel w, False)
                     MO_PopCnt w  -> (fsLit $ popCntLabel w, False)
+                    MO_Pdep w    -> (fsLit $ pdepLabel w, False)
+                    MO_Pext w    -> (fsLit $ pextLabel w, False)
                     MO_Clz _     -> unsupported
                     MO_Ctz _     -> unsupported
                     MO_AtomicRMW {} -> unsupported
index 55c1d15..6dfd589 100644 (file)
@@ -654,6 +654,8 @@ outOfLineMachOp_table mop
 
         MO_BSwap w   -> fsLit $ bSwapLabel w
         MO_PopCnt w  -> fsLit $ popCntLabel w
+        MO_Pdep w    -> fsLit $ pdepLabel w
+        MO_Pext w    -> fsLit $ pextLabel w
         MO_Clz w     -> fsLit $ clzLabel w
         MO_Ctz w     -> fsLit $ ctzLabel w
         MO_AtomicRMW w amop -> fsLit $ atomicRMWLabel w amop
index 6c0e0ac..62ed721 100644 (file)
@@ -1872,6 +1872,72 @@ genCCall dflags is32Bit (PrimTarget (MO_PopCnt width)) dest_regs@[dst]
     format = intFormat width
     lbl = mkCmmCodeLabel primUnitId (fsLit (popCntLabel width))
 
+genCCall dflags is32Bit (PrimTarget (MO_Pdep width)) dest_regs@[dst]
+         args@[src, mask] = do
+    let platform = targetPlatform dflags
+    if isBmi2Enabled dflags
+        then do code_src  <- getAnyReg src
+                code_mask <- getAnyReg mask
+                src_r     <- getNewRegNat format
+                mask_r    <- getNewRegNat format
+                let dst_r = getRegisterReg platform False (CmmLocal dst)
+                return $ code_src src_r `appOL` code_mask mask_r `appOL`
+                    (if width == W8 then
+                         -- The PDEP instruction doesn't take a r/m8
+                         unitOL (MOVZxL II8  (OpReg src_r ) (OpReg src_r )) `appOL`
+                         unitOL (MOVZxL II8  (OpReg mask_r) (OpReg mask_r)) `appOL`
+                         unitOL (PDEP   II16 (OpReg mask_r) (OpReg src_r ) dst_r)
+                     else
+                         unitOL (PDEP format (OpReg mask_r) (OpReg src_r) dst_r)) `appOL`
+                    (if width == W8 || width == W16 then
+                         -- We used a 16-bit destination register above,
+                         -- so zero-extend
+                         unitOL (MOVZxL II16 (OpReg dst_r) (OpReg dst_r))
+                     else nilOL)
+        else do
+            targetExpr <- cmmMakeDynamicReference dflags
+                          CallReference lbl
+            let target = ForeignTarget targetExpr (ForeignConvention CCallConv
+                                                           [NoHint] [NoHint]
+                                                           CmmMayReturn)
+            genCCall dflags is32Bit target dest_regs args
+  where
+    format = intFormat width
+    lbl = mkCmmCodeLabel primUnitId (fsLit (pdepLabel width))
+
+genCCall dflags is32Bit (PrimTarget (MO_Pext width)) dest_regs@[dst]
+         args@[src, mask] = do
+    let platform = targetPlatform dflags
+    if isBmi2Enabled dflags
+        then do code_src  <- getAnyReg src
+                code_mask <- getAnyReg mask
+                src_r     <- getNewRegNat format
+                mask_r    <- getNewRegNat format
+                let dst_r = getRegisterReg platform False (CmmLocal dst)
+                return $ code_src src_r `appOL` code_mask mask_r `appOL`
+                    (if width == W8 then
+                         -- The PEXT instruction doesn't take a r/m8
+                         unitOL (MOVZxL II8 (OpReg src_r ) (OpReg src_r )) `appOL`
+                         unitOL (MOVZxL II8 (OpReg mask_r) (OpReg mask_r)) `appOL`
+                         unitOL (PEXT II16 (OpReg mask_r) (OpReg src_r) dst_r)
+                     else
+                         unitOL (PEXT format (OpReg mask_r) (OpReg src_r) dst_r)) `appOL`
+                    (if width == W8 || width == W16 then
+                         -- We used a 16-bit destination register above,
+                         -- so zero-extend
+                         unitOL (MOVZxL II16 (OpReg dst_r) (OpReg dst_r))
+                     else nilOL)
+        else do
+            targetExpr <- cmmMakeDynamicReference dflags
+                          CallReference lbl
+            let target = ForeignTarget targetExpr (ForeignConvention CCallConv
+                                                           [NoHint] [NoHint]
+                                                           CmmMayReturn)
+            genCCall dflags is32Bit target dest_regs args
+  where
+    format = intFormat width
+    lbl = mkCmmCodeLabel primUnitId (fsLit (pextLabel width))
+
 genCCall dflags is32Bit (PrimTarget (MO_Clz width)) dest_regs@[dst] args@[src]
   | is32Bit && width == W64 = do
     -- Fallback to `hs_clz64` on i386
@@ -2689,6 +2755,9 @@ outOfLineCmmOp mop res args
               MO_Clz w     -> fsLit $ clzLabel w
               MO_Ctz _     -> unsupported
 
+              MO_Pdep _    -> fsLit "hs_pdep"
+              MO_Pext _    -> fsLit "hs_pext"
+
               MO_AtomicRMW _ _ -> fsLit "atomicrmw"
               MO_AtomicRead _  -> fsLit "atomicread"
               MO_AtomicWrite _ -> fsLit "atomicwrite"
index 1bb682a..fbe7383 100644 (file)
@@ -345,6 +345,10 @@ data Instr
         | BSF         Format Operand Reg -- bit scan forward
         | BSR         Format Operand Reg -- bit scan reverse
 
+    -- bit manipulation instructions
+        | PDEP        Format Operand Operand Reg -- [BMI2] deposit bits to   the specified mask
+        | PEXT        Format Operand Operand Reg -- [BMI2] extract bits from the specified mask
+
     -- prefetch
         | PREFETCH  PrefetchVariant Format Operand -- prefetch Variant, addr size, address to prefetch
                                         -- variant can be NTA, Lvl0, Lvl1, or Lvl2
@@ -464,6 +468,9 @@ x86_regUsageOfInstr platform instr
     BSF    _ src dst -> mkRU (use_R src []) [dst]
     BSR    _ src dst -> mkRU (use_R src []) [dst]
 
+    PDEP   _ src mask dst -> mkRU (use_R src $ use_R mask []) [dst]
+    PEXT   _ src mask dst -> mkRU (use_R src $ use_R mask []) [dst]
+
     -- note: might be a better way to do this
     PREFETCH _  _ src -> mkRU (use_R src []) []
     LOCK i              -> x86_regUsageOfInstr platform i
@@ -640,6 +647,8 @@ x86_patchRegsOfInstr instr env
     CLTD _              -> instr
 
     POPCNT fmt src dst -> POPCNT fmt (patchOp src) (env dst)
+    PDEP   fmt src mask dst -> PDEP   fmt (patchOp src) (patchOp mask) (env dst)
+    PEXT   fmt src mask dst -> PEXT   fmt (patchOp src) (patchOp mask) (env dst)
     BSF    fmt src dst -> BSF    fmt (patchOp src) (env dst)
     BSR    fmt src dst -> BSR    fmt (patchOp src) (env dst)
 
index 84ce751..f5011b2 100644 (file)
@@ -648,6 +648,9 @@ pprInstr (POPCNT format src dst) = pprOpOp (sLit "popcnt") format src (OpReg dst
 pprInstr (BSF format src dst)    = pprOpOp (sLit "bsf")    format src (OpReg dst)
 pprInstr (BSR format src dst)    = pprOpOp (sLit "bsr")    format src (OpReg dst)
 
+pprInstr (PDEP format src mask dst)   = pprFormatOpOpReg (sLit "pdep") format src mask dst
+pprInstr (PEXT format src mask dst)   = pprFormatOpOpReg (sLit "pext") format src mask dst
+
 pprInstr (PREFETCH NTA format src ) = pprFormatOp_ (sLit "prefetchnta") format src
 pprInstr (PREFETCH Lvl0 format src) = pprFormatOp_ (sLit "prefetcht0") format src
 pprInstr (PREFETCH Lvl1 format src) = pprFormatOp_ (sLit "prefetcht1") format src
@@ -1262,6 +1265,16 @@ pprFormatRegRegReg name format reg1 reg2 reg3
         pprReg format reg3
     ]
 
+pprFormatOpOpReg :: LitString -> Format -> Operand -> Operand -> Reg -> SDoc
+pprFormatOpOpReg name format op1 op2 reg3
+  = hcat [
+        pprMnemonic name format,
+        pprOperand format op1,
+        comma,
+        pprOperand format op2,
+        comma,
+        pprReg format reg3
+    ]
 
 pprFormatAddrReg :: LitString -> Format -> AddrMode -> Reg -> SDoc
 pprFormatAddrReg name format op dst
index ce72036..952d474 100644 (file)
@@ -403,6 +403,28 @@ primop   PopCnt64Op   "popCnt64#"   GenPrimOp   WORD64 -> Word#
 primop   PopCntOp   "popCnt#"   Monadic   Word# -> Word#
     {Count the number of set bits in a word.}
 
+primop   Pdep8Op   "pdep8#"   Dyadic   Word# -> Word# -> Word#
+    {Deposit bits to lower 8 bits of a word at locations specified by a mask.}
+primop   Pdep16Op   "pdep16#"   Dyadic   Word# -> Word# -> Word#
+    {Deposit bits to lower 16 bits of a word at locations specified by a mask.}
+primop   Pdep32Op   "pdep32#"   Dyadic   Word# -> Word# -> Word#
+    {Deposit bits to lower 32 bits of a word at locations specified by a mask.}
+primop   Pdep64Op   "pdep64#"   GenPrimOp   WORD64 -> WORD64 -> Word#
+    {Deposit bits to a word at locations specified by a mask.}
+primop   PdepOp   "pdep#"   Dyadic   Word# -> Word# -> Word#
+    {Deposit bits to a word at locations specified by a mask.}
+
+primop   Pext8Op   "pext8#"   Dyadic   Word# -> Word# -> Word#
+    {Extract bits from lower 8 bits of a word at locations specified by a mask.}
+primop   Pext16Op   "pext16#"   Dyadic   Word# -> Word# -> Word#
+    {Extract bits from lower 16 bits of a word at locations specified by a mask.}
+primop   Pext32Op   "pext32#"   Dyadic   Word# -> Word# -> Word#
+    {Extract bits from lower 32 bits of a word at locations specified by a mask.}
+primop   Pext64Op   "pext64#"   GenPrimOp   WORD64 -> WORD64 -> Word#
+    {Extract bits from a word at locations specified by a mask.}
+primop   PextOp   "pext#"   Dyadic   Word# -> Word# -> Word#
+    {Extract bits from a word at locations specified by a mask.}
+
 primop   Clz8Op   "clz8#" Monadic   Word# -> Word#
     {Count leading zeros in the lower 8 bits of a word.}
 primop   Clz16Op   "clz16#" Monadic   Word# -> Word#
diff --git a/libraries/ghc-prim/cbits/pdep.c b/libraries/ghc-prim/cbits/pdep.c
new file mode 100644 (file)
index 0000000..a3b7da3
--- /dev/null
@@ -0,0 +1,71 @@
+#include "Rts.h"
+#include "MachDeps.h"
+
+extern StgWord hs_pdep64(StgWord64 src, StgWord mask);
+StgWord
+hs_pdep64(StgWord src, StgWord mask)
+{
+  uint64_t result = 0;
+
+  while (1) {
+    // Mask out all but the lowest bit
+    const uint64_t lowest = (-mask & mask);
+
+    if (lowest == 0) {
+      break;
+    }
+
+    const uint64_t lsb = (uint64_t)((int64_t)(src << 63) >> 63);
+
+    result |= lsb & lowest;
+    mask &= ~lowest;
+    src >>= 1;
+  }
+
+  return result;
+}
+
+extern StgWord hs_pdep32(StgWord src, StgWord mask);
+StgWord
+hs_pdep32(StgWord src, StgWord mask)
+{
+  return hs_pdep64(src, mask);
+}
+
+extern StgWord hs_pdep16(StgWord src, StgWord mask);
+StgWord
+hs_pdep16(StgWord src, StgWord mask)
+{
+  return hs_pdep64(src, mask);
+}
+
+extern StgWord hs_pdep8(StgWord src, StgWord mask);
+StgWord
+hs_pdep8(StgWord src, StgWord mask)
+{
+  return hs_pdep64(src, mask);
+}
+
+#if WORD_SIZE_IN_BITS == 32
+
+extern StgWord hs_pdep(StgWord src, StgWord mask);
+StgWord
+hs_pdep(StgWord src, StgWord mask)
+{
+  return hs_pdep64(src, mask);
+}
+
+#elif WORD_SIZE_IN_BITS == 64
+
+extern StgWord hs_pdep(StgWord src, StgWord mask);
+StgWord
+hs_pdep(StgWord src, StgWord mask)
+{
+  return hs_pdep64(src, mask);
+}
+
+#else
+
+#error Unknown machine word size
+
+#endif
diff --git a/libraries/ghc-prim/cbits/pext.c b/libraries/ghc-prim/cbits/pext.c
new file mode 100644 (file)
index 0000000..d08fb94
--- /dev/null
@@ -0,0 +1,67 @@
+#include "Rts.h"
+#include "MachDeps.h"
+
+extern StgWord hs_pext64(StgWord src, StgWord mask);
+StgWord
+hs_pext64(StgWord src, StgWord mask)
+{
+  uint64_t result = 0;
+  int offset = 0;
+
+  for (int bit = 0; bit != sizeof(uint64_t) * 8; ++bit) {
+    const uint64_t src_bit = (src >> bit) & 1;
+    const uint64_t mask_bit = (mask >> bit) & 1;
+
+    if (mask_bit) {
+      result |= (uint64_t)(src_bit) << offset;
+      ++offset;
+    }
+  }
+
+  return result;
+}
+
+extern StgWord hs_pext32(StgWord src, StgWord mask);
+StgWord
+hs_pext32(StgWord src, StgWord mask)
+{
+  return hs_pext64(src, mask);
+}
+
+extern StgWord hs_pext16(StgWord src, StgWord mask);
+StgWord
+hs_pext16(StgWord src, StgWord mask)
+{
+  return hs_pext64(src, mask);
+}
+
+extern StgWord hs_pext8(StgWord src, StgWord mask);
+StgWord
+hs_pext8(StgWord src, StgWord mask)
+{
+  return hs_pext64(src, mask);
+}
+
+#if WORD_SIZE_IN_BITS == 32
+
+extern StgWord hs_pext(StgWord src, StgWord mask);
+StgWord
+hs_pext(StgWord src, StgWord mask)
+{
+  return hs_pext64(src, mask);
+}
+
+#elif WORD_SIZE_IN_BITS == 64
+
+extern StgWord hs_pext(StgWord src, StgWord mask);
+StgWord
+hs_pext(StgWord src, StgWord mask)
+{
+  return hs_pext64(src, mask);
+}
+
+#else
+
+#error Unknown machine word size
+
+#endif
index 5b6b857..ca50808 100644 (file)
@@ -77,6 +77,8 @@ Library
         cbits/ctz.c
         cbits/debug.c
         cbits/longlong.c
+        cbits/pdep.c
+        cbits/pext.c
         cbits/popcnt.c
         cbits/word2float.c
 
index 214a9d5..42d8a2f 100644 (file)
@@ -77,6 +77,8 @@ test('cgrun069', omit_ways(['ghci']), multi_compile_and_run,
 test('cgrun070', normal, compile_and_run, [''])
 test('cgrun071', normal, compile_and_run, [''])
 test('cgrun072', normal, compile_and_run, [''])
+test('cgrun075', normal, compile_and_run, [''])
+test('cgrun076', normal, compile_and_run, [''])
 
 test('T1852', normal, compile_and_run, [''])
 test('T1861', extra_run_opts('0'), compile_and_run, [''])
diff --git a/testsuite/tests/codeGen/should_run/cgrun075.hs b/testsuite/tests/codeGen/should_run/cgrun075.hs
new file mode 100644 (file)
index 0000000..09e35b4
--- /dev/null
@@ -0,0 +1,115 @@
+{-# LANGUAGE BangPatterns, CPP, MagicHash #-}
+
+module Main ( main ) where
+
+import Data.Bits
+import GHC.Int
+import GHC.Prim
+import GHC.Word
+import Data.Int
+import Data.Word
+
+#include "MachDeps.h"
+
+main = putStr
+        (   test_pdep   ++ "\n"
+        ++  test_pdep8  ++ "\n"
+        ++  test_pdep16 ++ "\n"
+        ++  test_pdep32 ++ "\n"
+        ++  test_pdep64 ++ "\n"
+        ++  "\n"
+        )
+
+class Pdep a where
+  pdep :: a -> a -> a
+
+instance Pdep Word where
+  pdep (W#   src#) (W#   mask#) = W#   (pdep#   src# mask#)
+
+instance Pdep Word8 where
+  pdep (W8#  src#) (W8#  mask#) = W8#  (pdep8#  src# mask#)
+
+instance Pdep Word16 where
+  pdep (W16# src#) (W16# mask#) = W16# (pdep16# src# mask#)
+
+instance Pdep Word32 where
+  pdep (W32# src#) (W32# mask#) = W32# (pdep32# src# mask#)
+
+instance Pdep Word64 where
+  pdep (W64# src#) (W64# mask#) = W64# (pdep64# src# mask#)
+
+class SlowPdep a where
+  slowPdep :: a -> a -> a
+
+instance SlowPdep Word where
+  slowPdep s m = fromIntegral (slowPdep64 (fromIntegral s) (fromIntegral m))
+
+instance SlowPdep Word8 where
+  slowPdep s m = fromIntegral (slowPdep64 (fromIntegral s) (fromIntegral m))
+
+instance SlowPdep Word16 where
+  slowPdep s m = fromIntegral (slowPdep64 (fromIntegral s) (fromIntegral m))
+
+instance SlowPdep Word32 where
+  slowPdep s m = fromIntegral (slowPdep64 (fromIntegral s) (fromIntegral m))
+
+instance SlowPdep Word64 where
+  slowPdep s m = fromIntegral (slowPdep64 (fromIntegral s) (fromIntegral m))
+
+slowPdep64 :: Word64 -> Word64 -> Word64
+slowPdep64 = slowPdep64' 0
+
+slowPdep32 :: Word32 -> Word32 -> Word32
+slowPdep32 s m = fromIntegral (slowPdep64 (fromIntegral s) (fromIntegral m))
+
+lsb :: Word64 -> Word64
+lsb src = fromIntegral ((fromIntegral (src `shiftL` 63) :: Int64) `shiftR` 63)
+
+slowPdep64' :: Word64 -> Word64 -> Word64 -> Word64
+slowPdep64' result src mask = if lowest /= 0
+  then slowPdep64' newResult (src `shiftR` 1) (mask .&. complement lowest)
+  else result
+  where lowest    = (-mask) .&. mask
+        newResult = (result .|. ((lsb src) .&. lowest))
+
+test_pdep   = test (0 :: Word  ) pdep slowPdep
+test_pdep8  = test (0 :: Word8 ) pdep slowPdep
+test_pdep16 = test (0 :: Word16) pdep slowPdep
+test_pdep32 = test (0 :: Word32) pdep slowPdep
+test_pdep64 = test (0 :: Word64) pdep slowPdep
+
+mask n = (2 ^ n) - 1
+
+fst4 :: (a, b, c, d) -> a
+fst4 (a, _, _, _) = a
+
+runCase :: Eq a
+        => (a -> a -> a)
+        -> (a -> a -> a)
+        -> (a, a)
+        -> (Bool, a, a, (a, a))
+runCase fast slow (x, y) = (slow x y == fast x y, slow x y, fast x y, (x, y))
+
+test :: (Show a, Num a, Eq a) => a -> (a -> a -> a) -> (a -> a -> a) -> String
+test _ fast slow = case failing of
+    [] -> "OK"
+    ((_, e, a, i):xs) ->
+        "FAIL\n" ++ "   Input: " ++ show i ++ "\nExpected: " ++ show e ++
+        "\n  Actual: " ++ show a
+  where failing = dropWhile fst4 . map (runCase fast slow) $ cases
+        cases   = (,) <$> numbers <*> numbers
+        -- 10 random numbers
+#if SIZEOF_HSWORD == 4
+        numbers = [ 1480294021, 1626858410, 2316287658, 1246556957, 3806579062
+                  , 65945563  , 1521588071, 791321966 , 1355466914, 2284998160
+                  ]
+#elif SIZEOF_HSWORD == 8
+        numbers = [ 11004539497957619752, 5625461252166958202
+                  , 1799960778872209546 , 16979826074020750638
+                  , 12789915432197771481, 11680809699809094550
+                  , 13208678822802632247, 13794454868797172383
+                  , 13364728999716654549, 17516539991479925226
+                  ]
+#else
+# error Unexpected word size
+#endif
diff --git a/testsuite/tests/codeGen/should_run/cgrun075.stdout b/testsuite/tests/codeGen/should_run/cgrun075.stdout
new file mode 100644 (file)
index 0000000..e22e2cd
--- /dev/null
@@ -0,0 +1,6 @@
+OK
+OK
+OK
+OK
+OK
+
diff --git a/testsuite/tests/codeGen/should_run/cgrun076.hs b/testsuite/tests/codeGen/should_run/cgrun076.hs
new file mode 100644 (file)
index 0000000..7fa42d7
--- /dev/null
@@ -0,0 +1,115 @@
+{-# LANGUAGE BangPatterns, CPP, MagicHash #-}
+
+module Main ( main ) where
+
+import Data.Bits
+import GHC.Int
+import GHC.Prim
+import GHC.Word
+import Data.Int
+import Data.Word
+
+#include "MachDeps.h"
+
+main = putStr
+        (   test_pext   ++ "\n"
+        ++  test_pext8  ++ "\n"
+        ++  test_pext16 ++ "\n"
+        ++  test_pext32 ++ "\n"
+        ++  test_pext64 ++ "\n"
+        ++  "\n"
+        )
+
+class Pext a where
+  pext :: a -> a -> a
+
+instance Pext Word where
+  pext (W#   src#) (W#   mask#) = W#   (pext#   src# mask#)
+
+instance Pext Word8 where
+  pext (W8#  src#) (W8#  mask#) = W8#  (pext8#  src# mask#)
+
+instance Pext Word16 where
+  pext (W16# src#) (W16# mask#) = W16# (pext16# src# mask#)
+
+instance Pext Word32 where
+  pext (W32# src#) (W32# mask#) = W32# (pext32# src# mask#)
+
+instance Pext Word64 where
+  pext (W64# src#) (W64# mask#) = W64# (pext64# src# mask#)
+
+class SlowPext a where
+  slowPext :: a -> a -> a
+
+instance SlowPext Word where
+  slowPext s m = fromIntegral (slowPext64 (fromIntegral s) (fromIntegral m))
+
+instance SlowPext Word8 where
+  slowPext s m = fromIntegral (slowPext64 (fromIntegral s) (fromIntegral m))
+
+instance SlowPext Word16 where
+  slowPext s m = fromIntegral (slowPext64 (fromIntegral s) (fromIntegral m))
+
+instance SlowPext Word32 where
+  slowPext s m = fromIntegral (slowPext64 (fromIntegral s) (fromIntegral m))
+
+instance SlowPext Word64 where
+  slowPext s m = fromIntegral (slowPext64 (fromIntegral s) (fromIntegral m))
+
+slowPext64 :: Word64 -> Word64 -> Word64
+slowPext64 = slowPext64' 0 0 0
+
+slowPext32 :: Word32 -> Word32 -> Word32
+slowPext32 s m = fromIntegral (slowPext64 (fromIntegral s) (fromIntegral m))
+
+slowPext64' :: Word64 -> Int -> Int -> Word64 -> Word64 -> Word64
+slowPext64' result offset index src mask = if index /= 64
+  then if maskBit /= 0
+          then slowPext64' nextResult (offset + 1) (index + 1) src mask
+          else slowPext64' result      offset      (index + 1) src mask
+  else result
+  where srcBit      = (src  `shiftR` index) .&. 1
+        maskBit     = (mask `shiftR` index) .&. 1
+        nextResult  = result .|. (srcBit `shiftL` offset)
+
+test_pext   = test (0 :: Word  ) pext slowPext
+test_pext8  = test (0 :: Word8 ) pext slowPext
+test_pext16 = test (0 :: Word16) pext slowPext
+test_pext32 = test (0 :: Word32) pext slowPext
+test_pext64 = test (0 :: Word64) pext slowPext
+
+mask n = (2 ^ n) - 1
+
+fst4 :: (a, b, c, d) -> a
+fst4 (a, _, _, _) = a
+
+runCase :: Eq a
+        => (a -> a -> a)
+        -> (a -> a -> a)
+        -> (a, a)
+        -> (Bool, a, a, (a, a))
+runCase fast slow (x, y) = (slow x y == fast x y, slow x y, fast x y, (x, y))
+
+test :: (Show a, Num a, Eq a) => a -> (a -> a -> a) -> (a -> a -> a) -> String
+test _ fast slow = case failing of
+    [] -> "OK"
+    ((_, e, a, i):xs) ->
+        "FAIL\n" ++ "   Input: " ++ show i ++ "\nExpected: " ++ show e ++
+        "\n  Actual: " ++ show a
+  where failing = dropWhile fst4 . map (runCase fast slow) $ cases
+        cases   = (,) <$> numbers <*> numbers
+        -- 10 random numbers
+#if SIZEOF_HSWORD == 4
+        numbers = [ 1480294021, 1626858410, 2316287658, 1246556957, 3806579062
+                  , 65945563  , 1521588071, 791321966 , 1355466914, 2284998160
+                  ]
+#elif SIZEOF_HSWORD == 8
+        numbers = [ 11004539497957619752, 5625461252166958202
+                  , 1799960778872209546 , 16979826074020750638
+                  , 12789915432197771481, 11680809699809094550
+                  , 13208678822802632247, 13794454868797172383
+                  , 13364728999716654549, 17516539991479925226
+                  ]
+#else
+# error Unexpected word size
+#endif
diff --git a/testsuite/tests/codeGen/should_run/cgrun076.stdout b/testsuite/tests/codeGen/should_run/cgrun076.stdout
new file mode 100644 (file)
index 0000000..e22e2cd
--- /dev/null
@@ -0,0 +1,6 @@
+OK
+OK
+OK
+OK
+OK
+