Add popcount, clz, ctz primitives

ghc/PrimTable.hs

@@ -62,6 +62,9 @@ primOps =
   , arithwi "shl" shiftL
   , arithwi "shr" shiftR
   , arith "ashr" shiftR
+  , arithu "popcount" popCount
+  , arithu "clz" countLeadingZeros
+  , arithu "ctz" countTrailingZeros
   , cmp "==" (==)
   , cmp "/=" (/=)
   , cmp "<"  (<)

lib/Data/Bits.hs

@@ -127,8 +127,10 @@ instance Bits Int where
   bitSize _ = _wordSize
   bit = bitDefault
   testBit = testBitDefault
-  popCount = popCountDefault
+  popCount = primIntPopcount
   zeroBits = 0
 
 instance FiniteBits Int where
   finiteBitSize _ = _wordSize
+  countLeadingZeros = primIntClz
+  countTrailingZeros = primIntCtz

lib/Data/Int/Instances.hs

@@ -108,11 +108,13 @@ instance Bits Int8 where
   bitSize _ = 8
   bit = bitDefault
   testBit = testBitDefault
-  popCount = popCountDefault
+  popCount (I8 x) = primIntPopcount (x .&. 0xff)
   zeroBits = 0
 
 instance FiniteBits Int8 where
   finiteBitSize _ = 8
+  countLeadingZeros (I8 x) = primIntClz (x .&. 0xff) - (_wordSize - 8)
+  countTrailingZeros (I8 x) = if x == 0 then 8 else primIntCtz x
 
 --------------------------------------------------------------------------------
 ----    Int16
@@ -202,11 +204,13 @@ instance Bits Int16 where
   bitSize _ = 16
   bit = bitDefault
   testBit = testBitDefault
-  popCount = popCountDefault
+  popCount (I16 x) = primIntPopcount (x .&. 0xffff)
   zeroBits = 0
 
 instance FiniteBits Int16 where
   finiteBitSize _ = 16
+  countLeadingZeros (I16 x) = primIntClz (x .&. 0xffff) - (_wordSize - 16)
+  countTrailingZeros (I16 x) = if x == 0 then 16 else primIntCtz x
 
 --------------------------------------------------------------------------------
 ----    Int32
@@ -296,11 +300,13 @@ instance Bits Int32 where
   bitSize _ = 32
   bit = bitDefault
   testBit = testBitDefault
-  popCount = popCountDefault
+  popCount (I32 x) = primIntPopcount (x .&. 0xffffffff)
   zeroBits = 0
 
 instance FiniteBits Int32 where
   finiteBitSize _ = 32
+  countLeadingZeros (I32 x) = primIntClz (x .&. 0xffffffff) - (_wordSize - 32)
+  countTrailingZeros (I32 x) = if x == 0 then 32 else primIntCtz x
 
 --------------------------------------------------------------------------------
 ----    Int64
@@ -389,8 +395,10 @@ instance Bits Int64 where
   bitSize _ = 64
   bit = bitDefault
   testBit = testBitDefault
-  popCount = popCountDefault
+  popCount (I64 x) = primIntPopcount x
   zeroBits = 0
 
 instance FiniteBits Int64 where
   finiteBitSize _ = 64
+  countLeadingZeros = primIntClz . unI64
+  countTrailingZeros = primIntCtz . unI64

lib/Data/Word.hs

@@ -97,11 +97,13 @@ instance Bits Word where
   bitSize _ = _wordSize
   bit = bitDefault
   testBit = testBitDefault
-  popCount = popCountDefault
+  popCount = primWordPopcount
   zeroBits = 0
 
 instance FiniteBits Word where
   finiteBitSize _ = _wordSize
+  countLeadingZeros = primWordClz
+  countTrailingZeros = primWordCtz
 
 --------------------------------------------------------------------------------
 ----    Word8
@@ -131,7 +133,7 @@ instance Num Word8 where
   (*)  = bin8 primWordMul
   abs x = x
   signum x = if x == 0 then 0 else 1
-  fromInteger i = w8 (primIntToWord (_integerToInt i))
+  fromInteger i = w8 (_integerToWord i)
 
 instance Integral Word8 where
   quot = bin8 primWordQuot
@@ -193,11 +195,13 @@ instance Bits Word8 where
   bitSize _ = 8
   bit = bitDefault
   testBit = testBitDefault
-  popCount = popCountDefault
+  popCount = primWordPopcount . unW8
   zeroBits = 0
 
 instance FiniteBits Word8 where
   finiteBitSize _ = 8
+  countLeadingZeros (W8 x) = primWordClz x - (_wordSize - 8)
+  countTrailingZeros (W8 x) = if x == 0 then 8 else primWordCtz x
 
 --------------------------------------------------------------------------------
 ----    Word16
@@ -227,7 +231,7 @@ instance Num Word16 where
   (*)  = bin16 primWordMul
   abs x = x
   signum x = if x == 0 then 0 else 1
-  fromInteger i = w16 (primIntToWord (_integerToInt i))
+  fromInteger i = w16 (_integerToWord i)
 
 instance Integral Word16 where
   quot = bin16 primWordQuot
@@ -288,11 +292,13 @@ instance Bits Word16 where
   bitSize _ = 16
   bit = bitDefault
   testBit = testBitDefault
-  popCount = popCountDefault
+  popCount = primWordPopcount . unW16
   zeroBits = 0
 
 instance FiniteBits Word16 where
   finiteBitSize _ = 16
