[5d1093]: src / compiler / globaldb.lisp Maximize Restore History

Download this file

globaldb.lisp    853 lines (765 with data), 40.9 kB

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
;;;; This file provides a functional interface to global information
;;;; about named things in the system. Information is considered to be
;;;; global if it must persist between invocations of the compiler. The
;;;; use of a functional interface eliminates the need for the compiler
;;;; to worry about the actual representation. This is important, since
;;;; the information may well have several representations.
;;;;
;;;; The database contains arbitrary Lisp values, addressed by a
;;;; combination of Name, Class and Type. The Name is an EQUAL-thing
;;;; which is the name of the thing we are recording information
;;;; about. Class is the kind of object involved. Typical classes are
;;;; :FUNCTION, :VARIABLE, :TYPE, ... A Type names a particular piece
;;;; of information within a given class. Class and Type are keywords,
;;;; and are compared with EQ.
;;;; The relation between this file and 'info-vectors' is that the
;;;; latter provides a fundamental mechanism to create property-list-like
;;;; things whose "indicators" are restricted to small integers
;;;; and whose values are anything; whereas the globaldb provides the
;;;; facility of looking up the properties by keyword, a/k/a Class+Type.
;;;; The keyword regime is somewhat arbitrary because ultimately the
;;;; pair of keywords just translates to a small integer, usually
;;;; resolvable at compile-time for the most part.
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB!C")
(!begin-collecting-cold-init-forms)
#!+sb-show (!cold-init-forms (/show0 "early in globaldb.lisp cold init"))
;;; The DEFVAR for this appears later.
;;; FIXME: centralize
(declaim (special *universal-type*))
;;; This is sorta semantically equivalent to SXHASH, but better-behaved for
;;; legal function names. It performs more work by not cutting off as soon
;;; in the CDR direction, thereby improving the distribution of method names.
;;; More work here equates to less work in the global hashtable.
;;; To wit: (eq (sxhash '(foo a b c bar)) (sxhash '(foo a b c d))) => T
;;; but the corresponding globaldb-sxhashoids differ.
;;; This is no longer inline because for the cases where it is needed -
;;; names which are not just symbols or (SETF F) - an extra call has no impact.
(defun globaldb-sxhashoid (name)
;; we can't use MIX because it's in 'target-sxhash',
;; so use the host's sxhash, but ensure that the result is a target fixnum.
#+sb-xc-host (logand (sxhash name) sb!xc:most-positive-fixnum)
#-sb-xc-host
(locally
(declare (optimize (safety 0))) ; after the argc check
;; TRAVERSE will walk across more cons cells than RECURSE will descend.
;; That's why this isn't just one self-recursive function.
(labels ((traverse (accumulator x length-limit)
(declare (fixnum length-limit))
(cond ((atom x) (sb!int:mix (sxhash x) accumulator))
((zerop length-limit) accumulator)
(t (traverse (sb!int:mix (recurse (car x) 4) accumulator)
(cdr x) (1- length-limit)))))
(recurse (x depthoid) ; depthoid = a blend of level and length
(declare (fixnum depthoid))
(cond ((atom x) (sxhash x))
((zerop depthoid) #xdeadbeef)
(t (sb!int:mix (recurse (car x) (1- depthoid))
(recurse (cdr x) (1- depthoid)))))))
(traverse 0 name 10))))
;;; Given any non-negative integer, return a prime number >= to it.
;;;
;;; FIXME: This logic should be shared with ALMOST-PRIMIFY in
;;; hash-table.lisp. Perhaps the merged logic should be
;;; PRIMIFY-HASH-TABLE-SIZE, implemented as a lookup table of primes
;;; after integral powers of two:
;;; #(17 37 67 131 ..)
;;; (Or, if that's too coarse, after half-integral powers of two.) By
;;; thus getting rid of any need for primality testing at runtime, we
;;; could punt POSITIVE-PRIMEP, too.
(defun primify (x)
(declare (type unsigned-byte x))
(do ((n (logior x 1) (+ n 2)))
((positive-primep n) n)))
;;;; info classes, info types, and type numbers, part I: what's needed
;;;; not only at compile time but also at run time
;;;; Note: This section is a blast from the past, a little trip down
;;;; memory lane to revisit the weird host/target interactions of the
;;;; CMU CL build process. Because of the way that the cross-compiler
;;;; and target compiler share stuff here, if you change anything in
;;;; here, you'd be well-advised to nuke all your fasl files and
;;;; restart compilation from the very beginning of the bootstrap
;;;; process.
;;; Why do we suppress the :COMPILE-TOPLEVEL situation here when we're
;;; running the cross-compiler? The cross-compiler (which was built
;;; from these sources) has its version of these data and functions
;;; defined in the same places we'd be defining into. We're happy with
;;; its version, since it was compiled from the same sources, so
;;; there's no point in overwriting its nice compiled version of this
;;; stuff with our interpreted version. (And any time we're *not*
;;; happy with its version, perhaps because we've been editing the
;;; sources partway through bootstrapping, tch tch, overwriting its
;;; version with our version would be unlikely to help, because that
;;; would make the cross-compiler very confused.)
(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
;;; a map from type numbers to TYPE-INFO objects. There is one type
;;; number for each defined CLASS/TYPE pair.
;;;
;;; We build its value at build-the-cross-compiler time (with calls to
;;; DEFINE-INFO-TYPE), then generate code to recreate the compile time
;;; value, and arrange for that code to be called in cold load.
;;; KLUDGE: We don't try to reset its value when cross-compiling the
;;; compiler, since that creates too many bootstrapping problems,
;;; instead just reusing the built-in-the-cross-compiler version,
;;; which is theoretically a little bit ugly but pretty safe in
;;; practice because the cross-compiler is as close to the target
;;; compiler as we can make it, i.e. identical in most ways, including
;;; this one. -- WHN 2001-08-19
(declaim (type (simple-vector #.(ash 1 type-number-bits)) *info-types*))
(defglobal *info-types* (make-array (ash 1 type-number-bits) :initial-element nil))
(defstruct (type-info
#-no-ansi-print-object
(:print-object (lambda (x s)
(print-unreadable-object (x s)
(format s
"~S ~S, Number = ~W"
(type-info-class x)
(type-info-name x)
(type-info-number x)))))
(:constructor
make-globaldb-info-metadata (number class name type-spec))
(:copier nil))
;; the name of this type
(name nil :type keyword)
;; this type's class
(class nil :type keyword)
;; a number that uniquely identifies this type (and implicitly its class)
(number nil :type type-number)
;; a type specifier which info of this type must satisfy
(type-spec nil :type t)
;; If FUNCTIONP, then a function called when there is no information of
;; this type. If not FUNCTIONP, then any object serving as a default.
(default nil)
;; Two functions called by (SETF INFO) before calling SET-INFO-VALUE.
;; Regarding the type specifiers on these slots, I wanted to write them
;; as (SFUNCTION (T) T) for documentation - and it elides the check for
;; multiple values returned - but doing that causes failure building the
;; cross-compiler under CMUCL 20c because it tries to call TYPEP on that,
;; and complains that it can't.
;; 1. A function that type-checks its argument and returns it,
;; or signals an error.
(type-checker #'identity :type function)
;; 2. a function of two arguments, a name and new-value, which performs
;; any other checks and/or side-effects including signaling an error.
(validate-function nil :type (or function null)))
(declaim (freeze-type type-info))
(defconstant +info-metainfo-type-num+ 0)
;; Perform the equivalent of (GET-INFO-VALUE sym +INFO-METAINFO-TYPE-NUM+)
;; but without the AVER that metadata already exists, and bypassing the
;; defaulting logic.
(defun %get-type-info-metadata (sym)
(let* ((info-vector (symbol-info-vector sym))
(index (if info-vector
(packed-info-value-index info-vector +no-auxilliary-key+
+info-metainfo-type-num+))))
(if index (svref info-vector index))))
;; Find or create a TYPE-INFO object designated by CLASS- and TYPE-KEYWORD.
;; If not found, the specified TYPE-NUM and TYPE-SPEC are used to
;; initialize it. If TYPE-NUM is -1, the next available number is assigned.
;; Return the new type-num.
(defun register-info-metadata (type-num class-keyword type-keyword type-spec)
(let ((metainfo (find-type-info class-keyword type-keyword)))
(cond (metainfo) ; Do absolutely positively nothing.
(t
(when (eql type-num -1) ; pick a new type-num
;; The zeroth type-num is reserved for INFO's own private use.
(setq type-num
(or (position nil *info-types* :start 1)
(error "no more INFO type numbers available"))))
(setf metainfo (make-globaldb-info-metadata
type-num class-keyword type-keyword type-spec)
(aref *info-types* type-num) metainfo)
(let ((list (%get-type-info-metadata type-keyword)))
(set-info-value
type-keyword +info-metainfo-type-num+
(cond ((not list) metainfo) ; unique, just store it
((listp list) (cons metainfo list)) ; prepend to the list
(t (list metainfo list))))))) ; convert atom to a list
(type-info-number metainfo)))
;; If CLASS-KEYWORD/TYPE-KEYWORD designate an info-type,
;; return the corresponding TYPE-INFO object, otherwise NIL.
(defun find-type-info (class-keyword type-keyword)
(declare (type keyword class-keyword type-keyword))
(let ((metadata (%get-type-info-metadata type-keyword)))
;; Most TYPE-KEYWORDs uniquely designate an object, so we store only that.
;; Otherwise we store a list which has a small handful of (<= 4) items.
(cond ((listp metadata)
;; Can we *please* make (FIND ...) not call GENERIC+
;; so that I don't feel compelled to express this as a DOLIST ?
(dolist (info metadata nil)
(when (eq (type-info-class (truly-the type-info info))
class-keyword)
(return info))))
((eq (type-info-class (truly-the type-info metadata)) class-keyword)
metadata))))
(declaim (ftype (function (keyword keyword) type-info) type-info-or-lose))
(defun type-info-or-lose (class type)
#+sb-xc (/noshow0 "entering TYPE-INFO-OR-LOSE, CLASS,TYPE=..")
#+sb-xc (/nohexstr class)
#+sb-xc (/nohexstr type)
(or (find-type-info class type)
(error "(~S ~S) is not a defined info type." class type)))
) ; EVAL-WHEN
;;;; info types, and type numbers, part II: what's
;;;; needed only at compile time, not at run time
(eval-when (:compile-toplevel :execute)
;;; a list of forms for initializing the DEFAULT slots of TYPE-INFO
;;; objects, accumulated during compilation and eventually converted
;;; into a function to be called at cold load time after the
;;; appropriate TYPE-INFO objects have been created
;;;
;;; Note: This is quite similar to the !COLD-INIT-FORMS machinery, but
;;; we can't conveniently use the ordinary !COLD-INIT-FORMS machinery
;;; here. The problem is that the natural order in which the
;;; default-slot-initialization forms are generated relative to the
;;; order in which the TYPE-INFO-creation forms are generated doesn't
;;; match the relative order in which the forms need to be executed at
;;; cold load time.
(defparameter *!reversed-type-info-init-forms* nil)
;;; Define a new type of global information.
;;; CLASS/TYPE form a two-piece name for the kind of information,
;;; DEFAULT is a defaulting expression, and TYPE-SPEC
;;; is a type specifier which values of the type must satisfy.
;;; Roughly speaking there is a hierarchy to the two-piece names
;;; but this is a fiction that is not maintained anywhere in the internals.
;;;
;;; If the defaulting expression's value is a function, it is called with
;;; the name for which the information is being looked up; otherwise it is
;;; taken as the default value. The defaulting expression is used each time
;;; a value is needed when one hasn't been previously set. (The result
;;; does not automatically become the new value for the piece of info.)
;;; Should a default value be itself a function, this must be expressed as
;;; :DEFAULT (CONSTANTLY #'<a-function-name>) to adhere to the convention
;;; that default objects satisfying FUNCTIONP will always be funcalled.
;;;
;;; The main thing we do is determine the type's number. We need to do
;;; this at macroexpansion time, since both the COMPILE and LOAD time
;;; calls to %DEFINE-INFO-TYPE must use the same type number.
(#+sb-xc-host defmacro
#-sb-xc-host sb!xc:defmacro
define-info-type ((class type)
&key (type-spec (missing-arg))
(validate-function)
default)
(declare (type keyword class type))
`(progn
(eval-when (:compile-toplevel :execute)
;; At compile time, ensure that the type number exists. It will
;; need to be forced to exist at cold load time, too, but
;; that's not handled here; it's handled by later code which
;; looks at the compile time state and generates code to
;; replicate it at cold load time.
(let ((num (register-info-metadata -1 ,class ,type ',type-spec)))
;; Arrange for TYPE-INFO-DEFAULT, TYPE-INFO-TYPE-CHECKER, and
;; TYPE-INFO-VALIDATE-FUNCTION to be set at cold load
;; time. (They can't very well be set at cross-compile time,
;; since they differ between host and target and are
;; host-compiled closures.)
(push `(let ((type-info (aref *info-types* ,num)))
;; cold-init can't actually AVER without crashing hard,
;; but what the heck, let's do it.
(aver type-info)
,@',(unless (eq type-spec 't)
;; avoid re-inventing #'IDENTITY N times over
`((setf (type-info-type-checker type-info)
(lambda (x) (declare (type ,type-spec x)) x))))
(setf (type-info-validate-function type-info)
,',validate-function
(type-info-default type-info) ,',default))
*!reversed-type-info-init-forms*)))
',type))
) ; EVAL-WHEN
;;; INFO is the standard way to access the database. It's settable.
;;;
;;; Return the information of the specified TYPE and CLASS for NAME.
;;; The second value returned is true if there is any such information
;;; recorded. If there is no information, the first value returned is
;;; the default and the second value returned is NIL.
(defun info (class type name)
(let ((info (type-info-or-lose class type)))
(get-info-value name (type-info-number info))))
(defun (setf info) (new-value class type name)
(let ((info (type-info-or-lose class type)))
(funcall (type-info-type-checker info) new-value)
(awhen (type-info-validate-function info)
(funcall it name new-value))
(set-info-value name (type-info-number info) new-value)))
;;; Clear the information of the specified TYPE and CLASS for NAME in
;;; the current environment. Return true if there was any info.
(defun clear-info (class type name)
(let ((info (type-info-or-lose class type)))
(clear-info-value name (type-info-number info))))
(defun clear-info-value (name type)
(declare (type type-number type))
;; A call to UNCROSS was suspiciously absent, so I added this ERROR
;; to be certain that it's not supposed to happen when building the xc.
#+sb-xc-xhost (error "Strange CLEAR-INFO building the xc: ~S ~S" name type)
(let (new)
(with-globaldb-name (key1 key2) name
:simple
;; If PACKED-INFO-REMOVE has nothing to do, it returns NIL,
;; corresponding to the input that UPDATE-SYMBOL-INFO expects.
(dx-flet ((clear-simple (old)
(setq new (packed-info-remove old key2 type))))
(update-symbol-info key1 #'clear-simple))
:hairy
;; The global hashtable is not imbued with knowledge of the convention
;; for PACKED-INFO-REMOVE because that would render it less useful
;; as a general-purpose global hashtable for other kinds of stuff
;; that I might want it to store aside from packed infos.
;; So here UPDATE might receive NIL but must not return NIL if
;; there was a non-nil input. NIL doesn't mean "do nothing".
(dx-flet ((clear-hairy (old)
(if old
;; if -REMOVE => nil, then update NEW but return OLD
(or (setq new (packed-info-remove
old +no-auxilliary-key+ type))
old))))
(info-puthash *info-environment* name #'clear-hairy)))
(not (null new))))
;;;; *INFO-ENVIRONMENT*
(!cold-init-forms
(setq *info-environment* (make-info-hashtable))
(/show0 "done setting *INFO-ENVIRONMENT*"))
;;;; GET-INFO-VALUE
;;; Return the value of NAME / TYPE-NUMBER from the global environment,
;;; or return the default if there is no global info.
;;; The secondary value indicates whether info was found vs defaulted.
(declaim (ftype (sfunction (t type-number) (values t boolean))
get-info-value))
(defun get-info-value (name type-number)
;; sanity check: If we have screwed up initialization somehow, then
;; *INFO-TYPES* could still be uninitialized at the time we try to
;; get an info value, and then we'd be out of luck. (This happened,
;; and was confusing to debug, when rewriting EVAL-WHEN in
;; sbcl-0.pre7.x.)
(let ((metainfo (aref *info-types* type-number)))
(aver metainfo)
(multiple-value-bind (vector aux-key)
(let ((name (uncross name)))
(with-globaldb-name (key1 key2) name
:simple (values (symbol-info-vector key1) key2)
:hairy (values (info-gethash name *info-environment*)
+no-auxilliary-key+)))
(when vector
(let ((index
(packed-info-value-index vector aux-key type-number)))
(when index
(return-from get-info-value (values (svref vector index) t))))))
(let ((val (type-info-default metainfo)))
(values (if (functionp val) (funcall val name) val) nil))))
;; Perform the approximate equivalent operations of retrieving
;; (INFO :CLASS :TYPE NAME), but if no info is found, invoke CREATION-FORM
;; to produce an object that becomes the value for that piece of info, storing
;; and returning it. The entire sequence behaves atomically but with a proviso:
;; the creation form's result may be discarded, and another object returned
;; instead (presumably) from another thread's execution of the creation form.
;; If constructing the object has either non-trivial cost, or deleterious
;; side-effects from making and discarding its result, do NOT use this macro.
;; A mutex-guarded table would probably be more appropriate in such cases.
;;
(def!macro get-info-value-initializing (info-class info-type name creation-form)
(with-unique-names (type-number proc)
`(let ((,type-number
,(if (and (keywordp info-type) (keywordp info-class))
(type-info-number (type-info-or-lose info-class info-type))
`(type-info-number
(type-info-or-lose ,info-class ,info-type)))))
(dx-flet ((,proc () ,creation-form))
(%get-info-value-initializing ,name ,type-number #',proc)))))
;; Return the fdefn object for NAME, or NIL if there is no fdefn.
;; Signal an error if name isn't valid.
;; Trying to get this to work properly in file 'fdefinition.lisp'
;; was an exercise in futility.
;; Creation of new fdefinitions is still defined there though.
;; Assume that exists-p implies LEGAL-FUN-NAME-P.
;;
#-sb-xc-host
(declaim (ftype (sfunction ((or symbol list)) (or fdefn null))
find-fdefinition))
(defun find-fdefinition (name0)
;; Since this emulates GET-INFO-VALUE, we have to uncross the name.
(let ((name (uncross name0)))
(declare (optimize (safety 0)))
(when (symbolp name) ; Don't need LEGAL-FUN-NAME-P check
(return-from find-fdefinition (sb!impl::symbol-fdefinition name)))
;; Technically the ALLOW-ATOM argument of NIL isn't needed, but
;; the compiler isn't figuring out not to test SYMBOLP twice in a row.
(with-globaldb-name (key1 key2 nil) name
:hairy
;; INFO-GETHASH returns NIL or a vector. INFO-VECTOR-FDEFINITION accepts
;; either. If fdefn isn't found, fall through to the legality test.
(awhen (info-vector-fdefinition (info-gethash name *info-environment*))
(return-from find-fdefinition it))
:simple
(progn
(awhen (symbol-info-vector key1)
(multiple-value-bind (data-idx descriptor-idx field-idx)
(info-find-aux-key/packed it key2)
(declare (type index descriptor-idx)
(type (integer 0 #.+infos-per-word+) field-idx))
;; Secondary names must have at least one info, so if a descriptor
;; exists, there's no need to extract the n-infos field.
(when data-idx
(when (eql (incf field-idx) +infos-per-word+)
(setq field-idx 0 descriptor-idx (1+ descriptor-idx)))
(when (eql (packed-info-field it descriptor-idx field-idx)
+fdefn-type-num+)
(return-from find-fdefinition
(aref it (1- (the index data-idx))))))))
(when (eq key1 'setf) ; bypass the legality test
(return-from find-fdefinition nil))))
(legal-fun-name-or-type-error name)))
;; Call FUNCTION once for each Name in globaldb that has information associated
;; with it, passing the function the Name as its only argument.
;;
(defun call-with-each-globaldb-name (function)
(let ((name (list nil nil)) ; preallocate just one, and mutate as we go
(function (%coerce-callable-to-fun function)))
(dolist (package (list-all-packages))
(do-symbols (symbol package)
(when (eq (symbol-package symbol) package)
(let ((vector (symbol-info-vector symbol)))
(when vector
;; Check whether SYMBOL has info for itself
(when (plusp (packed-info-field vector 0 0))
(funcall function symbol))
;; Now deal with (<othersym> SYMBOL) names
(do-packed-info-vector-aux-key (vector key-index)
(progn (setf (first name) (svref vector key-index)
(second name) symbol)
(funcall function name))))))))
(info-maphash (lambda (name data)
(declare (ignore data))
(funcall function name))
*info-environment*)))
;;;; ":FUNCTION" subsection - Data pertaining to globally known functions.
;; must be info type number 1
(define-info-type (:function :definition) :type-spec (or fdefn null))
(eval-when (:compile-toplevel)
(aver (= 1 (type-info-number (type-info-or-lose :function :definition)))))
;;; the kind of functional object being described. If null, NAME isn't
;;; a known functional object.
(define-info-type (:function :kind)
:type-spec (member nil :function :macro :special-form)
;; I'm a little confused what the correct behavior of this default
;; is. It's not clear how to generalize the FBOUNDP expression to
;; the cross-compiler. As far as I can tell, NIL is a safe default
;; -- it might keep the compiler from making some valid
;; optimization, but it shouldn't produce incorrect code. -- WHN
;; 19990330
:default
#+sb-xc-host nil
#-sb-xc-host (lambda (name) (if (fboundp name) :function nil)))
;;; The type specifier for this function.
(define-info-type (:function :type)
:type-spec ctype
;; Again (as in DEFINE-INFO-TYPE :CLASS :FUNCTION :TYPE :KIND) it's
;; not clear how to generalize the FBOUNDP expression to the
;; cross-compiler. -- WHN 19990330
:default
;; Delay evaluation of (SPECIFIER-TYPE) since it can't work yet
#+sb-xc-host (lambda (x) (declare (ignore x)) (specifier-type 'function))
#-sb-xc-host (lambda (name)
(if (fboundp name)
(handler-bind ((style-warning #'muffle-warning))
(specifier-type (sb!impl::%fun-type (fdefinition name))))
(specifier-type 'function))))
;;; the ASSUMED-TYPE for this function, if we have to infer the type
;;; due to not having a declaration or definition
(define-info-type (:function :assumed-type)
;; FIXME: The type-spec really should be
;; (or approximate-fun-type null)).
;; It was changed to T as a hopefully-temporary hack while getting
;; cold init problems untangled.
:type-spec t)
;;; where this information came from:
;;; :ASSUMED = from uses of the object
;;; :DEFINED = from examination of the definition
;;; :DEFINED-METHOD = implicit, incremental declaration by CLOS.
;;; :DECLARED = from a declaration
;;; :DEFINED trumps :ASSUMED, :DEFINED-METHOD trumps :DEFINED,
;;; and :DECLARED trumps :DEFINED-METHOD.
;;; :DEFINED and :ASSUMED are useful for issuing compile-time warnings,
;;; :DEFINED-METHOD and :DECLARED are useful for ANSIly specializing
;;; code which implements the function, or which uses the function's
;;; return values.
(define-info-type (:function :where-from)
:type-spec (member :declared :defined-method :assumed :defined)
:default
;; Again (as in DEFINE-INFO-TYPE :CLASS :FUNCTION :TYPE :KIND) it's
;; not clear how to generalize the FBOUNDP expression to the
;; cross-compiler. -- WHN 19990606
#+sb-xc-host :assumed
#-sb-xc-host (lambda (name) (if (fboundp name) :defined :assumed)))
;;; something which can be decoded into the inline expansion of the
;;; function, or NIL if there is none
;;;
;;; To inline a function, we want a lambda expression, e.g.
;;; '(LAMBDA (X) (+ X 1)). That can be encoded here in one of two
;;; ways.
;;; * The value in INFO can be the lambda expression itself, e.g.
;;; (SETF (INFO :FUNCTION :INLINE-EXPANSION-DESIGNATOR 'FOO)
;;; '(LAMBDA (X) (+ X 1)))
;;; This is the ordinary way, the natural way of representing e.g.
;;; (DECLAIM (INLINE FOO))
;;; (DEFUN FOO (X) (+ X 1))
;;; * The value in INFO can be a closure which returns the lambda
;;; expression, e.g.
;;; (SETF (INFO :FUNCTION :INLINE-EXPANSION-DESIGNATOR 'BAR-LEFT-CHILD)
;;; (LAMBDA ()
;;; '(LAMBDA (BAR) (BAR-REF BAR 3))))
;;; This twisty way of storing values is supported in order to
;;; allow structure slot accessors, and perhaps later other
;;; stereotyped functions, to be represented compactly.
(define-info-type (:function :inline-expansion-designator)
:type-spec (or list function))
;;; This specifies whether this function may be expanded inline. If
;;; null, we don't care.
(define-info-type (:function :inlinep) :type-spec inlinep)
;;; a macro-like function which transforms a call to this function
;;; into some other Lisp form. This expansion is inhibited if inline
;;; expansion is inhibited
(define-info-type (:function :source-transform) :type-spec (or function null))
;;; the macroexpansion function for this macro
(define-info-type (:function :macro-function) :type-spec (or function null))
;;; the compiler-macroexpansion function for this macro
(define-info-type (:function :compiler-macro-function)
:type-spec (or function null))
;;; a function which converts this special form into IR1
(define-info-type (:function :ir1-convert) :type-spec (or function null))
;;; If a function is "known" to the compiler, then this is a FUN-INFO
;;; structure containing the info used to special-case compilation.
(define-info-type (:function :info) :type-spec (or fun-info null))
(define-info-type (:function :structure-accessor)
:type-spec (or defstruct-description null))
;;;; ":VARIABLE" subsection - Data pertaining to globally known variables.
;;; the kind of variable-like thing described
(define-info-type (:variable :kind)
:type-spec (member :special :constant :macro :global :alien :unknown)
:default (lambda (name)
(if (typep name '(or boolean keyword))
:constant
:unknown)))
(define-info-type (:variable :always-bound)
:type-spec (member nil :eventually :always-bound))
(define-info-type (:variable :deprecated) :type-spec t)
;;; the declared type for this variable
(define-info-type (:variable :type)
:type-spec ctype
;; Delay evaluation of *UNIVERSAL-TYPE* since it can't work yet
:default (lambda (x) (declare (ignore x)) *universal-type*))
;;; where this type and kind information came from
(define-info-type (:variable :where-from)
:type-spec (member :declared :assumed :defined) :default :assumed)
;;; the macro-expansion for symbol-macros
(define-info-type (:variable :macro-expansion) :type-spec t)
(define-info-type (:variable :alien-info)
:type-spec (or heap-alien-info null))
(define-info-type (:variable :documentation) :type-spec (or string null))
;;;; ":TYPE" subsection - Data pertaining to globally known types.
;;; the kind of type described. We return :INSTANCE for standard types
;;; that are implemented as structures. For PCL classes, that have
;;; only been compiled, but not loaded yet, we return
;;; :FORTHCOMING-DEFCLASS-TYPE.
(define-info-type (:type :kind)
:type-spec (member :primitive :defined :instance
:forthcoming-defclass-type nil)
:validate-function (lambda (name new-value)
(declare (ignore new-value)
(notinline info))
(when (info :declaration :recognized name)
(error 'declaration-type-conflict-error
:format-arguments (list name)))))
;;; the expander function for a defined type
(define-info-type (:type :expander) :type-spec (or function null))
(define-info-type (:type :documentation) :type-spec (or string null))
;;; function that parses type specifiers into CTYPE structures
(define-info-type (:type :translator) :type-spec (or function null))
;;; If true, then the type coresponding to this name. Note that if
;;; this is a built-in class with a translation, then this is the
;;; translation, not the class object. This info type keeps track of
;;; various atomic types (NIL etc.) and also serves as a cache to
;;; ensure that common standard types (atomic and otherwise) are only
;;; consed once.
(define-info-type (:type :builtin) :type-spec (or ctype null))
;;; The classoid-cell for this type
(define-info-type (:type :classoid-cell) :type-spec t)
;;; layout for this type being used by the compiler
(define-info-type (:type :compiler-layout)
:type-spec (or layout null)
:default (lambda (name)
(let ((class (find-classoid name nil)))
(when class (classoid-layout class)))))
;;; DEFTYPE lambda-list
(define-info-type (:type :lambda-list) :type-spec list)
(define-info-type (:type :source-location) :type-spec t)
;;;; ":TYPED-STRUCTURE" subsection.
;;;; Data pertaining to structures that used DEFSTRUCT's :TYPE option.
(define-info-type (:typed-structure :info) :type-spec t)
(define-info-type (:typed-structure :documentation) :type-spec (or string null))
;;;; ":DECLARATION" subsection - Data pertaining to user-defined declarations.
;; CLTL2 offers an API to provide a list of known declarations, but it is
;; inefficient to iterate over info environments to find all such declarations,
;; and this is likely to be even slower when info is attached
;; directly to symbols, as it would entail do-all-symbols or similar.
;; Therefore maintain a list of recognized declarations. This list makes the
;; globaldb storage of same redundant, but oh well.
(defglobal *recognized-declarations* nil)
(define-info-type (:declaration :recognized)
:type-spec boolean
;; There's no portable way to unproclaim that a symbol is a declaration,
;; but at the low-level permit new-value to be NIL.
:validate-function (lambda (name new-value)
(declare (symbol name)
(notinline info))
(cond (new-value
(when (info :type :kind name)
(error 'declaration-type-conflict-error
:format-arguments (list name)))
(pushnew name *recognized-declarations*))
(t
(setq *recognized-declarations*
(delete name *recognized-declarations*))))))
(define-info-type (:declaration :handler) :type-spec (or function null))
;;;; ":ALIEN-TYPE" subsection - Data pertaining to globally known alien-types.
(define-info-type (:alien-type :kind)
:type-spec (member :primitive :defined :unknown)
:default :unknown)
(define-info-type (:alien-type :translator) :type-spec (or function null))
(define-info-type (:alien-type :definition) :type-spec (or alien-type null))
(define-info-type (:alien-type :struct) :type-spec (or alien-type null))
(define-info-type (:alien-type :union) :type-spec (or alien-type null))
(define-info-type (:alien-type :enum) :type-spec (or alien-type null))
;;;; ":SETF" subsection - Data pertaining to expansion of the omnipotent macro.
(define-info-type (:setf :inverse) :type-spec (or symbol null))
(define-info-type (:setf :documentation) :type-spec (or string null))
(define-info-type (:setf :expander) :type-spec (or function null))
;;;; ":RANDOM-DOCUMENTATION" subsection.
;;; This is used for storing miscellaneous documentation types. The
;;; stuff is an alist translating documentation kinds to values.
(define-info-type (:random-documentation :stuff) :type-spec list)
;;;; ":SOURCE-LOCATION" subsection.
;;; This is kind of the opposite of what I'd have thought more logical,
;;; where each of the above subsections - also called "info classes" -
;;; has one of its kinds of information being :SOURCE-LOCATION. And in fact
;;; that *is* how :TYPE was handled. However, many global entities
;;; store their source-location hanging off some other hook, avoiding the
;;; globaldb entirely, such as functions using a #<code-component>.
;;; So either way is basically a hodgepodge.
(define-info-type (:source-location :variable) :type-spec t)
(define-info-type (:source-location :constant) :type-spec t)
(define-info-type (:source-location :typed-structure) :type-spec t)
(define-info-type (:source-location :symbol-macro) :type-spec t)
#!-sb-fluid (declaim (freeze-type basic-info-env))
;; This is for the SB-INTROSPECT contrib module, and debugging.
(defun call-with-each-info (function symbol)
(awhen (symbol-info-vector symbol)
(%call-with-each-info function it symbol)))
;; This is for debugging at the REPL.
(defun show-info (sym)
(let ((prev 0))
(call-with-each-info
(lambda (name type-num val)
(unless (eq name prev)
(format t "~&~S" (setq prev name)))
(let ((type (svref *info-types* type-num)))
(format t "~& ~@[type ~D~]~@[~{~S ~S~}~] ~S = "
(if (not type) type-num)
(if type
(list (type-info-class type) (type-info-name type)))
name)
(write val :level 1)))
sym)))
;;; Now that we have finished initializing
;;; *INFO-TYPES* (at compile time), generate code to set them at cold
;;; load time to the same state they have currently.
(!cold-init-forms
(/show0 "beginning *INFO-TYPES* initialization")
#-sb-xc-host
;; Host already has this array, do not clobber it
(setq *info-types* (make-array (ash 1 type-number-bits) :initial-element nil))
(mapc (lambda (x)
(register-info-metadata (first x) (second x) (third x) (fourth x)))
'#.(loop for info-type across *info-types*
when info-type
collect (list (type-info-number info-type)
(type-info-class info-type)
(type-info-name info-type)
;; KLUDGE: for repeatable xc fasls, to
;; avoid different cross-compiler
;; treatment of equal constants here we
;; COPY-TREE, which is not in general a
;; valid identity transformation
;; [e.g. on (EQL (FOO))] but is OK for
;; all the types we use here.
(copy-tree (type-info-type-spec info-type)))))
(/show0 "done with *INFO-TYPES* initialization"))
;;; At cold load time, after the INFO-TYPE objects have been created,
;;; we can set their DEFAULT and TYPE slots.
(macrolet ((frob ()
`(!cold-init-forms
;; I [dpk] really think reversal now is a red herring.
;; I see nothing that would fail here regardless of order.
,@(reverse *!reversed-type-info-init-forms*))))
(frob))
;;; Source transforms / compiler macros for INFO functions.
;;;
;;; When building the XC, we give it a source transform, so that it can
;;; compile INFO calls in the target efficiently; we also give it a compiler
;;; macro, so that at least those INFO calls compiled after this file can be
;;; efficient. (Host compiler-macros do not fire when compiling the target,
;;; and source transforms don't fire when building the XC, so we need both.)
;;;
;;; Target needs just one, since there compiler macros and source-transforms
;;; are equivalent.
(macrolet ((def (name lambda-list form)
(aver (member 'class lambda-list))
(aver (member 'type lambda-list))
`(progn
#+sb-xc-host
(define-source-transform ,name ,lambda-list
(if (and (keywordp class) (keywordp type))
,form
(values nil t)))
(define-compiler-macro ,name ,(append '(&whole .whole.) lambda-list)
(if (and (keywordp class) (keywordp type))
,form
.whole.)))))
(def info (class type name)
(let (#+sb-xc-host (sb!xc:*gensym-counter* sb!xc:*gensym-counter*)
(info (type-info-or-lose class type)))
(with-unique-names (value foundp)
`(multiple-value-bind (,value ,foundp)
(get-info-value ,name ,(type-info-number info))
(values (truly-the ,(type-info-type-spec info) ,value) ,foundp)))))
(def (setf info) (new-value class type name)
(let* (#+sb-xc-host (sb!xc:*gensym-counter* sb!xc:*gensym-counter*)
(info (type-info-or-lose class type))
(tin (type-info-number info))
(type-spec (type-info-type-spec info))
(check
(when (type-info-validate-function info)
;; is (or ... null), but non-null in host implies non-null
`(truly-the function
(type-info-validate-function
(truly-the type-info (svref *info-types* ,tin)))))))
(with-unique-names (new)
`(let ((,new ,new-value))
;; enforce type-correctness regardless of enclosing policy
(let ((,new (locally (declare (optimize (safety 3)))
(the ,type-spec ,new))))
,@(when check
`((funcall ,check ,name ,new)))
(set-info-value ,name ,tin ,new))))))
(def clear-info (class type name)
(let ((info (type-info-or-lose class type)))
`(clear-info-value ,name ,(type-info-number info)))))
(!defun-from-collected-cold-init-forms !globaldb-cold-init)