Skip to content
Snippets Groups Projects
Commit 67fc4ac5 authored by rtoy's avatar rtoy
Browse files

boot-2009-07.lisp:

o Bootstrap file needed to compile this change (because the current
  shrink-vector derive-type optimizer didn't handle union types).

compiler/fndb.lisp:
o Make the compiler warn if the result of lisp::shrink-vector is not
  used.  This is a problem because the compiler doesn't know that
  shrink-vector destructively modifies the length of a vector.  As a
  partial solution, warn the user if the result of shrink-vector is
  not.

code/hash-new.lisp:
code/seq.lisp:
o Make sure the result of shrink-vector is used, to get rid of a new
  compiler warning.

code/unidata.lisp:
o Modify %unicode-full-case so that it doesn't use shrink-vector
  anymore.

compiler/seqtran.lisp:
o Fix shrink-vector derive-type optimizer to handle union types.

tools/build-unidata.lisp:
o Fix typo that someone got in.
o Make sure the result of shrink-vector is used, to get rid of a new
  compiler warning.
parent 47f46f11
No related branches found
No related tags found
No related merge requests found
;; Bootstrap shrink-vector changes. (The previous derive-type
;; optimizer for shrink-vector didn't handle union types.)
(in-package "C")
(without-package-locks
(defoptimizer (lisp::shrink-vector derive-type) ((vector new-size))
;; The result of shrink-vector is another vector of the same type as
;; the input. If the size is a known constant, we use it, otherwise
;; just make the dimension unknown.
(let* ((dim (if (constant-continuation-p new-size)
`(,(continuation-value new-size))
'(*)))
(vector-type (continuation-type vector))
(results (mapcar #'(lambda (type)
(let* ((new-type (kernel::copy-array-type type)))
(setf (kernel:array-type-dimensions new-type) dim)
new-type))
(if (typep vector-type 'union-type)
(union-type-types vector-type)
(list vector-type)))))
(if (rest results)
(make-union-type results)
(first results))))
)
......@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/hash-new.lisp,v 1.49 2009/06/11 16:03:57 rtoy Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/hash-new.lisp,v 1.50 2009/07/02 21:00:48 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -439,11 +439,11 @@
(setf (hash-table-next-vector table) new-next-vector)
(setf (hash-table-hash-vector table) new-hash-vector)
;; Shrink the old vectors to 0 size to help the conservative GC.
(shrink-vector old-kv-vector 0)
(shrink-vector old-index-vector 0)
(shrink-vector old-next-vector 0)
(setf old-kv-vector (shrink-vector old-kv-vector 0))
(setf old-index-vector (shrink-vector old-index-vector 0))
(setf old-next-vector (shrink-vector old-next-vector 0))
(when old-hash-vector
(shrink-vector old-hash-vector 0))
(setf old-hash-vector (shrink-vector old-hash-vector 0)))
(setf (hash-table-rehash-trigger table) new-size))
(undefined-value))
......@@ -824,11 +824,11 @@
(setf (hash-table-next-vector hash-table) new-next-vector)
(setf (hash-table-hash-vector hash-table) new-hash-vector)
;; Shrink the old vectors to 0 size to help the conservative GC.
(shrink-vector old-kv-vector 0)
(shrink-vector old-index-vector 0)
(shrink-vector old-next-vector 0)
(setf old-kv-vector (shrink-vector old-kv-vector 0))
(setf old-index-vector (shrink-vector old-index-vector 0))
(setf old-next-vector (shrink-vector old-next-vector 0))
(when old-hash-vector
(shrink-vector old-hash-vector 0)))
(setf old-hash-vector (shrink-vector old-hash-vector 0))))
hash-table)
......
......@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/seq.lisp,v 1.54 2009/06/11 16:03:59 rtoy Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/seq.lisp,v 1.55 2009/07/02 21:00:48 rtoy Rel $")
;;;
;;; **********************************************************************
;;;
......@@ -1698,8 +1698,7 @@
(do ((index index (1+ index)) ; copy the rest of the vector
(jndex jndex (1+ jndex)))
((= index length)
(shrink-vector vector jndex)
vector)
(shrink-vector vector jndex))
(setf (aref vector jndex) (aref vector index))))
(declare (fixnum index jndex))
(setf (aref vector jndex) (aref vector index))
......
......@@ -4,7 +4,7 @@
;;; This code was written by Paul Foley and has been placed in the public
;;; domain.
;;;
(ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/unidata.lisp,v 1.3 2009/06/16 17:23:15 rtoy Exp $")
(ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/unidata.lisp,v 1.4 2009/07/02 21:00:48 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -942,14 +942,13 @@
(defun %unicode-full-case (code data default)
(let* ((n (qref32 data code)))
(if (= n 0)
(let ((s (make-string 2)))
(multiple-value-bind (hi lo)
(surrogates (funcall default code))
(multiple-value-bind (hi lo)
(surrogates (funcall default code))
(let ((s (make-string (if lo 2 1))))
(setf (schar s 0) hi)
(if lo
(setf (schar s 1) lo)
(shrink-vector s 1)))
s)
(when lo
(setf (schar s 1) lo))
s))
(let ((off (logand n #xffff))
(len (ldb (byte 6 16) n)))
(subseq (full-case-tabl data) off (+ off len))))))
......
......@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/fndb.lisp,v 1.137 2009/06/11 16:03:59 rtoy Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/fndb.lisp,v 1.138 2009/07/02 21:00:48 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -1251,7 +1251,9 @@
(foldable flushable))
(defknown %set-symbol-package (symbol t) t (unsafe))
(defknown %coerce-to-function (t) function (flushable))
(defknown lisp::shrink-vector (vector fixnum) vector (unsafe))
(defknown lisp::shrink-vector (vector fixnum) vector
(unsafe)
:result-not-used #'function-result-not-used-p)
;;; Structure slot accessors or setters are magically "known" to be these
;;; functions, although the var remains the Slot-Accessor describing the actual
......
......@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/seqtran.lisp,v 1.32 2009/06/11 16:03:59 rtoy Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/seqtran.lisp,v 1.33 2009/07/02 21:00:48 rtoy Rel $")
;;;
;;; **********************************************************************
;;;
......@@ -666,11 +666,17 @@
;; The result of shrink-vector is another vector of the same type as
;; the input. If the size is a known constant, we use it, otherwise
;; just make the dimension unknown.
(let* ((type (continuation-type vector))
(dim (if (constant-continuation-p new-size)
(let* ((dim (if (constant-continuation-p new-size)
`(,(continuation-value new-size))
'(*)))
(new-type (kernel::copy-array-type type)))
(setf (kernel:array-type-dimensions new-type) dim)
new-type))
(vector-type (continuation-type vector))
(results (mapcar #'(lambda (type)
(let* ((new-type (kernel::copy-array-type type)))
(setf (kernel:array-type-dimensions new-type) dim)
new-type))
(if (typep vector-type 'union-type)
(union-type-types vector-type)
(list vector-type)))))
(if (rest results)
(make-union-type results)
(first results))))
......@@ -4,7 +4,7 @@
;;; This code was written by Paul Foley and has been placed in the public
;;; domain.
;;;
(ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/build-unidata.lisp,v 1.2 2009/06/11 16:04:02 rtoy Exp $")
(ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/build-unidata.lisp,v 1.3 2009/07/02 21:00:48 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -455,7 +455,7 @@
(write-vector (ntrie1-hvec data) stm :endian-swap :network-order)
(write-vector (ntrie1-mvec data) stm :endian-swap :network-order)
(write-vector (ntrie1-lvec data) stm :endian-swap :network-order))
(updavte-index (val array)
(update-index (val array)
(let ((result (vector-push val array)))
(unless result
(error "Index array too short for the data being written")))))
......@@ -707,8 +707,8 @@
(bool mirror) (str name1) (str comment)
(chr upper) (chr lower) (chr title)))
(incf pos))))
(lisp::shrink-vector vec pos)
(lisp::shrink-vector range rpos)
(setf vec (lisp::shrink-vector vec pos))
(setf range (lisp::shrink-vector range rpos))
(flet ((find-ucd (key)
(let ((index (gethash key vec-hash)))
(if index
......
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