Skip to content
Snippets Groups Projects
srctran.lisp 48.5 KiB
Newer Older
wlott's avatar
wlott committed

;;;; Character operations:

(deftransform char-equal ((a b) (base-character base-character))
  "open code"
wlott's avatar
wlott committed
  '(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-character))
  "open code"
wlott's avatar
wlott committed
  '(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-character))
  "open code"
wlott's avatar
wlott committed
  '(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.
wlott's avatar
wlott committed
;;;
(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))))
wlott's avatar
wlott committed


;;; 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)
wlott's avatar
wlott committed
	(t
wlott's avatar
wlott committed

(dolist (x '(eq char= equal))
  (%deftransform x '(function * *) #'simple-equality-transform))
wlott's avatar
wlott committed


;;; 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.
wlott's avatar
wlott committed
;;;
(deftransform eql ((x y))
  "convert to simpler equality predicate"
wlott's avatar
wlott committed
  (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))
wlott's avatar
wlott committed
	  (t
wlott's avatar
wlott committed


;;; = 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."))))
wlott's avatar
wlott committed
;;; 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.
wlott's avatar
wlott committed
;;;
(defun ir1-transform-< (x y first second inverse)
wlott's avatar
wlott committed
  (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))
wlott's avatar
wlott committed

(deftransform < ((x y) (integer integer))
  (ir1-transform-< x y x y '>))
wlott's avatar
wlott committed

(deftransform > ((x y) (integer integer))
  (ir1-transform-< y x x y '<))
wlott's avatar
wlott committed


;;;; 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))
wlott's avatar
wlott committed
  (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))
wlott's avatar
wlott committed
(def-source-transform logeqv (&rest args)
  (if (evenp (length args))
      `(lognot (logxor ,@args))
      `(logxor ,@args)))
wlott's avatar
wlott committed

;;; 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)))))

wlott's avatar
wlott committed

;;; Source-Transform-Intransitive  --  Internal
;;;
;;;    Do source transformations for intransitive n-arg functions such as /.
;;; With one arg, we form the inverse using the indentity, 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 identity)
  (case (length args)
    ((0 2) (values nil t))
    (1 `(,function ,identity ,(first args)))
    (t
     (associate-arguments function (first args) (rest args)))))

(def-source-transform - (&rest args) (source-transform-intransitive '- args 0))
(def-source-transform / (&rest args) (source-transform-intransitive '/ args 1))

(deftransform - ((x y))
  (unless (and (constant-continuation-p x) (zerop (continuation-value x)))
    (give-up))
  '(%negate y))


;;;; 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"
wlott's avatar
wlott committed
  (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)))

wlott's avatar
wlott committed
	    (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"
wlott's avatar
wlott committed

	  ;; 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)))))
wlott's avatar
wlott committed

	  (setq index (+ command-index 2)))))))