X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffop.lisp;h=417a12c7b9471dc64122359e7e86055c76ede06d;hb=b0b168c08b31a748150f404398af754f26fd4813;hp=fce38feddd2906c6893fe7f186244af7c094c5d4;hpb=aa2dc9529460ea0d9c99998dc87283fc1a43e808;p=sbcl.git diff --git a/src/code/fop.lisp b/src/code/fop.lisp index fce38fe..417a12c 100644 --- a/src/code/fop.lisp +++ b/src/code/fop.lisp @@ -24,7 +24,6 @@ `(with-fop-stack ,pushp ,@forms))) (%define-fop ',name ,fop-code))) -;;; FIXME: This can be byte coded. (defun %define-fop (name code) (let ((oname (svref *fop-names* code))) (when (and oname (not (eq oname name))) @@ -38,7 +37,7 @@ (error "multiple codes for fop name ~S: ~D and ~D" name code ocode))) (setf (svref *fop-names* code) name (get name 'fop-code) code - (svref *fop-functions* code) (symbol-function name)) + (svref *fop-funs* code) (symbol-function name)) (values)) ;;; Define a pair of fops which are identical except that one reads @@ -111,7 +110,7 @@ (declare (ignorable arg)) #!+sb-show (when *show-fop-nop4-p* - (format *debug-io* "~&/FOP-NOP4 ARG=~D=#X~X~%" arg arg)))) + (format *debug-io* "~&/FOP-NOP4 ARG=~W=#X~X~%" arg arg)))) (define-fop (fop-nop 0 :nope)) (define-fop (fop-pop 1 nil) (push-fop-table (pop-stack))) @@ -126,7 +125,7 @@ #+sb-xc-host ; since xc host doesn't know how to compile %PRIMITIVE (error "FOP-MISC-TRAP can't be defined without %PRIMITIVE.") #-sb-xc-host - (%primitive sb!c:make-other-immediate-type 0 sb!vm:unbound-marker-type)) + (%primitive sb!c:make-other-immediate-type 0 sb!vm:unbound-marker-widetag)) (define-fop (fop-character 68) (code-char (read-arg 3))) @@ -154,6 +153,7 @@ (find-and-init-or-check-layout name length inherits depthoid))) (define-fop (fop-end-group 64 :nope) + (/show0 "THROWing FASL-GROUP-END") (throw 'fasl-group-end t)) ;;; In the normal loader, we just ignore these. GENESIS overwrites @@ -410,7 +410,7 @@ (let* ((rank (read-arg 4)) (vec (pop-stack)) (length (length vec)) - (res (make-array-header sb!vm:simple-array-type rank))) + (res (make-array-header sb!vm:simple-array-widetag rank))) (declare (simple-array vec) (type (unsigned-byte 24) rank)) (set-array-header res vec length length 0 @@ -424,13 +424,13 @@ (define-fop (fop-single-float-vector 84) (let* ((length (read-arg 4)) (result (make-array length :element-type 'single-float))) - (read-n-bytes *fasl-input-stream* result 0 (* length sb!vm:word-bytes)) + (read-n-bytes *fasl-input-stream* result 0 (* length sb!vm:n-word-bytes)) result)) (define-fop (fop-double-float-vector 85) (let* ((length (read-arg 4)) (result (make-array length :element-type 'double-float))) - (read-n-bytes *fasl-input-stream* result 0 (* length sb!vm:word-bytes 2)) + (read-n-bytes *fasl-input-stream* result 0 (* length sb!vm:n-word-bytes 2)) result)) #!+long-float @@ -440,19 +440,22 @@ (read-n-bytes *fasl-input-stream* result 0 - (* length sb!vm:word-bytes #!+x86 3 #!+sparc 4)) + (* length sb!vm:n-word-bytes #!+x86 3 #!+sparc 4)) result)) (define-fop (fop-complex-single-float-vector 86) (let* ((length (read-arg 4)) (result (make-array length :element-type '(complex single-float)))) - (read-n-bytes *fasl-input-stream* result 0 (* length sb!vm:word-bytes 2)) + (read-n-bytes *fasl-input-stream* result 0 (* length sb!vm:n-word-bytes 2)) result)) (define-fop (fop-complex-double-float-vector 87) (let* ((length (read-arg 4)) (result (make-array length :element-type '(complex double-float)))) - (read-n-bytes *fasl-input-stream* result 0 (* length sb!vm:word-bytes 2 2)) + (read-n-bytes *fasl-input-stream* + result + 0 + (* length sb!vm:n-word-bytes 2 2)) result)) #!+long-float @@ -460,13 +463,14 @@ (let* ((length (read-arg 4)) (result (make-array length :element-type '(complex long-float)))) (read-n-bytes *fasl-input-stream* result 0 - (* length sb!vm:word-bytes #!+x86 3 #!+sparc 4 2)) + (* length sb!vm:n-word-bytes #!+x86 3 #!+sparc 4 2)) result)) -;;; *** NOT *** the FOP-INT-VECTOR as currently documented in rtguts. Size -;;; must be a directly supported I-vector element size, with no extra bits. -;;; This must be packed according to the local byte-ordering, allowing us to -;;; directly read the bits. +;;; CMU CL comment: +;;; *** NOT *** the FOP-INT-VECTOR as currently documented in rtguts. +;;; Size must be a directly supported I-vector element size, with no +;;; extra bits. This must be packed according to the local +;;; byte-ordering, allowing us to directly read the bits. (define-fop (fop-int-vector 43) (prepare-for-fast-read-byte *fasl-input-stream* (let* ((len (fast-read-u-integer 4)) @@ -486,7 +490,7 @@ res 0 (ceiling (the index (* size len)) - sb!vm:byte-bits)) + sb!vm:n-byte-bits)) res))) ;;; This is the same as FOP-INT-VECTOR, except this is for signed @@ -509,7 +513,7 @@ 0 (ceiling (the index (* (if (= size 30) 32 ; Adjust for (signed-byte 30) - size) len)) sb!vm:byte-bits)) + size) len)) sb!vm:n-byte-bits)) res))) (define-fop (fop-eval 53) @@ -605,23 +609,37 @@ (sb!vm:sanctify-for-execution component) component)) -;;; This a no-op except in cold load. (In ordinary warm load, -;;; everything involved with function definition can be handled nicely -;;; by ordinary toplevel code.) (define-fop (fop-fset 74 nil) - (pop-stack) - (pop-stack)) + ;; Ordinary, not-for-cold-load code shouldn't need to mess with this + ;; at all, since it's only used as part of the conspiracy between + ;; the cross-compiler and GENESIS to statically link FDEFINITIONs + ;; for cold init. + (warn "~@") + ;; Unlike CMU CL, we don't treat this as a no-op in ordinary code. + ;; If the user (or, more likely, developer) is trying to reload + ;; compiled-for-cold-load code into a warm SBCL, we'll do a warm + ;; assignment. (This is partly for abstract tidiness, since the warm + ;; assignment is the closest analogy to what happens at cold load, + ;; and partly because otherwise our compiled-for-cold-load code will + ;; fail, since in SBCL things like compiled-for-cold-load %DEFUN + ;; depend more strongly than in CMU CL on FOP-FSET actually doing + ;; something.) + (let ((fn (pop-stack)) + (name (pop-stack))) + (setf (fdefinition name) fn))) -;;; Modify a slot in a Constants object. +;;; Modify a slot in a CONSTANTS object. (define-cloned-fops (fop-alter-code 140 nil) (fop-byte-alter-code 141) (let ((value (pop-stack)) (code (pop-stack))) (setf (code-header-ref code (clone-arg)) value) (values))) -(define-fop (fop-function-entry 142) +(define-fop (fop-fun-entry 142) #+sb-xc-host ; since xc host doesn't know how to compile %PRIMITIVE - (error "FOP-FUNCTION-ENTRY can't be defined without %PRIMITIVE.") + (error "FOP-FUN-ENTRY can't be defined without %PRIMITIVE.") #-sb-xc-host (let ((type (pop-stack)) (arglist (pop-stack)) @@ -632,34 +650,18 @@ (unless (zerop (logand offset sb!vm:lowtag-mask)) (error "internal error: unaligned function object, offset = #X~X" offset)) - (let ((fun (%primitive sb!c:compute-function code-object offset))) - (setf (%function-self fun) fun) - (setf (%function-next fun) (%code-entry-points code-object)) + (let ((fun (%primitive sb!c:compute-fun code-object offset))) + (setf (%simple-fun-self fun) fun) + (setf (%simple-fun-next fun) (%code-entry-points code-object)) (setf (%code-entry-points code-object) fun) - (setf (%function-name fun) name) - (setf (%function-arglist fun) arglist) - (setf (%function-type fun) type) + (setf (%simple-fun-name fun) name) + (setf (%simple-fun-arglist fun) arglist) + (setf (%simple-fun-type fun) type) ;; FIXME: See the comment about *LOAD-PRINT* in FOP-EVAL. #+nil (when *load-print* (load-fresh-line) (format t "~S defined~%" fun)) fun))) - -(define-fop (fop-make-byte-compiled-function 143) - (let* ((size (read-arg 1)) - (layout (pop-stack)) - (res (%make-funcallable-instance size layout))) - (declare (type index size)) - (do ((n (1- size) (1- n))) - ((minusp n)) - (declare (type (integer -1 #.most-positive-fixnum) n)) - (setf (%funcallable-instance-info res n) (pop-stack))) - (initialize-byte-compiled-function res) - ;; FIXME: See the comment about *LOAD-PRINT* in FOP-EVAL. - #+nil (when *load-print* - (load-fresh-line) - (format t "~S defined~%" res)) - res)) ;;;; Some Dylan FOPs used to live here. By 1 November 1998 the code ;;;; was sufficiently stale that the functions it called were no