From 79ce97bb1f1d7fdc98c25a9fdc8730d6e850a04c Mon Sep 17 00:00:00 2001 From: hallgren <hallgren> Date: Wed, 2 Sep 1992 13:26:02 +0000 Subject: [PATCH] Added a couple fixes from Miles. --- compiler/disassem.lisp | 214 +++++++++++++++++++++++++++++------------ 1 file changed, 155 insertions(+), 59 deletions(-) diff --git a/compiler/disassem.lisp b/compiler/disassem.lisp index bc8f8da4d..8ac9f318b 100644 --- a/compiler/disassem.lisp +++ b/compiler/disassem.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/disassem.lisp,v 1.11 1992/08/31 11:53:27 hallgren Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/disassem.lisp,v 1.12 1992/09/02 13:26:02 hallgren Exp $") ;;; ;;; ********************************************************************** ;;; @@ -285,6 +285,26 @@ (cons nil) (t t))) +;;; ---------------------------------------------------------------- +;;; Some simple functions that help avoid consing when we're just +;;; recursively filtering things that usually don't change. + +(defun sharing-cons (old-cons car cdr) + "If CAR is eq to the car of OLD-CONS and CDR is eq to the CDR, return + OLD-CONS, otherwise return (cons CAR CDR)." + (if (and (eq car (car old-cons)) (eq cdr (cdr old-cons))) + old-cons + (cons car cdr))) + +(defun sharing-mapcar (fun list) + "A simple (one list arg) mapcar that avoids consing up a new list + as long as the results of calling FUN on the elements of LIST are + eq to the original." + (and list + (sharing-cons list + (funcall fun (car list)) + (sharing-mapcar fun (cdr list))))) + ;;; ---------------------------------------------------------------- ;;; A Dchunk contains the bits we look at to decode an ;;; instruction. @@ -545,7 +565,7 @@ (defun arg-or-lose (name funstate) (let ((arg (find name (funstate-args funstate) :key #'arg-name))) (when (null arg) - (error "Unknown argument ~s" name)) + (pd-error "Unknown argument ~s" name)) arg)) (defun get-arg-temp (arg kind funstate) @@ -692,6 +712,12 @@ (equal (arg-sign-extend-p new-arg) (arg-sign-extend-p old-arg)))) +(defun valsrc-equal (f1 f2) + (if (null f1) + (null f2) + (equal (value-or-source f1) + (value-or-source f2)))) + (def-arg-form-kind (:filtering) :producer #'(lambda (arg funstate) (let ((sign-extended-forms @@ -704,12 +730,7 @@ t) (values sign-extended-forms nil)))) :checker #'(lambda (new-arg old-arg) - (let ((pf1 (arg-prefilter new-arg)) - (pf2 (arg-prefilter old-arg))) - (if (null pf1) - (null pf2) - (equal (value-or-source pf1) - (value-or-source pf2)))))) + (valsrc-equal (arg-prefilter new-arg) (arg-prefilter old-arg)))) (def-arg-form-kind (:filtered :unadjusted) :producer #'(lambda (arg funstate) @@ -735,12 +756,7 @@ ,(source-form use-label))) filtered-forms))) :checker #'(lambda (new-arg old-arg) - (let ((lf1 (arg-use-label new-arg)) - (lf2 (arg-use-label old-arg))) - (if (null lf1) - (null lf2) - (equal (value-or-source lf1) - (value-or-source lf2)))))) + (valsrc-equal (arg-use-label new-arg) (arg-use-label old-arg)))) (def-arg-form-kind (:labelled :final) :producer #'(lambda (arg funstate) @@ -762,6 +778,18 @@ (lf2 (arg-use-label old-arg))) (if (null lf1) (null lf2) t)))) +;;; This is a bogus kind that's just used to ensure that printers are +;;; compatible... +(def-arg-form-kind (:printed) + :producer #'(lambda (&rest noise) + (declare (ignore noise)) + (pd-error "Bogus! Can't use the :printed value of an arg!")) + :checker #'(lambda (new-arg old-arg) + (valsrc-equal (arg-printer new-arg) (arg-printer old-arg)))) + +(defun remember-printer-use (arg funstate) + (set-arg-temps nil nil arg :printed funstate)) + ;;; ---------------------------------------------------------------- (defun compare-fields-form (val-form-1 val-form-2) @@ -830,7 +858,7 @@ ;;; ---------------------------------------------------------------- -(defun find-first-symbol (tree) +(defun find-first-field-name (tree) "Returns the first non-keyword symbol in a depth-first search of TREE." (cond ((null tree) nil) @@ -838,9 +866,11 @@ tree) ((atom tree) nil) + ((eq (car tree) 'quote) + nil) (t - (or (find-first-symbol (car tree)) - (find-first-symbol (cdr tree)))))) + (or (find-first-field-name (car tree)) + (find-first-field-name (cdr tree)))))) (defun string-or-qsym-p (thing) (or (stringp thing) @@ -880,6 +910,7 @@ (printer (or printer (arg-printer arg))) (printer-val (value-or-source printer)) (printer-src (source-form printer))) + (remember-printer-use arg funstate) (cond ((stringp printer-val) `(local-format-arg ,(arg-value-form arg funstate) ,printer-val)) ((vectorp printer-val) @@ -930,26 +961,16 @@ `(local-princ ,source)) ((eq (car source) 'function) `(local-call-global-printer ,source)) - ((member (car source) '(:unless :when)) - `(,(if (eq (car source) :when) 'when 'unless) - ,(compile-test (find-first-symbol (cddr source)) - (cadr source) - funstate) - ,@(compile-printer-list (cddr source) funstate))) ((eq (car source) :cond) `(cond ,@(mapcar #'(lambda (clause) - `(,(compile-test (find-first-symbol + `(,(compile-test (find-first-field-name (cdr clause)) (car clause) funstate) ,@(compile-printer-list (cdr clause) funstate))) (cdr source)))) - ((eq (car source) :if) - `(if ,(compile-test (find-first-symbol (cddr source)) - (cadr source) - funstate) - ,@(compile-printer-list (cddr source) funstate))) + ;; :if, :unless, and :when are replaced by :cond during preprocessing (t `(progn ,@(compile-printer-list source funstate))))) @@ -1012,12 +1033,6 @@ ;;; ---------------------------------------------------------------- -(defun choose-in-printer-p (printer) - "Returns non-NIL if :CHOOSE occurs somewhere in PRINTER." - (if (atom printer) - (eq printer :choose) - (some #'choose-in-printer-p printer))) - (defun all-arg-refs-relevent-p (printer args) (cond ((or (null printer) (keywordp printer) (eq printer t)) t) @@ -1026,27 +1041,103 @@ ((listp printer) (every #'(lambda (x) (all-arg-refs-relevent-p x args)) printer)) - (t - t))) + (t t))) (defun pick-printer-choice (choices args) (dolist (choice choices - (pd-error "No suitable choice found in ~s" choices)) - (when (choose-in-printer-p choice) - (setf choice (preprocess-printer choice args))) + (pd-error "No suitable choice found in ~s" choices)) (when (all-arg-refs-relevent-p choice args) (return choice)))) +(defun preprocess-chooses (printer args) + (cond ((atom printer) + printer) + ((eq (car printer) :choose) + (pick-printer-choice (cdr printer) args)) + (t + (sharing-mapcar #'(lambda (sub) (preprocess-chooses sub args)) + printer)))) + +;;; ---------------------------------------------------------------- + +(defun preprocess-test (subj form args) + (multiple-value-bind (subj test) + (if (and (consp form) (symbolp (car form)) (not (keywordp (car form)))) + (values (car form) (cdr form)) + (values subj form)) + (let ((key (if (consp test) (car test) test)) + (body (if (consp test) (cdr test) nil))) + (case key + (:constant + (if (null body) + ;; if no supplied constant values, just any constant is ok, just + ;; see if there's some constant value in the arg. + (not + (null + (arg-value + (or (find subj args :key #'arg-name) + (pd-error "Unknown argument ~s" subj))))) + ;; otherwise, defer to run-time + form)) + ((:or :and :not) + (sharing-cons + form + subj + (sharing-cons + test + key + (sharing-mapcar + #'(lambda (sub-test) + (preprocess-test subj sub-test args)) + body)))) + (t form))))) + +(defun preprocess-conditionals (printer args) + (if (atom printer) + printer + (case (car printer) + (:unless + (preprocess-conditionals + `(:cond ((:not ,(nth 1 printer)) ,@(nthcdr 2 printer))) + args)) + (:when + (preprocess-conditionals `(:cond (,(cdr printer))) args)) + (:if + (preprocess-conditionals + `(:cond (,(nth 1 printer) ,(nth 2 printer)) + (t ,(nth 3 printer))) + args)) + (:cond + (sharing-cons + printer + :cond + (sharing-mapcar + #'(lambda (clause) + (let ((filtered-body + (sharing-mapcar + #'(lambda (sub-printer) + (preprocess-conditionals sub-printer args)) + (cdr clause)))) + (sharing-cons + clause + (preprocess-test (find-first-field-name filtered-body) + (car clause) + args) + filtered-body))) + (cdr printer)))) + (quote printer) + (t + (sharing-mapcar + #'(lambda (sub-printer) + (preprocess-conditionals sub-printer args)) + printer))))) + (defun preprocess-printer (printer args) - "Returns a version of the disassembly-template PRINTER with any :CHOOSE - operators resolved properly for the args ARGS. (:CHOOSE Sub*) - simply returns the first Sub in which every field reference refers to a - valid arg." - (if (and (choose-in-printer-p printer) (listp printer)) - (if (eq (car printer) :choose) - (pick-printer-choice (cdr printer) args) - (mapcar #'(lambda (sub) (preprocess-printer sub args)) printer)) - printer)) + "Returns a version of the disassembly-template PRINTER with compile-time + tests (e.g. :constant without a value), and any :CHOOSE operators resolved + properly for the args ARGS. (:CHOOSE Sub*) simply returns the first Sub in + which every field reference refers to a valid arg." + (preprocess-conditionals (preprocess-chooses printer args) args)) ;;; ---------------------------------------------------------------- @@ -1083,12 +1174,15 @@ (make-cached-function :name ,name-var :funstate ,funstate-var :constraint ,constraint-var))) - (push ,cache-var ,cache-place) #+nil (format t "~&; Making new function ~s~%" (cached-fun-name ,cache-var)) - (values (cached-fun-name ,cache-var) - (progn ,@defun-maker-forms)))))))) + (multiple-value-prog1 + (values (cached-fun-name ,cache-var) + (progn ,@defun-maker-forms)) + ;; Add to the cache second, so errors in defun-maker-forms + ;; will result in nothing being added. + (push ,cache-var ,cache-place)))))))) ;;; ---------------------------------------------------------------- @@ -1385,7 +1479,8 @@ `(progn ,@wrapper-defs (eval-when (compile eval) - ,(update-args-form (arg-type-table-name) `',name args evalp))))) + ,(update-args-form (arg-type-table-name) `',name args evalp)) + ',name))) (defun maybe-quote (evalp form) (if (or evalp (self-evaluating-p form)) form `',form)) @@ -2052,12 +2147,13 @@ (type segment segment)) (setf (dstate-segment dstate) segment) (setf (dstate-cur-offs-hooks dstate) - (sort (copy-list (seg-hooks segment)) - #'(lambda (oh1 oh2) - (or (< (offs-hook-offset oh1) (offs-hook-offset oh2)) - (and (= (offs-hook-offset oh1) (offs-hook-offset oh2)) - (offs-hook-before-address oh1) - (not (offs-hook-before-address oh2))))))) + (stable-sort (nreverse (copy-list (seg-hooks segment))) + #'(lambda (oh1 oh2) + (or (< (offs-hook-offset oh1) (offs-hook-offset oh2)) + (and (= (offs-hook-offset oh1) + (offs-hook-offset oh2)) + (offs-hook-before-address oh1) + (not (offs-hook-before-address oh2))))))) (setf (dstate-cur-offs dstate) 0) (setf (dstate-cur-labels dstate) (dstate-labels dstate))) -- GitLab