X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Fgeneric%2Fvm-ir2tran.lisp;h=fda40cdd6f6553ed2261a01558d4723f8fa86184;hb=54da325f13fb41669869aea688ae195426c0e231;hp=2cbe33b4da376affedb0f9364e427d828a80625d;hpb=1d5026183c434517a84d03239804a44ebf8cfd1e;p=sbcl.git diff --git a/src/compiler/generic/vm-ir2tran.lisp b/src/compiler/generic/vm-ir2tran.lisp index 2cbe33b..fda40cd 100644 --- a/src/compiler/generic/vm-ir2tran.lisp +++ b/src/compiler/generic/vm-ir2tran.lisp @@ -13,14 +13,25 @@ sb!vm:instance-header-widetag sb!vm:instance-pointer-lowtag nil) -(defoptimizer (%make-structure-instance stack-allocate-result) ((&rest args) node dx) - (declare (ignore 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) @@ -64,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) @@ -156,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 @@ -173,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)) @@ -208,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))