+  countLeadingZeros (W16 x) = primWordClz x - (_wordSize - 16)
+  countTrailingZeros (W16 x) = if x == 0 then 16 else primWordCtz x
 
 --------------------------------------------------------------------------------
 ----    Word32
@@ -322,7 +328,7 @@ instance Num Word32 where
   (*)  = bin32 primWordMul
   abs x = x
   signum x = if x == 0 then 0 else 1
-  fromInteger i = w32 (primIntToWord (_integerToInt i))
+  fromInteger i = w32 (_integerToWord i)
 
 instance Integral Word32 where
   quot = bin32 primWordQuot
@@ -384,11 +390,13 @@ instance Bits Word32 where
   bitSize _ = 32
   bit = bitDefault
   testBit = testBitDefault
-  popCount = popCountDefault
+  popCount = primWordPopcount . unW32
   zeroBits = 0
 
 instance FiniteBits Word32 where
   finiteBitSize _ = 32
+  countLeadingZeros (W32 x) = primWordClz x - (_wordSize - 32)
+  countTrailingZeros (W32 x) = if x == 0 then 32 else primWordCtz x
 
 --------------------------------------------------------------------------------
 ----    Word64
@@ -418,7 +426,7 @@ instance Num Word64 where
   (*)  = bin64 primWordMul
   abs x = x
   signum x = if x == 0 then 0 else 1
-  fromInteger i = w64 (primIntToWord (_integerToInt i))
+  fromInteger i = w64 (_integerToWord i)
 
 instance Integral Word64 where
   quot = bin64 primWordQuot
@@ -480,8 +488,10 @@ instance Bits Word64 where
   bitSize _ = 64
   bit = bitDefault
   testBit = testBitDefault
-  popCount = popCountDefault
+  popCount = primWordPopcount . unW64
   zeroBits = 0
 
 instance FiniteBits Word64 where
   finiteBitSize _ = 64
+  countLeadingZeros = primWordClz . unW64
+  countTrailingZeros = primWordCtz . unW64

lib/Primitives.hs

@@ -119,6 +119,12 @@ primWordAshr :: Word -> Int -> Word
 primWordAshr  = primitive "ashr"
 primWordInv :: Word -> Word
 primWordInv  = primitive "inv"
+primWordPopcount :: Word -> Int
+primWordPopcount = primitive "popcount"
+primWordClz :: Word -> Int
+primWordClz = primitive "clz"
+primWordCtz :: Word -> Int
+primWordCtz = primitive "ctz"
 primWordToFloatWRaw :: Word -> FloatW
 primWordToFloatWRaw = primitive "toDbl"
 primWordFromFloatWRaw :: FloatW -> Word
@@ -136,6 +142,12 @@ primIntShr :: Int -> Int -> Int
 primIntShr  = primitive "ashr"
 primIntInv :: Int -> Int
 primIntInv  = primitive "inv"
+primIntPopcount :: Int -> Int
+primIntPopcount = primitive "popcount"
+primIntClz :: Int -> Int
+primIntClz = primitive "clz"
+primIntCtz :: Int -> Int
+primIntCtz = primitive "ctz"
 
 primWordEQ  :: Word -> Word -> Bool
 primWordEQ  = primitive "=="

src/MicroHs/Translate.hs

@@ -79,6 +79,9 @@ primTable = [
   ("shr", primitive "shr"),
   ("ashr", primitive "ashr"),
   ("subtract", primitive "subtract"),
+  ("popcount", primitive "popcount"),
+  ("clz", primitive "clz"),
+  ("ctz", primitive "ctz"),
   ("==", primitive "=="),
   ("/=", primitive "/="),
   ("<", primitive "<"),

src/runtime/config-mingw-64.h

@@ -43,6 +43,22 @@
  */
 #define FFS __builtin_ffsll
 
+#define POPCOUNT __builtin_popcountll
+
+#include <inttypes.h>
+
+static inline uint64_t clz(uint64_t x) {
+  if (x == 0) return 64;
+  return __builtin_clzll(x);
+}
+#define CLZ clz
+
+static inline uint64_t ctz(uint64_t x) {
+  if (x == 0) return 64;
+  return __builtin_ctzll(x);
+}
+#define CTZ ctz
+
 /*
  * This is the character used for comma-separation in printf.
  * Defaults to "'".

src/runtime/config-stm32f4.h

@@ -142,6 +142,8 @@ ffs(uintptr_t x)
 }
 #define FFS ffs
 
+#define CLZ __CLZ
+
 #define FFI_EXTRA \
   { "set_led",   (funptr_t)set_led,   FFI_IIV }, \
   { "busy_wait", (funptr_t)busy_wait, FFI_IV },

src/runtime/config-windows-64.h

@@ -62,6 +62,32 @@ ffs(int64_t arg)
 }
 #define FFS ffs
 
+#if defined(_M_X64)
+#define POPCOUNT __popcnt64
+#elif defined(_M_IX86)
+#define POPCOUNT __popcnt
+#endif
+
+static inline uint64_t clz(uint64_t x) {
+  unsigned long count;
+  if (_BitScanReverse64(&count, x)) {
+    return 63 - (uint64_t)count;
+  } else {
+    return 64;
+  }
+}
+#define CLZ clz
+
+static inline uint64_t ctz(uint64_t x) {
+  unsigned long count;
+  if (_BitScanForward64(&count, x)) {
+    return (uint64_t)count;
+  } else {
+    return 64;
+  }
+}
+#define CTZ ctz
+
 /*
  * This is the character used for comma-separation in printf.
  * Defaults to "'".