Ignore:
Timestamp:
Sep 15, 2010, 12:07:42 AM (9 years ago)
Author:
gz
Message:

r14258 from trunk (defstruct changes)

Location:
branches/qres/ccl
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • branches/qres/ccl

  • branches/qres/ccl/lib/defstruct.lisp

    r14057 r14259  
    3535             (cons type refinfo)))))
    3636
    37 (declaim (inline type-and-refinfo-p))
    38 (defun type-and-refinfo-p (object)
    39   (or (fixnump object) (consp object)))
     37(declaim (inline accessor-structref-info-p))
     38(defun accessor-structref-info-p (object) ;; as opposed to predicate structref-info.
     39  (consp object))
     40
     41(declaim (inline structref-info-type))
     42(defun structref-info-type (info)
     43  (when (consp info)
     44    (if (consp (%car info)) (%caar info) 't)))
     45
     46(declaim (inline structref-info-refinfo))
     47(defun structref-info-refinfo (info)
     48  (when (consp info)
     49    (if (consp (%car info)) (%cdar info) (%car info))))
     50
     51(defun structref-set-r/o (sym &optional env)
     52  (let ((info (structref-info sym env)))
     53    (when (accessor-structref-info-p info)
     54      (if (consp (%car info))
     55        (setf (%cdar info) (%ilogior2 (%ilsl $struct-r/o 1) (%cdar info)))
     56        (setf (%car info) (%ilogior2 (%ilsl $struct-r/o 1) (%car info)))))))
     57
     58(declaim (inline structref-info-struct))
     59(defun structref-info-struct (info)
     60  (when (consp info)
     61    (%cdr info)))
    4062
    4163(defun ssd-set-reftype (ssd reftype)
     
    4668(defun ssd-set-r/o (ssd)
    4769  (ssd-update-refinfo (ssd refinfo)
    48                       (%ilogior2 #x1000000 refinfo)))
     70                      (%ilogior2 (%ilsl $struct-r/o 1) refinfo)))
    4971
    5072(defun ssd-set-inherited (ssd)
     
    139161;;; return stuff for defstruct to compile
    140162(defun %defstruct-compile (sd refnames env)
    141   (let ((stuff))   
     163  (let ((stuff)
     164        (struct (and (not (sd-type sd)) (sd-name sd))))
    142165    (dolist (slot (sd-slots sd))
    143166      (unless (fixnump (ssd-name slot))
     
    151174                      accessor)))
    152175            (unless (sd-refname-in-included-struct-p sd accessor env)
    153               (let ((fn (slot-accessor-fn slot accessor env)))
     176              (let ((fn (slot-accessor-fn sd slot accessor env))
     177                    (info (cons (ssd-type-and-refinfo slot) struct)))
    154178                (push
    155179                 `(progn
    156180                    ,.fn
    157                     (puthash ',accessor %structure-refs% ',(ssd-type-and-refinfo slot))
     181                    (puthash ',accessor %structure-refs% ',info)
    158182                    (record-source-file ',accessor 'structure-accessor))
    159183                 stuff)))))))
    160184    (nreverse stuff)))
    161185
    162 
    163 ; no #. for cross compile
    164 (defvar *struct-ref-vector*
    165   (vector #'(lambda (x) (struct-ref x 0))
    166           #'(lambda (x) (struct-ref x 1))
    167           #'(lambda (x) (struct-ref x 2))
    168           #'(lambda (x) (struct-ref x 3))
    169           #'(lambda (x) (struct-ref x 4))
    170           #'(lambda (x) (struct-ref x 5))
    171           #'(lambda (x) (struct-ref x 6))
    172           #'(lambda (x) (struct-ref x 7))
    173           #'(lambda (x) (struct-ref x 8))
    174           #'(lambda (x) (struct-ref x 9))))
    175 
    176 (defvar *svref-vector*
    177   (vector #'(lambda (x) (svref x 0))
    178           #'(lambda (x) (svref x 1))
    179           #'(lambda (x) (svref x 2))
    180           #'(lambda (x) (svref x 3))
    181           #'(lambda (x) (svref x 4))
    182           #'(lambda (x) (svref x 5))
    183           #'(lambda (x) (svref x 6))
    184           #'(lambda (x) (svref x 7))
    185           #'(lambda (x) (svref x 8))
    186           #'(lambda (x) (svref x 9))))
    187 
    188 
    189 ;;; too bad there isnt a way to suppress generating these darn
    190 ;;; functions when you dont want them.  Makes no sense to fetch
    191 ;;; functions from a vector of 68K functions and send them over to
    192 ;;; PPC.  So can use that space optimization iff host and target are
    193 ;;; the same.
    194 
    195 
    196 (defparameter *defstruct-share-accessor-functions* t)   ;; TODO: isn't it time to get rid of this?
    197 
    198 (defun slot-accessor-fn (slot name env &aux (ref (ssd-reftype slot)) (offset (ssd-offset slot)))
    199   (cond ((eq ref $defstruct-nth)
    200          (if (and  (%i< offset 10) *defstruct-share-accessor-functions*)
    201            `((eval-when (:compile-toplevel)
    202                (record-function-info ',name ',*one-arg-defun-def-info* ,env))
    203               (fset ',name
    204                     ,(symbol-function
    205                       (%svref '#(first second third fourth fifth
    206                                  sixth seventh eighth ninth tenth) offset))))
    207            `((defun ,name (x)  (nth ,offset x)))))
    208         ((eq ref $defstruct-struct)
    209          (if (and (%i< offset 10) *defstruct-share-accessor-functions*)
    210            `((eval-when (:compile-toplevel)
    211                (record-function-info ',name ',*one-arg-defun-def-info* ,env))               
    212              (fset ',name , (%svref *struct-ref-vector* offset)))
    213            `((defun ,name (x)  (struct-ref x ,offset)))))
    214         ((or (eq ref target::subtag-simple-vector)
    215              (eq ref $defstruct-simple-vector))
    216          (if (and (%i< offset 10) *defstruct-share-accessor-functions*)
    217            `((eval-when (:compile-toplevel)
    218                (record-function-info ',name ',*one-arg-defun-def-info* ,env))
    219              (fset ',name ,(%svref *svref-vector* offset)))
    220            `((defun ,name (x)  (svref x ,offset)))))
    221         (t `((defun ,name (x) (uvref x ,offset))))))
     186(defun defstruct-var (name env)
     187  (declare (ignore env))
     188  (if (symbolp name)
     189    (if (or (constant-symbol-p name) (proclaimed-special-p name))
     190      (make-symbol (symbol-name name))
     191      name)
     192    'object))
     193
     194(defun slot-accessor-fn (sd slot name env)
     195  (let* ((ref (ssd-reftype slot))
     196         (offset (ssd-offset slot))
     197         (arg (defstruct-var (sd-name sd) env))
     198         (value (gensym "VALUE"))
     199         (type (defstruct-type-for-typecheck (ssd-type slot) env))
     200         (form (cond ((eq ref $defstruct-nth)
     201                      `(nth ,offset ,arg))
     202                     ((eq ref $defstruct-struct)
     203                      `(struct-ref (typecheck ,arg ,(sd-name sd)) ,offset))
     204                     ((or (eq ref target::subtag-simple-vector)
     205                          (eq ref $defstruct-simple-vector))
     206                      `(svref ,arg ,offset))
     207                     (t `(uvref ,arg ,offset)))))
     208    `((defun ,name (,arg)
     209        ,(if (eq type 't) form `(the ,type ,form)))
     210      ,@(unless (ssd-r/o slot)
     211          `((defun (setf ,name) (,value ,arg)
     212              ,(if (eq type 't)
     213                 `(setf ,form ,value)
     214                 `(the ,type (setf ,form (typecheck ,value ,type))))))))))
    222215
    223216(defun defstruct-reftype (type)
     
    238231    `((declaim (inline ,@defs)))))
    239232
     233(defun structref-info (sym &optional env)
     234  (let ((info (or (and env (environment-structref-info sym env))
     235                  (gethash sym %structure-refs%))))
     236    ;; This can be removed once $fasl-min-vers is greater than #x5e
     237    #-BOOTSTRAPPED
     238    (when (or (fixnump info)
     239              (and (consp info) (fixnump (%cdr info))))
     240      ;; Old style, without struct type info.
     241      (setq info (cons info 'structure-object)))
     242    info))
     243
     244(defun defstruct-type-for-typecheck (type env)
     245  (if (or (eq type 't)
     246          (specifier-type-if-known type env)
     247          (nx-declarations-typecheck env))
     248    type
     249    ;; Else have an unknown type used only for an implicit declaration.
     250    ;; Just ignore it, it's most likely a forward reference, and while it
     251    ;; means we might be missing out on a possible optimization, most of
     252    ;; the time it's not worth warning about.
     253    't))
     254
    240255;;;Used by nx-transform, setf, and whatever...
    241 (defun defstruct-ref-transform (predicate-or-type-and-refinfo args &optional env)
    242   (if (type-and-refinfo-p predicate-or-type-and-refinfo)
    243     (multiple-value-bind (type refinfo)
    244                          (if (consp predicate-or-type-and-refinfo)
    245                            (values (%car predicate-or-type-and-refinfo)
    246                                    (%cdr predicate-or-type-and-refinfo))
    247                            (values 't predicate-or-type-and-refinfo))
    248       (let* ((offset (refinfo-offset refinfo))
    249              (ref (refinfo-reftype refinfo))
    250              (accessor
    251               (cond ((eq ref $defstruct-nth)
    252                      `(nth ,offset ,@args))
    253                     ((eq ref $defstruct-struct)
    254                      `(struct-ref ,@args ,offset))
    255                     ((eq ref target::subtag-simple-vector)
    256                      `(svref ,@args ,offset))
    257                     (ref
    258                      `(aref (the (simple-array ,(element-subtype-type ref) (*))
    259                                  ,@args) ,offset))
    260                     (t `(uvref ,@args ,offset)))))
    261         (if (eq type 't)
    262           accessor
    263           (if (specifier-type-if-known type env)
    264             `(the ,type ,accessor)
    265             (if (nx-declarations-typecheck env)
    266               `(require-type ,accessor ',type)
    267               ;; Otherwise just ignore the type, it's most likely a forward reference,
    268               ;; and while it means we might be missing out on a possible optimization,
    269               ;; most of the time it's not worth warning about.
    270               accessor)))))
    271     `(structure-typep ,@args ',predicate-or-type-and-refinfo)))
     256(defun defstruct-ref-transform (structref-info args env &optional no-type-p)
     257  (if (accessor-structref-info-p structref-info)
     258    (let* ((type (if no-type-p
     259                   't
     260                   (defstruct-type-for-typecheck (structref-info-type structref-info) env)))
     261           (refinfo (structref-info-refinfo structref-info))
     262           (offset (refinfo-offset refinfo))
     263           (ref (refinfo-reftype refinfo))
     264           (accessor
     265            (cond ((eq ref $defstruct-nth)
     266                   `(nth ,offset ,@args))
     267                  ((eq ref $defstruct-struct)
     268                   `(struct-ref (typecheck ,@args ,(structref-info-struct structref-info)) ,offset))
     269                  ((eq ref target::subtag-simple-vector)
     270                   `(svref ,@args ,offset))
     271                  (ref
     272                   `(aref (the (simple-array ,(element-subtype-type ref) (*))
     273                               ,@args) ,offset))
     274                  (t `(uvref ,@args ,offset)))))
     275      (if (eq type 't)
     276        accessor
     277        `(the ,type ,accessor)))
     278    `(structure-typep ,@args ',structref-info)))
    272279
    273280;;; Should probably remove the constructor, copier, and predicate as
     
    292299    (when sd
    293300      (dolist (refname (sd-refnames sd))
    294         (remhash refname %structure-refs%)
    295301        (let ((def (assq refname *nx-globally-inline*)))
    296302          (when def (set-function-info refname nil)))
    297         (when (symbolp refname)(fmakunbound refname)))
     303        (let ((info (structref-info refname)))
     304          (when (accessor-structref-info-p info)
     305            (unless (refinfo-r/o (structref-info-refinfo info))
     306              (fmakunbound (setf-function-name refname)))
     307            (fmakunbound refname))))
    298308      #|
    299309      ;; The print-function may indeed have become obsolete,
Note: See TracChangeset for help on using the changeset viewer.