Forked from
cmucl / cmucl
9023 commits behind the upstream repository.
srctran.lisp 52.58 KiB
;;; -*- Package: C; Log: C.Log -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of CMU Common Lisp, please contact
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.38 1992/08/05 00:27:15 ram Exp $")
;;;
;;; **********************************************************************
;;;
;;; This file contains macro-like source transformations which convert
;;; uses of certain functions into the canonical form desired within the
;;; compiler. ### and other IR1 transforms and stuff. Some code adapted from
;;; CLC, written by Wholey and Fahlman.
;;;
;;; Written by Rob MacLachlan
;;;
(in-package "C")
;;; Source transform for Not, Null -- Internal
;;;
;;; Convert into an IF so that IF optimizations will eliminate redundant
;;; negations.
;;;
(def-source-transform not (x) `(if ,x nil t))
(def-source-transform null (x) `(if ,x nil t))
;;; Source transform for Endp -- Internal
;;;
;;; Endp is just NULL with a List assertion.
;;;
(def-source-transform endp (x) `(null (the list ,x)))
;;; We turn Identity into Prog1 so that it is obvious that it just returns the
;;; first value of its argument. Ditto for Values with one arg.
(def-source-transform identity (x) `(prog1 ,x))
(def-source-transform values (x) `(prog1 ,x))
;;; CONSTANTLY source transform -- Internal
;;;
;;; Bind the values and make a closure that returns them.
;;;
(def-source-transform constantly (value &rest values)
(let ((temps (loop repeat (1+ (length values))
collect (gensym)))
(dum (gensym)))
`(let ,(loop for temp in temps and
value in (list* value values)
collect `(,temp ,value))
#'(lambda (&rest ,dum)
(declare (ignore ,dum))
(values ,@temps)))))
;;; COMPLEMENT IR1 transform -- Internal
;;;
;;; If the function has a known number of arguments, then return a lambda
;;; with the appropriate fixed number of args. If the destination is a
;;; FUNCALL, then do the &REST APPLY thing, and let MV optimization figure
;;; things out.
;;;
(deftransform complement ((fun) * * :node node)
"open code"
(multiple-value-bind (min max)
(function-type-nargs (continuation-type fun))
(cond
((and min (eql min max))
(let ((dums (loop repeat min collect (gensym))))
`#'(lambda ,dums (not (funcall fun ,@dums)))))
((let* ((cont (node-cont node))
(dest (continuation-dest cont)))
(and (combination-p dest)
(eq (combination-fun dest) cont)))
'#'(lambda (&rest args)
(not (apply fun args))))
(t
(give-up "Function doesn't have fixed argument count.")))))
;;;; List hackery:
;;;
;;; Translate CxxR into car/cdr combos.
(def-source-transform caar (x) `(car (car ,x)))
(def-source-transform cadr (x) `(car (cdr ,x)))
(def-source-transform cdar (x) `(cdr (car ,x)))
(def-source-transform cddr (x) `(cdr (cdr ,x)))
(def-source-transform caaar (x) `(car (car (car ,x))))
(def-source-transform caadr (x) `(car (car (cdr ,x))))
(def-source-transform cadar (x) `(car (cdr (car ,x))))
(def-source-transform caddr (x) `(car (cdr (cdr ,x))))
(def-source-transform cdaar (x) `(cdr (car (car ,x))))
(def-source-transform cdadr (x) `(cdr (car (cdr ,x))))
(def-source-transform cddar (x) `(cdr (cdr (car ,x))))
(def-source-transform cdddr (x) `(cdr (cdr (cdr ,x))))
(def-source-transform caaaar (x) `(car (car (car (car ,x)))))
(def-source-transform caaadr (x) `(car (car (car (cdr ,x)))))
(def-source-transform caadar (x) `(car (car (cdr (car ,x)))))
(def-source-transform caaddr (x) `(car (car (cdr (cdr ,x)))))
(def-source-transform cadaar (x) `(car (cdr (car (car ,x)))))
(def-source-transform cadadr (x) `(car (cdr (car (cdr ,x)))))
(def-source-transform caddar (x) `(car (cdr (cdr (car ,x)))))
(def-source-transform cadddr (x) `(car (cdr (cdr (cdr ,x)))))
(def-source-transform cdaaar (x) `(cdr (car (car (car ,x)))))
(def-source-transform cdaadr (x) `(cdr (car (car (cdr ,x)))))
(def-source-transform cdadar (x) `(cdr (car (cdr (car ,x)))))
(def-source-transform cdaddr (x) `(cdr (car (cdr (cdr ,x)))))
(def-source-transform cddaar (x) `(cdr (cdr (car (car ,x)))))
(def-source-transform cddadr (x) `(cdr (cdr (car (cdr ,x)))))
(def-source-transform cdddar (x) `(cdr (cdr (cdr (car ,x)))))
(def-source-transform cddddr (x) `(cdr (cdr (cdr (cdr ,x)))))
;;;
;;; Turn First..Fourth and Rest into the obvious synonym, assuming whatever is
;;; right for them is right for us. Fifth..Tenth turn into Nth, which can be
;;; expanded into a car/cdr later on if policy favors it.
(def-source-transform first (x) `(car ,x))
(def-source-transform rest (x) `(cdr ,x))
(def-source-transform second (x) `(cadr ,x))
(def-source-transform third (x) `(caddr ,x))
(def-source-transform fourth (x) `(cadddr ,x))
(def-source-transform fifth (x) `(nth 4 ,x))
(def-source-transform sixth (x) `(nth 5 ,x))
(def-source-transform seventh (x) `(nth 6 ,x))
(def-source-transform eighth (x) `(nth 7 ,x))
(def-source-transform ninth (x) `(nth 8 ,x))
(def-source-transform tenth (x) `(nth 9 ,x))
;;;
;;; Translate RPLACx to LET and SETF.
(def-source-transform rplaca (x y)
(once-only ((n-x x))
`(progn
(setf (car ,n-x) ,y)
,n-x)))
;;;
(def-source-transform rplacd (x y)
(once-only ((n-x x))
`(progn
(setf (cdr ,n-x) ,y)
,n-x)))
(def-source-transform nth (n l) `(car (nthcdr ,n ,l)))
(defvar *default-nthcdr-open-code-limit* 6)
(defvar *extreme-nthcdr-open-code-limit* 20)
(deftransform nthcdr ((n l) (unsigned-byte t) * :node node)
"convert NTHCDR to CAxxR"
(unless (constant-continuation-p n) (give-up))
(let ((n (continuation-value n)))
(when (> n
(if (policy node (= speed 3) (= space 0))
*extreme-nthcdr-open-code-limit*
*default-nthcdr-open-code-limit*))
(give-up))
(labels ((frob (n)
(if (zerop n)
'l
`(cdr ,(frob (1- n))))))
(frob n))))
;;;; ARITHMETIC and NUMEROLOGY.
(def-source-transform plusp (x) `(> ,x 0))
(def-source-transform minusp (x) `(< ,x 0))
(def-source-transform zerop (x) `(= ,x 0))
(def-source-transform 1+ (x) `(+ ,x 1))
(def-source-transform 1- (x) `(- ,x 1))
(def-source-transform oddp (x) `(not (zerop (logand ,x 1))))
(def-source-transform evenp (x) `(zerop (logand ,x 1)))
;;; Note that all the integer division functions are available for inline
;;; expansion.
(macrolet ((frob (fun)
`(def-source-transform ,fun (x &optional (y nil y-p))
(declare (ignore y))
(if y-p
(values nil t)
`(,',fun ,x 1)))))
(frob truncate)
(frob round))
(def-source-transform lognand (x y) `(lognot (logand ,x ,y)))
(def-source-transform lognor (x y) `(lognot (logior ,x ,y)))
(def-source-transform logandc1 (x y) `(logand (lognot ,x) ,y))
(def-source-transform logandc2 (x y) `(logand ,x (lognot ,y)))
(def-source-transform logorc1 (x y) `(logior (lognot ,x) ,y))
(def-source-transform logorc2 (x y) `(logior ,x (lognot ,y)))
(def-source-transform logtest (x y) `(not (zerop (logand ,x ,y))))
(def-source-transform logbitp (index integer)
`(not (zerop (logand (ash 1 ,index) ,integer))))
(def-source-transform byte (size position) `(cons ,size ,position))
(def-source-transform byte-size (spec) `(car ,spec))
(def-source-transform byte-position (spec) `(cdr ,spec))
(def-source-transform ldb-test (bytespec integer)
`(not (zerop (mask-field ,bytespec ,integer))))
;;; With the ratio and complex accessors, we pick off the "identity" case, and
;;; use a primitive to handle the cell access case.
;;;
(def-source-transform numerator (num)
(once-only ((n-num `(the rational ,num)))
`(if (ratiop ,n-num)
(%primitive numerator ,n-num)
,n-num)))
;;;
(def-source-transform denominator (num)
(once-only ((n-num `(the rational ,num)))
`(if (ratiop ,n-num)
(%primitive denominator ,n-num)
1)))
;;;
(def-source-transform realpart (num)
(once-only ((n-num num))
`(if (complexp ,n-num)
(%primitive realpart ,n-num)
,n-num)))
;;;
(def-source-transform imagpart (num)
(once-only ((n-num num))
`(cond ((complexp ,n-num)
(%primitive imagpart ,n-num))
((floatp ,n-num)
(float 0 ,n-num))
(t
0))))
;;;; Numeric Derive-Type methods:
;;; Derive-Integer-Type -- Internal
;;;
;;; Utility for defining derive-type methods of integer operations. If the
;;; types of both X and Y are integer types, then we compute a new integer type
;;; with bounds determined Fun when applied to X and Y. Otherwise, we use
;;; Numeric-Contagion.
;;;
(defun derive-integer-type (x y fun)
(declare (type continuation x y) (type function fun))
(let ((x (continuation-type x))
(y (continuation-type y)))
(if (and (numeric-type-p x) (numeric-type-p y)
(eq (numeric-type-class x) 'integer)
(eq (numeric-type-class y) 'integer)
(eq (numeric-type-complexp x) :real)
(eq (numeric-type-complexp y) :real))
(multiple-value-bind (low high)
(funcall fun x y)
(make-numeric-type :class 'integer :complexp :real
:low low :high high))
(numeric-contagion x y))))
(defoptimizer (+ derive-type) ((x y))
(derive-integer-type
x y
#'(lambda (x y)
(flet ((frob (x y)
(if (and x y)
(+ x y)
nil)))
(values (frob (numeric-type-low x) (numeric-type-low y))
(frob (numeric-type-high x) (numeric-type-high y)))))))
(defoptimizer (- derive-type) ((x y))
(derive-integer-type
x y
#'(lambda (x y)
(flet ((frob (x y)
(if (and x y)
(- x y)
nil)))
(values (frob (numeric-type-low x) (numeric-type-high y))
(frob (numeric-type-high x) (numeric-type-low y)))))))
(defoptimizer (* derive-type) ((x y))
(derive-integer-type
x y
#'(lambda (x y)
(let ((x-low (numeric-type-low x))
(x-high (numeric-type-high x))
(y-low (numeric-type-low y))
(y-high (numeric-type-high y)))
(cond ((not (and x-low y-low))
(values nil nil))
((or (minusp x-low) (minusp y-low))
(if (and x-high y-high)
(let ((max (* (max (abs x-low) (abs x-high))
(max (abs y-low) (abs y-high)))))
(values (- max) max))
(values nil nil)))
(t
(values (* x-low y-low)
(if (and x-high y-high)
(* x-high y-high)
nil))))))))
(defoptimizer (/ derive-type) ((x y))
(numeric-contagion (continuation-type x) (continuation-type y)))
(defoptimizer (ash derive-type) ((n shift))
(or (let ((n-type (continuation-type n)))
(when (numeric-type-p n-type)
(let ((n-low (numeric-type-low n-type))
(n-high (numeric-type-high n-type)))
(if (constant-continuation-p shift)
(let ((shift (continuation-value shift)))
(make-numeric-type :class 'integer :complexp :real
:low (when n-low
#+new-compiler
(ash n-low shift)
;; ### fuckin' bignum bug.
#-new-compiler
(* n-low (ash 1 shift)))
:high (when n-high (ash n-high shift))))
(let ((s-type (continuation-type shift)))
(when (numeric-type-p s-type)
(let ((s-low (numeric-type-low s-type))
(s-high (numeric-type-high s-type)))
(if (and s-low s-high (<= s-low 32) (<= s-high 32))
(make-numeric-type :class 'integer :complexp :real
:low (when n-low
(min (ash n-low s-high)
(ash n-low s-low)))
:high (when n-high
(max (ash n-high s-high)
(ash n-high s-low))))
(make-numeric-type :class 'integer
:complexp :real)))))))))
*universal-type*))
(macrolet ((frob (fun)
`#'(lambda (type type2)
(declare (ignore type2))
(let ((lo (numeric-type-low type))
(hi (numeric-type-high type)))
(values (if hi (,fun hi) nil) (if lo (,fun lo) nil))))))
(defoptimizer (%negate derive-type) ((num))
(derive-integer-type num num (frob -)))
(defoptimizer (lognot derive-type) ((int))
(derive-integer-type int int (frob lognot))))
(defoptimizer (abs derive-type) ((num))
(let ((type (continuation-type num)))
(if (and (numeric-type-p type)
(eq (numeric-type-class type) 'integer)
(eq (numeric-type-complexp type) :real))
(let ((lo (numeric-type-low type))
(hi (numeric-type-high type)))
(make-numeric-type :class 'integer :complexp :real
:low (cond ((and hi (minusp hi))
(abs hi))
(lo
(max 0 lo))
(t
0))
:high (if (and hi lo)
(max (abs hi) (abs lo))
nil)))
(numeric-contagion type type))))
(defoptimizer (truncate derive-type) ((number divisor))
(let ((number-type (continuation-type number))
(divisor-type (continuation-type divisor))
(integer-type (specifier-type 'integer)))
(if (and (numeric-type-p number-type)
(csubtypep number-type integer-type)
(numeric-type-p divisor-type)
(csubtypep divisor-type integer-type))
(let ((number-low (numeric-type-low number-type))
(number-high (numeric-type-high number-type))
(divisor-low (numeric-type-low divisor-type))
(divisor-high (numeric-type-high divisor-type)))
(values-specifier-type
`(values ,(integer-truncate-derive-type number-low number-high
divisor-low divisor-high)
,(integer-rem-derive-type number-low number-high
divisor-low divisor-high))))
*universal-type*)))
;;; NUMERIC-RANGE-INFO -- internal.
;;;
;;; Derive useful information about the range. Returns three values:
;;; - '+ if its positive, '- negative, or nil if it overlaps 0.
;;; - The abs of the minimal value (i.e. closest to 0) in the range.
;;; - The abs of the maximal value if there is one, or nil if it is unbounded.
;;;
(defun numeric-range-info (low high)
(cond ((and low (not (minusp low)))
(values '+ low high))
((and high (not (plusp high)))
(values '- (- high) (if low (- low) nil)))
(t
(values nil 0 (and low high (max (- low) high))))))
;;; INTEGER-TRUNCATE-DERIVE-TYPE -- internal
;;;
(defun integer-truncate-derive-type
(number-low number-high divisor-low divisor-high)
;; The result cannot be larger in magnitude than the number, but the sign
;; might change. If we can determine the sign of either the number or
;; the divisor, we can eliminate some of the cases.
(multiple-value-bind
(number-sign number-min number-max)
(numeric-range-info number-low number-high)
(multiple-value-bind
(divisor-sign divisor-min divisor-max)
(numeric-range-info divisor-low divisor-high)
(when (and divisor-max (zerop divisor-max))
;; We've got a problem: guarenteed division by zero.
(return-from integer-truncate-derive-type t))
(when (zerop divisor-min)
;; We'll assume that they arn't going to divide by zero.
(incf divisor-min))
(cond ((and number-sign divisor-sign)
;; We know the sign of both.
(if (eq number-sign divisor-sign)
;; Same sign, so the result will be positive.
`(integer ,(if divisor-max
(truncate number-min divisor-max)
0)
,(if number-max
(truncate number-max divisor-min)
'*))
;; Different signs, the result will be negative.
`(integer ,(if number-max
(- (truncate number-max divisor-min))
'*)
,(if divisor-max
(- (truncate number-min divisor-max))
0))))
((eq divisor-sign '+)
;; The divisor is positive. Therefore, the number will just
;; become closer to zero.
`(integer ,(if number-low
(truncate number-low divisor-min)
'*)
,(if number-high
(truncate number-high divisor-min)
'*)))
((eq divisor-sign '-)
;; The divisor is negative. Therefore, the absolute value of
;; the number will become closer to zero, but the sign will also
;; change.
`(integer ,(if number-high
(- (truncate number-high divisor-min))
'*)
,(if number-low
(- (truncate number-low divisor-min))
'*)))
;; The divisor could be either positive or negative.
(number-max
;; The number we are dividing has a bound. Divide that by the
;; smallest posible divisor.
(let ((bound (truncate number-max divisor-min)))
`(integer ,(- bound) ,bound)))
(t
;; The number we are dividing is unbounded, so we can't tell
;; anything about the result.
'integer)))))
(defun integer-rem-derive-type
(number-low number-high divisor-low divisor-high)
(if (and divisor-low divisor-high)
;; We know the range of the divisor, and the remainder must be smaller
;; than the divisor. We can tell the sign of the remainer if we know
;; the sign of the number.
(let ((divisor-max (1- (max (abs divisor-low) (abs divisor-high)))))
`(integer ,(if (or (null number-low)
(minusp number-low))
(- divisor-max)
0)
,(if (or (null number-high)
(plusp number-high))
divisor-max
0)))
;; The divisor is potentially either very positive or very negative.
;; Therefore, the remainer is unbounded, but we might be able to tell
;; something about the sign from the number.
`(integer ,(if (and number-low (not (minusp number-low)))
;; The number we are dividing is positive. Therefore,
;; the remainder must be positive.
0
'*)
,(if (and number-high (not (plusp number-high)))
;; The number we are dividing is negative. Therefore,
;; the remainder must be negative.
0
'*))))
(defoptimizer (random derive-type) ((bound &optional state))
(let ((type (continuation-type bound)))
(when (numeric-type-p type)
(let ((class (numeric-type-class type))
(high (numeric-type-high type))
(format (numeric-type-format type)))
(make-numeric-type
:class class
:format format
:low (coerce 0 (or format class 'real))
:high (cond ((not high) nil)
((eq class 'integer) (max (1- high) 0))
((or (consp high) (zerop high)) high)
(t `(,high))))))))
;;;; Logical derive-type methods:
;;; Integer-Type-Length -- Internal
;;;
;;; Return the maximum number of bits an integer of the supplied type can take
;;; up, or NIL if it is unbounded. The second (third) value is T if the
;;; integer can be positive (negative) and NIL if not. Zero counts as
;;; positive.
;;;
(defun integer-type-length (type)
(if (numeric-type-p type)
(let ((min (numeric-type-low type))
(max (numeric-type-high type)))
(values (and min max (max (integer-length min) (integer-length max)))
(or (null max) (not (minusp max)))
(or (null min) (minusp min))))
(values nil t t)))
(defoptimizer (logand derive-type) ((x y))
(multiple-value-bind
(x-len x-pos x-neg)
(integer-type-length (continuation-type x))
(declare (ignore x-pos))
(multiple-value-bind
(y-len y-pos y-neg)
(integer-type-length (continuation-type y))
(declare (ignore y-pos))
(if (not x-neg)
;; X must be positive.
(if (not y-neg)
;; The must both be positive.
(cond ((or (null x-len) (null y-len))
(specifier-type 'unsigned-byte))
((or (zerop x-len) (zerop y-len))
(specifier-type '(integer 0 0)))
(t
(specifier-type `(unsigned-byte ,(min x-len y-len)))))
;; X is positive, but Y might be negative.
(cond ((null x-len)
(specifier-type 'unsigned-byte))
((zerop x-len)
(specifier-type '(integer 0 0)))
(t
(specifier-type `(unsigned-byte ,x-len)))))
;; X might be negative.
(if (not y-neg)
;; Y must be positive.
(cond ((null y-len)
(specifier-type 'unsigned-byte))
((zerop y-len)
(specifier-type '(integer 0 0)))
(t
(specifier-type
`(unsigned-byte ,y-len))))
;; Either might be negative.
(if (and x-len y-len)
;; The result is bounded.
(specifier-type `(signed-byte ,(1+ (max x-len y-len))))
;; We can't tell squat about the result.
(specifier-type 'integer)))))))
(defoptimizer (logior derive-type) ((x y))
(multiple-value-bind
(x-len x-pos x-neg)
(integer-type-length (continuation-type x))
(multiple-value-bind
(y-len y-pos y-neg)
(integer-type-length (continuation-type y))
(cond
((and (not x-neg) (not y-neg))
;; Both are positive.
(specifier-type `(unsigned-byte ,(if (and x-len y-len)
(max x-len y-len)
'*))))
((not x-pos)
;; X must be negative.
(if (not y-pos)
;; Both are negative. The result is going to be negative and be
;; the same length or shorter than the smaller.
(if (and x-len y-len)
;; It's bounded.
(specifier-type `(integer ,(ash -1 (min x-len y-len)) -1))
;; It's unbounded.
(specifier-type '(integer * -1)))
;; X is negative, but we don't know about Y. The result will be
;; negative, but no more negative than X.
(specifier-type
`(integer ,(or (numeric-type-low (continuation-type x)) '*)
-1))))
(t
;; X might be either positive or negative.
(if (not y-pos)
;; But Y is negative. The result will be negative.
(specifier-type
`(integer ,(or (numeric-type-low (continuation-type y)) '*)
-1))
;; We don't know squat about either. It won't get any bigger.
(if (and x-len y-len)
;; Bounded.
(specifier-type `(signed-byte ,(1+ (max x-len y-len))))
;; Unbounded.
(specifier-type 'integer))))))))
(defoptimizer (logxor derive-type) ((x y))
(multiple-value-bind
(x-len x-pos x-neg)
(integer-type-length (continuation-type x))
(multiple-value-bind
(y-len y-pos y-neg)
(integer-type-length (continuation-type y))
(cond
((or (and (not x-neg) (not y-neg))
(and (not x-pos) (not y-pos)))
;; Either both are negative or both are positive. The result will be
;; positive, and as long as the longer.
(specifier-type `(unsigned-byte ,(if (and x-len y-len)
(max x-len y-len)
'*))))
((or (and (not x-pos) (not y-neg))
(and (not y-neg) (not y-pos)))
;; Either X is negative and Y is positive of vice-verca. The result
;; will be negative.
(specifier-type `(integer ,(if (and x-len y-len)
(ash -1 (max x-len y-len))
'*)
-1)))
;; We can't tell what the sign of the result is going to be. All we
;; know is that we don't create new bits.
((and x-len y-len)
(specifier-type `(signed-byte ,(1+ (max x-len y-len)))))
(t
(specifier-type 'integer))))))
;;;; Miscellaneous derive-type methods:
(defoptimizer (code-char derive-type) ((code))
(specifier-type 'base-char))
(defoptimizer (values derive-type) ((&rest values))
(values-specifier-type
`(values ,@(mapcar #'(lambda (x)
(type-specifier (continuation-type x)))
values))))
;;;; Byte operations:
;;;
;;; We try to turn byte operations into simple logical operations. First,
;;; we convert byte specifiers into separate size and position arguments passed
;;; to internal %FOO functions. We then attempt to transform the %FOO
;;; functions into boolean operations when the size and position are constant
;;; and the operands are fixnums.
;;; With-Byte-Specifier -- Internal
;;;
;;; Evaluate body with Size-Var and Pos-Var bound to expressions that
;;; evaluate to the Size and Position of the byte-specifier form Spec. We may
;;; wrap a let around the result of the body to bind some variables.
;;;
;;; If the spec is a Byte form, then bind the vars to the subforms.
;;; otherwise, evaluate Spec and use the Byte-Size and Byte-Position. The goal
;;; of this transformation is to avoid consing up byte specifiers and then
;;; immediately throwing them away.
;;;
(defmacro with-byte-specifier ((size-var pos-var spec) &body body)
(once-only ((spec `(macroexpand ,spec))
(temp '(gensym)))
`(if (and (consp ,spec)
(eq (car ,spec) 'byte)
(= (length ,spec) 3))
(let ((,size-var (second ,spec))
(,pos-var (third ,spec)))
,@body)
(let ((,size-var `(byte-size ,,temp))
(,pos-var `(byte-position ,,temp)))
`(let ((,,temp ,,spec))
,,@body)))))
(def-source-transform ldb (spec int)
(with-byte-specifier (size pos spec)
`(%ldb ,size ,pos ,int)))
(def-source-transform dpb (newbyte spec int)
(with-byte-specifier (size pos spec)
`(%dpb ,newbyte ,size ,pos ,int)))
(def-source-transform mask-field (spec int)
(with-byte-specifier (size pos spec)
`(%mask-field ,size ,pos ,int)))
(def-source-transform deposit-field (newbyte spec int)
(with-byte-specifier (size pos spec)
`(%deposit-field ,newbyte ,size ,pos ,int)))
(defoptimizer (%ldb derive-type) ((size posn num))
(let ((size (continuation-type size)))
(if (and (numeric-type-p size)
(csubtypep size (specifier-type 'integer)))
(let ((size-high (numeric-type-high size)))
(if (and size-high (<= size-high vm:word-bits))
(specifier-type `(unsigned-byte ,size-high))
(specifier-type 'unsigned-byte)))
*universal-type*)))
(defoptimizer (%mask-field derive-type) ((size posn num))
(let ((size (continuation-type size))
(posn (continuation-type posn)))
(if (and (numeric-type-p size)
(csubtypep size (specifier-type 'integer))
(numeric-type-p posn)
(csubtypep posn (specifier-type 'integer)))
(let ((size-high (numeric-type-high size))
(posn-high (numeric-type-high posn)))
(if (and size-high posn-high
(<= (+ size-high posn-high) vm:word-bits))
(specifier-type `(unsigned-byte ,(+ size-high posn-high)))
(specifier-type 'unsigned-byte)))
*universal-type*)))
(defoptimizer (%dpb derive-type) ((newbyte size posn int))
(let ((size (continuation-type size))
(posn (continuation-type posn))
(int (continuation-type int)))
(if (and (numeric-type-p size)
(csubtypep size (specifier-type 'integer))
(numeric-type-p posn)
(csubtypep posn (specifier-type 'integer))
(numeric-type-p int)
(csubtypep int (specifier-type 'integer)))
(let ((size-high (numeric-type-high size))
(posn-high (numeric-type-high posn))
(high (numeric-type-high int))
(low (numeric-type-low int)))
(if (and size-high posn-high high low
(<= (+ size-high posn-high) vm:word-bits))
(specifier-type
(list (if (minusp low) 'signed-byte 'unsigned-byte)
(max (integer-length high)
(integer-length low)
(+ size-high posn-high))))
*universal-type*))
*universal-type*)))
(defoptimizer (%deposit-field derive-type) ((newbyte size posn int))
(let ((size (continuation-type size))
(posn (continuation-type posn))
(int (continuation-type int)))
(if (and (numeric-type-p size)
(csubtypep size (specifier-type 'integer))
(numeric-type-p posn)
(csubtypep posn (specifier-type 'integer))
(numeric-type-p int)
(csubtypep int (specifier-type 'integer)))
(let ((size-high (numeric-type-high size))
(posn-high (numeric-type-high posn))
(high (numeric-type-high int))
(low (numeric-type-low int)))
(if (and size-high posn-high high low
(<= (+ size-high posn-high) vm:word-bits))
(specifier-type
(list (if (minusp low) 'signed-byte 'unsigned-byte)
(max (integer-length high)
(integer-length low)
(+ size-high posn-high))))
*universal-type*))
*universal-type*)))
(deftransform %ldb ((size posn int)
(fixnum fixnum integer)
(unsigned-byte #.vm:word-bits))
"convert to inline logical ops"
`(logand (ash int (- posn))
(ash ,(1- (ash 1 vm:word-bits))
(- size ,vm:word-bits))))
(deftransform %mask-field ((size posn int)
(fixnum fixnum integer)
(unsigned-byte #.vm:word-bits))
"convert to inline logical ops"
`(logand int
(ash (ash ,(1- (ash 1 vm:word-bits))
(- size ,vm:word-bits))
posn)))
;;; Note: for %dpb and %deposit-field, we can't use (or (signed-byte n)
;;; (unsigned-byte n)) as the result type, as that would allow result types
;;; that cover the range -2^(n-1) .. 1-2^n, instead of allowing result types
;;; of (unsigned-byte n) and result types of (signed-byte n).
(deftransform %dpb ((new size posn int)
*
(unsigned-byte #.vm:word-bits))
"convert to inline logical ops"
`(let ((mask (ldb (byte size 0) -1)))
(logior (ash (logand new mask) posn)
(logand int (lognot (ash mask posn))))))
(deftransform %dpb ((new size posn int)
*
(signed-byte #.vm:word-bits))
"convert to inline logical ops"
`(let ((mask (ldb (byte size 0) -1)))
(logior (ash (logand new mask) posn)
(logand int (lognot (ash mask posn))))))
(deftransform %deposit-field ((new size posn int)
*
(unsigned-byte #.vm:word-bits))
"convert to inline logical ops"
`(let ((mask (ash (ldb (byte size 0) -1) posn)))
(logior (logand new mask)
(logand int (lognot mask)))))
(deftransform %deposit-field ((new size posn int)
*
(signed-byte #.vm:word-bits))
"convert to inline logical ops"
`(let ((mask (ash (ldb (byte size 0) -1) posn)))
(logior (logand new mask)
(logand int (lognot mask)))))
;;;; Funny function stubs:
;;;
;;; These functions are the result of compiler transformations. We never
;;; actually compile a call to these functions, but we need to have a
;;; definition to allow constant folding.
;;;
#-new-compiler
(progn
(defun %negate (x) (%primitive negate x))
(defun %ldb (s p i) (%primitive ldb s p i))
(defun %dpb (n s p i) (%primitive dpb n s p i))
(defun %mask-field (s p i) (%primitive mask-field s p i))
(defun %deposit-field (n s p i) (%primitive deposit-field n s p i))
); #-new-compiler progn
;;; Miscellanous numeric transforms:
;;; COMMUTATIVE-ARG-SWAP -- Internal
;;;
;;; If a constant appears as the first arg, swap the args.
;;;
(deftransform commutative-arg-swap ((x y) * * :defun-only t :node node)
(if (and (constant-continuation-p x)
(not (constant-continuation-p y)))
`(,(continuation-function-name (basic-combination-fun node))
y
,(continuation-value x))
(give-up)))
(dolist (x '(= char= + * logior logand logxor))
(%deftransform x '(function * *) #'commutative-arg-swap
"place constant arg last."))
;;; Handle the case of a constant boole-code.
;;;
(deftransform boole ((op x y))
"convert to inline logical ops"
(unless (constant-continuation-p op)
(give-up "BOOLE code is not a constant."))
(let ((control (continuation-value op)))
(case control
(#.boole-clr 0)
(#.boole-set -1)
(#.boole-1 'x)
(#.boole-2 'y)
(#.boole-c1 '(lognot x))
(#.boole-c2 '(lognot y))
(#.boole-and '(logand x y))
(#.boole-ior '(logior x y))
(#.boole-xor '(logxor x y))
(#.boole-eqv '(logeqv x y))
(#.boole-nand '(lognand x y))
(#.boole-nor '(lognor x y))
(#.boole-andc1 '(logandc1 x y))
(#.boole-andc2 '(logandc2 x y))
(#.boole-orc1 '(logorc1 x y))
(#.boole-orc2 '(logorc2 x y))
(t
(abort-transform "~S illegal control arg to BOOLE." control)))))
;;;; Convert multiply/divide to shifts.
;;; If arg is a constant power of two, turn * into a shift.
;;;
(deftransform * ((x y) (integer integer))
"convert x*2^k to shift"
(unless (constant-continuation-p y) (give-up))
(let* ((y (continuation-value y))
(y-abs (abs y))
(len (1- (integer-length y-abs))))
(unless (= y-abs (ash 1 len)) (give-up))
(if (minusp y)
`(- (ash x ,len))
`(ash x ,len))))
;;; If both arguments and the result are (unsigned-byte 32), try to come up
;;; with a ``better'' multiplication using multiplier recoding. There are two
;;; different ways the multiplier can be recoded. The more obvious is to shift
;;; X by the correct amount for each bit set in Y and to sum the results. But
;;; if there is a string of bits that are all set, you can add X shifted by
;;; one more then the bit position of the first set bit and subtract X shifted
;;; by the bit position of the last set bit. We can't use this second method
;;; when the high order bit is bit 31 because shifting by 32 doesn't work
;;; too well.
;;;
(deftransform * ((x y)
((unsigned-byte 32) (unsigned-byte 32))
(unsigned-byte 32))
"recode as shift and add"
(unless (constant-continuation-p y)
(give-up))
(let ((y (continuation-value y))
(result nil)
(first-one nil))
(labels ((tub32 (x) `(truly-the (unsigned-byte 32) ,x))
(add (next-factor)
(setf result
(tub32
(if result
`(+ ,result ,(tub32 next-factor))
next-factor)))))
(declare (inline add))
(dotimes (bitpos 32)
(if first-one
(when (not (logbitp bitpos y))
(add (if (= (1+ first-one) bitpos)
;; There is only a single bit in the string.
`(ash x ,first-one)
;; There are at least two.
`(- ,(tub32 `(ash x ,bitpos))
,(tub32 `(ash x ,first-one)))))
(setf first-one nil))
(when (logbitp bitpos y)
(setf first-one bitpos))))
(when first-one
(cond ((= first-one 31))
((= first-one 30)
(add '(ash x 30)))
(t
(add `(- ,(tub32 '(ash x 31)) ,(tub32 `(ash x ,first-one))))))
(add '(ash x 31))))
(or result 0)))
;;; If arg is a constant power of two, turn floor into a shift and mask.
;;; If ceiling, add in (1- (abs y)) and then do floor.
;;;
(flet ((frob (y ceil-p)
(unless (constant-continuation-p y) (give-up))
(let* ((y (continuation-value y))
(y-abs (abs y))
(len (1- (integer-length y-abs))))
(unless (= y-abs (ash 1 len)) (give-up))
(let ((shift (- len))
(mask (1- y-abs)))
`(let ,(when ceil-p `((x (+ x ,(1- y-abs)))))
,(if (minusp y)
`(values (ash (- x) ,shift)
(- (logand (- x) ,mask)))
`(values (ash x ,shift)
(logand x ,mask))))))))
(deftransform floor ((x y) (integer integer))
"convert division by 2^k to shift"
(frob y nil))
(deftransform ceiling ((x y) (integer integer))
"convert division by 2^k to shift"
(frob y t)))
;;; Do the same for mod.
;;;
(deftransform mod ((x y) (integer integer))
"convert remainder mod 2^k to LOGAND"
(unless (constant-continuation-p y) (give-up))
(let* ((y (continuation-value y))
(y-abs (abs y))
(len (1- (integer-length y-abs))))
(unless (= y-abs (ash 1 len)) (give-up))
(let ((mask (1- y-abs)))
(if (minusp y)
`(- (logand (- x) ,mask))
`(logand x ,mask)))))
;;; If arg is a constant power of two, turn truncate into a shift and mask.
;;;
(deftransform truncate ((x y) (integer integer))
"convert division by 2^k to shift"
(unless (constant-continuation-p y) (give-up))
(let* ((y (continuation-value y))
(y-abs (abs y))
(len (1- (integer-length y-abs))))
(unless (= y-abs (ash 1 len)) (give-up))
(let* ((shift (- len))
(mask (1- y-abs)))
`(if (minusp x)
(values ,(if (minusp y)
`(ash (- x) ,shift)
`(- (ash (- x) ,shift)))
(- (logand (- x) ,mask)))
(values ,(if (minusp y)
`(- (ash (- x) ,shift))
`(ash x ,shift))
(logand x ,mask))))))
;;; And the same for rem.
;;;
(deftransform rem ((x y) (integer integer))
"convert remainder mod 2^k to LOGAND"
(unless (constant-continuation-p y) (give-up))
(let* ((y (continuation-value y))
(y-abs (abs y))
(len (1- (integer-length y-abs))))
(unless (= y-abs (ash 1 len)) (give-up))
(let ((mask (1- y-abs)))
`(if (minusp x)
(- (logand (- x) ,mask))
(logand x ,mask)))))
;;;; Arithmetic and logical identity operation elimination:
;;;
;;; Flush calls to random arith functions that convert to the identity
;;; function or a constant.
(dolist (stuff '((ash 0 x)
(logand -1 x)
(logand 0 0)
(logior 0 x)
(logior -1 -1)
(logxor -1 (lognot x))
(logxor 0 x)))
(destructuring-bind (name identity result) stuff
(deftransform name ((x y) `(* (constant-argument (member ,identity))) '*
:eval-name t)
"fold identity operations"
result)))
;;; These are restricted to rationals, because (- 0 0.0) is 0.0, not -0.0, and
;;; (* 0 -4.0) is -0.0.
;;;
(deftransform - ((x y) ((constant-argument (member 0)) rational))
"convert (- 0 x) to negate"
'(%negate y))
;;;
(deftransform * ((x y) (rational (constant-argument (member 0))))
"convert (* x 0) to 0."
0)
;;; NOT-MORE-CONTAGIOUS -- Interface
;;;
;;; Return T if in an arithmetic op including continuations X and Y, the
;;; result type is not affected by the type of X. That is, Y is at least as
;;; contagious as X.
;;;
(defun not-more-contagious (x y)
(declare (type continuation x y))
(let ((x (continuation-type x))
(y (continuation-type y)))
(values (type= (numeric-contagion x y)
(numeric-contagion y y)))))
;;; Fold (OP x 0).
;;;
;;; If y is not constant, not zerop, or is contagious, then give up.
;;;
(dolist (stuff '((+ x)
(- x)
(expt 1)))
(destructuring-bind (name result) stuff
(deftransform name ((x y) '(t (constant-argument t)) '* :eval-name t)
"fold zero arg"
(let ((val (continuation-value y)))
(unless (and (zerop val)
(not (and (floatp val) (minusp (float-sign val))))
(not-more-contagious y x))
(give-up)))
result)))
;;; Fold (OP x +/-1)
;;;
(dolist (stuff '((* x (%negate x))
(/ x (%negate x))
(expt x (/ 1 x))))
(destructuring-bind (name result minus-result) stuff
(deftransform name ((x y) '(t (constant-argument real)) '* :eval-name t)
"fold identity operations"
(let ((val (continuation-value y)))
(unless (and (= (abs val) 1)
(not-more-contagious y x))
(give-up))
(if (minusp val) minus-result result)))))
;;;; Character operations:
(deftransform char-equal ((a b) (base-char base-char))
"open code"
'(let* ((ac (char-code a))
(bc (char-code b))
(sum (logxor ac bc)))
(or (zerop sum)
(when (eql sum #x20)
(let ((sum (+ ac bc)))
(and (> sum 161) (< sum 213)))))))
(deftransform char-upcase ((x) (base-char))
"open code"
'(let ((n-code (char-code x)))
(if (and (> n-code #o140) ; Octal 141 is #\a.
(< n-code #o173)) ; Octal 172 is #\z.
(code-char (logxor #x20 n-code))
x)))
(deftransform char-downcase ((x) (base-char))
"open code"
'(let ((n-code (char-code x)))
(if (and (> n-code 64) ; 65 is #\A.
(< n-code 91)) ; 90 is #\Z.
(code-char (logxor #x20 n-code))
x)))
;;;; Equality predicate transforms:
;;; SAME-LEAF-REF-P -- Internal
;;;
;;; Return true if X and Y are continuations whose only use is a reference
;;; to the same leaf, and the value of the leaf cannot change.
;;;
(defun same-leaf-ref-p (x y)
(declare (type continuation x y))
(let ((x-use (continuation-use x))
(y-use (continuation-use y)))
(and (ref-p x-use)
(ref-p y-use)
(eq (ref-leaf x-use) (ref-leaf y-use))
(constant-reference-p x-use))))
;;; SIMPLE-EQUALITY-TRANSFORM -- Internal
;;;
;;; If X and Y are the same leaf, then the result is true. Otherwise, if
;;; there is no intersection between the types of the arguments, then the
;;; result is definitely false.
;;;
(deftransform simple-equality-transform ((x y) * * :defun-only t)
(cond ((same-leaf-ref-p x y)
't)
((not (types-intersect (continuation-type x) (continuation-type y)))
'nil)
(t
(give-up))))
(dolist (x '(eq char= equal))
(%deftransform x '(function * *) #'simple-equality-transform))
;;; EQL IR1 Transform -- Internal
;;;
;;; Similar to SIMPLE-EQUALITY-PREDICATE, except that we also try to convert
;;; to a type-specific predicate or EQ:
;;; -- If both args are characters, convert to CHAR=. This is better than just
;;; converting to EQ, since CHAR= may have special compilation strategies
;;; for non-standard representations, etc.
;;; -- If either arg is definitely not a number, then we can compare with EQ.
;;; -- Otherwise, we try to put the arg we know more about second. If X is
;;; constant then we put it second. If X is a subtype of Y, we put it
;;; second. These rules make it easier for the back end to match these
;;; interesting cases.
;;; -- If Y is a fixnum, then we quietly pass because the back end can handle
;;; that case, otherwise give an efficency note.
;;;
(deftransform eql ((x y))
"convert to simpler equality predicate"
(let ((x-type (continuation-type x))
(y-type (continuation-type y))
(char-type (specifier-type 'character))
(number-type (specifier-type 'number)))
(cond ((same-leaf-ref-p x y)
't)
((not (types-intersect x-type y-type))
'nil)
((and (csubtypep x-type char-type)
(csubtypep y-type char-type))
'(char= x y))
((or (not (types-intersect x-type number-type))
(not (types-intersect y-type number-type)))
'(eq x y))
((and (not (constant-continuation-p y))
(or (constant-continuation-p x)
(and (csubtypep x-type y-type)
(not (csubtypep y-type x-type)))))
'(eql y x))
(t
(give-up)))))
;;; = IR1 Transform -- Internal
;;;
;;; Convert to EQL if both args are the "same" numeric type. This allows
;;; all of EQL's type-specific expertise to come into play. "Same" means
;;; either both rational or both floats of the same format. Complexp must also
;;; be specified and identical.
;;;
(deftransform = ((x y))
"open code"
(let ((x-type (continuation-type x))
(y-type (continuation-type y)))
(if (and (numeric-type-p x-type) (numeric-type-p y-type)
(let ((x-class (numeric-type-class x-type))
(y-class (numeric-type-class y-type))
(x-format (numeric-type-format x-type)))
(or (and (eq x-class 'float) (eq y-class 'float)
x-format
(eq x-format (numeric-type-format y-type)))
(and (member x-class '(rational integer))
(member y-class '(rational integer)))))
(let ((x-complexp (numeric-type-complexp x-type)))
(and x-complexp
(eq x-complexp (numeric-type-complexp y-type)))))
'(eql x y)
(give-up "Operands might not be the same type."))))
;;; Numeric-Type-Or-Lose -- Interface
;;;
;;; If Cont's type is a numeric type, then return the type, otherwise
;;; GIVE-UP.
;;;
(defun numeric-type-or-lose (cont)
(declare (type continuation cont))
(let ((res (continuation-type cont)))
(unless (numeric-type-p res) (give-up))
res))
;;; IR1-TRANSFORM-< -- Internal
;;;
;;; See if we can statically determine (< X Y) using type information. If
;;; X's high bound is < Y's low, then X < Y. Similarly, if X's low is >= to
;;; Y's high, the X >= Y (so return NIL). If not, at least make sure any
;;; constant arg is second.
;;;
(defun ir1-transform-< (x y first second inverse)
(if (same-leaf-ref-p x y)
'nil
(let* ((x-type (numeric-type-or-lose x))
(x-lo (numeric-type-low x-type))
(x-hi (numeric-type-high x-type))
(y-type (numeric-type-or-lose y))
(y-lo (numeric-type-low y-type))
(y-hi (numeric-type-high y-type)))
(cond ((and x-hi y-lo (< x-hi y-lo))
't)
((and y-hi x-lo (>= x-lo y-hi))
'nil)
((and (constant-continuation-p first)
(not (constant-continuation-p second)))
`(,inverse y x))
(t
(give-up))))))
(deftransform < ((x y) (integer integer))
(ir1-transform-< x y x y '>))
(deftransform > ((x y) (integer integer))
(ir1-transform-< y x x y '<))
;;;; Converting N-arg comparisons:
;;;
;;; We convert calls to N-arg comparison functions such as < into two-arg
;;; calls. This transformation is enabled for all such comparisons in this
;;; file. If any of these predicates are not open-coded, then the
;;; transformation should be removed at some point to avoid pessimization.
;;; Multi-Compare -- Internal
;;;
;;; This function is used for source transformation of N-arg comparison
;;; functions other than inequality. We deal both with converting to two-arg
;;; calls and inverting the sense of the test, if necessary. If the call has
;;; two args, then we pass or return a negated test as appropriate. If it is a
;;; degenerate one-arg call, then we transform to code that returns true.
;;; Otherwise, we bind all the arguments and expand into a bunch of IFs.
;;;
(proclaim '(function multi-compare (symbol list boolean)))
(defun multi-compare (predicate args not-p)
(let ((nargs (length args)))
(cond ((< nargs 1) (values nil t))
((= nargs 1) `(progn ,@args t))
((= nargs 2)
(if not-p
`(if (,predicate ,(first args) ,(second args)) nil t)
(values nil t)))
(t
(do* ((i (1- nargs) (1- i))
(last nil current)
(current (gensym) (gensym))
(vars (list current) (cons current vars))
(result 't (if not-p
`(if (,predicate ,current ,last)
nil ,result)
`(if (,predicate ,current ,last)
,result nil))))
((zerop i)
`((lambda ,vars ,result) . ,args)))))))
(def-source-transform = (&rest args) (multi-compare '= args nil))
(def-source-transform < (&rest args) (multi-compare '< args nil))
(def-source-transform > (&rest args) (multi-compare '> args nil))
(def-source-transform <= (&rest args) (multi-compare '> args t))
(def-source-transform >= (&rest args) (multi-compare '< args t))
(def-source-transform char= (&rest args) (multi-compare 'char= args nil))
(def-source-transform char< (&rest args) (multi-compare 'char< args nil))
(def-source-transform char> (&rest args) (multi-compare 'char> args nil))
(def-source-transform char<= (&rest args) (multi-compare 'char> args t))
(def-source-transform char>= (&rest args) (multi-compare 'char< args t))
(def-source-transform char-equal (&rest args) (multi-compare 'char-equal args nil))
(def-source-transform char-lessp (&rest args) (multi-compare 'char-lessp args nil))
(def-source-transform char-greaterp (&rest args) (multi-compare 'char-greaterp args nil))
(def-source-transform char-not-greaterp (&rest args) (multi-compare 'char-greaterp args t))
(def-source-transform char-not-lessp (&rest args) (multi-compare 'char-lessp args t))
;;; Multi-Not-Equal -- Internal
;;;
;;; This function does source transformation of N-arg inequality functions
;;; such as /=. This is similar to Multi-Compare in the <3 arg cases. If
;;; there are more than two args, then we expand into the appropriate n^2
;;; comparisons only when speed is important.
;;;
(proclaim '(function multi-not-equal (symbol list)))
(defun multi-not-equal (predicate args)
(let ((nargs (length args)))
(cond ((< nargs 1) (values nil t))
((= nargs 1) `(progn ,@args t))
((= nargs 2)
`(if (,predicate ,(first args) ,(second args)) nil t))
((not (policy nil (>= speed space) (>= speed cspeed)))
(values nil t))
(t
(collect ((vars))
(dotimes (i nargs) (vars (gensym)))
(do ((var (vars) next)
(next (cdr (vars)) (cdr next))
(result 't))
((null next)
`((lambda ,(vars) ,result) . ,args))
(let ((v1 (first var)))
(dolist (v2 next)
(setq result `(if (,predicate ,v1 ,v2) nil ,result))))))))))
(def-source-transform /= (&rest args) (multi-not-equal '= args))
(def-source-transform char/= (&rest args) (multi-not-equal 'char= args))
(def-source-transform char-not-equal (&rest args) (multi-not-equal 'char-equal args))
;;; Expand Max and Min into the obvious comparisons.
(def-source-transform max (arg &rest more-args)
(if (null more-args)
`(values ,arg)
(once-only ((arg1 arg)
(arg2 `(max ,@more-args)))
`(if (> ,arg1 ,arg2)
,arg1 ,arg2))))
;;;
(def-source-transform min (arg &rest more-args)
(if (null more-args)
`(values ,arg)
(once-only ((arg1 arg)
(arg2 `(min ,@more-args)))
`(if (< ,arg1 ,arg2)
,arg1 ,arg2))))
;;;; Converting N-arg arithmetic functions:
;;;
;;; N-arg arithmetic and logic functions are associated into two-arg
;;; versions, and degenerate cases are flushed.
;;; Associate-Arguments -- Internal
;;;
;;; Left-associate First-Arg and More-Args using Function.
;;;
(proclaim '(function associate-arguments (symbol t list) list))
(defun associate-arguments (function first-arg more-args)
(let ((next (rest more-args))
(arg (first more-args)))
(if (null next)
`(,function ,first-arg ,arg)
(associate-arguments function `(,function ,first-arg ,arg) next))))
;;; Source-Transform-Transitive -- Internal
;;;
;;; Do source transformations for transitive functions such as +. One-arg
;;; cases are replaced with the arg and zero arg cases with the identity. If
;;; Leaf-Fun is true, then replace two-arg calls with a call to that function.
;;;
(defun source-transform-transitive (fun args identity &optional leaf-fun)
(declare (symbol fun leaf-fun) (list args))
(case (length args)
(0 identity)
(1 `(values ,(first args)))
(2 (if leaf-fun
`(,leaf-fun ,(first args) ,(second args))
(values nil t)))
(t
(associate-arguments fun (first args) (rest args)))))
(def-source-transform + (&rest args) (source-transform-transitive '+ args 0))
(def-source-transform * (&rest args) (source-transform-transitive '* args 1))
(def-source-transform logior (&rest args) (source-transform-transitive 'logior args 0))
(def-source-transform logxor (&rest args) (source-transform-transitive 'logxor args 0))
(def-source-transform logand (&rest args) (source-transform-transitive 'logand args -1))
(def-source-transform logeqv (&rest args)
(if (evenp (length args))
`(lognot (logxor ,@args))
`(logxor ,@args)))
;;; Note: we can't use source-transform-transitive for GCD and LCM because when
;;; they are given one argument, they return it's absolute value.
(def-source-transform gcd (&rest args)
(case (length args)
(0 0)
(1 `(abs (the integer ,(first args))))
(2 (values nil t))
(t (associate-arguments 'gcd (first args) (rest args)))))
(def-source-transform lcm (&rest args)
(case (length args)
(0 1)
(1 `(abs (the integer ,(first args))))
(2 (values nil t))
(t (associate-arguments 'lcm (first args) (rest args)))))
;;; Source-Transform-Intransitive -- Internal
;;;
;;; Do source transformations for intransitive n-arg functions such as /.
;;; With one arg, we form the inverse. With two args we pass. Otherwise we
;;; associate into two-arg calls.
;;;
(proclaim '(function source-transform-intransitive (symbol list t) list))
(defun source-transform-intransitive (function args inverse)
(case (length args)
((0 2) (values nil t))
(1 `(,@inverse ,(first args)))
(t
(associate-arguments function (first args) (rest args)))))
(def-source-transform - (&rest args)
(source-transform-intransitive '- args '(%negate)))
(def-source-transform / (&rest args)
(source-transform-intransitive '/ args '(/ 1)))
;;;; Apply:
;;;
;;; We convert Apply into Multiple-Value-Call so that the compiler only
;;; needs to understand one kind of variable-argument call. It is more
;;; efficient to convert Apply to MV-Call than MV-Call to Apply.
(def-source-transform apply (fun arg &rest more-args)
(let ((args (cons arg more-args)))
`(multiple-value-call ,fun
,@(mapcar #'(lambda (x)
`(values ,x))
(butlast args))
(values-list ,(car (last args))))))
;;;; FORMAT transform:
;;; A transform for FORMAT, based on the original (courtesy of Skef.)
;;;
(deftransform format ((stream control &rest args)
((or (member t) stream) simple-string &rest t))
"convert to output primitives"
(unless (constant-continuation-p control)
(give-up "Control string is not a constant."))
(let* ((control (continuation-value control))
(end (length control))
(penultimus (1- end))
(stream-form (if (csubtypep (continuation-type stream)
(specifier-type 'stream))
`(stream)
()))
(arg-vars (mapcar #'(lambda (x)
(declare (ignore x))
(gensym))
args))
(args arg-vars)
(index 0))
(declare (simple-string control))
(collect ((forms))
(loop
(let ((command-index (position #\~ control :start index)))
(unless command-index
;; Write out the final part of the string.
(forms `(write-string ,(subseq control index end)
,@stream-form))
(when args
(compiler-warning "~R extra format argument~:P. Ignoring..."
(length args))
(forms `(progn ,@args)))
(return `(lambda (stream control ,@arg-vars)
(declare (ignorable stream control))
,@(forms)
nil)))
(when (= command-index penultimus)
(abort-transform "FORMAT control string ends in a ~~: ~S"
control))
;; Non-command stuff gets write-string'ed out.
(when (/= index command-index)
(forms `(write-string
,(subseq control index command-index)
,@stream-form)))
;; Get the format directive.
(flet ((next-arg ()
(unless args
(abort-transform "Missing FORMAT argument."))
(pop args)))
(forms
(case (schar control (1+ command-index))
((#\b #\B) `(let ((*print-base* 2))
(princ ,(next-arg) ,@stream-form)))
((#\o #\O) `(let ((*print-base* 8))
(princ ,(next-arg) ,@stream-form)))
((#\d #\D) `(let ((*print-base* 10))
(princ ,(next-arg) ,@stream-form)))
((#\x #\X) `(let ((*print-base* 16))
(princ ,(next-arg) ,@stream-form)))
((#\a #\A) `(princ ,(next-arg) ,@stream-form))
((#\s #\S) `(prin1 ,(next-arg) ,@stream-form))
(#\% `(terpri ,@stream-form))
(#\& `(fresh-line ,@stream-form))
(#\| `(write-char #\form ,@stream-form))
(#\~ `(write-char #\~ ,@stream-form))
(#\newline
(let ((new-pos (position-if-not
#'lisp::whitespace-char-p
control
:start (+ command-index 2))))
(if new-pos
(setq command-index (- new-pos 2)))))
(t
(give-up)))))
(setq index (+ command-index 2)))))))