Index: /branches/source-tracking-0801/ccl/compiler/X86/x862.lisp =================================================================== --- /branches/source-tracking-0801/ccl/compiler/X86/x862.lisp (revision 8391) +++ /branches/source-tracking-0801/ccl/compiler/X86/x862.lisp (revision 8392) @@ -432,5 +432,4 @@ 0 (min (- (ash ea (- x8664::word-shift)) count) #xff))) - (defun x862-compile (afunc &optional lambda-form *x862-record-symbols*) (progn @@ -534,99 +533,99 @@ (with-dll-node-freelist ((frag-list make-frag-list) *frag-freelist*) (with-dll-node-freelist ((uuo-frag-list make-frag-list) *frag-freelist*) - (let* ((*x86-lap-labels* nil) - (instruction (x86::make-x86-instruction)) - (end-code-tag (gensym)) - debug-info) - (make-x86-lap-label end-code-tag) - (x86-lap-directive frag-list :long `(ash (+ (- (:^ ,end-code-tag ) 8) - *x86-lap-entry-offset*) -3)) - (x86-lap-directive frag-list :byte 0) ;regsave PC - (x86-lap-directive frag-list :byte 0) ;regsave ea - (x86-lap-directive frag-list :byte 0) ;regsave mask - - (x862-expand-vinsns vinsns frag-list instruction uuo-frag-list) - (when (or *x862-double-float-constant-alist* - *x862-single-float-constant-alist*) + (let* ((*x86-lap-labels* nil) + (instruction (x86::make-x86-instruction)) + (end-code-tag (gensym)) + debug-info) + (make-x86-lap-label end-code-tag) + (x86-lap-directive frag-list :long `(ash (+ (- (:^ ,end-code-tag ) 8) + *x86-lap-entry-offset*) + -3)) + (x86-lap-directive frag-list :byte 0) ;regsave PC + (x86-lap-directive frag-list :byte 0) ;regsave ea + (x86-lap-directive frag-list :byte 0) ;regsave mask + + (x862-expand-vinsns vinsns frag-list instruction uuo-frag-list) + (when (or *x862-double-float-constant-alist* + *x862-single-float-constant-alist*) + (x86-lap-directive frag-list :align 3) + (dolist (double-pair *x862-double-float-constant-alist*) + (destructuring-bind (dfloat . lab) double-pair + (setf (vinsn-label-info lab) (emit-x86-lap-label frag-list lab)) + (multiple-value-bind (high low) + (x862-double-float-bits dfloat) + (x86-lap-directive frag-list :long low) + (x86-lap-directive frag-list :long high)))) + (dolist (single-pair *x862-single-float-constant-alist*) + (destructuring-bind (sfloat . lab) single-pair + (setf (vinsn-label-info lab) (emit-x86-lap-label frag-list lab)) + (let* ((val (single-float-bits sfloat))) + (x86-lap-directive frag-list :long val))))) (x86-lap-directive frag-list :align 3) - (dolist (double-pair *x862-double-float-constant-alist*) - (destructuring-bind (dfloat . lab) double-pair - (setf (vinsn-label-info lab) (emit-x86-lap-label frag-list lab)) - (multiple-value-bind (high low) - (x862-double-float-bits dfloat) - (x86-lap-directive frag-list :long low) - (x86-lap-directive frag-list :long high)))) - (dolist (single-pair *x862-single-float-constant-alist*) - (destructuring-bind (sfloat . lab) single-pair - (setf (vinsn-label-info lab) (emit-x86-lap-label frag-list lab)) - (let* ((val (single-float-bits sfloat))) - (x86-lap-directive frag-list :long val))))) - (x86-lap-directive frag-list :align 3) - (x86-lap-directive frag-list :quad x8664::function-boundary-marker) - (emit-x86-lap-label frag-list end-code-tag) - (dolist (c (reverse *x862-constant-alist*)) - (let* ((vinsn-label (cdr c))) - (or (vinsn-label-info vinsn-label) - (setf (vinsn-label-info vinsn-label) - (find-or-create-x86-lap-label - vinsn-label))) - (emit-x86-lap-label frag-list vinsn-label) - (x86-lap-directive frag-list :quad 0))) + (x86-lap-directive frag-list :quad x8664::function-boundary-marker) + (emit-x86-lap-label frag-list end-code-tag) + (dolist (c (reverse *x862-constant-alist*)) + (let* ((vinsn-label (cdr c))) + (or (vinsn-label-info vinsn-label) + (setf (vinsn-label-info vinsn-label) + (find-or-create-x86-lap-label + vinsn-label))) + (emit-x86-lap-label frag-list vinsn-label) + (x86-lap-directive frag-list :quad 1))) - (if (logbitp $fbitnonnullenv (the fixnum (afunc-bits afunc))) + (if (logbitp $fbitnonnullenv (the fixnum (afunc-bits afunc))) (setq bits (+ bits (ash 1 $lfbits-nonnullenv-bit)))) - - - - (unless (afunc-parent afunc) - (x862-fixup-fwd-refs afunc)) - (setf (afunc-all-vars afunc) nil) - - (let* ((regsave-label (if (typep *x862-compiler-register-save-label* 'vinsn-note) + (unless (afunc-parent afunc) + (x862-fixup-fwd-refs afunc)) + (setf (afunc-all-vars afunc) nil) + (let* ((regsave-label (if (typep *x862-compiler-register-save-label* 'vinsn-note) (vinsn-label-info (vinsn-note-label *x862-compiler-register-save-label*)))) - (regsave-mask (if regsave-label (x862-register-mask-byte - *x862-register-restore-count*))) - (regsave-addr (if regsave-label (x862-encode-register-save-ea - *x862-register-restore-ea* - *x862-register-restore-count*)))) - - (when (or lambda-form - (and *compiler-record-source* *definition-source-note*) - *x862-recorded-symbols* - (and *compiler-record-source* *x862-emitted-source-notes*)) - (x86-lap-directive frag-list :quad 0)) - (when fname - (x86-lap-directive frag-list :quad 0)) - (x86-lap-directive frag-list :quad 0) - (relax-frag-list frag-list) - (apply-relocs frag-list) - (fill-for-alignment frag-list) - (x862-lap-process-regsave-info frag-list regsave-label regsave-mask regsave-addr) - (setf debug-info - (nconc (when lambda-form - (list 'function-debugging-info lambda-form)) - (when (and *compiler-record-source* *definition-source-note*) - (list 'function-source-note - (source-note-to-list *definition-source-note* :form nil :children nil))) - (when *x862-recorded-symbols* - (list 'function-symbol-map (x862-digest-symbols))) - (when (and *compiler-record-source* - *x862-emitted-source-notes* - *definition-source-note*) - (list 'pc-source-map - (x862-generate-pc-source-map *definition-source-note* - *x862-emitted-source-notes*))))) - (when debug-info - (setq bits (logior (ash 1 $lfbits-info-bit) bits))) - (unless fname - (setq bits (logior (ash 1 $lfbits-noname-bit) bits))) - (setf (afunc-argsword afunc) bits) - (setf (afunc-lfun afunc) - #+x86-target - (if (eq *host-backend* *target-backend*) - (create-x86-function fname frag-list *x862-constant-alist* bits debug-info) + (regsave-mask (if regsave-label (x862-register-mask-byte + *x862-register-restore-count*))) + (regsave-addr (if regsave-label (x862-encode-register-save-ea + *x862-register-restore-ea* + *x862-register-restore-count*)))) + + + (when (or (afunc-lfun-info afunc) + lambda-form + (and *compiler-record-source* *definition-source-note*) + *x862-recorded-symbols* + (and *compiler-record-source* *x862-emitted-source-notes* *definition-source-note*)) + (x86-lap-directive frag-list :quad 0)) + (when fname + (x86-lap-directive frag-list :quad 0)) + (x86-lap-directive frag-list :quad 0) + (relax-frag-list frag-list) + (apply-relocs frag-list) + (fill-for-alignment frag-list) + (x862-lap-process-regsave-info frag-list regsave-label regsave-mask regsave-addr) + (setf debug-info + (nconc (copy-list (afunc-lfun-info afunc)) + (when lambda-form + (list 'function-debugging-info lambda-form)) + (when (and *compiler-record-source* *definition-source-note*) + (list 'function-source-note + (source-note-to-list *definition-source-note* :form nil :children nil))) + (when *x862-recorded-symbols* + (list 'function-symbol-map *x862-recorded-symbols*)) + (when (and *compiler-record-source* + *x862-emitted-source-notes* + *definition-source-note*) + (list 'pc-source-map + (x862-generate-pc-source-map *definition-source-note* + *x862-emitted-source-notes*))))) + (when debug-info + (setq bits (logior (ash 1 $lfbits-info-bit) bits))) + (unless (or fname lambda-form *x862-recorded-symbols*) + (setq bits (logior (ash 1 $lfbits-noname-bit) bits))) + (setf (afunc-argsword afunc) bits) + (setf (afunc-lfun afunc) + #+x86-target + (if (eq *host-backend* *target-backend*) + (create-x86-function fname frag-list *x862-constant-alist* bits debug-info) (cross-create-x86-function fname frag-list *x862-constant-alist* bits debug-info)) - #-x86-target - (cross-create-x86-function fname frag-list *x862-constant-alist* bits ()))) - )))) + #-x86-target + (cross-create-x86-function fname frag-list *x862-constant-alist* bits debug-info)) + (x862-digest-symbols)))))) (backend-remove-labels)))) afunc))