source: branches/working-0711-perf/ccl/level-1/sysutils.lisp @ 9518

Last change on this file since 9518 was 9518, checked in by gb, 12 years ago

Remove some type-predicates, TYPE-OF uses %CLASS-PROPER-NAME; could
probably avoid CLASS-OF in more cases.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 27.3 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17
18;; sysutils.lisp - things which have outgrown l1-utils
19
20(in-package "CCL")
21
22(eval-when (:execute :compile-toplevel)
23  (require 'level-2)
24  (require 'optimizers)
25  (require 'backquote)
26  (require 'defstruct-macros)
27  )
28
29;;; things might be clearer if this stuff were in l1-typesys?
30;;; Translation from type keywords to specific predicates.
31(eval-when (:execute :compile-toplevel)
32
33(defconstant type-pred-pairs
34  '((array . arrayp)
35    (atom . atom)
36    (base-string . base-string-p)
37    (bignum . bignump)
38    (bit . bitp)
39    (bit-vector . bit-vector-p)
40    (character . characterp)
41    (compiled-function . compiled-function-p)
42    (complex . complexp)
43    (cons . consp)
44    (double-float . double-float-p)
45    (fixnum . fixnump) ;not cl
46    (float . floatp)
47    (function . functionp)
48    (hash-table . nil)
49    (integer . integerp)
50    (real . realp)
51    (keyword . keywordp)
52    (list . listp)
53    (long-float . double-float-p)
54    (nil . false)
55    (null . null)
56    (number . numberp)
57    (package . packagep)
58    (pathname . pathnamep)
59    (logical-pathname . nil)
60    (random-state . nil)
61    (ratio . ratiop)
62    (rational . rationalp)
63    (readtable . readtablep)
64    (semaphore . semaphorep)
65    (sequence . sequencep)
66    (short-float . short-float-p)
67    (signed-byte . integerp)
68    (simple-array . simple-array-p)
69    (simple-base-string . simple-base-string-p)
70    (simple-extended-string . simple-extended-string-p)
71    (simple-bit-vector . simple-bit-vector-p)
72    (simple-string . simple-string-p)
73    (simple-vector . simple-vector-p)
74    (single-float . short-float-p)
75    (stream . streamp)
76    (string . stringp)
77    (extended-string . extended-string-p)
78    (base-char . base-char-p)
79    (extended-char . extended-char-p)
80    (structure-object . structurep)
81    (symbol . symbolp)
82    (t . true)
83    (unsigned-byte . unsigned-byte-p)
84    (vector . vectorp)
85    ))
86
87(defmacro init-type-predicates ()
88  `(dolist (pair ',type-pred-pairs)
89     (setf (type-predicate (car pair)) (cdr pair))
90     (let ((ctype (info-type-builtin (car pair))))       
91       (if (typep ctype 'numeric-ctype)
92         (setf (numeric-ctype-predicate ctype) (cdr pair))))))
93
94)
95
96(init-type-predicates)
97
98(defun unsigned-byte-8-p (n)
99  (and (fixnump n)
100       (locally (declare (fixnum n))
101         (and 
102          (>= n 0)
103          (< n #x100)))))
104
105(defun signed-byte-8-p (n)
106  (and (fixnump n)
107       (locally (declare (fixnum n))
108         (and 
109          (>= n -128)
110          (<= n 127)))))
111
112(defun unsigned-byte-16-p (n)
113  (and (fixnump n)
114       (locally (declare (fixnum n))
115         (and 
116          (>= n 0)
117          (< n #x10000)))))
118
119(defun signed-byte-16-p (n)
120  (and (fixnump n)
121       (locally (declare (fixnum n))
122         (and 
123          (>= n -32768)
124          (<= n 32767)))))
125
126(defun unsigned-byte-32-p (n)
127  (and (integerp n)
128       (>= n 0)
129       (<= n #xffffffff)))
130
131(defun signed-byte-32-p (n)
132  (and (integerp n)
133       (>= n  -2147483648)
134       (<= n 2147483647)))
135
136(eval-when (:load-toplevel :execute)
137  (let ((more-pairs
138         '(((unsigned-byte 8) . unsigned-byte-8-p)
139           ((signed-byte 8) . signed-byte-8-p)
140           ((unsigned-byte 16) . unsigned-byte-16-p)
141           ((signed-byte 16) . signed-byte-16-p)
142           ((unsigned-byte 32) . unsigned-byte-32-p)
143           ((signed-byte 32) . signed-byte-32-p))))         
144    (dolist (pair more-pairs)
145      (let ((ctype (info-type-builtin (car pair))))       
146        (if (typep ctype 'numeric-ctype) (setf (numeric-ctype-predicate ctype) (cdr pair))))))
147  )
148
149
150(defun specifier-type-known (type) 
151  (let ((ctype (specifier-type type)))
152    (if (typep ctype 'unknown-ctype)
153      (error "Unknown type specifier ~s." type)
154      (if (and (typep ctype 'numeric-ctype) ; complexp??
155               (eq 'integer (numeric-ctype-class ctype))
156               (not (numeric-ctype-predicate ctype)))
157        (setf (numeric-ctype-predicate ctype)(make-numeric-ctype-predicate ctype))))
158    ctype))
159
160
161(defun find-builtin-cell (type  &optional (create t))
162  (let ((cell (gethash type %builtin-type-cells%)))
163    (or cell
164        (when create
165          (setf (gethash type %builtin-type-cells%)
166                (cons type (or (info-type-builtin type)(specifier-type-known type))))))))
167
168
169; for now only called for builtin types or car = unsigned-byte, signed-byte, mod or integer
170
171(defun builtin-typep (form cell)
172  (unless (listp cell)
173    (setq cell (require-type cell 'list)))
174  (locally (declare (type list cell))
175    (let ((ctype (cdr cell))
176          (name (car cell)))
177      (when (not ctype)
178        (setq ctype (or (info-type-builtin name)(specifier-type-known name)))
179        (when ctype (setf (gethash (car cell) %builtin-type-cells%) cell))
180        (rplacd cell ctype))
181      (if ctype 
182        (if (and (typep ctype 'numeric-ctype)
183                 (numeric-ctype-predicate ctype))
184          ; doing this inline is a winner - at least if true
185          (funcall (numeric-ctype-predicate ctype) form)
186          (%%typep form ctype))
187        (typep form name)))))
188
189#|
190(defvar %find-classes% (make-hash-table :test 'eq))
191
192(defun find-class-cell (name create?)
193  (let ((cell (gethash name %find-classes%)))
194    (or cell
195        (and create?
196             (setf (gethash name %find-classes%) (cons name nil))))))
197|#
198
199;(setq *type-system-initialized* t)
200
201
202;; Type-of, typep, and a bunch of other predicates.
203
204;;; Data type predicates.
205
206;;; things might be clearer if this stuff were in l1-typesys?
207;;; Translation from type keywords to specific predicates.
208
209
210
211
212;necessary since standard-char-p, by definition, errors if not passed a char.
213(setf (type-predicate 'standard-char)
214      #'(lambda (form) (and (characterp form) (standard-char-p form))))
215
216(defun type-of (form)
217  "Return the type of OBJECT."
218  (case form
219    ((t) 'boolean)
220    ((0 1) 'bit)
221    (t
222     (typecase form
223       (standard-char 'standard-char)
224       (keyword 'keyword)
225       ;; Partition integers so that the negative cases
226       ;; are SIGNED-BYTE and the positive are UNSIGNED-BYTE
227       (fixnum
228        (if (< (the fixnum form) 0)
229          'fixnum
230          '(integer 0 #.target::target-most-positive-fixnum)))
231       (bignum
232        (if (< form 0)
233          'bignum
234          '(integer  #.(1+ target::target-most-positive-fixnum))))
235       ((or array complex) (type-specifier (ctype-of form)))
236       (single-float 'single-float)
237       (double-float 'double-float)
238       (t
239        (if (eql (typecode form) target::subtag-istruct)
240          (istruct-type-name form)
241          (let* ((class (class-of form)))
242            (or (%class-proper-name class)
243                class))))))))
244
245;;; Create the list-style description of an array.
246
247;made more specific by fry. slisp used  (mod 2) , etc.
248;Oh.
249; As much fun as this has been, I think it'd be really neat if
250; it returned a type specifier.
251
252(defun describe-array (array)
253  (if (arrayp array)
254    (type-specifier
255     (specifier-type
256      `(,(if (simple-array-p array) 'simple-array 'array) 
257        ,(array-element-type array) 
258        ,(array-dimensions array))))
259    (report-bad-arg array 'array)))
260 
261
262;;;; TYPEP and auxiliary functions.
263
264
265
266(defun type-specifier-p (form &aux sym)
267  (cond ((symbolp form)
268         (or (type-predicate form)
269             (structure-class-p form)
270             (%deftype-expander form)
271             (find-class form nil)
272             ))
273        ((consp form)
274         (setq sym (%car form))
275         (or (type-specifier-p sym)
276             (memq sym '(member satisfies mod))
277             (and (memq sym '(and or not))
278                  (dolist (spec (%cdr form) t)
279                    (unless (type-specifier-p spec) (return nil))))))
280        (t (typep form 'class))))
281
282(defun built-in-type-p (type)
283  (if (symbolp type)
284    (or (type-predicate type)
285        (let ((class (find-class type nil)))
286          (and class (typep class 'built-in-class))))
287    (and (consp type)
288         (or (and (memq (%car type) '(and or not))
289                  (every #'built-in-type-p (%cdr type)))
290             (memq (%car type) '(array simple-array vector simple-vector
291                                 string simple-string bit-vector simple-bit-vector 
292                                 complex integer mod signed-byte unsigned-byte
293                                 rational float short-float single-float
294                                 double-float long-float real member))))))
295
296(defun typep (object type &optional env)
297  "Is OBJECT of type TYPE?"
298  (let* ((pred (if (symbolp type) (type-predicate type))))
299    (if pred
300      (funcall pred object)
301      (values (%typep object (if env (specifier-type type env) type))))))
302
303
304
305;;; This is like check-type, except it returns the value rather than setf'ing
306;;; anything, and so can be done entirely out-of-line.
307(defun require-type (arg type)
308  (multiple-value-bind (win sure)
309      (ctypep  arg (specifier-type type))
310    (if (or win (not sure))
311      arg
312      (%kernel-restart $xwrongtype arg type))))
313
314;;; Might want to use an inverted mapping instead of (satisfies ccl::obscurely-named)
315(defun %require-type (arg predsym)
316  (if (funcall predsym arg)
317    arg
318    (%kernel-restart $xwrongtype arg (type-for-predicate predsym))))
319
320(defun %require-type-builtin (arg type-cell) 
321  (if (builtin-typep arg type-cell)
322    arg
323    (%kernel-restart $xwrongtype arg (car type-cell))))
324
325
326
327;;; In lieu of an inverted mapping, at least try to find cases involving
328;;; builtin numeric types and predicates associated with them.
329(defun type-for-predicate (pred)
330  (or (block find
331        (maphash #'(lambda (type ctype) (when (and (typep ctype 'numeric-ctype)
332                                                   (eq (numeric-ctype-predicate ctype)
333                                                       pred))
334                                          (return-from find type)))
335                 *builtin-type-info*))
336      `(satisfies ,pred)))
337
338
339
340; Subtypep.
341
342(defun subtypep (type1 type2 &optional env)
343  "Return two values indicating the relationship between type1 and type2.
344  If values are T and T, type1 definitely is a subtype of type2.
345  If values are NIL and T, type1 definitely is not a subtype of type2.
346  If values are NIL and NIL, it couldn't be determined."
347  (csubtypep (specifier-type type1 env) (specifier-type type2 env)))
348
349
350
351
352(defun preload-all-functions ()
353  nil)
354
355
356 ; used by arglist
357(defun temp-cons (a b)
358  (cons a b))
359
360
361
362
363(defun copy-into-float (src dest)
364  (%copy-double-float src dest))
365
366(queue-fixup
367 (defun fmakunbound (name)
368   "Make NAME have no global function definition."
369   (let* ((fname (validate-function-name name)))
370     (remhash fname %structure-refs%)
371     (%unfhave fname))
372   name))
373
374(defun frozen-definition-p (name)
375  (if (symbolp name)
376    (%ilogbitp $sym_fbit_frozen (%symbol-bits name))))
377
378(defun redefine-kernel-function (name)
379  (when (and *warn-if-redefine-kernel*
380             (frozen-definition-p name)
381             (or (lfunp (fboundp name))
382                 (and (not (consp name)) (macro-function name)))
383             (or (and (consp name) (neq (car name) 'setf))
384                 (let ((pkg (symbol-package (if (consp name) (cadr name) name))))
385                   (or (eq *common-lisp-package* pkg) (eq *ccl-package* pkg)))))
386    (cerror "Replace the definition of ~S."
387            "The function ~S is predefined in OpenMCL." name)
388    (unless (consp name)
389      (proclaim-inline nil name))))
390
391(defun fset (name function)
392  (setq function (require-type function 'function))
393  (when (symbolp name)
394    (when (special-operator-p name)
395      (error "Can not redefine a special-form: ~S ." name))
396    (when (macro-function name)
397      (cerror "Redefine the macro ~S as a function"
398              "The macro ~S is being redefined as a function." name)))
399; This lets us redefine %FHAVE.  Big fun.
400  (let ((fhave #'%fhave))
401    (redefine-kernel-function name)
402    (fmakunbound name)
403    (funcall fhave name function)
404    function))
405
406(defsetf symbol-function fset)
407(defsetf fdefinition fset)
408
409(defun (setf macro-function) (macro-fun name &optional env)
410  (declare (ignore env))
411  (unless (typep macro-fun 'function)
412    (report-bad-arg macro-fun 'function))
413  (if (special-operator-p name)
414    (error "Can not redefine a special-form: ~S ." name))
415  (when (and (fboundp name) (not (macro-function name)))
416    (warn "The function ~S is being redefined as a macro." name))
417  (redefine-kernel-function name)
418  (fmakunbound name)
419  (%macro-have name macro-fun)
420  macro-fun)
421
422(defun set-macro-function (name def)
423  (setf (macro-function name) def))
424
425
426
427
428;;; Arrays and vectors, including make-array.
429
430
431
432
433
434
435
436(defun char (string index)
437  "Given a string and a non-negative integer index less than the length of
438  the string, returns the character object representing the character at
439  that position in the string."
440  (if (typep string 'simple-string)
441    (schar (the simple-string string) index)
442    (if (stringp string)
443      (multiple-value-bind (data offset) (array-data-and-offset string)
444        (schar (the simple-string data) (+ index offset)))
445      (report-bad-arg string 'string))))
446
447(defun set-char (string index new-el)
448  (if (typep string 'simple-string)
449    (setf (schar string index) new-el)
450    (if (stringp string)
451      (multiple-value-bind (data offset) (array-data-and-offset string)
452        (setf (schar (the simple-string data) (+ index offset)) new-el))
453      (report-bad-arg string 'string))))
454
455(defun equalp (x y)
456  "Just like EQUAL, but more liberal in several respects.
457  Numbers may be of different types, as long as the values are identical
458  after coercion.  Characters may differ in alphabetic case.  Vectors and
459  arrays must have identical dimensions and EQUALP elements, but may differ
460  in their type restriction.
461  If one of x or y is a pathname and one is a string with the name of the
462  pathname then this will return T."
463  (cond ((eql x y) t)
464        ((characterp x) (and (characterp y) (eq (char-upcase x) (char-upcase y))))
465        ((numberp x) (and (numberp y) (= x y)))
466        ((consp x)
467         (and (consp y)
468              (equalp (car x) (car y))
469              (equalp (cdr x) (cdr y))))       
470        ((pathnamep x) (equal x y))
471        ((vectorp x)
472         (and (vectorp y)
473              (let ((length (length x)))
474                (when (eq length (length y))
475                  (dotimes (i length t)
476                    (declare (fixnum i))
477                    (let ((x-el (aref x i))
478                          (y-el (aref y i)))
479                      (unless (or (eq x-el y-el) (equalp x-el y-el))
480                        (return nil))))))))
481        ((arrayp x)
482         (and (arrayp y)
483              (let ((rank (array-rank x)) x-el y-el)
484                (and (eq (array-rank y) rank)
485                     (if (%izerop rank) (equalp (aref x) (aref y))
486                         (and
487                          (dotimes (i rank t)
488                            (declare (fixnum i))
489                            (unless (eq (array-dimension x i)
490                                        (array-dimension y i))
491                              (return nil)))
492                          (multiple-value-bind (x0 i) (array-data-and-offset x)
493                            (multiple-value-bind (y0 j) (array-data-and-offset y)
494                              (dotimes (count (array-total-size x) t)
495                                (declare (fixnum count))
496                                (setq x-el (uvref x0 i) y-el (uvref y0 j))
497                                (unless (or (eq x-el y-el) (equalp x-el y-el))
498                                  (return nil))
499                                (setq i (%i+ i 1) j (%i+ j 1)))))))))))
500        ((and (structurep x) (structurep y))
501         (let ((size (uvsize x)))
502           (and (eq size (uvsize y))
503                (dotimes (i size t)
504                  (declare (fixnum i))
505                  (unless (equalp (uvref x i) (uvref y i))
506                    (return nil))))))
507        ((and (hash-table-p x) (hash-table-p y))
508         (%hash-table-equalp x y))
509        (t nil)))
510
511
512; The compiler (or some transforms) might want to do something more interesting
513; with these, but they have to exist as functions anyhow.
514
515
516
517(defun complement (function)
518  "Return a new function that returns T whenever FUNCTION returns NIL and
519   NIL whenever FUNCTION returns non-NIL."
520  (let ((f (coerce-to-function function))) ; keep poor compiler from consing value cell
521  #'(lambda (&rest args)
522      (declare (dynamic-extent args)) ; not tail-recursive anyway
523      (not (apply f args)))))
524
525; Special variables are evil, but I can't think of a better way to do this.
526
527(defparameter *outstanding-deferred-warnings* nil)
528
529
530(defun %defer-warnings (override &optional flags)
531  (%istruct 'deferred-warnings (unless override *outstanding-deferred-warnings*) nil nil flags))
532
533(defun report-deferred-warnings ()
534  (let* ((current *outstanding-deferred-warnings*)
535         (parent (deferred-warnings.parent current))
536         (defs (deferred-warnings.defs current))
537         (warnings (deferred-warnings.warnings current))
538         (any nil)
539         (harsh nil))
540    (if parent
541      (setf (deferred-warnings.warnings parent) (append warnings (deferred-warnings.warnings parent))
542            (deferred-warnings.defs parent) (append defs (deferred-warnings.defs parent))
543            parent t)
544      (let* ((file nil)
545             (init t))
546        (flet ((signal-warning (w)
547                 (multiple-value-setq (harsh any file) (signal-compiler-warning w init file harsh any))
548                 (setq init nil)))
549          (dolist (w warnings)
550            (let* ((args (compiler-warning-args w))
551                   (wfname (car args))
552                   (def nil))
553              (when (if (typep w 'undefined-function-reference)
554                      (not (setq def (or (assq wfname defs)
555                                         (let* ((global (fboundp wfname)))
556                                           (if (typep global 'function)
557                                             global))))))
558                (signal-warning w))
559              ;; Check args in call to forward-referenenced function.
560              (if (or (typep def 'function)
561                      (and (consp def)
562                           (consp (cdr def))
563                           (cadr def)))
564                (when (cdr args)
565                  (destructuring-bind (arglist spread-p)
566                      (cdr args)
567                    (multiple-value-bind (deftype reason)
568                        (nx1-check-call-args def arglist spread-p)
569                      (when deftype
570                        (let* ((w2 (make-condition
571                                    'invalid-arguments
572                                    :file-name (compiler-warning-file-name w)
573                                    :function-name (compiler-warning-function-name w)
574                                    :warning-type deftype
575                                    :args (list (car args) reason arglist spread-p))))
576                          (setf (compiler-warning-stream-position w2)
577                                (compiler-warning-stream-position w))
578                          (signal-warning w2))))))
579                (if (and (consp def)
580                         (consp (cdr def))
581                         (eq (cddr def) 'macro))
582                  (let* ((w2 (make-condition
583                              'macro-used-before-definition
584                              :file-name (compiler-warning-file-name w)
585                              :function-name (compiler-warning-function-name w)
586                              :warning-type :macro-used-before-definition
587                              :args (list (car args)))))
588                    (setf (compiler-warning-stream-position w2)
589                          (compiler-warning-stream-position w))
590                    (signal-warning w2)))))))))
591    (values any harsh parent)))
592
593(defun print-nested-name (name-list stream)
594  (if (null name-list)
595    (princ "a toplevel form" stream)
596    (progn
597      (if (car name-list)
598        (prin1 (%car name-list) stream)
599        (princ "an anonymous lambda form" stream))
600      (when (%cdr name-list)
601        (princ " inside " stream)
602        (print-nested-name (%cdr name-list) stream)))))
603
604(defparameter *suppress-compiler-warnings* nil)
605
606(defun signal-compiler-warning (w init-p last-w-file harsh-p any-p &optional eval-p)
607  (let ((muffled *suppress-compiler-warnings*)
608        (w-file (compiler-warning-file-name w))
609        (s *error-output*))
610    (unless muffled 
611      (restart-case (signal w)
612        (muffle-warning () (setq muffled t))))
613    (unless muffled
614      (setq any-p t)
615      (unless (typep w 'style-warning) (setq harsh-p t))
616      (when (or init-p (not (equalp w-file last-w-file)))
617        (format s "~&;~A warnings " (if (null eval-p) "Compiler" "Interpreter"))
618        (if w-file (format s "for ~S :" w-file) (princ ":" s)))
619      (let* ((indenting-stream (make-indenting-string-output-stream #\; 4)))
620        (format indenting-stream "~%~a" w)
621        (format s "~a" (get-output-stream-string indenting-stream))))
622    (values harsh-p any-p w-file)))
623
624;;;; Assorted mumble-P type predicates.
625;;;; No functions have been in the kernel for the last year or so.
626;;;; (Just thought you'd like to know.)
627
628(defun sequencep (form)
629  "Not CL. SLISP Returns T if form is a sequence, NIL otherwise."
630   (or (listp form) (vectorp form)))
631
632;;; The following are not defined at user level, but are necessary for
633;;; internal use by TYPEP.
634
635(defun bitp (form)
636  "Not CL. SLISP"
637  (or (eq form 0) (eq form 1)))
638
639(defun unsigned-byte-p (form)
640  (and (integerp form) (not (< form 0))))
641
642;This is false for internal structures.
643;;; ---- look at defenv.structures, not defenv.structrefs
644
645(defun structure-class-p (form &optional env)
646  (and (symbolp form)
647       (let ((sd (or (and env
648                          (let ((defenv (definition-environment env)))
649                            (and defenv
650                                 (%cdr (assq form (defenv.structures defenv))))))
651                     (gethash form %defstructs%))))
652         (and sd
653              (null (sd-type sd))
654              sd))))
655
656
657
658
659
660(defun type-keyword-code (type-keyword &optional target)
661  (let* ((backend (if target (find-backend target) *target-backend*))
662         (alist (arch::target-uvector-subtags (backend-target-arch backend)))
663         (entry (assq type-keyword alist)))
664    (if entry
665      (let* ((code (cdr entry)))
666        (or code (error "Vector type ~s invalid," type-keyword)))
667      (error "Unknown type-keyword ~s. " type-keyword))))
668
669
670(defstruct id-map
671  (vector (make-array 1 :initial-element nil))
672  (free 0)
673  (lock (make-lock)))
674
675;;; Caller owns the lock on the id-map.
676(defun id-map-grow (id-map)
677  (without-interrupts
678   (let* ((old-vector (id-map-vector id-map))
679          (old-size (length old-vector))
680          (new-size (+ old-size old-size))
681          (new-vector (make-array new-size)))
682     (declare (fixnum old-size new-size))
683     (dotimes (i old-size)
684       (setf (svref new-vector i) (svref old-vector i)))
685     (let* ((limit (1- new-size)))
686       (declare (fixnum limit))
687       (do* ((i old-size (1+ i)))
688            ((= i limit) (setf (svref new-vector i) nil))
689         (declare (fixnum i))
690         (setf (svref new-vector i) (the fixnum (1+ i)))))
691     (setf (id-map-vector id-map) new-vector
692           (id-map-free id-map) old-size))))
693
694;;; Map an object to a small fixnum ID in id-map.
695;;; Object can't be NIL or a fixnum itself.
696(defun assign-id-map-id (id-map object)
697  (if (or (null object) (typep object 'fixnum))
698    (setq object (require-type object '(not (or null fixnum)))))
699  (with-lock-grabbed ((id-map-lock id-map))
700    (let* ((free (or (id-map-free id-map) (id-map-grow id-map)))
701           (vector (id-map-vector id-map))
702           (newfree (svref vector free)))
703      (setf (id-map-free id-map) newfree
704            (svref vector free) object)
705      free)))
706     
707;;; Referemce the object with id ID in ID-MAP.  Leave the object in
708;;; the map.
709(defun id-map-object (id-map id)
710  (let* ((object (with-lock-grabbed ((id-map-lock id-map))
711                   (svref (id-map-vector id-map) id))))
712    (if (or (null object) (typep object 'fixnum))
713      (error "invalid index ~d for ~s" id id-map)
714      object)))
715
716;;; Referemce the object with id ID in ID-MAP.  Remove the object from
717;;; the map.
718(defun id-map-free-object (id-map id)
719  (with-lock-grabbed ((id-map-lock id-map))
720    (let* ((vector (id-map-vector id-map))
721           (object (svref vector id)))
722      (if (or (null object) (typep object 'fixnum))
723        (error "invalid index ~d for ~s" id id-map))
724      (setf (svref vector id) (id-map-free id-map)
725            (id-map-free id-map) id)
726      object)))
727
728(defun id-map-modify-object (id-map id old-value new-value)
729  (with-lock-grabbed ((id-map-lock id-map))
730    (let* ((vector (id-map-vector id-map))
731           (object (svref vector id)))
732      (if (or (null object) (typep object 'fixnum))
733        (error "invalid index ~d for ~s" id id-map))
734      (if (eq object old-value)
735        (setf (svref vector id) new-value)))))
736
737
738   
739
740(setq *type-system-initialized* t)
741
742;;; Try to map from a CTYPE describing some array/stream
743;;; element-type to a target-specific typecode, catching
744;;; cases that CTYPE-SUBTYPE missed.
745
746(defun harder-ctype-subtype (ctype)
747  (cond ((csubtypep ctype (load-time-value (specifier-type 'bit)))
748         target::subtag-bit-vector)
749        ((csubtypep ctype (load-time-value (specifier-type '(unsigned-byte 8))))
750         target::subtag-u8-vector)
751        ((csubtypep ctype (load-time-value (specifier-type '(unsigned-byte 16))))
752         target::subtag-u16-vector)
753        ((csubtypep ctype (load-time-value (specifier-type '(unsigned-byte 32))))
754         target::subtag-u32-vector)
755        #+64-bit-target
756        ((csubtypep ctype (load-time-value (specifier-type '(unsigned-byte 64))))
757         target::subtag-u64-vector)
758        ((csubtypep ctype (load-time-value (specifier-type '(signed-byte 8))))
759         target::subtag-s8-vector)
760        ((csubtypep ctype (load-time-value (specifier-type '(signed-byte 16))))
761         target::subtag-s16-vector)
762        #+32-bit-target
763        ((csubtypep ctype (load-time-value (specifier-type `(integer ,target::target-most-negative-fixnum ,target::target-most-positive-fixnum))))
764         target::subtag-fixnum-vector)
765        ((csubtypep ctype (load-time-value (specifier-type '(signed-byte 32))))
766         target::subtag-s32-vector)
767        #+64-bit-target
768        ((csubtypep ctype (load-time-value (specifier-type `(integer ,target::target-most-negative-fixnum ,target::target-most-positive-fixnum))))
769         target::subtag-fixnum-vector)
770        #+64-bit-target
771        ((csubtypep ctype (load-time-value (specifier-type '(signed-byte 64))))
772         target::subtag-s64-vector)
773        (t target::subtag-simple-vector)))
774
775
776#+count-gf-calls
777(progn
778;;; Call-counting for generic functions.  We overload the
779;;; (previously unused
780(defmethod generic-function-call-count ((gf generic-function))
781  (gf.hash gf))
782
783
784(defun (setf generic-function-call-count) (count gf)
785  (setf (gf.hash gf) (require-type count 'fixnum)))
786
787(defun clear-all-generic-function-call-counts ()
788  (dolist (gf (population.data %all-gfs%))
789    (setf (gf.hash gf) 0)))
790);#+count-gf-calls
791
792
Note: See TracBrowser for help on using the repository browser.