X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-defstruct.lisp;h=3937071758563cb12b0dbee688db28c2c7181d45;hb=b0b168c08b31a748150f404398af754f26fd4813;hp=0147801f986d1fcc5d85dc4a3f614346309eccf1;hpb=4eb1a6d3ad2b7dcc19ac0ec979a1eb1eb049659a;p=sbcl.git diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp index 0147801..3937071 100644 --- a/src/code/target-defstruct.lisp +++ b/src/code/target-defstruct.lisp @@ -133,8 +133,14 @@ (if (funcallable-instance-p new-value) (%funcallable-instance-lexenv new-value) new-value))) + +;;; service function for structure constructors +(defun %make-instance-with-layout (layout) + (let ((result (%make-instance (layout-length layout)))) + (setf (%instance-layout result) layout) + result)) -;;;; target-only parts of the DEFSTRUCT top-level code +;;;; target-only parts of the DEFSTRUCT top level code ;;; Catch attempts to mess up definitions of symbols in the CL package. (defun protect-cl (symbol) @@ -148,9 +154,7 @@ (/show0 "leaving PROTECT-CL") (values)) -;;; the part of %DEFSTRUCT which sets up out-of-line implementations -;;; of those structure functions which are sufficiently similar -;;; between structures that they can be closures +;;; the part of %DEFSTRUCT which makes sense only on the target SBCL ;;; ;;; (The "static" in the name is because it needs to be done not only ;;; in ordinary toplevel %DEFSTRUCT, but also in cold init as early as @@ -162,9 +166,11 @@ (/show0 "entering %TARGET-DEFSTRUCT") + (remhash (dd-name dd) *typecheckfuns*) + ;; (Constructors aren't set up here, because constructors are ;; varied enough (possibly parsing any specified argument list) - ;; that we can't reasonably implement them as closures, and so + ;; that we can't reasonably implement them as closures, so we ;; implement them with DEFUN instead.) ;; Set FDEFINITIONs for slot accessors. @@ -222,9 +228,129 @@ (/show0 ":TYPE LIST case") #'listp)))) + (when (dd-doc dd) + (setf (fdocumentation (dd-name dd) 'type) + (dd-doc dd))) + (/show0 "leaving %TARGET-DEFSTRUCT") (values)) +;;;; generating out-of-line slot accessor functions + +;;; FIXME: Ideally, the presence of the type checks in the functions +;;; here would be conditional on the optimization policy at the point +;;; of expansion of DEFSTRUCT. (For now we're just doing the simpler +;;; thing, putting in the type checks unconditionally.) + +;;; Return (VALUES SLOT-READER-FUN SLOT-WRITER-FUN). +(defun slot-accessor-funs (dd dsd) + + #+sb-xc (/show0 "entering SLOT-ACCESSOR-FUNS") + + ;; various code generators + ;; + ;; Note: They're only minimally parameterized, and cavalierly grab + ;; things like INSTANCE and DSD-INDEX from the namespace they're + ;; expanded in. + (macrolet (;; code shared between funcallable instance case and the + ;; ordinary STRUCTURE-OBJECT case: Handle native + ;; structures with LAYOUTs and (possibly) raw slots. + (%native-slot-accessor-funs (dd-ref-fun-name) + (let ((instance-type-check-form + '(%check-structure-type-from-layout instance layout))) + (/show "macroexpanding %NATIVE-SLOT-ACCESSOR-FUNS" dd-ref-fun-name instance-type-check-form) + `(let ((layout (dd-layout-or-lose dd)) + (dsd-raw-type (dsd-raw-type dsd))) + #+sb-xc (/show0 "in %NATIVE-SLOT-ACCESSOR-FUNS macroexpanded code") + ;; Map over all the possible RAW-TYPEs, compiling + ;; a different closure function for each one, so + ;; that once the COND over RAW-TYPEs happens (at + ;; the time closure is allocated) there are no + ;; more decisions to be made and things execute + ;; reasonably efficiently. + (cond + ;; nonraw slot case + ((eql dsd-raw-type t) + #+sb-xc (/show0 "in nonraw slot case") + (%slotplace-accessor-funs + (,dd-ref-fun-name instance dsd-index) + ,instance-type-check-form)) + ;; raw slot cases + ,@(mapcar (lambda (rtd) + (let ((raw-type (raw-slot-data-raw-type rtd)) + (accessor-name + (raw-slot-data-accessor-name rtd)) + (n-words (raw-slot-data-n-words rtd))) + `((equal dsd-raw-type ',raw-type) + #+sb-xc (/show0 "in raw slot case") + (let ((raw-index (dd-raw-index dd))) + (multiple-value-bind (scaled-dsd-index + misalignment) + (floor dsd-index ,n-words) + (aver (zerop misalignment)) + (%slotplace-accessor-funs + (,accessor-name (,dd-ref-fun-name + instance + raw-index) + scaled-dsd-index) + ,instance-type-check-form)))))) + *raw-slot-data-list*) + ;; oops + (t + (error "internal error: unexpected DSD-RAW-TYPE ~S" + dsd-raw-type)))))) + ;; code shared between DEFSTRUCT :TYPE LIST and + ;; DEFSTRUCT :TYPE VECTOR cases: Handle the "typed + ;; structure" case, with no LAYOUTs and no raw slots. + (%colontyped-slot-accessor-funs () (error "stub")) + ;; the common structure of the raw-slot and not-raw-slot + ;; cases, defined in terms of the writable SLOTPLACE. All + ;; possible flavors of slot access should be able to pass + ;; through here. + (%slotplace-accessor-funs (slotplace instance-type-check-form) + (/show "macroexpanding %SLOTPLACE-ACCESSOR-FUNS" slotplace instance-type-check-form) + `(values (lambda (instance) + (/noshow0 "in %SLOTPLACE-ACCESSOR-FUNS-defined reader") + ,instance-type-check-form + (/noshow0 "back from INSTANCE-TYPE-CHECK-FORM") + ,slotplace) + (let ((typecheckfun (typespec-typecheckfun dsd-type))) + (lambda (new-value instance) + (/noshow0 "in %SLOTPLACE-ACCESSOR-FUNS-defined writer") + ,instance-type-check-form + (/noshow0 "back from INSTANCE-TYPE-CHECK-FORM") + (funcall typecheckfun new-value) + (/noshow0 "back from TYPECHECKFUN") + (setf ,slotplace new-value)))))) + + (let ((dsd-index (dsd-index dsd)) + (dsd-type (dsd-type dsd))) + + #+sb-xc (/show0 "got DSD-TYPE=..") + #+sb-xc (/hexstr dsd-type) + (ecase (dd-type dd) + + ;; native structures + (structure + #+sb-xc (/show0 "case of DSD-TYPE = STRUCTURE") + (%native-slot-accessor-funs %instance-ref)) + + ;; structures with the :TYPE option + + ;; FIXME: Worry about these later.. + #| + ;; In :TYPE LIST and :TYPE VECTOR structures, ANSI specifies the + ;; layout completely, so that raw slots are impossible. + (list + (dd-type-slot-accessor-funs nth-but-with-sane-arg-order + `(%check-structure-type-from-dd + :maybe-raw-p nil)) + (vector + (dd-type-slot-accessor-funs aref + :maybe-raw-p nil))) + |# + )))) + ;;; Copy any old kind of structure. (defun copy-structure (structure) #!+sb-doc @@ -318,7 +444,7 @@ (*print-pretty* (%default-structure-pretty-print structure stream)) (t - (%default-structure-ugly-print structure-stream)))) + (%default-structure-ugly-print structure stream)))) (def!method print-object ((x structure-object) stream) (default-structure-print x stream *current-level*))