Skip to content
Snippets Groups Projects
Commit 4c0438e9 authored by ram's avatar ram
Browse files

Fixed some SAP-consign in MAP-ALLOCATED-OBJECTS. Eliminated some annoying

notes in unimportant functions my changing the optimize declaration.
parent 0787a273
No related branches found
No related tags found
No related merge requests found
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/room.lisp,v 1.13 1992/01/02 22:45:25 ram Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/room.lisp,v 1.14 1992/02/09 18:29:20 ram Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -146,7 +146,7 @@ ...@@ -146,7 +146,7 @@
(proclaim '(inline vector-total-size)) (proclaim '(inline vector-total-size))
(defun vector-total-size (obj info) (defun vector-total-size (obj info)
(let ((shift (room-info-length info)) (let ((shift (room-info-length info))
(len (+ (length (the vector obj)) (len (+ (length (the (simple-array * (*)) obj))
(ecase (room-info-kind info) (ecase (room-info-kind info)
(:vector 0) (:vector 0)
(:string 1))))) (:string 1)))))
...@@ -174,8 +174,10 @@ ...@@ -174,8 +174,10 @@
(without-gcing (without-gcing
(multiple-value-bind (start end) (multiple-value-bind (start end)
(space-bounds space) (space-bounds space)
(declare (type system-area-pointer start end))
(declare (optimize (speed 3) (safety 0))) (declare (optimize (speed 3) (safety 0)))
(let ((current start) (let ((current start)
#+nil
(prev nil)) (prev nil))
(loop (loop
(let* ((header (sap-ref-32 current 0)) (let* ((header (sap-ref-32 current 0))
...@@ -209,6 +211,7 @@ ...@@ -209,6 +211,7 @@
(assert (zerop (logand size lowtag-mask))) (assert (zerop (logand size lowtag-mask)))
#+nil #+nil
(when (> size 200000) (break "Implausible size, prev ~S" prev)) (when (> size 200000) (break "Implausible size, prev ~S" prev))
#+nil
(setq prev current) (setq prev current)
(setq current (sap+ current size)))) (setq current (sap+ current size))))
(t (t
...@@ -239,12 +242,14 @@ ...@@ -239,12 +242,14 @@
#+nil #+nil
(when (> size 200000) (when (> size 200000)
(break "Implausible size, prev ~S" prev)) (break "Implausible size, prev ~S" prev))
#+nil
(setq prev current) (setq prev current)
(setq current (sap+ current size)))))) (setq current (sap+ current size))))))
(unless (pointer< current end) (unless (pointer< current end)
(assert (not (pointer> current end))) (assert (not (pointer> current end)))
(return))) (return)))
#+nil
prev)))) prev))))
...@@ -412,7 +417,7 @@ ...@@ -412,7 +417,7 @@
(type unsigned-byte total-bytes)) (type unsigned-byte total-bytes))
(map-allocated-objects (map-allocated-objects
#'(lambda (obj type size) #'(lambda (obj type size)
(declare (fixnum size) (optimize (speed 3) (safety 0))) (declare (fixnum size) (optimize (safety 0)))
(when (eql type code-header-type) (when (eql type code-header-type)
(incf total-bytes size) (incf total-bytes size)
(let ((words (truly-the fixnum (%primitive code-code-size obj))) (let ((words (truly-the fixnum (%primitive code-code-size obj)))
...@@ -443,7 +448,7 @@ ...@@ -443,7 +448,7 @@
(declare (inline map-allocated-objects)) (declare (inline map-allocated-objects))
(map-allocated-objects (map-allocated-objects
#'(lambda (obj type size) #'(lambda (obj type size)
(declare (fixnum size) (optimize (speed 3) (safety 0))) (declare (fixnum size) (optimize (safety 0)))
(case type (case type
(#.code-header-type (#.code-header-type
(let ((inst-words (let ((inst-words
...@@ -602,7 +607,7 @@ ...@@ -602,7 +607,7 @@
(fixnum pages-so-far count-so-far pagesize)) (fixnum pages-so-far count-so-far pagesize))
(map-allocated-objects (map-allocated-objects
#'(lambda (obj obj-type size) #'(lambda (obj obj-type size)
(declare (optimize (speed 3) (safety 0))) (declare (optimize (safety 0)))
(let ((addr (get-lisp-obj-address obj))) (let ((addr (get-lisp-obj-address obj)))
(when (>= addr start) (when (>= addr start)
(when (if count (when (if count
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment