src/optim.lisp

   1 ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
   2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   3 ;;;     The data in this file contains enhancments.                    ;;;;;
   4 ;;;                                                                    ;;;;;
   5 ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
   6 ;;;     All rights reserved                                            ;;;;;
   7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   8
   9 (in-package :maxima)
  10
  11 ;;      ** (c) Copyright 1982 Massachusetts Institute of Technology **
  12
  13 (macsyma-module optim)
  14
  15 (declare-top (unspecial args))
  16
  17 (defvar *subexp* (make-array 64 :initial-element nil))
  18
  19 (defmvar $optimprefix '$%)
  20
  21 (defmvar $optimwarn t "warns if `optimize' encounters a special form.")
  22
  23 ;; $OPTIMIZE takes a Macsyma expression and returns a BLOCK form which is
  24 ;; equivalent, but which uses local variables to store the results of computing
  25 ;; common subexpressions.  These subexpressions are found by hashing them.
  26
  27 (defmfun $optimize (x0)
  28   (let (($optimwarn $optimwarn)
  29         *setqs*
  30         vars
  31         (*optimcount* 0)
  32         (*xvars* (cdr ($listofvars x0))))
  33     (declare (special *optimcount* *xvars* *setqs* vars))
  34     (fill *subexp* nil)
  35     (prog ((x (collapse (opformat (collapse x0)))))
  36        (when (atom x) (return x))
  37        (comexp x)
  38        (setq x (optim x))
  39        (return (prog1 (cond ((null vars) x0)
  40                             (t (if (or (not (eq (caar x) 'mprog))
  41                                        (and ($listp (cadr x)) (cdadr x)))
  42                                    (setq x (nreverse (cons x *setqs*)))
  43                                    (setq x (nreconc *setqs* (cddr x))))
  44                                `((mprog simp) ((mlist) ,@(nreverse vars)) ,@x)))
  45                  (fill *subexp* nil))))))
  46
  47 (defun opformat (x)
  48   (cond ((atom x) x)
  49         ((specrepp x) (opformat (specdisrep x)))
  50         ((and $optimwarn
  51               (mspecfunp (caar x))
  52               (prog2 (mtell (intl:gettext "optimize: encountered a special form; result may be wrong."))
  53                   (setq $optimwarn nil))))
  54         ((eq (caar x) 'mexpt) (opmexpt x))
  55         (t (let ((newargs (mapcar #'opformat (cdr x))))
  56              (if (alike newargs (cdr x)) x (cons (car x) newargs))))))
  57
  58 (defun opmexpt (x)
  59   (let ((*base (opformat (cadr x))) (exp (opformat (caddr x))) xnew negexp)
  60     (setq negexp
  61           (cond ((and (realp exp) (minusp exp)) (- exp))
  62                 ((and (ratnump exp) (minusp (cadr exp)))
  63                  (list (car exp) (- (cadr exp)) (caddr exp)))
  64                 ((and (mtimesp exp) (realp (cadr exp)) (minusp (cadr exp)))
  65                  (if (equal (cadr exp) -1)
  66                      (if (null (cdddr exp)) (caddr exp)
  67                          (cons (car exp) (cddr exp)))
  68                      (list* (car exp) (- (cadr exp)) (cddr exp))))
  69                 ((and (mtimesp exp) (ratnump (cadr exp)) (minusp (cadadr exp)))
  70                  (list* (car exp)
  71                         (list (caadr exp) (- (cadadr exp)) (caddr (cadr exp)))
  72                         (cddr exp)))))
  73     (setq xnew
  74           (cond (negexp
  75                  `((mquotient)
  76                    1
  77                    ,(cond ((equal negexp 1) *base)
  78                           (t (setq xnew (list (car x) *base negexp))
  79                              (if (and (ratnump negexp) (equal (caddr negexp) 2))
  80                                  (opmexpt xnew)
  81                                  xnew)))))
  82                 ((and (ratnump exp) (equal (caddr exp) 2))
  83                  (setq exp (cadr exp))
  84                  (if (equal exp 1) `((%sqrt) ,*base)
  85                      `((mexpt) ((%sqrt) ,*base) ,exp)))
  86                 (t (list (car x) *base exp))))
  87     (if (alike1 x xnew) x xnew)))
  88
  89 (defmfun $collapse (x)
  90   (fill *subexp* nil)
  91   (prog1 (collapse x) (fill *subexp* nil)))
  92
  93 (defun collapse (x)
  94   (cond ((atom x) x)
  95         ((specrepp x) (collapse (specdisrep x)))
  96         (t (let ((n (opt-hash (caar x))))
  97              (do ((l (cdr x) (cdr l)))
  98                  ((null l))
  99                (if (not (eq (collapse (car l)) (car l)))
 100                    (rplaca l (collapse (car l))))
 101                (setq n (rem (+ (opt-hash (car l)) n) 12553.)))
 102              (setq n (logand 63 n))
 103              (do ((l (aref *subexp* n) (cdr l)))
 104                  ((null l) (setf (aref *subexp* n) (cons (list x) (aref *subexp* n))) x)
 105                (if (alike1 x (caar l)) (return (caar l))))))))
 106
 107 (defun comexp (x)
 108   (if (not (or (atom x) (eq (caar x) 'rat)))
 109       (let ((n (opt-hash (caar x))))
 110         (dolist (u (cdr x)) (setq n (rem (+ (opt-hash u) n) 12553.)))
 111         (setq x (assol x (aref *subexp* (logand 63. n))))
 112         (cond ((null (cdr x)) (rplacd x 'seen) (mapc #'comexp (cdar x)))
 113               (t (rplacd x 'comexp))))))
 114
 115 (defun optim (x)
 116   (declare (special *setqs*))
 117   (cond ((atom x) x)
 118         ((and (member 'array (cdar x) :test #'eq)
 119               (not (eq (caar x) 'mqapply))
 120               (not (mget (caar x) 'arrayfun-mode)))
 121          x)
 122         ((eq (caar x) 'rat) x)
 123         (t (let ((n (opt-hash (caar x))) (nx (list (car x))))
 124              (dolist (u (cdr x))
 125                (setq n (rem (+ (opt-hash u) n) 12553.)
 126                      nx (cons (optim u) nx)))
 127              (setq x (assol x (aref *subexp* (logand 63. n))) nx (nreverse nx))
 128              (cond ((eq (cdr x) 'seen) nx)
 129                    ((eq (cdr x) 'comexp)
 130                     (rplacd x (getoptimvar))
 131                     (push `((msetq) ,(cdr x) ,nx) *setqs*)
 132                     (cdr x))
 133                    (t (cdr x)))))))
 134
 135 (defun opt-hash (exp)              ; EXP is in general representation.
 136   (rem (if (atom exp)
 137            (sxhash exp)
 138            (do ((n (opt-hash (caar exp)))
 139                 (args (cdr exp) (cdr args)))
 140                ((null args) n)
 141              (setq n (rem (+ (opt-hash (car args)) n) 12553.))))
 142        12553.))                ; a prime number < 2^14 ; = PRIME(1500)
 143
 144
 145 (defun getoptimvar ()
 146   (declare (special *optimcount* *xvars* vars))
 147   (loop with var
 148      do
 149      (incf *optimcount*)
 150      (setq var (make-symbol (format nil "~A~D" $optimprefix *optimcount*)))
 151      while (member var *xvars* :test #'eq)
 152      finally
 153      (push var vars)
 154      (return var)))