What is the easiest way to promise a Common Lisp compiler that the result of an arithmetic expression is a fixnum?

Question

I wanted to tell sbcl that the following function will only be called with fixnum values for which the result fits in a fixnum:

(defun layer (x y z n)
  (+ (* 2 (+ (* x y) (* y z) (* x z)))
     (* 4 (+ x y z n -2) (1- n))))

My first attempt was to do

(defun layer (x y z n)
  (declare (fixnum x y z n))
  (the fixnum
    (+ (* 2 (+ (* x y) (* y z) (* x z)))
       (* 4 (+ x y z n -2) (1- n))))

But that return type declaration doesn't promise that all intermediate results will also be fixnums, as I found out by looking at the wonderfully useful compilation notes sbcl produced. So then I did this:

(defmacro fixnum+ (&rest args)
  (reduce
    (lambda (x y) `(the fixnum (+ ,x ,y)))
    args))

(defmacro fixnum* (&rest args)
  (reduce
    (lambda (x y) `(the fixnum (* ,x ,y)))
    args))

(defun layer (x y z n)
  (declare (fixnum x y z n))
  (fixnum+ (fixnum* 2 (fixnum+ (fixnum* x y) (fixnum* y z) (fixnum* x z)))
     (fixnum* 4 (fixnum+ x y z n -2) (the fixnum (1- n)))))

And that worked just fine. My question is: is there an easier, more idiomatic way to do this?

For example, maybe I can redeclare the types of +, -, *, 1- to promise fixnum results? (I know that's a bad idea in general, but I might want to do it in certain programs.) CHICKEN scheme has (declare (fixnum-arithmetic)) that does what I want: it (unsafely) assumes that the results of all arithmetic operations on fixnums are fixnums.

Answer 1

Declaring the layer function inline results in a much faster speed even when block compilation is on.

On my Apple Air M1 with layer inlined and block compilation on it runs in 0.06 second under the Arm64 version of SBCL 2.1.2.

CL-USER> (time (first-time 1000))
Evaluation took:
  0.060 seconds of real time
  0.060558 seconds of total run time (0.060121 user, 0.000437 system)
  101.67% CPU
  303,456 bytes consed

I've just remembered that declaring the count array in cube should help as well.

(declare (type (simple-array fixnum (*)) count))

Without inlining the layer function it is around 0.2 second.

CL-USER> (time (first-time 1000))
Evaluation took:
  0.201 seconds of real time
  0.201049 seconds of total run time (0.200497 user, 0.000552 system)
  100.00% CPU
  251,488 bytes consed

Or converting the layer function to a macro makes it even faster.

(defmacro layer (x y z n)
  (declare (fixnum x y z n))
  `(logand #.(1- (ash 1 (integer-length most-positive-fixnum)))
      (+ (* 2 (+ (* ,x ,y) (* ,y ,z) (* ,x ,z)))
         (* 4 (+ ,x ,y ,z ,n -2) (1- ,n)))))

CL-USER> (time (first-time 1000))
Evaluation took:
  0.047 seconds of real time
  0.047032 seconds of total run time (0.046854 user, 0.000178 system)
  100.00% CPU
  312,576 bytes consed

Benchmarked with trivial-benchmark on average it runs just bellow 0.04 second:

CL-USER> (benchmark:with-timing (100) (first-time 1000))
-                SAMPLES  TOTAL     MINIMUM   MAXIMUM   MEDIAN    AVERAGE    DEVIATION  
REAL-TIME        100      3.985173  0.039528  0.06012   0.039595  0.039852   0.002046   
RUN-TIME         100      3.985848  0.039534  0.06014   0.039605  0.039858   0.002048   
USER-RUN-TIME    100      3.975407  0.039466  0.059829  0.039519  0.039754   0.002026   
SYSTEM-RUN-TIME  100      0.010469  0.00005   0.000305  0.000088  0.000105   0.00005    
PAGE-FAULTS      100      0         0         0         0         0          0.0        
GC-RUN-TIME      100      0         0         0         0         0          0.0        
BYTES-CONSED     100      50200736  273056    504320    504320    502007.38  23010.477  
EVAL-CALLS       100      0         0         0         0         0          0.0

Answer 2

You can declare types for functions using FTYPE.

Example:

(defun foo (a b)
  (declare (ftype (function (&rest fixnum) fixnum) + * 1-)
           (type fixnum a b)
           (inline + * 1-)
           (optimize (speed 3) (safety 0) (debug 0) (space 0)))
  (+ a (* a (1- b))))

Does that make a difference?

Answer 3

In his book ANSI Common Lisp, Paul Graham shows the macro with-type, that wraps an expression and all its sub-expressions inthe forms, also ensuring that operators given more than two arguments are properly handled.

E.g. (with-type fixnum (+ 1 2 3)) will expand to the form

(the fixnum (+ (the fixnum (+ (the fixnum 1) (the fixnum 2))) 
               (the fixnum 3))

The code for the macro with helper functions is

(defmacro with-type (type expr)
  `(the ,type ,(if (atom expr) 
                   expr
                   (expand-call type (binarize expr)))))

(defun expand-call (type expr)
  `(,(car expr) ,@(mapcar #'(lambda (a) 
                              `(with-type ,type ,a))
                          (cdr expr))))

