From c5146075b07d3b2539d2c3708f1c8d74840b6924 Mon Sep 17 00:00:00 2001 From: Douglas Katzman Date: Fri, 23 Jan 2015 23:30:27 -0500 Subject: [PATCH] Enforce consistency between DEFINE-COLD-FOP and DEFINE-FOP. Delete :pushp option. Make it an error if define-cold-fop does not name the same non-stack operands as define-fop did. --- src/code/early-fasl.lisp | 12 ++++- src/code/fop.lisp | 41 +++++++++-------- src/code/load.lisp | 19 ++++---- src/compiler/dump.lisp | 15 +++--- src/compiler/generic/genesis.lisp | 97 ++++++++++++++++----------------------- 5 files changed, 86 insertions(+), 98 deletions(-) diff --git a/src/code/early-fasl.lisp b/src/code/early-fasl.lisp index f20592039..0fa10daa6 100644 --- a/src/code/early-fasl.lisp +++ b/src/code/early-fasl.lisp @@ -141,8 +141,16 @@ ;;; the fop stack. But if the fop is defined to receive an argument (or two) ;;; then loader's main loop is responsible for supplying it. (defvar *fop-funs* (make-array 256 :initial-element 0)) -(declaim (type (simple-bit-vector 64) *fop-argp*)) -(defglobal *fop-argp* (make-array 64 :element-type 'bit :initial-element 0)) + +;; Two bitmaps indicate function signature. One tells whether the fop takes +;; operands (other than from the stack). Each consecutive block of 4 opcodes +;; either does or doesn't, so the array is 1/4th the size of the opcode space. +;; The other tells whether the fop wants its result pushed on the stack. +(declaim (type (cons (simple-bit-vector 64) (simple-bit-vector 256)) + *fop-signatures*)) +(defglobal *fop-signatures* + (cons (make-array 64 :element-type 'bit :initial-element 0) + (make-array 256 :element-type 'bit :initial-element 0))) ;;;; variables diff --git a/src/code/fop.lisp b/src/code/fop.lisp index 719301d0a..8105a5833 100644 --- a/src/code/fop.lisp +++ b/src/code/fop.lisp @@ -33,48 +33,49 @@ ;;; (defmacro !define-fop (fop-code (name &optional arglist (pushp t)) &body forms) (aver (member pushp '(nil t))) - (binding* (((operands stack-args) - (if (consp (car arglist)) - (ecase (caar arglist) - (:operands (values (cdar arglist) (cdr arglist)))) - (values nil arglist))) - (guts (if pushp `((push-fop-stack (progn ,@forms))) forms))) + (multiple-value-bind (operands stack-args) + (if (consp (car arglist)) + (ecase (caar arglist) + (:operands (values (cdar arglist) (cdr arglist)))) + (values nil arglist)) (assert (<= (length operands) 2)) `(progn (defun ,name ,operands ,@(if (null stack-args) - guts + forms (with-unique-names (stack ptr) `((with-fop-stack (,stack ,ptr ,(length stack-args)) (multiple-value-bind ,stack-args (values ,@(loop for i below (length stack-args) collect `(fop-stack-ref (+ ,ptr ,i)))) - ,@guts)))))) - (!%define-fop ',name ,fop-code ,(length operands))))) + ,@forms)))))) + (!%define-fop ',name ,fop-code ,(length operands) ,(if pushp 1 0))))) -(defun !%define-fop (name code n-operands) +(defun !%define-fop (name base-opcode n-operands pushp) (declare (type (mod 3) n-operands)) ; 0, 1, or 2 are allowed (let ((n-slots (expt 4 n-operands))) - (unless (zerop (mod code n-slots)) + (unless (zerop (mod base-opcode n-slots)) (error "Opcode for fop ~S must be a multiple of ~D" name n-slots)) - (loop for opcode from code below (+ code n-slots) + (loop for opcode from base-opcode below (+ base-opcode n-slots) when (functionp (svref *fop-funs* opcode)) do (let ((oname (svref *fop-names* opcode))) (when (and oname (not (eq oname name))) (error "fop ~S with opcode ~D conflicts with fop ~S." name opcode oname)))) (let ((existing-opcode (get name 'opcode))) - (when (and existing-opcode (/= existing-opcode code)) + (when (and existing-opcode (/= existing-opcode base-opcode)) (error "multiple codes for fop name ~S: ~D and ~D" - name code existing-opcode))) - (setf (get name 'opcode) code) + name base-opcode existing-opcode))) + (setf (get name 'opcode) base-opcode) ;; The low 2 bits of the opcode comprise the length modifier if there is ;; exactly one operand. Such opcodes are aligned in blocks of 4. ;; 2-operand fops occupy 16 slots in a reserved range of the function table. - (loop for opcode from code below (+ code n-slots) - do (setf (svref *fop-names* opcode) name - (svref *fop-funs* opcode) (symbol-function name) - (sbit *fop-argp* (ash opcode -2)) (signum n-operands)))) + (dotimes (j n-slots) + (let ((opcode (+ base-opcode j))) + (setf (svref *fop-names* opcode) name + (svref *fop-funs* opcode) (symbol-function name) + (sbit (car *fop-signatures*) (ash opcode -2)) (signum n-operands) + (sbit (cdr *fop-signatures*) opcode) pushp)))) name) ;;; a helper function for reading string values from FASL files: sort @@ -512,7 +513,7 @@ (let* ((obi (read-word-arg)) (obj (ref-fop-table obi)) (idx (read-word-arg))) - (if (%instancep obj) + (if (%instancep obj) ; suspicious. should have been FOP-STRUCTSET (setf (%instance-ref obj idx) val) (setf (svref obj idx) val)))) diff --git a/src/code/load.lisp b/src/code/load.lisp index 0ec6d9042..30512090e 100644 --- a/src/code/load.lisp +++ b/src/code/load.lisp @@ -437,10 +437,10 @@ (let ((*skip-until* nil)) (declare (special *skip-until*)) (loop - (let ((byte (the (unsigned-byte 8) (read-byte stream)))) + (let ((byte (the (unsigned-byte 8) (read-byte stream))) + (trace (or #!+sb-show *show-fops-p*))) ;; Do some debugging output. - #!+sb-show - (when *show-fops-p* + (when trace (format *trace-output* "~&~6x : [~D,~D] ~2,'0x(~A)" (1- (file-position stream)) (svref *fop-stack* 0) ; stack pointer @@ -451,8 +451,8 @@ (let ((function (svref *fop-funs* byte))) (cond ((not (functionp function)) (error "corrupt fasl file: FOP code #x~x" byte)) - ((zerop (sbit *fop-argp* (ash byte -2))) ; no operands - (funcall function)) + ((zerop (sbit (car *fop-signatures*) (ash byte -2))) + (funcall function)) ; takes no arguments (t (let (arg1 arg2) ; See !%DEFINE-FOP for encoding (with-fast-read-byte ((unsigned-byte 8) stream) @@ -461,15 +461,14 @@ (when (>= byte +2-operand-fops+) (setq arg2 (fast-read-var-u-integer (ash 1 (ldb (byte 2 2) byte)))))) - #!+sb-show - (when *show-fops-p* + (when trace (format *trace-output* "{~D~@[,~D~]}" arg1 arg2)) (if arg2 (funcall function arg1 arg2) (funcall function arg1)))))))) - (declare (ignorable result)) - #!+sb-show - (when *show-fops-p* + (when (plusp (sbit (cdr *fop-signatures*) byte)) + (push-fop-stack result)) + (when trace (let* ((stack *fop-stack*) (ptr (svref stack 0))) (format *trace-output* " -- ~[,~D~:;[~:*~D,~D] ~S~]" diff --git a/src/compiler/dump.lisp b/src/compiler/dump.lisp index 0f7176eec..0d1d0f6b4 100644 --- a/src/compiler/dump.lisp +++ b/src/compiler/dump.lisp @@ -167,16 +167,15 @@ ;;; optimizations should be conditional on #!+SB-FROZEN. (defmacro dump-fop (fs-expr file &rest args) (let* ((fs (eval fs-expr)) - (val (get fs 'opcode)) + (val (or (get fs 'opcode) + (error "compiler bug: ~S is not a legal fasload operator." + fs-expr))) (fop-argc - (if val - (if (>= val +2-operand-fops+) 2 (sbit *fop-argp* (ash val -2))) - 0)) - (supplied-argc (length args))) + (if (>= val +2-operand-fops+) + 2 + (sbit (car *fop-signatures*) (ash val -2))))) (cond - ((not val) - (error "compiler bug: ~S is not a legal fasload operator." fs-expr)) - ((not (eql supplied-argc fop-argc)) + ((not (eql (length args) fop-argc)) (error "~S takes ~D argument~:P" fs fop-argc)) (t `(progn diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index 84f68bce6..d74db27b6 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -2104,18 +2104,17 @@ core and return a descriptor to it." ;;; DEFINE-FOP) instead of creating a code, and ;;; (2) stores its definition in the *COLD-FOP-FUNS* vector, ;;; instead of storing in the *FOP-FUNS* vector. -(defmacro define-cold-fop ((name &key (pushp t)) &rest forms) - (aver (member pushp '(nil t))) +(defmacro define-cold-fop ((name &optional arglist) &rest forms) (let* ((code (get name 'opcode)) - (argp (plusp (sbit *fop-argp* (ash code -2)))) + (argp (plusp (sbit (car *fop-signatures*) (ash code -2)))) (fname (symbolicate "COLD-" name))) (unless code (error "~S is not a defined FOP." name)) + (when (and argp (not (singleton-p arglist))) + (error "~S must take one argument" name)) `(progn - (defun ,fname ,(if argp '(.arg.) '()) - (macrolet ((pop-stack () `(pop-fop-stack)) - ,@(if argp '((clone-arg () '.arg.)))) - ,@(if pushp `((push-fop-stack (progn ,@forms))) forms))) + (defun ,fname ,arglist + (macrolet ((pop-stack () `(pop-fop-stack))) ,@forms)) ,@(loop for i from code to (logior code (if argp 3 0)) collect `(setf (svref *cold-fop-funs* ,i) #',fname))))) @@ -2141,15 +2140,14 @@ core and return a descriptor to it." (define-cold-fop (fop-misc-trap) *unbound-marker*) -(define-cold-fop (fop-character) - (make-character-descriptor (clone-arg))) +(define-cold-fop (fop-character (c)) + (make-character-descriptor c)) (define-cold-fop (fop-empty-list) nil) (define-cold-fop (fop-truth) t) -(define-cold-fop (fop-struct) - (let* ((size (clone-arg)) ; n-words including layout, excluding header - (layout (pop-stack)) +(define-cold-fop (fop-struct (size)) ; n-words incl. layout, excluding header + (let* ((layout (pop-stack)) (result (allocate-structure-object *dynamic* size layout)) (metadata (descriptor-fixnum @@ -2252,27 +2250,26 @@ core and return a descriptor to it." ;; I don't feel like hacking up DEFINE-COLD-FOP any more than necessary, ;; so this code is handcrafted to accept two operands. (flet ((fop-cold-symbol-in-package-save (index pname-len) - (push-fop-stack (cold-load-symbol pname-len (ref-fop-table index))))) + (cold-load-symbol pname-len (ref-fop-table index)))) (dotimes (i 16) ; occupies 16 cells in the dispatch table (setf (svref *cold-fop-funs* (+ (get 'fop-symbol-in-package-save 'opcode) i)) #'fop-cold-symbol-in-package-save))) -(define-cold-fop (fop-lisp-symbol-save) - (cold-load-symbol (clone-arg) *cl-package*)) +(define-cold-fop (fop-lisp-symbol-save (namelen)) + (cold-load-symbol namelen *cl-package*)) -(define-cold-fop (fop-keyword-symbol-save) - (cold-load-symbol (clone-arg) *keyword-package*)) +(define-cold-fop (fop-keyword-symbol-save (namelen)) + (cold-load-symbol namelen *keyword-package*)) -(define-cold-fop (fop-uninterned-symbol-save) - (let ((name (make-string (clone-arg)))) +(define-cold-fop (fop-uninterned-symbol-save (namelen)) + (let ((name (make-string namelen))) (read-string-as-bytes *fasl-input-stream* name) (push-fop-table (get-uninterned-symbol name)))) ;;;; cold fops for loading packages -(define-cold-fop (fop-named-package-save :pushp nil) - (let* ((size (clone-arg)) - (name (make-string size))) +(define-cold-fop (fop-named-package-save (namelen)) + (let ((name (make-string namelen))) (read-string-as-bytes *fasl-input-stream* name) (push-fop-table (find-package name)))) @@ -2325,19 +2322,17 @@ core and return a descriptor to it." ;;;; cold fops for loading vectors -(define-cold-fop (fop-base-string) - (let* ((len (clone-arg)) - (string (make-string len))) +(define-cold-fop (fop-base-string (len)) + (let ((string (make-string len))) (read-string-as-bytes *fasl-input-stream* string) (base-string-to-core string))) #!+sb-unicode -(define-cold-fop (fop-character-string) - (bug "CHARACTER-STRING dumped by cross-compiler.")) +(define-cold-fop (fop-character-string (len)) + (bug "CHARACTER-STRING[~D] dumped by cross-compiler." len)) -(define-cold-fop (fop-vector) - (let* ((size (clone-arg)) - (result (allocate-vector-object *dynamic* +(define-cold-fop (fop-vector (size)) + (let* ((result (allocate-vector-object *dynamic* sb!vm:n-word-bits size sb!vm:simple-vector-widetag))) @@ -2401,14 +2396,9 @@ core and return a descriptor to it." ;;;; cold fops for loading numbers -(defmacro define-cold-number-fop (fop) - `(define-cold-fop (,fop) - ;; Invoke the ordinary warm version of this fop to push the - ;; number. - (,fop) - ;; Replace the warm fop result with the cold image of the warm - ;; fop result. - (number-to-core (pop-stack)))) +(defmacro define-cold-number-fop (fop &optional arglist) + ;; Invoke the ordinary warm version of this fop to cons the number. + `(define-cold-fop (,fop ,arglist) (number-to-core (,fop ,@arglist)))) (define-cold-number-fop fop-single-float) (define-cold-number-fop fop-double-float) @@ -2416,12 +2406,7 @@ core and return a descriptor to it." (define-cold-number-fop fop-byte-integer) (define-cold-number-fop fop-complex-single-float) (define-cold-number-fop fop-complex-double-float) -;; FOP-INTEGER is different because it affects 4 cells of the fop-funs vector, -;; though none except the lowest is used. A bignum would have to be so big -;; that its length required > 1 byte to store. -(define-cold-fop (fop-integer) - (fop-integer (clone-arg)) - (number-to-core (pop-stack))) +(define-cold-number-fop fop-integer (n-bytes)) (define-cold-fop (fop-ratio) (let ((den (pop-stack))) @@ -2460,7 +2445,7 @@ core and return a descriptor to it." *load-time-value-counter* sb!vm:simple-vector-widetag))) -(define-cold-fop (fop-funcall-for-effect :pushp nil) +(define-cold-fop (fop-funcall-for-effect) (if (= (read-byte-arg) 0) (cold-push (pop-stack) *current-reversed-cold-toplevels*) @@ -2468,17 +2453,17 @@ core and return a descriptor to it." ;;;; cold fops for fixing up circularities -(define-cold-fop (fop-rplaca :pushp nil) +(define-cold-fop (fop-rplaca) (let ((obj (ref-fop-table (read-word-arg))) (idx (read-word-arg))) (write-memory (cold-nthcdr idx obj) (pop-stack)))) -(define-cold-fop (fop-rplacd :pushp nil) +(define-cold-fop (fop-rplacd) (let ((obj (ref-fop-table (read-word-arg))) (idx (read-word-arg))) (write-wordindexed (cold-nthcdr idx obj) 1 (pop-stack)))) -(define-cold-fop (fop-svset :pushp nil) +(define-cold-fop (fop-svset) (let ((obj (ref-fop-table (read-word-arg))) (idx (read-word-arg))) (write-wordindexed obj @@ -2488,13 +2473,11 @@ core and return a descriptor to it." (#.sb!vm:other-pointer-lowtag 2))) (pop-stack)))) -(define-cold-fop (fop-structset :pushp nil) +(define-cold-fop (fop-structset) (let ((obj (ref-fop-table (read-word-arg))) (idx (read-word-arg))) (write-wordindexed obj (1+ idx) (pop-stack)))) -;;; In the original CMUCL code, this actually explicitly declared PUSHP -;;; to be T, even though that's what it defaults to in DEFINE-COLD-FOP. (define-cold-fop (fop-nthcdr) (cold-nthcdr (read-word-arg) (pop-stack))) @@ -2513,7 +2496,7 @@ core and return a descriptor to it." ;; (SETF CAR). (make-hash-table :test 'equal)) -(define-cold-fop (fop-fset :pushp nil) +(define-cold-fop (fop-fset) (let* ((fn (pop-stack)) (cold-name (pop-stack)) (warm-name (warm-fun-name cold-name))) @@ -2522,7 +2505,7 @@ core and return a descriptor to it." (setf (gethash warm-name *cold-fset-warm-names*) t)) (static-fset cold-name fn))) -(define-cold-fop (fop-note-debug-source :pushp nil) +(define-cold-fop (fop-note-debug-source) (let ((debug-source (pop-stack))) (cold-push debug-source *current-debug-sources*))) @@ -2539,7 +2522,6 @@ core and return a descriptor to it." (defun cold-load-code (nconst code-size) (macrolet ((pop-stack () '(pop-fop-stack))) - (push-fop-stack (let* ((raw-header-n-words (+ sb!vm:code-constants-offset nconst)) (header-n-words ;; Note: we round the number of constants up to ensure @@ -2582,15 +2564,14 @@ core and return a descriptor to it." "/#X~8,'0x: #X~8,'0x~%" (+ i (gspace-byte-address (descriptor-gspace des))) (bvref-32 (descriptor-bytes des) i))))) - des)))) + des))) (dotimes (i 16) ; occupies 16 cells in the dispatch table (setf (svref *cold-fop-funs* (+ (get 'fop-code 'opcode) i)) #'cold-load-code)) -(define-cold-fop (fop-alter-code :pushp nil) - (let ((slot (clone-arg)) - (value (pop-stack)) +(define-cold-fop (fop-alter-code (slot)) + (let ((value (pop-stack)) (code (pop-stack))) (write-wordindexed code slot value))) -- 2.11.4.GIT