X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Fgeneric%2Fgenesis.lisp;h=301d162842d2c404959829937ea2d6de82fe330e;hb=2912f5f6c2acb2da3b9fcc0f5afd1ca89782a9f8;hp=f32e88dd9304e10533d1220e858b32ad8d2be1d0;hpb=3bb2fb5b9ecdeebecaded4ac6e5af0f653be8867;p=sbcl.git diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index f32e88d..301d162 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -598,7 +598,7 @@ (des (allocate-vector-object gspace sb!vm:n-byte-bits (1+ length) - sb!vm:simple-string-widetag)) + sb!vm:simple-base-string-widetag)) (bytes (gspace-bytes gspace)) (offset (+ (* sb!vm:vector-data-offset sb!vm:n-word-bytes) (descriptor-byte-offset des)))) @@ -716,20 +716,32 @@ (ecase sb!c:*backend-byte-order* (:little-endian (write-wordindexed des sb!vm:complex-double-float-real-slot low-bits) - (write-wordindexed des (1+ sb!vm:complex-double-float-real-slot) high-bits)) + (write-wordindexed des + (1+ sb!vm:complex-double-float-real-slot) + high-bits)) (:big-endian (write-wordindexed des sb!vm:complex-double-float-real-slot high-bits) - (write-wordindexed des (1+ sb!vm:complex-double-float-real-slot) low-bits)))) + (write-wordindexed des + (1+ sb!vm:complex-double-float-real-slot) + low-bits)))) (let* ((imag (imagpart num)) (high-bits (make-random-descriptor (double-float-high-bits imag))) (low-bits (make-random-descriptor (double-float-low-bits imag)))) (ecase sb!c:*backend-byte-order* (:little-endian - (write-wordindexed des sb!vm:complex-double-float-imag-slot low-bits) - (write-wordindexed des (1+ sb!vm:complex-double-float-imag-slot) high-bits)) + (write-wordindexed des + sb!vm:complex-double-float-imag-slot + low-bits) + (write-wordindexed des + (1+ sb!vm:complex-double-float-imag-slot) + high-bits)) (:big-endian - (write-wordindexed des sb!vm:complex-double-float-imag-slot high-bits) - (write-wordindexed des (1+ sb!vm:complex-double-float-imag-slot) low-bits)))) + (write-wordindexed des + sb!vm:complex-double-float-imag-slot + high-bits) + (write-wordindexed des + (1+ sb!vm:complex-double-float-imag-slot) + low-bits)))) des)) ;;; Copy the given number to the core. @@ -1253,14 +1265,15 @@ (macrolet ((frob (symbol) `(cold-set ',symbol (cold-fdefinition-object (cold-intern ',symbol))))) - (frob maybe-gc) + (frob sub-gc) (frob internal-error) (frob sb!kernel::control-stack-exhausted-error) (frob sb!di::handle-breakpoint) - (frob sb!di::handle-fun-end-breakpoint)) + (frob sb!di::handle-fun-end-breakpoint) + (frob sb!thread::handle-thread-exit)) - (cold-set '*current-catch-block* (make-fixnum-descriptor 0)) - (cold-set '*current-unwind-protect-block* (make-fixnum-descriptor 0)) + (cold-set 'sb!vm::*current-catch-block* (make-fixnum-descriptor 0)) + (cold-set 'sb!vm::*current-unwind-protect-block* (make-fixnum-descriptor 0)) (cold-set '*free-interrupt-context-index* (make-fixnum-descriptor 0)) @@ -1759,12 +1772,14 @@ (ash value -2))) (:lui (setf (bvref-32 gspace-bytes gspace-byte-offset) - (logior (mask-field (byte 16 16) (bvref-32 gspace-bytes gspace-byte-offset)) + (logior (mask-field (byte 16 16) + (bvref-32 gspace-bytes gspace-byte-offset)) (+ (ash value -16) (if (logbitp 15 value) 1 0))))) (:addi (setf (bvref-32 gspace-bytes gspace-byte-offset) - (logior (mask-field (byte 16 16) (bvref-32 gspace-bytes gspace-byte-offset)) + (logior (mask-field (byte 16 16) + (bvref-32 gspace-bytes gspace-byte-offset)) (ldb (byte 16 0) value)))))) (:ppc (ecase kind @@ -1896,7 +1911,9 @@ forms)) (setf (svref *cold-fop-funs* ,code) #',fname)))) -(defmacro clone-cold-fop ((name &key (pushp t) (stackp t)) (small-name) &rest forms) +(defmacro clone-cold-fop ((name &key (pushp t) (stackp t)) + (small-name) + &rest forms) (aver (member pushp '(nil t))) (aver (member stackp '(nil t))) `(progn @@ -1928,8 +1945,6 @@ (define-cold-fop (fop-misc-trap) *unbound-marker*) -(define-cold-fop (fop-character) - (make-character-descriptor (read-arg 3))) (define-cold-fop (fop-short-character) (make-character-descriptor (read-arg 1))) @@ -2021,7 +2036,7 @@ (defun cold-load-symbol (size package) (let ((string (make-string size))) (read-string-as-bytes *fasl-input-stream* string) - (cold-intern (intern string package) package))) + (cold-intern (intern string package)))) (macrolet ((frob (name pname-len package-len) `(define-cold-fop (,name) @@ -2125,11 +2140,18 @@ (let* ((len (read-arg 4)) (sizebits (read-arg 1)) (type (case sizebits + (0 sb!vm:simple-array-nil-widetag) (1 sb!vm:simple-bit-vector-widetag) (2 sb!vm:simple-array-unsigned-byte-2-widetag) (4 sb!vm:simple-array-unsigned-byte-4-widetag) + (7 (prog1 sb!vm:simple-array-unsigned-byte-7-widetag + (setf sizebits 8))) (8 sb!vm:simple-array-unsigned-byte-8-widetag) + (15 (prog1 sb!vm:simple-array-unsigned-byte-15-widetag + (setf sizebits 16))) (16 sb!vm:simple-array-unsigned-byte-16-widetag) + (31 (prog1 sb!vm:simple-array-unsigned-byte-31-widetag + (setf sizebits 32))) (32 sb!vm:simple-array-unsigned-byte-32-widetag) (t (error "losing element size: ~W" sizebits)))) (result (allocate-vector-object *dynamic* sizebits len type)) @@ -2798,13 +2820,18 @@ ;; type things. We therefore don't export it, but instead do #!+sparc (when (boundp 'sb!vm::pseudo-atomic-trap) - (format t "#define PSEUDO_ATOMIC_TRAP ~D /* 0x~:*~X */~%" sb!vm::pseudo-atomic-trap) + (format t + "#define PSEUDO_ATOMIC_TRAP ~D /* 0x~:*~X */~%" + sb!vm::pseudo-atomic-trap) (terpri)) ;; possibly this is another candidate for a rename (to ;; pseudo-atomic-trap-number or pseudo-atomic-magic-constant ;; [possibly applicable to other platforms]) - (dolist (symbol '(sb!vm::float-traps-byte sb!vm::float-exceptions-byte sb!vm::float-sticky-bits sb!vm::float-rounding-mode)) + (dolist (symbol '(sb!vm::float-traps-byte + sb!vm::float-exceptions-byte + sb!vm::float-sticky-bits + sb!vm::float-rounding-mode)) (format t "#define ~A_POSITION ~A /* ~:*0x~X */~%" (substitute #\_ #\- (symbol-name symbol)) (sb!xc:byte-position (symbol-value symbol))) @@ -3290,7 +3317,12 @@ initially undefined function references:~2%") (dolist (obj structs) (out-to (string-downcase (string (sb!vm:primitive-object-name obj))) - (write-primitive-object obj)))) + (write-primitive-object obj))) + (out-to "primitive-objects" + (dolist (obj structs) + (format t "~&#include \"~A.h\"~%" + (string-downcase + (string (sb!vm:primitive-object-name obj))))))) (out-to "static-symbols" (write-static-symbols)) (when core-file-name