(defun binarize (expr)
  (if (and (nthcdr 3 expr)
           (member (car expr) '(+ - * /)))
      (destructuring-bind (op a1 a2 . rest) expr
        (binarize `(,op (,op ,a1 ,a2) ,@rest)))
      expr))

A link to the code from the book in found at http://www.paulgraham.com/acl.html

A comment in the code states that "This code is copyright 1995 by Paul Graham, but anyone who wants to use it is free to do so."

Answer 4

Try this:

(defun layer (x y z n)
  (declare (optimize speed) (fixnum x y z n))
  (logand most-positive-fixnum
          (+ (* 2 (+ (* x y) (* y z) (* x z)))
             (* 4 (+ x y z n -2) (1- n)))))

See SBCL User Manual, Sec 6.3 Modular arithmetic.

Edit:

As mentioned in the comments, SBCL-1.1.9 (or later) is required for this to work. Also, it's possible to shave another ~40% time off by inlining the subroutines:

;;; From: https://gist.github.com/oantolin/6073417
(declaim (optimize (speed 3) (safety 0)))

(defmacro with-type (type expr)
  (if (atom expr)
      expr
      (let ((op (car expr)))
        (reduce
         (lambda (x y)
           `(the ,type
                 (,op ,@(if x (list x) '())
                      (with-type ,type ,y))))
         (cdr expr)
         :initial-value nil))))
 
(defun layer (x y z n)
  (declare (fixnum x y z n))
  (with-type fixnum
    (+ (* 2 (+ (* x y) (* y z) (* x z)))
       (* 4 (+ x y z n -2) (1- n)))))

(defun cubes (n)
  (declare (fixnum n))
  (let ((count (make-array (+ n 1) :element-type 'fixnum)))
    (loop for x of-type fixnum from 1 while (<= (layer x x x 1) n) do
      (loop for y of-type fixnum from x while (<= (layer x y y 1) n) do
        (loop for z of-type fixnum from y while (<= (layer x y z 1) n) do
          (loop for k of-type fixnum from 1 while (<= (layer x y z k) n) do
            (incf (elt count (layer x y z k)))))))
    count))

(defun first-time (x)
  (declare (fixnum x))
  (loop for n of-type fixnum = 1000 then (* 2 n)
        for k = (position x (cubes n))
        until k
        finally (return k)))

;;; With modarith and inlining
(defun first-time/inline (x)
  (declare (fixnum x))
  (labels
      ((layer (x y z n)
         (logand #.(1- (ash 1 (integer-length most-positive-fixnum)))
                 (+ (* 2 (+ (* x y) (* y z) (* x z)))
                    (* 4 (+ x y z n -2) (1- n)))))
       (cubes (n)
         (let ((count (make-array (+ n 1) :element-type 'fixnum)))
           (loop for x of-type fixnum from 1 while (<= (layer x x x 1) n) do
             (loop for y of-type fixnum from x while (<= (layer x y y 1) n) do
               (loop for z of-type fixnum from y while (<= (layer x y z 1) n) do
                 (loop for k of-type fixnum from 1 while (<= (layer x y z k) n)
                       do (incf (elt count (layer x y z k)))))))
           count)))
    (declare (inline layer cubes))
    (loop for n of-type fixnum = 1000 then (* 2 n)
          thereis (position x (cubes n)))))

#+(or) 
(progn
  (time (print (first-time 1000)))
  (time (print (first-time/inline 1000))))

;; 18522 
;; Evaluation took:
;;   0.448 seconds of real time
;;   0.448028 seconds of total run time (0.448028 user, 0.000000 system)
;;   100.00% CPU
;;   1,339,234,815 processor cycles
;;   401,840 bytes consed
;;   
;; 
;; 18522 
;; Evaluation took:
;;   0.259 seconds of real time
;;   0.260016 seconds of total run time (0.260016 user, 0.000000 system)
;;   100.39% CPU
;;   776,585,475 processor cycles
;;   381,024 bytes consed