X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fvm-ir2tran.lisp;h=fda40cdd6f6553ed2261a01558d4723f8fa86184;hb=9b79c4c51954ffc46c631e56547ac865860e8855;hp=0f5f92e84c8f809e1633ac19b68dfb3f3058e6b5;hpb=e840f481796d191997a47421d60cd039cd260613;p=sbcl.git diff --git a/src/compiler/generic/vm-ir2tran.lisp b/src/compiler/generic/vm-ir2tran.lisp index 0f5f92e..fda40cd 100644 --- a/src/compiler/generic/vm-ir2tran.lisp +++ b/src/compiler/generic/vm-ir2tran.lisp @@ -13,13 +13,25 @@ sb!vm:instance-header-widetag sb!vm:instance-pointer-lowtag nil) -(defoptimizer (%make-structure-instance stack-allocate-result) ((&rest args) node dx) +#!+stack-allocatable-fixed-objects +(defoptimizer (%make-structure-instance stack-allocate-result) ((defstruct-description &rest args) node dx) + (aver (constant-lvar-p defstruct-description)) + ;; A structure instance can be stack-allocated if it has no raw + ;; slots, or if we're on a target with a conservatively-scavenged + ;; stack. We have no reader conditional for stack conservation, but + ;; it turns out that the only time stack conservation is in play is + ;; when we're on GENCGC (since CHENEYGC doesn't have conservation) + ;; and C-STACK-IS-CONTROL-STACK (otherwise, the C stack is the + ;; number stack, and we precisely-scavenge the control stack). + #!-(and :gencgc :c-stack-is-control-stack) + (zerop (sb!kernel::dd-raw-length (lvar-value defstruct-description))) + #!+(and :gencgc :c-stack-is-control-stack) t) (defoptimizer ir2-convert-reffer ((object) node block name offset lowtag) (let* ((lvar (node-lvar node)) (locs (lvar-result-tns lvar - (list *backend-t-primitive-type*))) + (list *backend-t-primitive-type*))) (res (first locs))) (vop slot node block (lvar-tn node block object) name offset lowtag res) @@ -63,29 +75,42 @@ (slot (cdr init))) (case kind (:slot - (let ((raw-type (pop slot)) - (arg-tn (lvar-tn node block (pop args)))) - (macrolet ((make-case () - `(ecase raw-type - ((t) - (vop set-slot node block object arg-tn - name (+ sb!vm:instance-slots-offset slot) lowtag)) - ,@(mapcar (lambda (rsd) - `(,(sb!kernel::raw-slot-data-raw-type rsd) - (vop ,(sb!kernel::raw-slot-data-init-vop rsd) - node block - object arg-tn instance-length slot))) - #!+raw-instance-init-vops - sb!kernel::*raw-slot-data-list* - #!-raw-instance-init-vops - nil)))) + (let* ((raw-type (pop slot)) + (arg (pop args)) + (arg-tn (lvar-tn node block arg))) + (macrolet + ((make-case () + `(ecase raw-type + ((t) + (vop init-slot node block object arg-tn + name (+ sb!vm:instance-slots-offset slot) lowtag)) + ,@(mapcar + (lambda (rsd) + (let ((specifier (sb!kernel::raw-slot-data-raw-type + rsd))) + `(,specifier + (let ((type (specifier-type ',specifier)) + (arg-tn arg-tn)) + (unless (csubtypep (lvar-type arg) type) + (let ((tmp (make-normal-tn + (primitive-type type)))) + (emit-type-check node block arg-tn + tmp type) + (setf arg-tn tmp))) + (vop ,(sb!kernel::raw-slot-data-init-vop rsd) + node block + object arg-tn instance-length slot))))) + #!+raw-instance-init-vops + sb!kernel::*raw-slot-data-list* + #!-raw-instance-init-vops + nil)))) (make-case)))) (:dd - (vop set-slot node block object + (vop init-slot node block object (emit-constant (sb!kernel::dd-layout-or-lose slot)) name sb!vm:instance-slots-offset lowtag)) (otherwise - (vop set-slot node block object + (vop init-slot node block object (ecase kind (:arg (aver args) @@ -193,7 +218,7 @@ ,@(nreverse clauses))))) (frob))) (tnify (index) - (constant-tn (find-constant index)))) + (emit-constant index))) (let ((setter (compute-setter)) (length (length initial-contents))) (dotimes (i length) @@ -218,21 +243,28 @@ node block (list value-tn) (node-lvar node)))))))) ;;; Stack allocation optimizers per platform support -;;; -;;; Platforms with stack-allocatable vectors -#!+(or hppa mips x86 x86-64) +#!+stack-allocatable-vectors (progn (defoptimizer (allocate-vector stack-allocate-result) ((type length words) node dx) - (or (eq dx :truly) - (zerop (policy node safety)) - ;; a vector object should fit in one page -- otherwise it might go past - ;; stack guard pages. - (values-subtypep (lvar-derived-type words) - (load-time-value - (specifier-type `(integer 0 ,(- (/ sb!vm::*backend-page-bytes* - sb!vm:n-word-bytes) - sb!vm:vector-data-offset))))))) + (and + ;; Can't put unboxed data on the stack unless we scavenge it + ;; conservatively. + #!-c-stack-is-control-stack + (constant-lvar-p type) + #!-c-stack-is-control-stack + (member (lvar-value type) + '#.(list (sb!vm:saetp-typecode (find-saetp 't)) + (sb!vm:saetp-typecode (find-saetp 'fixnum)))) + (or (eq dx :always-dynamic) + (zerop (policy node safety)) + ;; a vector object should fit in one page -- otherwise it might go past + ;; stack guard pages. + (values-subtypep (lvar-derived-type words) + (load-time-value + (specifier-type `(integer 0 ,(- (/ sb!vm::*backend-page-bytes* + sb!vm:n-word-bytes) + sb!vm:vector-data-offset)))))))) (defoptimizer (allocate-vector ltn-annotate) ((type length words) call ltn-policy) (let ((args (basic-combination-args call)) @@ -253,20 +285,19 @@ (annotate-1-value-lvar arg))))) ;;; ...lists -#!+(or alpha hppa mips ppc sparc x86 x86-64) +#!+stack-allocatable-lists (progn (defoptimizer (list stack-allocate-result) ((&rest args) node dx) - (declare (ignore node dx)) (not (null args))) (defoptimizer (list* stack-allocate-result) ((&rest args) node dx) - (declare (ignore node dx)) (not (null (rest args)))) (defoptimizer (%listify-rest-args stack-allocate-result) ((&rest args) node dx) - (declare (ignore node dx)) t)) ;;; ...conses -#!+(or hppa mips x86 x86-64) -(defoptimizer (cons stack-allocate-result) ((&rest args) node dx) - (declare (ignore node dx)) - t) +#!+stack-allocatable-fixed-objects +(progn + (defoptimizer (cons stack-allocate-result) ((&rest args) node dx) + t) + (defoptimizer (%make-complex stack-allocate-result) ((&rest args) node dx) + t))