X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Fgeneric%2Fvm-ir2tran.lisp;h=4254f3d22c0282da6664c650dc07d8185196988f;hb=57d30b9b5a4b2be52431e0a8daaf81d409d146a9;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..4254f3d 100644 --- a/src/compiler/generic/vm-ir2tran.lisp +++ b/src/compiler/generic/vm-ir2tran.lisp @@ -13,7 +13,8 @@ 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) ((&rest args) node dx) t) (defoptimizer ir2-convert-reffer ((object) node block name offset lowtag) @@ -54,6 +55,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) @@ -66,7 +69,7 @@ (macrolet ((make-case () `(ecase raw-type ((t) - (vop set-slot node block object arg-tn + (vop init-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) @@ -79,11 +82,11 @@ 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 +156,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) + (constant-tn (find-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 +217,57 @@ (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) + (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) + (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 +#!+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))