From ae411f84e8a2c29059d2cc9a1bacab630f14f32f Mon Sep 17 00:00:00 2001 From: Stas Boukarev Date: Tue, 7 Feb 2017 18:44:31 +0300 Subject: [PATCH] More robust undefined restarts. Keep the restarts if the user supplied value is no good. Don't use fdefns and don't overwrite input registers of safe-fdefn-fun. --- package-data-list.lisp-expr | 3 +- src/assembly/x86-64/tramps.lisp | 19 +----- src/code/condition.lisp | 3 + src/code/fdefinition.lisp | 5 -- src/code/interr.lisp | 137 ++++++++++++++++++++++---------------- src/compiler/debug-dump.lisp | 36 ++++++++-- src/compiler/generic/vm-fndb.lisp | 1 - src/compiler/x86-64/alloc.lisp | 10 --- src/compiler/x86-64/cell.lisp | 6 +- 9 files changed, 122 insertions(+), 98 deletions(-) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 555577d1b..009881cbe 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -326,6 +326,7 @@ of SBCL which maintained the CMU-CL-style split into two packages.)" "NODE-STACK-ALLOCATE-P" "NON-DESCRIPTOR-STACK" "NOTE-ENVIRONMENT-START" "NOTE-THIS-LOCATION" "*LOCATION-CONTEXT*" + "MAKE-RESTART-LOCATION" "OPTIMIZER" "PARSE-EVAL-WHEN-SITUATIONS" "POLICY" @@ -1008,6 +1009,7 @@ possibly temporarily, because it might be used internally." "+NIL-PACKED-INFOS+" "CLEAR-INFO" "FIND-FDEFN" + "SYMBOL-FDEFN" "GET-INFO-VALUE-INITIALIZING" "INFO" "INFO-FIND-AUX-KEY/PACKED" @@ -2031,7 +2033,6 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "%FUN-NAME" "FDEFN" "MAKE-FDEFN" "FDEFN-P" "FDEFN-NAME" "FDEFN-FUN" - "MAKE-DUMMY-FDEFN" "FDEFN-MAKUNBOUND" "%COERCE-CALLABLE-TO-FUN" "FUN-SUBTYPE" "*MAXIMUM-ERROR-DEPTH*" "%SET-SYMBOL-PLIST" diff --git a/src/assembly/x86-64/tramps.lisp b/src/assembly/x86-64/tramps.lisp index 5f30a06ff..11f5d7f4c 100644 --- a/src/assembly/x86-64/tramps.lisp +++ b/src/assembly/x86-64/tramps.lisp @@ -18,25 +18,10 @@ (inst pop (make-ea :qword :base rbp-tn :disp n-word-bytes)) (emit-error-break nil cerror-trap (error-number-or-lose 'undefined-fun-error) (list rax)) (inst push (make-ea :qword :base rbp-tn :disp n-word-bytes)) - #!-immobile-code (inst jmp (make-ea :qword :base rax - :disp (- (* fdefn-raw-addr-slot - n-word-bytes) - other-pointer-lowtag))) - #!+immobile-code - ;; No single instruction can jump to the raw function in an fdefn. - ;; There are a couple ways to go about it: load the tagged function object - ;; and call that, or circuitously "return" to an address that directs - ;; control flow to the raw function. This logic opts for the latter, - ;; on the grounds that it does not mutate the contents of RAX. - ;; FIXME: Maybe it would be ok to just add 9 to rax and jump there, - ;; but have to think about lifetime of the FDEFN if we have no pointer - ;; to it. Or teach GC about interior pointers to fdefns. Or something. - (progn (inst push rax) - (inst add (make-ea :qword :base rsp-tn) - (- (* fdefn-raw-addr-slot n-word-bytes) other-pointer-lowtag)) - (inst ret))) + :disp (- (* closure-fun-slot n-word-bytes) + fun-pointer-lowtag)))) (define-assembly-routine (undefined-alien-tramp (:return-style :none)) diff --git a/src/code/condition.lisp b/src/code/condition.lisp index 26ffe2986..ad5cab0c4 100644 --- a/src/code/condition.lisp +++ b/src/code/condition.lisp @@ -598,6 +598,9 @@ "The function ~S is undefined." (cell-error-name condition)))))) +(define-condition retry-undefined-function + (simple-condition undefined-function) ()) + (define-condition special-form-function (undefined-function) () (:report (lambda (condition stream) diff --git a/src/code/fdefinition.lisp b/src/code/fdefinition.lisp index 1ad26004b..70f70a9d7 100644 --- a/src/code/fdefinition.lisp +++ b/src/code/fdefinition.lisp @@ -18,11 +18,6 @@ ;;;; fdefinition (fdefn) objects -;;; This is used for undefined-fun-error restarts - (defun make-dummy-fdefn () ; FIXME: what's wrong with just MAKE-FDEFN ? - #!+(or (not immobile-space) immobile-code) (make-fdefn nil) - #!+(and immobile-space (not immobile-code)) (make-dummy-fdefn)) - (defun make-fdefn (name) #!-immobile-space (make-fdefn name) ;; This is %primitive because it needs pseudo-atomic, diff --git a/src/code/interr.lisp b/src/code/interr.lisp index 3c26613fb..8e1637b84 100644 --- a/src/code/interr.lisp +++ b/src/code/interr.lisp @@ -45,6 +45,86 @@ (defvar *current-internal-error-args*) (defvar *current-internal-error-context*) +#!+undefined-fun-restarts +(defun restart-undefined (name fdefn-or-symbol context) + (multiple-value-bind (tn-offset pc-offset) + (if context + (sb!c::decode-restart-location context) + (car *current-internal-error-args*)) + (labels ((retry-value (value) + (or (typecase value + (fdefn (fdefn-fun value)) + (symbol + (let ((fdefn (symbol-fdefn value))) + (and fdefn + (fdefn-fun fdefn)))) + (function value) + (t + (try (make-condition 'retry-undefined-function + :name name + :format-control "Bad value when resarting ~s: ~s" + :format-arguments (list name value)) + t))) + (try (make-condition 'retry-undefined-function + :name name + :format-control (if (fdefn-p value) + "~S is still undefined" + "Can't replace ~s with ~s because it is undefined") + :format-arguments (list name value)) + t))) + (set-value (function retrying) + (if retrying + (retry-value function) + (sb!di::sub-set-debug-var-slot + nil tn-offset + (retry-value function) + *current-internal-error-context*))) + (try (condition &optional retrying) + (cond (context + ;; The #'abc case from SAFE-FDEFN-FUN, CONTEXT + ;; specifies the offset from the error location + ;; where it can retry checking the FDEFN + (restart-case (error condition) + (continue () + :report (lambda (stream) + (format stream "Retry using ~s." name)) + (set-value fdefn-or-symbol retrying)) + (use-value (value) + :report (lambda (stream) + (format stream "Use specified function.")) + :interactive read-evaluated-form + (set-value value retrying))) + (unless retrying + (sb!vm::incf-context-pc *current-internal-error-context* + pc-offset))) + (t + (restart-case (error condition) + (continue () + :report (lambda (stream) + (format stream "Retry calling ~s." name)) + (set-value fdefn-or-symbol retrying)) + (use-value (value) + :report (lambda (stream) + (format stream "Call specified function.")) + :interactive read-evaluated-form + (set-value value retrying)) + (return-value (&rest values) + :report (lambda (stream) + (format stream "Return specified values.")) + :interactive mv-read-evaluated-form + (set-value (lambda (&rest args) + (declare (ignore args)) + (values-list values)) + retrying)) + (return-nothing () + :report (lambda (stream) + (format stream "Return zero values.")) + (set-value (lambda (&rest args) + (declare (ignore args)) + (values)) + retrying))))))) + (try (make-condition 'undefined-function :name name))))) + (deferr undefined-fun-error (fdefn-or-symbol) (let ((name (etypecase fdefn-or-symbol (symbol fdefn-or-symbol) @@ -54,62 +134,7 @@ (cond #!+undefined-fun-restarts ((or (= *current-internal-trap-number* sb!vm:cerror-trap) (integerp (setf context (sb!di:error-context)))) - (flet ((set-value (value) - ;; Can't use the VOP because FDEFNs have to go in low space - ;; to allow immobile-code to do what it should. - ;; Assumptions are violated if they are found in high space, - ;; not the least being how far a rel32 operand can reach. - #!+immobile-code (declare (notinline make-dummy-fdefn)) - (let ((fdefn (make-dummy-fdefn))) - (setf (fdefn-fun fdefn) value) - (sb!di::sub-set-debug-var-slot - nil (car *current-internal-error-args*) - fdefn - *current-internal-error-context*)))) - (cond (context - ;; The #'abc case from SAFE-FDEFN-FUN, CONTEXT - ;; specifies the offset from the error location - ;; where it can retry checking the FDEFN - ;; NOTE: - ;; This overwrites the original FDEFN register - ;; but is unlikely to cause any problems since - ;; FDEFNs are usually loaded by SAFE-FDEFN-FUN - ;; from constants. And it's not overwriting the - ;; FDEFN with some garbage but with another FDEFN. - (restart-case (error 'undefined-function :name name) - (continue () - :report (lambda (stream) - (format stream "Retry using ~s." name))) - (use-value (value) - :report (lambda (stream) - (format stream "Use specified function.")) - :interactive read-evaluated-form - (set-value (%coerce-callable-to-fun value)))) - (sb!vm::incf-context-pc *current-internal-error-context* - context)) - (t - (restart-case (error 'undefined-function :name name) - (continue () - :report (lambda (stream) - (format stream "Retry calling ~s." name))) - (use-value (value) - :report (lambda (stream) - (format stream "Call specified function.")) - :interactive read-evaluated-form - (set-value (%coerce-callable-to-fun value))) - (return-value (&rest values) - :report (lambda (stream) - (format stream "Return specified values.")) - :interactive mv-read-evaluated-form - (set-value (lambda (&rest args) - (declare (ignore args)) - (values-list values)))) - (return-nothing () - :report (lambda (stream) - (format stream "Return zero values.")) - (set-value (lambda (&rest args) - (declare (ignore args)) - (values))))))))) + (restart-undefined name fdefn-or-symbol context)) (t (error 'undefined-function :name name))))) diff --git a/src/compiler/debug-dump.lisp b/src/compiler/debug-dump.lisp index 898e157fe..628593a83 100644 --- a/src/compiler/debug-dump.lisp +++ b/src/compiler/debug-dump.lisp @@ -39,6 +39,13 @@ ;; The VOP that emitted this location (for node, save-set, ir2-block, etc.) (vop nil :type vop)) +(defstruct (restart-location + (:constructor make-restart-location (label tn)) + (:predicate nil) + (:copier nil)) + (label nil :type label :read-only t) + (tn nil :type tn :read-only t)) + ;;; This is called during code generation in places where there is an ;;; "interesting" location: someplace where we are likely to end up ;;; in the debugger, and thus want debug info. @@ -110,6 +117,26 @@ (defvar *previous-location*) (declaim (type index *previous-location*)) +(defun encode-restart-location (location x) + (typecase x + (restart-location + (let ((tn-offset (tn-offset (restart-location-tn x))) + (offset (- (label-position (restart-location-label x)) + location)) + (registers-size #.(integer-length (sb-size (sb-or-lose 'sb!vm::registers))))) + (the fixnum (logior (ash offset registers-size) + tn-offset)))) + (t + x))) + +(defun decode-restart-location (x) + (declare (fixnum x)) + (let ((registers-size #.(integer-length (sb-size (sb-or-lose 'sb!vm::registers))))) + (values (make-sc-offset + (sc-number-or-lose 'sb!vm::descriptor-reg) + (ldb (byte registers-size 0) x)) + (ash x (- registers-size))))) + ;;; Dump a compiled debug-location into *BYTE-BUFFER* that describes ;;; the code/source map and live info. If true, VOP is the VOP ;;; associated with this location, for use in determining whether TNs @@ -159,11 +186,10 @@ (when stepping (write-var-string stepping byte-buffer)) (when context - (when (label-p context) - (setf context (- (label-position context) loc))) - (write-var-integer (or (position context *contexts* :test #'equal) - (vector-push-extend context *contexts*)) - byte-buffer))) + (let ((context (encode-restart-location loc context))) + (write-var-integer (or (position context *contexts* :test #'equal) + (vector-push-extend context *contexts*)) + byte-buffer)))) (values)) ;;; Extract context info from a Location-Info structure and use it to diff --git a/src/compiler/generic/vm-fndb.lisp b/src/compiler/generic/vm-fndb.lisp index 751aa6ba2..c203db7f7 100644 --- a/src/compiler/generic/vm-fndb.lisp +++ b/src/compiler/generic/vm-fndb.lisp @@ -430,7 +430,6 @@ (flushable)) (defknown make-fdefn (t) fdefn (flushable movable)) -(defknown make-dummy-fdefn () fdefn (flushable movable)) (defknown fdefn-p (t) boolean (movable foldable flushable)) (defknown fdefn-name (fdefn) t (foldable flushable)) (defknown fdefn-fun (fdefn) (or function null) (flushable)) diff --git a/src/compiler/x86-64/alloc.lisp b/src/compiler/x86-64/alloc.lisp index 77eee16b8..0f443d96f 100644 --- a/src/compiler/x86-64/alloc.lisp +++ b/src/compiler/x86-64/alloc.lisp @@ -280,16 +280,6 @@ (storew nil-value result fdefn-fun-slot other-pointer-lowtag) (storew (make-fixup 'undefined-tramp :assembly-routine) result fdefn-raw-addr-slot other-pointer-lowtag)))) -#!+immobile-space -(define-vop (make-dummy-fdefn) - (:policy :fast-safe) - (:translate make-dummy-fdefn) - (:results (result :scs (descriptor-reg))) - (:node-var node) - (:generator 37 - (with-fixed-allocation (result fdefn-widetag fdefn-size node) - (storew nil-value result fdefn-name-slot other-pointer-lowtag) - (storew nil-value result fdefn-fun-slot other-pointer-lowtag)))) (define-vop (make-closure) (:args (function :to :save :scs (descriptor-reg))) diff --git a/src/compiler/x86-64/cell.lisp b/src/compiler/x86-64/cell.lisp index 9de8481b6..1041d0af8 100644 --- a/src/compiler/x86-64/cell.lisp +++ b/src/compiler/x86-64/cell.lisp @@ -336,13 +336,13 @@ (:vop-var vop) (:save-p :compute-only) (:generator 10 - RETRY (loadw value object fdefn-fun-slot other-pointer-lowtag) ;; byte comparison works because lowtags of function and nil differ (inst cmp (reg-in-size value :byte) (logand nil-value #xff)) - (let* ((*location-context* RETRY) + (let* ((*location-context* (make-restart-location RETRY value)) (err-lab (generate-error-code vop 'undefined-fun-error object))) - (inst jmp :e err-lab)))) + (inst jmp :e err-lab)) + RETRY)) #!-immobile-code (define-vop (set-fdefn-fun) -- 2.11.4.GIT