X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fvm-ir2tran.lisp;h=fda40cdd6f6553ed2261a01558d4723f8fa86184;hb=19319c931fc1636835dbef71808cc10e252bcf45;hp=5df3845b1e6bb6a455d2a53ab6c6b683f765c556;hpb=641fe4d4aa7cafc39219e93baa0b5fd019f376ee;p=sbcl.git diff --git a/src/compiler/generic/vm-ir2tran.lisp b/src/compiler/generic/vm-ir2tran.lisp index 5df3845..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)) +#!+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) @@ -54,6 +66,8 @@ (move-lvar-result node block locs lvar))) (defun emit-inits (node block name object lowtag instance-length inits args) + #!-raw-instance-init-vops + (declare (ignore instance-length)) (let ((unbound-marker-tn nil) (funcallable-instance-tramp-tn nil)) (dolist (init inits) @@ -61,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) @@ -153,6 +180,52 @@ (emit-inits node block name result lowtag words `((:dd . ,c-dd) ,@c-slot-specs) args) (move-lvar-result node block locs lvar)))) +(defoptimizer (initialize-vector ir2-convert) + ((vector &rest initial-contents) node block) + (let* ((vector-ctype (lvar-type vector)) + (elt-ctype (if (array-type-p vector-ctype) + (array-type-specialized-element-type vector-ctype) + (bug "Unknow vector type in IR2 conversion for ~S." + 'initialize-vector))) + (saetp (find-saetp-by-ctype elt-ctype)) + (lvar (node-lvar node)) + (locs (lvar-result-tns lvar (list (primitive-type vector-ctype)))) + (result (first locs)) + (elt-ptype (primitive-type elt-ctype)) + (tmp (make-normal-tn elt-ptype))) + (emit-move node block (lvar-tn node block vector) result) + (flet ((compute-setter () + (macrolet + ((frob () + (let ((*package* (find-package :sb!vm)) + (clauses nil)) + (map nil (lambda (s) + (when (sb!vm:saetp-specifier s) + (push + `(,(sb!vm:saetp-typecode s) + (lambda (index tn) + #!+(or x86 x86-64) + (vop ,(symbolicate "DATA-VECTOR-SET-WITH-OFFSET/" + (sb!vm:saetp-primitive-type-name s)) + node block result index tn 0 tn) + #!-(or x86 x86-64) + (vop ,(symbolicate "DATA-VECTOR-SET/" + (sb!vm:saetp-primitive-type-name s)) + node block result index tn tn))) + clauses))) + sb!vm:*specialized-array-element-type-properties*) + `(ecase (sb!vm:saetp-typecode saetp) + ,@(nreverse clauses))))) + (frob))) + (tnify (index) + (emit-constant index))) + (let ((setter (compute-setter)) + (length (length initial-contents))) + (dotimes (i length) + (emit-move node block (lvar-tn node block (pop initial-contents)) tmp) + (funcall setter (tnify i) tmp)))) + (move-lvar-result node block locs lvar))) + ;;; :SET-TRANS (in objdef.lisp DEFINE-PRIMITIVE-OBJECT) doesn't quite ;;; cut it for symbols, where under certain compilation options ;;; (e.g. #!+SB-THREAD) we have to do something complicated, rather @@ -168,3 +241,63 @@ (lvar-tn node block symbol) value-tn) (move-lvar-result node block (list value-tn) (node-lvar node)))))))) + +;;; Stack allocation optimizers per platform support +#!+stack-allocatable-vectors +(progn + (defoptimizer (allocate-vector stack-allocate-result) + ((type length words) node dx) + (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)) + (template (template-or-lose (if (awhen (node-lvar call) + (lvar-dynamic-extent it)) + 'sb!vm::allocate-vector-on-stack + 'sb!vm::allocate-vector-on-heap)))) + (dolist (arg args) + (setf (lvar-info arg) + (make-ir2-lvar (primitive-type (lvar-type arg))))) + (unless (is-ok-template-use template call (ltn-policy-safe-p ltn-policy)) + (ltn-default-call call) + (return-from allocate-vector-ltn-annotate-optimizer (values))) + (setf (basic-combination-info call) template) + (setf (node-tail-p call) nil) + + (dolist (arg args) + (annotate-1-value-lvar arg))))) + +;;; ...lists +#!+stack-allocatable-lists +(progn + (defoptimizer (list stack-allocate-result) ((&rest args) node dx) + (not (null args))) + (defoptimizer (list* stack-allocate-result) ((&rest args) node dx) + (not (null (rest args)))) + (defoptimizer (%listify-rest-args stack-allocate-result) ((&rest args) node dx) + t)) + +;;; ...conses +#!+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))