(in-package :cl-user)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Compiler macros
;;; Arthur Lemmens, 2004
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

* basics and simple example

* when and why

* details: &whole and &environment

* real-life examples

* benchmarking, disassembling and profiling














* HOW

Q: How do you use compiler macros?

A: Define a function with DEFUN.

   Define a compiler macro with DEFINE-COMPILER-MACRO.

   Test a compiler macro with
   (FUNCALL (COMPILER-MACRO-FUNCTION 'compiler-macro)
            form 
            NIL) ; environment










* MINI-EXAMPLE

(defun cube (x) (* x x x))

(cube 10)
(mapcar #'cube '(1 2 3 4 5 6))

(define-compiler-macro cube (x)
  (if (numberp x)
      (* x x x)     ; evaluate at compile time
    `(let ((.x ,x)) ; avoid multiple evaluation
       (* .x .x .x))))

(funcall (compiler-macro-function 'cube)
         '(cube (incf x))
         nil)

(funcall (compiler-macro-function 'cube)
         '(cube 10) 
         nil)









* WHEN

Q: When should you use compiler macros?

A: Use compiler macros when you need a function
   and a macro with the same name and the same
   semantics.













* WHY (1)

Only one reason to use compiler macros: speed.

Unlike normal macros, you shouldn't use compiler macros to
define syntactic extensions.

There are several reasons for this:

 1. Technical: No guarantee that a compiler macro call is
    ever expanded (similar to inline declarations).

 2. Semantics: the goal of a compiler macro is to speed
    up an existing function. A function has no access to
    the program source in which it is used, so it can't
    manipulate the program source. The effect of the 
    expanded compiler macro form should be the same as
    the effect of the function, so it shouldn't do
    anything that the function can't do.






* WHY (2)

Q: Why can't you just use a macro, and forget the function?
A: You can't use a macro function as an argument for other
   functions (apply, funcall, map, reduce, etc.)

(defmacro square (x)
  `(let ((.x ,x)) ; avoid multiple evaluation
     (* .x .x)))

(square 10) -> 100
(apply 'square '(10)) -> ERROR
(mapcar (macro-function 'square) '(1 2 3 4 5)) -> ERRO

but:

(apply 'cube '(10)) -> 100
(mapcar #'cube '(1 2 3 4 5)) -> (1 8 27 64 125)











* WHY (3)

Q: Why can't you declare the function to be inline?
   E.g. (declaim (inline cube))

A: In simple cases, the effect is probably the same.
   But in more complicated cases, the compiler needs more
   help.















* DIRTY DETAILS: The &whole parameter

Compiler macros can decline to expand a form by
just returning the whole form. In that case the
corresponding function will be called. (Normal
macros can't do this, because "Recursive expansion
of the form returned must terminate.")

















(defun vector-add (vector-1 vector-2)
  (map 'vector #'+ vector-1 vector-2))

(vector-add #(1 2 3) #(4 5 6))




















            
(define-compiler-macro vector-add (&whole form vector-1 vector-2)
  (cond ((and (constantp vector-1) (constantp vector-2))
         ;; Compute result at compile time.
         (vector-add vector-1 vector-2))
        ((constantp vector-1)
         ;; Generate code to add all constant elements of vector-1
         ;; to vector-2.
         `(vector ,@(loop for x across vector-1
                          for i from 0
                          collect `(+ ,x (aref ,vector-2 ,i)))))
        ((constantp vector-2)
         `(vector-add ,vector-2 ,vector-1))
        (t ; Can't optimize anything. 
         form)))













(funcall (compiler-macro-function 'vector-add)
         '(vector-add #(10 20 30) #(1 2 3))
         nil)

(funcall (compiler-macro-function 'vector-add)
         '(vector-add #(10 20 30) x)
         nil)

(funcall (compiler-macro-function 'vector-add)
         '(vector-add x y)
         nil)








* DIRTY DETAILS: The &whole parameter (2)

The &whole form can start with:
 1. The name of the compiler macro, e.g. (CUBE 1)
 2. FUNCALL. The second element of the form will be (FUNCTION name).
    Example: (FUNCALL #'CUBE 1)

This is normally not relevant.
But you must be careful when destructuring the &whole parameter.

(funcall (compiler-macro-function 'cube)
         '(cube x)
         nil)

(funcall (compiler-macro-function 'cube)
         '(funcall #'cube x)
         nil)

(funcall (compiler-macro-function 'cube)
         '(apply #'cube (list x))
         nil) -> ERROR










* DIRTY DETAILS: The &environment parameter

Don't forget the &environment argument when you use
MACROEXPAND or CONSTANTP within your compiler-macro.


(defconstant +some-constant+ 10)

;; Without environment

(define-compiler-macro constantp-without-environment (x)
  (let ((expanded-x (macroexpand x)))
    (if (constantp expanded-x)
        ''constant
      ''variable)))

(defun test-without-environment ()
  (symbol-macrolet ((x +some-constant+))
    (constantp-without-environment x)))

(compile 'test-without-environment)
(test-without-environment)





; With environment

(define-compiler-macro constantp-with-environment 
    (x &environment env)
  (let ((expanded-x (macroexpand x env)))
    (if (constantp expanded-x env)
        ''constant
      ''variable)))

(defun test-with-environment ()
  (symbol-macrolet ((x +some-constant+))
    (constantp-with-environment x)))

(compile 'test-with-environment)

(test-with-environment)








* TYPICAL USES

Translating n-ary to binary functions.

Optimizing for constant arguments.

Compile-time processing of keyword arguments
(no real-life examples found, but makes lots of sense).
See the second example in the Hyperspec.

Adding type declarations.









* REAL-LIFE EXAMPLE: CL-PPCRE

Regular expression library by Edi Weitz.
Part of Portable AllegroServe.

Optimizes for constant regex argument: scanner created at load-time.

(define-compiler-macro scan
    (&whole form regex target-string &rest rest)
  "Make sure that constant forms are compiled into
scanners at compile time."
  (cond ((constantp regex)
          `(scan (load-time-value (create-scanner ,regex))
                 ,target-string ,@rest))
        (t form)))









* REAL-LIFE EXAMPLE: BLOWFISH

Implementation by Alain Picard of the Blowfish encryption algorithm.
Inspired by code from Pierre Mai.

Adds type declarations.

;; This hack alone speeds up encryption a factor of 3,
;; as well as diminishing the consing a factor of 3.
 
#+cmu
(define-compiler-macro mod32-add (a b)
  `(ext:truly-the unsigned-byte-32 (+ ,a ,b)))

#-cmu
(declaim
 (inline mod32-add)
 (ftype (function (unsigned-byte-32 unsigned-byte-32)
                  unsigned-byte-32) 
        mod32-add))

#-cmu
(defun mod32-add (a b)
  (declare (type unsigned-byte-32 a b)
           (optimize (speed 3) (safety 0) (space 0)
                     (debug 0)))
  (ldb (byte 32 0) (+ a b)))










 

* REAL-LIFE EXAMPLE: McClim

From INFLATE.LISP. Written by Gilbert Baumann.
Implements the DEFLATE compression method.
Uses compiler macros to have a better chance of
getting inlined functions.

#+excl
(defmacro defsubst (fun args &body body)
  `(progn
     (defun ,fun ,args .,body)
     (define-compiler-macro ,fun (&rest .args.)
       (cons '(lambda ,args .,body)
             .args.))))

#+(OR CMU CLISP)
(defmacro defsubst (name args &body body)
  `(progn
     (declaim (inline ,name))
     (defun ,name ,args .,body)))







;; Example of use

(defsubst reverse-byte (n x)
  (declare (optimize (speed 3) (safety 0))
           (type (unsigned-byte 16) x)
           (type (integer 0 16) n))
  (setf x (logior (ash (logand x #b1010101010101010) -1)
                  (ash (logand x #b0101010101010101) +1)))
  (setf x (logior (ash (logand x #b1100110011001100) -2)
                  (ash (logand x #b0011001100110011) +2)))
  (setf x (logior (ash (logand x #b1111000011110000) -4)
                  (ash (logand x #b0000111100001111) +4)))
  (setf x (logior (ash (logand x #b1111111100000000) -8)
                  (ash (logand x #b0000000011111111) +8)))
  (ash x (- n 16)))
  



* REAL-LIFE EXAMPLE: McClim

From UTILS.LISP. Written by Gilbert Baumann.
Uses compiler macros for straightforward inlining.

(defun curry (fun &rest args)
  #'(lambda (&rest more)
      (apply fun (append args more))))

(define-compiler-macro curry (fun &rest args)
  `(lambda (&rest more)
     (apply ,fun ,@args more)))


;; ALWAYS is not necessary. (Same as CONSTANTLY.)

(defun always (x)
  #'(lambda (&rest more)
      (declare (ignore more))
      x))

(define-compiler-macro always (x)
  (let ((g (gensym)))
    `(let ((,g ,x))
       (lambda (&rest more)
         (declare (ignore more))
         ,g))))









 
* REAL-LIFE EXAMPLE: CLOSURE

Lisp browser by Gilbert Baumann

Uses compiler macros instead of inline declaration.

(defun neq (x y) (not (eq x y)))

(define-compiler-macro neq (x y)
  `(not (eq ,x ,y))) 












;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; REAL-LIFE EXAMPLE: DEFDOC
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

HTML-engine of DefDoc (A TeX-inspired, Lisp-based
document processing system by Rahul Jain)

Generates inline code by unrolling the attribute loop 'by hand'.

(defun write-html-attributes (&rest attributes)
  (when attributes
    (write-char #\space *html-stream*)
    (pprint-indent :current 0 *html-stream*)
    (pprint-newline :miser *html-stream*)
    (apply #'%write-html-attributes attributes)))

(declaim (inline %write-html-attributes))
(defun %write-html-attributes (&rest attributes)
  (loop
      for (key val . rest) on attributes by #'cddr
      do (when val
           (if (eq val t) ;; just print the attribute with no value
               (write-string (string key) *html-stream*)
               (progn
                 (write-string (string key) *html-stream*)
                 (write-char #\= *html-stream*)
                 (typecase val
                   (integer (write val :stream *html-stream*))
                   (symbol (write-string (symbol-name val)
                                         *html-stream*))
                   (string (write-char #\" *html-stream*)
                           (write-string val *html-stream*)
                           (write-char #\" *html-stream*)))))
           (when rest
             (write-char #\space *html-stream*)
             (pprint-newline :fill *html-stream*))))) 




(define-compiler-macro write-html-attributes
    (&whole whole &rest attributes)
  (when attributes
    (if (eq (car whole) 'write-html-attributes)
      `(progn
         (write-char #\space *html-stream*)
         (pprint-indent :current 0 *html-stream*)
         (pprint-newline :miser *html-stream*)
         ,@(loop
            with val-sym = (gensym "VAL-")
            for (key val . rest) on attributes by #'cddr
            collect
            `(let ((,val-sym ,val))
               (when ,val-sym
                 (if (eq ,val-sym t)
                     (write-string ,(string key) *html-stream*)
                   (progn
                     (write-string ,(string key)  *html-stream*)
                     (write-char #\= *html-stream*)
                     (typecase ,val-sym
                       (integer (write ,val-sym
                                       :stream *html-stream*))
                       (symbol (write-string (symbol-name ,val-sym)
                                             *html-stream*))
                       (string (write-char #\" *html-stream*)
                               (write-string ,val-sym *html-stream*)
                                 (write-char #\" *html-stream*)))))
                   ,@(when rest
                       '((write-char #\space *html-stream*)
                         (pprint-newline :fill *html-stream*)))))))
        whole)))
  
Note: (IF (EQ (CAR WHOLE) 'WRITE-HTML-ATTRIBUTES) ...) is not
      necessary here.












;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; REAL-LIFE EXAMPLE: DEFDOC
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

Layout-core of DefDoc.


* PENALTY+

Specialize an n-ary function for 2 arguments.
A penalty is an integer or NIL or T.

(defun two-arg-penalty+ (x y)
  (declare (optimize (speed 3) (safety 1) (space 0)
                     (debug 0) (compilation-speed 0))
           (type penalty x y))
  (cond
   ((or (null y) (null x))
    (if (or (eq t x) (eq t y))
        (error "Attempt to add an infinitely positive
penalty to an infinitely negative penalty.")
      nil))
   ((or (eq t x) (eq t y)) t)
   (t (locally (declare (type integer x y))
        (+ x y)))))

(defun penalty+ (&rest penalties)
  (declare (optimize (speed 3) (safety 1) (space 0)
                     (debug 0) (compilation-speed 0)))
  (reduce #'two-arg-penalty+ penalties :initial-value 0))








(define-compiler-macro penalty+ (&whole whole &rest args)
  (if (and (eq 'penalty+ (first whole))
           (= (length whole) 3))
      `(two-arg-penalty+ ,(second whole) ,(third whole))
      whole)) 

Note: the check for 2 arguments is better written as:
      (if (= (length args) 2) ...)











* PENALTY=

Make PENALTY= a synonym for EQL.

(defun penalty= (&rest penalties)
  (declare (optimize (speed 3) (safety 1) (space 0)
                     (debug 0) (compilation-speed 0)))
  (apply #'eql penalties))


(define-compiler-macro penalty= (&whole whole &rest args)
  (cond ((eq 'penalty= (first whole))
         `(eql ,@(rest whole)))
        ((eq 'funcall (first whole))
         `(eql ,@(rest (rest whole))))
        ((eq 'apply (first whole))
         `(apply #'eql ,@(rest whole)))))

Note: Check for APPLY is not necessary.

Exercise: How can we simplify this?

(define-compiler-macro penalty= (&rest args)
  `(eql ,@args))





* PENALTY>=

(defun penalty>= (&rest penalties)
  (declare (optimize (speed 3) (safety 1) (space 0)
                     (debug 0) (compilation-speed 0)))
  (or (apply #'penalty= penalties)
      (apply #'penalty> penalties)))

(define-compiler-macro penalty>= (&whole whole &rest args)
  (if (eq (first whole) 'penalty>=)
      (let ((args (mapcar #'gensym- (rest whole))))
        `(let (,@(mapcar #'list args (rest whole)))
           (or (penalty= ,@args)
               (penalty> ,@args))))
      whole)) 










;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; REAL-LIFE EXAMPLE: MAXIMA
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

Symbolic mathematics program by William Schelter.
Defines a few specialized binary operators that
automatically include type declarations.

(defmacro defbinop (name op type)
  `(progn
     (defun ,name (x y)
       (the ,type (,op  (the ,type x) (the ,type y))))
     (eval-when (compile eval)     
       (define-compiler-macro ,name (x y)
         `(the ,',type
               (,',op  (the ,',type ,x)
                       (the ,',type ,y)))))))

(defbinop f+ + fixnum)
(defbinop f- - fixnum)

(defbinop $+ + long-float)
(defbinop $- - long-float)
(defbinop $* * long-float)
(defbinop $/ / long-float)











;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; REAL-LIFE EXAMPLE: COMPUTING PHYSICAL QUANTITIES
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

Written by Arthur Lemmens. See UNITS-DEMO-SESSION.LISP.

Adding a few simple compiler macros increased the speed of a
simulation program by a factor of 3, without changing a single
line in the source code.





















* QUANTITY: Creating quantities

Optimizes constant units argument (the usual case).

(defun quantity (magnitude units)
  "Creates a quantity for the given magnitude and
unit-combination specifier."
  (check-type magnitude number)
  (if (null units)
      magnitude
    (multiple-value-bind (converted-value base-exponents)
        (apply-conversions magnitude 
                           (if (symbolp units) (list units) units))
      (%quantity converted-value base-exponents))))


(defun %quantity (magnitude exponents)
  (if (si-exponents-zero-p exponents)
      magnitude
    (make-quantity :magnitude magnitude :units exponents)))








(define-compiler-macro quantity (&whole form magnitude units)
  (cond ((null units)
         ;; Unitless: just use the magnitude
         magnitude)
        ((constantp units)
         ;; UNITS is constant. Expand it at compile time.
         (multiple-value-bind (conversion-factor base-exponents)
             (apply-conversions 1 (second units))
           (if (si-exponents-zero-p base-exponents)
               magnitude
             `(make-quantity
               :magnitude ,(if (= 1 conversion-factor)
                               magnitude
                             `(cl:* ,conversion-factor ,magnitude))
               :units ,base-exponents))))
        ;; UNITS is variable. Deal with it at run-time.
        (t form)))















* Multiplication

Optimizes simple cases, translates n-ary to binary function calls.

(defun * (&rest numbers)
  ;; When multiplying, add the exponents of all units
  (let ((value (apply #'cl:* (numbers-values numbers))))
    (%quantity value
               (reduce #'add-si-exponents (numbers-units numbers)
                       :initial-value +zero-si-exponents+))))

(in-package :units)
(* (quantity 1 '((meter 1)))
   (quantity 1 '((meter 1))))












(defun binary-* (a b)
  (let ((value (cl:* (magnitude a) (magnitude b))))
    (%quantity value (add-si-exponents (units a) (units b)))))

(define-compiler-macro * (&rest args)
  (case (length args)
    (0 1)
    (1 (first args))
    (2 `(binary-* ,(first args) ,(second args)))
    (otherwise `(binary-* ,(first args)
                          (* ,@(rest args))))))

(pprint (funcall (compiler-macro-function '*)
                 '(* (quantity 1 'meter) (quantity 2 'meter) 
                     (quantity 1 '((sec -1))))
                 nil))









* Check-units

Use: optimize constant units argument (usual case).

(define-compiler-macro check-units (&whole form number units)
  (if (constantp units)
      ;; UNITS is constant. Expand it at compile time.
      `(check-exponents 
        ,number 
        ,(nth-value 1 (expand-unit-combination (second units)))
        ,units)
    form))