Newer
Older
`(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))
`(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))
`(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))
`(let ((mask (ash (ldb (byte size 0) -1) posn)))
(logior (logand new mask)
(logand int (lognot mask)))))
;;; 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."))
(deftransform boole ((op x y) * * :when :both)
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
(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) * :when :both)
(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) *)
(deftransform ceiling ((x y) (integer integer) *)
;;; Do the same for mod.
;;;
(deftransform mod ((x y) (integer integer) * :when :both)
(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))
(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) * :when :both)
(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 :when :both)
"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) *
:when :both)
"convert (- 0 x) to negate"
'(%negate y))
(deftransform * ((x y) (rational (constant-argument (member 0))) *
:when :both)
"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
:when :both)
"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
:when :both)
"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)))))
;;; Fold (expt x n) into multiplications for small integral values of N.
(deftransform expt ((x y) (t (constant-argument real)) *)
"recode as multiplication"
(let ((val (continuation-value y)))
;; If Y would cause the result to be promoted to the same type as
;; Y, we give up. If not, then the result will be the same type
;; as X, so we can replace the exponentiation with simple
;; multiplication and division for small integral powers.
(unless (not-more-contagious y x)
(give-up))
(cond ((= val 2) '(* x x))
((= val -2) '(/ (* x x)))
((= val 3) '(* x x x))
((= val -3) '(/ (* x x x)))
(t (give-up)))))
(dolist (name '(ash /))
(deftransform name ((x y) '((constant-argument (integer 0 0)) integer) '*
:eval-name t :when :both)
"fold zero arg"
0))
(dolist (name '(truncate round floor ceiling))
(deftransform name ((x y) '((constant-argument (integer 0 0)) integer) '*
:eval-name t :when :both)
"fold zero arg"
'(values 0 0)))
(deftransform char-equal ((a b) (base-char base-char))
'(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))
'(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))
'(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
:when :both)
((not (types-intersect (continuation-type x) (continuation-type y)))
'nil)
(%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) * * :when :both)
(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))
(give-up)))))
;;; = IR1 Transform -- Internal
;;;
;;; Convert to EQL if both args are rational and complexp is specified
;;; and the same for both.
(deftransform = ((x y) * * :when :both)
(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)))
(cond ((and (eq x-class 'float) (eq y-class 'float))
;; They are both floats. Leave as = so that -0.0 is
;; handled correctly.
(give-up))
((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)))))
;; They are both rationals and complexp is the same. Convert
;; to EQL.
'(eql x y))
(t
(give-up "Operands might not be the same type."))))
(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)
(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))))))
#+propagate-float-type
(defun ir1-transform-< (x y first second inverse)
(if (same-leaf-ref-p x y)
'nil
(let ((xi (numeric-type->interval (numeric-type-or-lose x)))
(yi (numeric-type->interval (numeric-type-or-lose y))))
(cond ((interval-< xi yi)
t)
((interval-< yi xi)
nil)
((and (constant-continuation-p first)
(not (constant-continuation-p second)))
`(,inverse y x))
(t
(give-up))))))
(deftransform < ((x y) (integer integer) * :when :both)
(ir1-transform-< x y x y '>))
(deftransform > ((x y) (integer integer) * :when :both)
(ir1-transform-< y x x y '<))
#+propagate-float-type
(deftransform < ((x y) (float float) * :when :both)
(ir1-transform-< x y x y '>))
#+propagate-float-type
(deftransform > ((x y) (float float) * :when :both)
(ir1-transform-< y x x y '<))
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
;;;; 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))
(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)
(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:
;;;
;;; If the control string is a compile-time constant, then replace it with
;;; a use of the FORMATTER macro so that the control string is ``compiled.''
;;; Furthermore, if the destination is either a stream or T and the control
;;; string is a function (i.e. formatter), then convert the call to format to
;;; just a funcall of that function.
;;;
(deftransform format ((dest control &rest args) (t simple-string &rest t) *
:policy (> speed space))
(unless (constant-continuation-p control)
(give-up "Control string is not a constant."))
(let ((arg-names (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) args)))
`(lambda (dest control ,@arg-names)
(declare (ignore control))
(format dest (formatter ,(continuation-value control)) ,@arg-names))))
;;;
(deftransform format ((stream control &rest args) (stream function &rest t) *
:policy (> speed space))
(let ((arg-names (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) args)))
`(lambda (stream control ,@arg-names)
(funcall control stream ,@arg-names)
nil)))
;;;
(deftransform format ((tee control &rest args) ((member t) function &rest t) *
:policy (> speed space))