X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fvm-ir2tran.lisp;h=b0a2d3d68acca6644f41fd46021af5db2eb30692;hb=49e8403800426f37a54d9b87353a31af36e7af40;hp=19527a6f56d49f20d23a091f22085069a533bcf8;hpb=96bb2dc76dddb1a21b3886fa7522796879e9ed9d;p=sbcl.git diff --git a/src/compiler/generic/vm-ir2tran.lisp b/src/compiler/generic/vm-ir2tran.lisp index 19527a6..b0a2d3d 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) @@ -53,7 +54,9 @@ res) (move-lvar-result node block locs lvar))) -(defun emit-inits (node block name object lowtag inits args) +(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) @@ -72,7 +75,7 @@ `(,(sb!kernel::raw-slot-data-raw-type rsd) (vop ,(sb!kernel::raw-slot-data-init-vop rsd) node block - object arg-tn slot))) + object arg-tn instance-length slot))) #!+raw-instance-init-vops sb!kernel::*raw-slot-data-list* #!-raw-instance-init-vops @@ -123,7 +126,7 @@ (locs (lvar-result-tns lvar (list *backend-t-primitive-type*))) (result (first locs))) (emit-fixed-alloc node block name words type lowtag result lvar) - (emit-inits node block name result lowtag inits args) + (emit-inits node block name result lowtag words inits args) (move-lvar-result node block locs lvar))) (defoptimizer ir2-convert-variable-allocation @@ -136,7 +139,7 @@ (emit-fixed-alloc node block name words type lowtag result lvar)) (vop var-alloc node block (lvar-tn node block extra) name words type lowtag result)) - (emit-inits node block name result lowtag inits args) + (emit-inits node block name result lowtag nil inits args) (move-lvar-result node block locs lvar))) (defoptimizer ir2-convert-structure-allocation @@ -150,9 +153,55 @@ (c-slot-specs (lvar-value slot-specs)) (words (+ (sb!kernel::dd-instance-length c-dd) words))) (emit-fixed-alloc node block name words type lowtag result lvar) - (emit-inits node block name result lowtag `((:dd . ,c-dd) ,@c-slot-specs) args) + (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 :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))))))) + + (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))