X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fvm-ir2tran.lisp;h=4254f3d22c0282da6664c650dc07d8185196988f;hb=57d30b9b5a4b2be52431e0a8daaf81d409d146a9;hp=247e09bbb8eed3e3de4eb778b2c829d99c45c405;hpb=cea4896b2482b7b2b429c1631d774b4cfbc0efba;p=sbcl.git diff --git a/src/compiler/generic/vm-ir2tran.lisp b/src/compiler/generic/vm-ir2tran.lisp index 247e09b..4254f3d 100644 --- a/src/compiler/generic/vm-ir2tran.lisp +++ b/src/compiler/generic/vm-ir2tran.lisp @@ -9,204 +9,265 @@ (in-package "SB!C") +(def-alloc %make-structure-instance 1 :structure-alloc + sb!vm:instance-header-widetag sb!vm:instance-pointer-lowtag + nil) + +#!+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) - (let* ((cont (node-cont node)) - (locs (continuation-result-tns cont - (list *backend-t-primitive-type*))) - (res (first locs))) - (vop slot node block (continuation-tn node block object) - name offset lowtag res) - (move-continuation-result node block locs cont))) - -#!+gengc -(defun needs-remembering (cont) - (if (csubtypep (continuation-type cont) - (load-time-value (specifier-type '(or fixnum character - (member t nil))))) - nil - t)) + (let* ((lvar (node-lvar node)) + (locs (lvar-result-tns lvar + (list *backend-t-primitive-type*))) + (res (first locs))) + (vop slot node block (lvar-tn node block object) + name offset lowtag res) + (move-lvar-result node block locs lvar))) (defoptimizer ir2-convert-setter ((object value) node block name offset lowtag) - (let ((value-tn (continuation-tn node block value))) - (vop set-slot node block (continuation-tn node block object) value-tn - name offset lowtag #!+gengc (needs-remembering value)) - (move-continuation-result node block (list value-tn) (node-cont node)))) + (let ((value-tn (lvar-tn node block value))) + (vop set-slot node block (lvar-tn node block object) value-tn + name offset lowtag) + (move-lvar-result node block (list value-tn) (node-lvar node)))) +;;; FIXME: Isn't there a name for this which looks less like a typo? +;;; (The name IR2-CONVERT-SETTER is used for something else, just above.) (defoptimizer ir2-convert-setfer ((value object) node block name offset lowtag) - (let ((value-tn (continuation-tn node block value))) - (vop set-slot node block (continuation-tn node block object) value-tn - name offset lowtag #!+gengc (needs-remembering value)) - (move-continuation-result node block (list value-tn) (node-cont node)))) + (let ((value-tn (lvar-tn node block value))) + (vop set-slot node block (lvar-tn node block object) value-tn + name offset lowtag) + (move-lvar-result node block (list value-tn) (node-lvar node)))) + +#!+compare-and-swap-vops +(defoptimizer ir2-convert-casser + ((object old new) node block name offset lowtag) + (let* ((lvar (node-lvar node)) + (locs (lvar-result-tns lvar (list *backend-t-primitive-type*))) + (res (first locs))) + (vop compare-and-swap-slot node block + (lvar-tn node block object) + (lvar-tn node block old) + (lvar-tn node block new) + name offset lowtag + res) + (move-lvar-result node block locs lvar))) -(defun do-inits (node block name result lowtag inits args) - (let ((unbound-marker-tn nil)) +(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) (let ((kind (car init)) - (slot (cdr init))) - (vop set-slot node block result - (ecase kind - (:arg - (assert args) - (continuation-tn node block (pop args))) - (:unbound - (or unbound-marker-tn - (setf unbound-marker-tn - (let ((tn (make-restricted-tn - nil - (sc-number-or-lose 'sb!vm::any-reg)))) - (vop make-unbound-marker node block tn) - tn)))) - (:null - (emit-constant nil))) - name slot lowtag #!+gengc nil)))) - (assert (null args))) - -(defun do-fixed-alloc (node block name words type lowtag result) - #!-gengc - (vop fixed-alloc node block name words type lowtag result) - #!+gengc - (if (>= words sb!vm:large-object-cutoff) - (vop large-alloc node block (emit-constant (logandc2 (1+ words) 1)) - (emit-constant lowtag) (emit-constant type) (emit-constant 0) name - result) - (vop fixed-alloc node block name words type lowtag result))) + (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 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) + (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 init-slot node block object + (emit-constant (sb!kernel::dd-layout-or-lose slot)) + name sb!vm:instance-slots-offset lowtag)) + (otherwise + (vop init-slot node block object + (ecase kind + (:arg + (aver args) + (lvar-tn node block (pop args))) + (:unbound + (or unbound-marker-tn + (setf unbound-marker-tn + (let ((tn (make-restricted-tn + nil + (sc-number-or-lose 'sb!vm::any-reg)))) + (vop make-unbound-marker node block tn) + tn)))) + (:null + (emit-constant nil)) + (:funcallable-instance-tramp + (or funcallable-instance-tramp-tn + (setf funcallable-instance-tramp-tn + (let ((tn (make-restricted-tn + nil + (sc-number-or-lose 'sb!vm::any-reg)))) + (vop make-funcallable-instance-tramp node block tn) + tn))))) + name slot lowtag)))))) + (unless (null args) + (bug "Leftover args: ~S" args))) + +(defun emit-fixed-alloc (node block name words type lowtag result lvar) + (let ((stack-allocate-p (and lvar (lvar-dynamic-extent lvar)))) + (when stack-allocate-p + (vop current-stack-pointer node block + (ir2-lvar-stack-pointer (lvar-info lvar)))) + (vop fixed-alloc node block name words type lowtag stack-allocate-p result))) (defoptimizer ir2-convert-fixed-allocation - ((&rest args) node block name words type lowtag inits) - (let* ((cont (node-cont node)) - (locs (continuation-result-tns cont - (list *backend-t-primitive-type*))) - (result (first locs))) - (do-fixed-alloc node block name words type lowtag result) - (do-inits node block name result lowtag inits args) - (move-continuation-result node block locs cont))) + ((&rest args) node block name words type lowtag inits) + (let* ((lvar (node-lvar node)) + (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 words inits args) + (move-lvar-result node block locs lvar))) (defoptimizer ir2-convert-variable-allocation - ((extra &rest args) node block name words type lowtag inits) - (let* ((cont (node-cont node)) - (locs (continuation-result-tns cont - (list *backend-t-primitive-type*))) - (result (first locs))) - (if (constant-continuation-p extra) - (let ((words (+ (continuation-value extra) words))) - (do-fixed-alloc node block name words type lowtag result)) - (vop var-alloc node block (continuation-tn node block extra) name words - type lowtag result)) - (do-inits node block name result lowtag inits args) - (move-continuation-result node block locs cont))) - - - -;;;; other allocation support - -#!+gengc -(defoptimizer (make-array-header ir2-convert) ((type rank) node block) - (let* ((cont (node-cont node)) - (locs (continuation-result-tns cont - (list *backend-t-primitive-type*))) - (result (first locs))) - (if (and (constant-continuation-p type) - (constant-continuation-p rank)) - (do-fixed-alloc node block 'make-array-header - (+ (continuation-value rank) - sb!vm:array-dimensions-offset) - (continuation-value type) - sb!vm:other-pointer-type result) - (vop make-array-header node block (continuation-tn node block type) - (continuation-tn node block rank) result)) - (move-continuation-result node block locs cont))) - -;;;; replacements for stuff in ir2tran to make gengc work - -#!+gengc -(defun ir2-convert-closure (node block leaf res) - (declare (type ref node) (type ir2-block block) - (type functional leaf) (type tn res)) - (unless (leaf-info leaf) - (setf (leaf-info leaf) (make-entry-info))) - (let ((entry (make-load-time-constant-tn :entry leaf)) - (closure (etypecase leaf - (clambda - (environment-closure (get-lambda-environment leaf))) - (functional - (assert (eq (functional-kind leaf) :top-level-xep)) - nil)))) - (if closure - (let ((this-env (node-environment node))) - #!+gengc (let ((temp (make-normal-tn *backend-t-primitive-type*))) - (do-fixed-alloc node block 'make-closure - (+ (length closure) - sb!vm:closure-info-offset) - sb!vm:closure-header-type - sb!vm:function-pointer-type - res) - (emit-move node block entry temp) - (vop %set-function-self node block temp res temp)) - ;; KLUDGE: #!-GENGC nested inside #!+GENGC doesn't make much sense; - ;; it's just a literal translation of the CMU CL distinction between - ;; host and backend. If GENGC code is ever revived, this should be - ;; cleaned up. - #!-gengc (vop make-closure node block entry (length closure) res) - (loop for what in closure and n from 0 do - (unless (and (lambda-var-p what) - (null (leaf-refs what))) - (vop closure-init node block - res - (find-in-environment what this-env) - n - nil)))) - (emit-move node block entry res))) - (values)) - -#!+gengc -(defun ir2-convert-set (node block) - (declare (type cset node) (type ir2-block block)) - (let* ((cont (node-cont node)) - (leaf (set-var node)) - (value (set-value node)) - (val-tn (continuation-tn node block value)) - (locs (if (continuation-info cont) - (continuation-result-tns - cont (list (primitive-type (leaf-type leaf)))) - nil))) - (etypecase leaf - (lambda-var - (when (leaf-refs leaf) - (let ((tn (find-in-environment leaf (node-environment node)))) - (if (lambda-var-indirect leaf) - (vop value-cell-set node block tn val-tn - (needs-remembering value)) - (emit-move node block val-tn tn))))) - (global-var - (ecase (global-var-kind leaf) - ((:special :global) - (assert (symbolp (leaf-name leaf))) - (vop set node block (emit-constant (leaf-name leaf)) val-tn - (needs-remembering value)))))) - - (when locs - (emit-move node block val-tn (first locs)) - (move-continuation-result node block locs cont))) - (values)) - -#!+gengc -(defoptimizer (%lexical-exit-breakup ir2-convert) ((info) node block) - (vop value-cell-set node block - (find-in-environment (continuation-value info) (node-environment node)) - (emit-constant 0) - nil)) - -#!+gengc -(defoptimizer (%slot-setter ir2-convert) ((value str) node block) - (let ((val (continuation-tn node block value))) - (vop instance-set node block - (continuation-tn node block str) - val - (dsd-index - (slot-accessor-slot - (ref-leaf - (continuation-use - (combination-fun node))))) - (needs-remembering value)) - - (move-continuation-result node block (list val) (node-cont node)))) + ((extra &rest args) node block name words type lowtag inits) + (let* ((lvar (node-lvar node)) + (locs (lvar-result-tns lvar (list *backend-t-primitive-type*))) + (result (first locs))) + (if (constant-lvar-p extra) + (let ((words (+ (lvar-value extra) words))) + (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 nil inits args) + (move-lvar-result node block locs lvar))) + +(defoptimizer ir2-convert-structure-allocation + ((dd slot-specs &rest args) node block name words type lowtag inits) + (let* ((lvar (node-lvar node)) + (locs (lvar-result-tns lvar (list *backend-t-primitive-type*))) + (result (first locs))) + (aver (constant-lvar-p dd)) + (aver (constant-lvar-p slot-specs)) + (let* ((c-dd (lvar-value dd)) + (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 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 +;;; than simply set the slot. So we build the IR2 converting function +;;; by hand. -- CSR, 2003-05-08 +(let ((fun-info (fun-info-or-lose '%set-symbol-value))) + (setf (fun-info-ir2-convert fun-info) + (lambda (node block) + (let ((args (basic-combination-args node))) + (destructuring-bind (symbol value) args + (let ((value-tn (lvar-tn node block value))) + (vop set node block + (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))