Count 1s in fixnums

count-bits.rkt

#lang racket
(require racket/unsafe/ops
         (for-syntax racket/fixnum racket/vector))
(provide fxcount)
;; Count set bits for 30 bit number in 5 steps.
;; for 62 bit number in 6.

(define-for-syntax lut
  #(#x2AAAAAAA
    #x0CCCCCCC
    #x30F0F0F0
    #x3F00FF00
    #x3FFF0000))

(define-for-syntax lut62
  #(#x2AAAAAAAAAAAAAAA
    #x0CCCCCCCCCCCCCCC
    #x30F0F0F0F0F0F0F0
    #x3F00FF00FF00FF00
    #x3FFF0000FFFF0000
    #x3FFFFFFF00000000))

(define-syntax (mk-fxcount stx)
  (syntax-case stx ()
    [(_ name)
     ;; Choose at compile time what word length is
     (let* ([lut (if (fixnum? (expt 2 61)) lut62 lut)]
            [flut (vector-map bitwise-not lut)])
       ;; Unroll the addition loop
       #`(define (name n)
           (unless (fixnum? n) (raise-argument-error 'name "fixnum?" 0 n))
           (let* #,(for/list ([m (in-vector lut)]
                              [f (in-vector flut)]
                              [b (in-naturals)])
                     #`[n (unsafe-fx+ (unsafe-fxrshift (unsafe-fxand n #,m)
                                                       #,(fxlshift 1 b))
                                      (unsafe-fxand n #,f))])
             n)))]))
(mk-fxcount fxcount)

(fxcount #xF) ;; 4
(fxcount #xFC) ;; 6
(fxcount #x0FCFC00000100010) ;; 14

;; How it works (Demonstrated on #xFC)

;; 1111 1100
;; &
;; 1010 1010
;;============
;; 1010 1000
;; Shift right 1
;; 0101 0100

;; opposite
;; 0101 0100
;; Add:
;; 1010 1000 == A8
;; &
;; 1100 1100
;;============
;; 1000 1000
;; Shift right 2
;; 0010 0010

;; Opposite
;; 0010 0000
;; Add:
;; 0100 0010 == 42
;; &
;; 1111 0000
;;==========
;; 0100 0000
;; Shift right 4
;; 0000 0100

;; Opposite
;; 0000 0010
;; Add:
;; 0000 0110 == 6 (answer!)