source: branches/working-0711-perf/ccl/lib/defstruct.lisp @ 9523

Last change on this file since 9523 was 9523, checked in by gb, 13 years ago

Arrange that structure instances will have a list of their class's
CLASS-CELLS (rather than class-names) in its 0th element.

May have missed a few things.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 11.1 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(in-package "CCL")
18
19;;; Defstruct.lisp
20
21(eval-when (eval compile)
22  (require 'defstruct-macros)
23)
24
25
26
27(defvar %structure-refs% (make-hash-table :test #'eq))
28(defvar %defstructs% (make-hash-table :test #'eq))
29
30(defun make-ssd (name initform offset r/o &optional (type t))
31  (let ((refinfo (%ilogior2 offset (if r/o #x1000000 0))))
32    (list* name initform
33           (if (eq type 't)
34             refinfo
35             (cons type refinfo)))))
36
37(declaim (inline type-and-refinfo-p))
38(defun type-and-refinfo-p (object)
39  (or (fixnump object) (consp object)))
40
41(defun ssd-set-reftype (ssd reftype)
42  (ssd-update-refinfo (ssd refinfo)
43                      (%ilogior2 (%ilogand2 #x300FFFF refinfo)
44                                 (%ilsl 16 reftype))))
45
46(defun ssd-set-r/o (ssd) 
47  (ssd-update-refinfo (ssd refinfo)
48                      (%ilogior2 #x1000000 refinfo)))
49
50(defun ssd-set-inherited (ssd)
51  (ssd-update-refinfo (ssd refinfo)
52                       (bitset $struct-inherited refinfo)))
53
54(defun copy-ssd (ssd)
55  (let* ((cdr (cdr ssd))
56         (cddr (cdr cdr)))
57    (list* (%car ssd) (%car cdr)
58           (if (consp cddr)
59             (list* (%car cddr) (%cdr cddr))
60             cddr))))
61
62(declaim (inline ssd-type-and-refinfo))
63(defun ssd-type-and-refinfo (ssd)
64  (cddr ssd))
65
66(defun ssd-type (ssd)
67  (let ((type-and-refinfo (ssd-type-and-refinfo ssd)))
68    (if (consp type-and-refinfo)
69      (%car type-and-refinfo)
70      't)))
71
72(defun ssd-refinfo (ssd)
73  (let ((type-and-refinfo (ssd-type-and-refinfo ssd)))
74    (if (consp type-and-refinfo) (%cdr type-and-refinfo) type-and-refinfo)))
75
76(defun %structure-class-of (thing)
77  (let* ((cell (car (uvref thing 0))))
78    (or (class-cell-class name)
79        (setf (class-cell-class cell)
80              (find-class (class-cell-name name))))))
81
82;These might want to compiler-transform into non-typechecking versions...
83(defun struct-ref (struct offset)
84  (if (structurep struct) (uvref struct offset)
85      (report-bad-arg struct 'structure-object)))
86
87(defun struct-set (struct offset value)
88  (if (structurep struct) (uvset struct offset value)
89      (report-bad-arg struct 'structure-object)))
90
91(defsetf struct-ref struct-set)
92
93
94; things for defstruct to do - at load time
95(defun %defstruct-do-load-time (sd predicate &optional doc &aux (name (sd-name sd)))
96  ;(declare (ignore refnames))
97  (when (null (sd-type sd))
98    (%define-structure-class sd))
99  (when (and doc *save-doc-strings*)
100    (set-documentation name 'type doc)) 
101  (puthash name %defstructs% sd)
102  (record-source-file name 'structure)
103  (when (and predicate (null (sd-type sd)))
104    (puthash predicate %structure-refs% name)) 
105  (when *fasload-print* (format t "~&~S~%" name))
106  name)
107
108(defun %defstruct-set-print-function (sd print-function print-object-p)
109  (sd-set-print-function sd (if print-object-p
110                              (list print-function)
111                              print-function)))
112
113
114(defun sd-refname-pos-in-included-struct (sd name)
115  (dolist (included-type (cdr (sd-superclasses sd)))
116    (let ((sub-sd (gethash included-type %defstructs%)))
117      (when sub-sd
118        (let ((refnames (sd-refnames sub-sd)))
119          (if refnames
120            (let ((pos (position name refnames :test 'eq)))
121              (and pos (1+ pos)))
122            (dolist (slot (sd-slots sub-sd))
123              (let ((ssd-name (ssd-name slot)))
124                (unless (fixnump ssd-name)
125                  (when (eq name ssd-name)
126                    (return-from sd-refname-pos-in-included-struct
127                      (ssd-offset slot))))))))))))
128
129;;; return stuff for defstruct to compile
130(defun %defstruct-compile (sd refnames)
131  (let ((stuff))   
132    (dolist (slot (sd-slots sd))
133      (unless (fixnump (ssd-name slot))
134        (let* ((accessor (if refnames (pop refnames) (ssd-name slot)))
135               (pos (sd-refname-pos-in-included-struct sd accessor)))
136          (if pos
137            (let ((offset (ssd-offset slot)))
138              (unless (eql pos offset)
139                ; This should be a style-warning
140                (warn "Accessor ~s at different position than in included structure"
141                      accessor)))
142            (let ((fn (slot-accessor-fn slot accessor)))
143              (push
144               `(progn
145                  ,fn
146                  (puthash ',accessor %structure-refs% ',(ssd-type-and-refinfo slot))
147                  (record-source-file ',accessor 'structure-accessor))
148               stuff))))))
149    `(progn ,@(nreverse stuff))))
150
151
152; no #. for cross compile
153(defvar *struct-ref-vector* 
154  (vector #'(lambda (x) (struct-ref x 0))
155          #'(lambda (x) (struct-ref x 1))
156          #'(lambda (x) (struct-ref x 2))
157          #'(lambda (x) (struct-ref x 3))
158          #'(lambda (x) (struct-ref x 4))
159          #'(lambda (x) (struct-ref x 5))
160          #'(lambda (x) (struct-ref x 6))
161          #'(lambda (x) (struct-ref x 7))
162          #'(lambda (x) (struct-ref x 8))
163          #'(lambda (x) (struct-ref x 9))))
164
165(defvar *svref-vector*
166  (vector #'(lambda (x) (svref x 0))
167          #'(lambda (x) (svref x 1))
168          #'(lambda (x) (svref x 2))
169          #'(lambda (x) (svref x 3))
170          #'(lambda (x) (svref x 4))
171          #'(lambda (x) (svref x 5))
172          #'(lambda (x) (svref x 6))
173          #'(lambda (x) (svref x 7))
174          #'(lambda (x) (svref x 8))
175          #'(lambda (x) (svref x 9))))
176
177
178;;; too bad there isnt a way to suppress generating these darn
179;;; functions when you dont want them.  Makes no sense to fetch
180;;; functions from a vector of 68K functions and send them over to
181;;; PPC.  So can use that space optimization iff host and target are
182;;; the same.
183
184(defparameter *defstruct-share-accessor-functions* t)
185
186(defun slot-accessor-fn (slot name &aux (ref (ssd-reftype slot))
187                              (offset (ssd-offset slot)))
188    (cond ((eq ref $defstruct-nth)
189           (if (and  (%i< offset 10) *defstruct-share-accessor-functions*)
190             `(fset ',name
191                    ,(symbol-function
192                      (%svref '#(first second third fourth fifth
193                                       sixth seventh eighth ninth tenth) offset)))
194             `(defun ,name (x)  (nth ,offset x))))
195          ((eq ref $defstruct-struct)
196           (if (and (%i< offset 10) *defstruct-share-accessor-functions*)
197             `(fset ',name , (%svref *struct-ref-vector* offset))
198             `(defun ,name (x)  (struct-ref x ,offset))))
199          ((or (eq ref target::subtag-simple-vector)
200               (eq ref $defstruct-simple-vector))
201           (if (and (%i< offset 10) *defstruct-share-accessor-functions*)
202             `(fset ',name ,(%svref *svref-vector* offset))
203             `(defun ,name (x)  (svref x ,offset))))
204          (t `(defun ,name (x) (uvref x ,offset)))))
205
206(defun defstruct-reftype (type)
207  (cond ((null type) $defstruct-struct)
208        ((eq type 'list) $defstruct-nth)
209        (t (element-type-subtype (cadr type)))))
210
211(defun defstruct-slot-defs (sd refnames env)
212  (let ((ref (defstruct-reftype (sd-type sd))) name defs)
213    (dolist (slot (sd-slots sd))
214      (ssd-set-reftype slot ref)
215      (unless (fixnump (setq name (ssd-name slot))) ;Ignore fake 'name' slots
216        (when refnames (setq name (pop refnames)))
217        (unless (sd-refname-pos-in-included-struct sd name)
218          (push name defs))))
219    (setq defs (nreverse defs))
220    (let* ((info (list (cons (dpb 1 $lfbits-numreq 0) nil))))
221      `(progn
222        (eval-when (:compile-toplevel)
223          ,@(mapcar #'(lambda (name) `(record-function-info ',name ',info ,env)) defs))
224        (declaim (inline ,@defs))))))
225
226;;;Used by setf and whatever...
227(defun defstruct-ref-transform (predicate-or-type-and-refinfo args)
228  (if (type-and-refinfo-p predicate-or-type-and-refinfo)
229    (multiple-value-bind (type refinfo)
230                         (if (consp predicate-or-type-and-refinfo)
231                           (values (%car predicate-or-type-and-refinfo)
232                                   (%cdr predicate-or-type-and-refinfo))
233                           (values 't predicate-or-type-and-refinfo))
234      (let* ((offset (refinfo-offset refinfo))
235             (ref (refinfo-reftype refinfo))
236             (accessor
237              (cond ((eq ref $defstruct-nth)
238                     `(nth ,offset ,@args))
239                    ((eq ref $defstruct-struct)
240                     `(struct-ref ,@args ,offset))
241                    ((eq ref target::subtag-simple-vector)
242                     `(svref ,@args ,offset))
243                    (ref
244                     `(aref (the (simple-array ,(element-subtype-type ref) (*))
245                                 ,@args) ,offset))
246                    (t `(uvref ,@args ,offset)))))
247        (if (eq type 't)
248          accessor
249          `(the ,type ,accessor))))
250    `(structure-typep ,@args ',predicate-or-type-and-refinfo)))
251
252;;; Should probably remove the constructor, copier, and predicate as
253;;; well. Can't remove the inline proclamations for the refnames,
254;;; as the user may have explicitly said this. Questionable - but surely
255;;; must delete the inline definitions.
256;;; Doesn't remove the copier because we don't know for sure what it's name is
257(defmethod change-class ((from structure-class)
258                         (to class)
259                          &rest initargs &key &allow-other-keys)
260  (declare (dynamic-extent initargs))
261  (let ((class-name (class-name from)))
262    (unless (eq from to)                  ; shouldn't be
263      (remove-structure-defs class-name)
264      (remhash class-name %defstructs%)))
265  (%change-class from to initargs))
266
267;;; if redefining a structure as another structure or redefining a
268;;; structure as a class
269(defun remove-structure-defs (class-name)
270  (let ((sd (gethash class-name %defstructs%)))
271    (when sd
272      (dolist (refname (sd-refnames sd))
273        (remhash refname %structure-refs%)
274        (let ((def (assq refname *nx-globally-inline*)))
275          (when def (set-function-info refname nil)))
276        (when (symbolp refname)(fmakunbound refname)))
277      (let ((print-fn (sd-print-function sd)))
278        (when (symbolp print-fn) (fmakunbound print-fn)))
279      (let ((constructor (sd-constructor sd)))
280        (when (symbolp constructor) (fmakunbound constructor)))
281      (let ((delete-match #'(lambda (pred struct-name)
282                              (when (eq struct-name class-name)
283                                (remhash pred %structure-refs%)
284                                (fmakunbound pred)))))
285        (declare (dynamic-extent delete-match))
286        ; get rid of the predicate
287        (maphash delete-match %structure-refs%)))))
288
289(defun copy-structure (source)
290  "Return a copy of STRUCTURE with the same (EQL) slot values."
291  (copy-uvector (require-type source 'structure-object)))
292
293(provide 'defstruct)
294
295; End of defstruct.lisp
Note: See TracBrowser for help on using the repository browser.