X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fcodegen.lisp;h=b0107e189904b28852241eb0b94a1de53103b3d2;hb=eda83f00e869193cb69826be5fa1086b95d12ff7;hp=861bced9eff4f10482c3fbb998c306e7c16d0109;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git diff --git a/src/compiler/codegen.lisp b/src/compiler/codegen.lisp index 861bced..b0107e1 100644 --- a/src/compiler/codegen.lisp +++ b/src/compiler/codegen.lisp @@ -13,52 +13,45 @@ ;;;; files for more information. (in-package "SB!C") - -(file-comment - "$Header$") ;;;; utilities used during code generation +;;; the number of bytes used by the code object header (defun component-header-length (&optional - (component *component-being-compiled*)) - #!+sb-doc - "Returns the number of bytes used by the code object header." + (component *component-being-compiled*)) (let* ((2comp (component-info component)) - (constants (ir2-component-constants 2comp)) - (num-consts (length constants))) + (constants (ir2-component-constants 2comp)) + (num-consts (length constants))) (ash (logandc2 (1+ num-consts) 1) sb!vm:word-shift))) +;;; the size of the NAME'd SB in the currently compiled component. +;;; This is useful mainly for finding the size for allocating stack +;;; frames. (defun sb-allocated-size (name) - #!+sb-doc - "The size of the Name'd SB in the currently compiled component. Useful - mainly for finding the size for allocating stack frames." (finite-sb-current-size (sb-or-lose name))) +;;; the TN that is used to hold the number stack frame-pointer in +;;; VOP's function, or NIL if no number stack frame was allocated (defun current-nfp-tn (vop) - #!+sb-doc - "Return the TN that is used to hold the number stack frame-pointer in VOP's - function. Returns NIL if no number stack frame was allocated." (unless (zerop (sb-allocated-size 'non-descriptor-stack)) (let ((block (ir2-block-block (vop-block vop)))) - (when (ir2-environment-number-stack-p - (environment-info - (block-environment block))) + (when (ir2-physenv-number-stack-p + (physenv-info + (block-physenv block))) (ir2-component-nfp (component-info (block-component block))))))) +;;; the TN that is used to hold the number stack frame-pointer in the +;;; function designated by 2ENV, or NIL if no number stack frame was +;;; allocated (defun callee-nfp-tn (2env) - #!+sb-doc - "Return the TN that is used to hold the number stack frame-pointer in the - function designated by 2env. Returns NIL if no number stack frame was - allocated." (unless (zerop (sb-allocated-size 'non-descriptor-stack)) - (when (ir2-environment-number-stack-p 2env) + (when (ir2-physenv-number-stack-p 2env) (ir2-component-nfp (component-info *component-being-compiled*))))) +;;; the TN used for passing the return PC in a local call to the function +;;; designated by 2ENV (defun callee-return-pc-tn (2env) - #!+sb-doc - "Return the TN used for passing the return PC in a local call to the function - designated by 2env." - (ir2-environment-return-pc-pass 2env)) + (ir2-physenv-return-pc-pass 2env)) ;;;; specials used during code generation @@ -66,24 +59,29 @@ (defvar *code-segment* nil) (defvar *elsewhere* nil) (defvar *elsewhere-label* nil) +#!+inline-constants +(progn + (defvar *constant-segment* nil) + (defvar *constant-table* nil) + (defvar *constant-vector* nil)) + ;;;; noise to emit an instruction trace (defvar *prev-segment*) (defvar *prev-vop*) -#!+sb-show (defun trace-instruction (segment vop inst args) (let ((*standard-output* *compiler-trace-output*)) (unless (eq *prev-segment* segment) - (format t "in the ~A segment:~%" (sb!assem:segment-name segment)) + (format t "in the ~A segment:~%" (sb!assem:segment-type segment)) (setf *prev-segment* segment)) (unless (eq *prev-vop* vop) (when vop - (format t "~%VOP ") - (if (vop-p vop) - (print-vop vop) - (format *compiler-trace-output* "~S~%" vop))) + (format t "~%VOP ") + (if (vop-p vop) + (print-vop vop) + (format *compiler-trace-output* "~S~%" vop))) (terpri) (setf *prev-vop* vop)) (case inst @@ -100,69 +98,111 @@ ;;; standard defaults for slots of SEGMENT objects (defun default-segment-run-scheduler () (and *assembly-optimize* - (policy (lambda-bind - (block-home-lambda - (block-next (component-head *component-being-compiled*)))) - (or (> speed cspeed) (> space cspeed))))) + (policy (lambda-bind + (block-home-lambda + (block-next (component-head *component-being-compiled*)))) + (or (> speed compilation-speed) (> space compilation-speed))))) (defun default-segment-inst-hook () - #!+sb-show - (and *compiler-trace-output* #'trace-instruction)) + (and *compiler-trace-output* + #'trace-instruction)) (defun init-assembler () (setf *code-segment* - (sb!assem:make-segment :name "regular" - :run-scheduler (default-segment-run-scheduler) - :inst-hook (default-segment-inst-hook))) + (sb!assem:make-segment :type :regular + :run-scheduler (default-segment-run-scheduler) + :inst-hook (default-segment-inst-hook))) #!+sb-dyncount (setf (sb!assem:segment-collect-dynamic-statistics *code-segment*) - *collect-dynamic-statistics*) + *collect-dynamic-statistics*) (setf *elsewhere* - (sb!assem:make-segment :name "elsewhere" - :run-scheduler (default-segment-run-scheduler) - :inst-hook (default-segment-inst-hook))) + (sb!assem:make-segment :type :elsewhere + :run-scheduler (default-segment-run-scheduler) + :inst-hook (default-segment-inst-hook) + :alignment 0)) + #!+inline-constants + (setf *constant-segment* + (sb!assem:make-segment :type :elsewhere + :run-scheduler nil + :inst-hook (default-segment-inst-hook) + :alignment 0) + *constant-table* (make-hash-table :test #'equal) + *constant-vector* (make-array 16 :adjustable t :fill-pointer 0)) (values)) (defun generate-code (component) - #!+sb-show (when *compiler-trace-output* (format *compiler-trace-output* - "~|~%assembly code for ~S~2%" - component)) + "~|~%assembly code for ~S~2%" + component)) (let ((prev-env nil) - (*trace-table-info* nil) - (*prev-segment* nil) - (*prev-vop* nil) - (*fixups* nil)) + (*trace-table-info* nil) + (*prev-segment* nil) + (*prev-vop* nil) + (*fixup-notes* nil)) (let ((label (sb!assem:gen-label))) (setf *elsewhere-label* label) (sb!assem:assemble (*elsewhere*) - (sb!assem:emit-label label))) + (sb!assem:emit-label label))) (do-ir2-blocks (block component) (let ((1block (ir2-block-block block))) - (when (and (eq (block-info 1block) block) - (block-start 1block)) - (sb!assem:assemble (*code-segment*) - (sb!assem:emit-label (block-label 1block))) - (let ((env (block-environment 1block))) - (unless (eq env prev-env) - (let ((lab (gen-label))) - (setf (ir2-environment-elsewhere-start (environment-info env)) - lab) - (emit-label-elsewhere lab)) - (setq prev-env env))))) + (when (and (eq (block-info 1block) block) + (block-start 1block)) + (sb!assem:assemble (*code-segment*) + ;; Align first emitted block of each loop: x86 and x86-64 both + ;; like 16 byte alignment, however, since x86 aligns code objects + ;; on 8 byte boundaries we cannot guarantee proper loop alignment + ;; there (yet.) Only x86-64 does something with ALIGNP, but + ;; it may be useful in the future. + (let ((alignp (let ((cloop (block-loop 1block))) + (when (and cloop + (loop-tail cloop) + (not (loop-info cloop))) + ;; Mark the loop as aligned by saving the IR1 block aligned. + (setf (loop-info cloop) 1block) + t)))) + (emit-block-header (block-label 1block) + (ir2-block-%trampoline-label block) + (ir2-block-dropped-thru-to block) + alignp))) + (let ((env (block-physenv 1block))) + (unless (eq env prev-env) + (let ((lab (gen-label))) + (setf (ir2-physenv-elsewhere-start (physenv-info env)) + lab) + (emit-label-elsewhere lab)) + (setq prev-env env))))) (do ((vop (ir2-block-start-vop block) (vop-next vop))) - ((null vop)) - (let ((gen (vop-info-generator-function (vop-info vop)))) - (if gen - (funcall gen vop) - (format t - "missing generator for ~S~%" - (template-name (vop-info vop))))))) + ((null vop)) + (let ((gen (vop-info-generator-function (vop-info vop)))) + (if gen + (funcall gen vop) + (format t + "missing generator for ~S~%" + (template-name (vop-info vop))))))) (sb!assem:append-segment *code-segment* *elsewhere*) (setf *elsewhere* nil) + #!+inline-constants + (progn + (unless (zerop (length *constant-vector*)) + (let ((constants (sb!vm:sort-inline-constants *constant-vector*))) + (assemble (*constant-segment*) + (sb!vm:emit-constant-segment-header + *constant-segment* + constants + (do-ir2-blocks (2block component nil) + (when (policy (block-last (ir2-block-block 2block)) + (> speed space)) + (return t)))) + (map nil (lambda (constant) + (sb!vm:emit-inline-constant (car constant) (cdr constant))) + constants))) + (sb!assem:append-segment *code-segment* *constant-segment*)) + (setf *constant-segment* nil + *constant-vector* nil + *constant-table* nil)) (values (sb!assem:finalize-segment *code-segment*) - (nreverse *trace-table-info*) - *fixups*))) + (nreverse *trace-table-info*) + *fixup-notes*))) (defun emit-label-elsewhere (label) (sb!assem:assemble (*elsewhere*) @@ -171,7 +211,16 @@ (defun label-elsewhere-p (label-or-posn) (<= (label-position *elsewhere-label*) (etypecase label-or-posn - (label - (label-position label-or-posn)) - (index - label-or-posn)))) + (label + (label-position label-or-posn)) + (index + label-or-posn)))) + +#!+inline-constants +(defun register-inline-constant (&rest constant-descriptor) + (declare (dynamic-extent constant-descriptor)) + (let ((constant (sb!vm:canonicalize-inline-constant constant-descriptor))) + (or (gethash constant *constant-table*) + (multiple-value-bind (label value) (sb!vm:inline-constant-value constant) + (vector-push-extend (cons constant label) *constant-vector*) + (setf (gethash constant *constant-table*) value)))))