X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir2tran.lisp;h=e2b593e4de2c81e924aa081019861ededda9c25a;hb=cd5a858174d892f876699373dc3ea389cf2c4d40;hp=af5c7e4f66bd37d1d75f92543f2e9387d013f529;hpb=e6f4c7523aa628ece995ee01879d3fb90eed6d9f;p=sbcl.git diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index af5c7e4..e2b593e 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -31,14 +31,16 @@ ;;; If there is any CHECK-xxx template for TYPE, then return it, ;;; otherwise return NIL. +;;; The second value is T if the template needs TYPE to be passed (defun type-check-template (type) (declare (type ctype type)) (multiple-value-bind (check-ptype exact) (primitive-type type) (if exact (primitive-type-check check-ptype) - (let ((name (hairy-type-check-template-name type))) + (multiple-value-bind (name type-needed) + (hairy-type-check-template-name type) (if name - (template-or-lose name) + (values (template-or-lose name) type-needed) nil))))) ;;; Emit code in BLOCK to check that VALUE is of the specified TYPE, @@ -49,7 +51,10 @@ (defun emit-type-check (node block value result type) (declare (type tn value result) (type node node) (type ir2-block block) (type ctype type)) - (emit-move-template node block (type-check-template type) value result) + (multiple-value-bind (template type-needed) (type-check-template type) + (if type-needed + (emit-load-template node block template value result (list type)) + (emit-move-template node block template value result))) (values)) ;;; Allocate an indirect value cell. @@ -157,29 +162,40 @@ (functional (ir2-convert-closure node block leaf res)) (global-var - (let ((unsafe (policy node (zerop safety))) - (name (leaf-source-name leaf))) - (ecase (global-var-kind leaf) - ((:special :unknown) - (aver (symbolp name)) - (let ((name-tn (emit-constant name))) - (if (or unsafe (info :variable :always-bound name)) - (vop fast-symbol-value node block name-tn res) - (vop symbol-value node block name-tn res)))) - (:global - (aver (symbolp name)) - (let ((name-tn (emit-constant name))) - (if (or unsafe (info :variable :always-bound name)) - (vop fast-symbol-global-value node block name-tn res) - (vop symbol-global-value node block name-tn res)))) - (:global-function - (let ((fdefn-tn (make-load-time-constant-tn :fdefinition name))) - (if unsafe - (vop fdefn-fun node block fdefn-tn res) - (vop safe-fdefn-fun node block fdefn-tn res)))))))) + (ir2-convert-global-var node block leaf res))) (move-lvar-result node block locs lvar)) (values)) +(defun ir2-convert-global-var (node block leaf res) + (let ((unsafe (policy node (zerop safety))) + (name (leaf-source-name leaf))) + (ecase (global-var-kind leaf) + ((:special :unknown) + (aver (symbolp name)) + (let ((name-tn (emit-constant name))) + (if (or unsafe (info :variable :always-bound name)) + (vop fast-symbol-value node block name-tn res) + (vop symbol-value node block name-tn res)))) + (:global + (aver (symbolp name)) + (let ((name-tn (emit-constant name))) + (if (or unsafe (info :variable :always-bound name)) + (vop fast-symbol-global-value node block name-tn res) + (vop symbol-global-value node block name-tn res)))) + (:global-function + (cond #-sb-xc-host + ((and (info :function :definition name) + (info :function :info name)) + ;; Known functions can be saved without going through fdefns, + ;; except during cross-compilation + (emit-move node block (make-load-time-constant-tn :known-fun name) + res)) + (t + (let ((fdefn-tn (make-load-time-constant-tn :fdefinition name))) + (if unsafe + (vop fdefn-fun node block fdefn-tn res) + (vop safe-fdefn-fun node block fdefn-tn res))))))))) + ;;; some sanity checks for a CLAMBDA passed to IR2-CONVERT-CLOSURE (defun assertions-on-ir2-converted-clambda (clambda) ;; This assertion was sort of an experiment. It would be nice and @@ -244,13 +260,23 @@ (physenv-closure (get-lambda-physenv functional))) (functional (aver (eq (functional-kind functional) :toplevel-xep)) - nil)))) - + nil))) + global-var) (cond (closure (let* ((physenv (node-physenv ref)) (tn (find-in-physenv functional physenv))) (emit-move ref ir2-block tn res))) + ;; we're about to emit a reference to a "closure" that's actually + ;; an inlinable global function. + ((and (global-var-p (setf global-var + (functional-inline-expanded functional))) + (eq :global-function (global-var-kind global-var))) + (ir2-convert-global-var ref ir2-block global-var res)) (t + ;; if we're here, we should have either a toplevel-xep (some + ;; global scope function in a different component) or an external + ;; reference to the "closure"'s body. + (aver (memq (functional-kind functional) '(:external :toplevel-xep))) (let ((entry (make-load-time-constant-tn :entry functional))) (emit-move ref ir2-block entry res))))) (values)) @@ -1542,8 +1568,7 @@ (progn (labels ((,unbind (vars) (declare (optimize (speed 2) (debug 0))) - (let ((unbound-marker (%primitive make-other-immediate-type - 0 sb!vm:unbound-marker-widetag))) + (let ((unbound-marker (%primitive make-unbound-marker))) (dolist (var vars) ;; CLHS says "bound and then made to have no value" -- user ;; should not be able to tell the difference between that and this. @@ -1768,6 +1793,46 @@ (def list*)) +(defoptimizer (mask-signed-field ir2-convert) ((width x) node block) + (block nil + (when (constant-lvar-p width) + (case (lvar-value width) + (#.(- sb!vm:n-word-bits sb!vm:n-fixnum-tag-bits) + (when (or (csubtypep (lvar-type x) + (specifier-type 'word)) + (csubtypep (lvar-type x) + (specifier-type 'sb!vm:signed-word))) + (let* ((lvar (node-lvar node)) + (temp (make-normal-tn + (if (csubtypep (lvar-type x) + (specifier-type 'word)) + (primitive-type-of most-positive-word) + (primitive-type-of + (- (ash most-positive-word -1)))))) + (results (lvar-result-tns + lvar + (list (primitive-type-or-lose 'fixnum))))) + (emit-move node block (lvar-tn node block x) temp) + (vop sb!vm::move-from-word/fixnum node block + temp (first results)) + (move-lvar-result node block results lvar) + (return)))) + (#.sb!vm:n-word-bits + (when (csubtypep (lvar-type x) (specifier-type 'word)) + (let* ((lvar (node-lvar node)) + (temp (make-normal-tn + (primitive-type-of most-positive-word))) + (results (lvar-result-tns + lvar + (list (primitive-type + (specifier-type 'sb!vm:signed-word)))))) + (emit-move node block (lvar-tn node block x) temp) + (vop sb!vm::word-move node block + temp (first results)) + (move-lvar-result node block results lvar) + (return)))))) + (ir2-convert-full-call node block))) + ;;; Convert the code in a component into VOPs. (defun ir2-convert (component) (declare (type component component))