Index: /branches/lscan/source/compiler/X86/x862.lisp =================================================================== --- /branches/lscan/source/compiler/X86/x862.lisp (revision 16276) +++ /branches/lscan/source/compiler/X86/x862.lisp (revision 16277) @@ -764,165 +764,162 @@ 0))) (backend-get-next-label) ; start @ label 1, 0 is confused with NIL in compound cd - (with-dll-node-freelist (vinsns *vinsn-freelist*) - (unwind-protect - (progn - (setq bits (x862-toplevel-form vinsns (make-wired-lreg *x862-result-reg*) - $backend-return (afunc-acode afunc))) - (do* ((constants *x862-constant-alist* (cdr constants))) - ((null constants)) - (let* ((imm (caar constants))) - (when (x862-symbol-locative-p imm) - (setf (caar constants) (car imm))))) - (optimize-vinsns vinsns) - (when (logbitp x862-debug-vinsns-bit *x862-debug-mask*) - (format t "~% vinsns for ~s (after generation)" (afunc-name afunc)) - (do-dll-nodes (v vinsns) (format t "~&~s" v)) - (format t "~%~%")) + (let* ((vinsns (make-vinsn-list))) + (setq bits (x862-toplevel-form vinsns (make-wired-lreg *x862-result-reg*) + $backend-return (afunc-acode afunc))) + (do* ((constants *x862-constant-alist* (cdr constants))) + ((null constants)) + (let* ((imm (caar constants))) + (when (x862-symbol-locative-p imm) + (setf (caar constants) (car imm))))) + (optimize-vinsns vinsns) + (when (logbitp x862-debug-vinsns-bit *x862-debug-mask*) + (format t "~% vinsns for ~s (after generation)" (afunc-name afunc)) + (do-dll-nodes (v vinsns) (format t "~&~s" v)) + (format t "~%~%")) - (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)) - (start-tag (gensym)) - (srt-tag (gensym)) - debug-info) - (make-x86-lap-label end-code-tag) - (target-arch-case - (:x8664 - (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 - (:x8632 - (make-x86-lap-label start-tag) - (make-x86-lap-label srt-tag) - (x86-lap-directive frag-list :short `(ash (+ (- (:^ ,end-code-tag) 4) - *x86-lap-entry-offset*) -2)) - (emit-x86-lap-label frag-list start-tag))) - (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))))) - (target-arch-case - (:x8632 - (x86-lap-directive frag-list :align 2) - ;; start of self reference table - (x86-lap-directive frag-list :long 0) - (emit-x86-lap-label frag-list srt-tag) - ;; make space for self-reference offsets - (do-dll-nodes (frag frag-list) - (dolist (reloc (frag-relocs frag)) - (when (eq (reloc-type reloc) :self) - (x86-lap-directive frag-list :long 0)))) - (x86-lap-directive frag-list :long x8632::function-boundary-marker)) - (:x8664 - (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) + (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)) + (start-tag (gensym)) + (srt-tag (gensym)) + debug-info) + (make-x86-lap-label end-code-tag) + (target-arch-case + (:x8664 + (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 + (:x8632 + (make-x86-lap-label start-tag) + (make-x86-lap-label srt-tag) + (x86-lap-directive frag-list :short `(ash (+ (- (:^ ,end-code-tag) 4) + *x86-lap-entry-offset*) -2)) + (emit-x86-lap-label frag-list start-tag))) + (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))))) + (target-arch-case + (:x8632 + (x86-lap-directive frag-list :align 2) + ;; start of self reference table + (x86-lap-directive frag-list :long 0) + (emit-x86-lap-label frag-list srt-tag) + ;; make space for self-reference offsets + (do-dll-nodes (frag frag-list) + (dolist (reloc (frag-relocs frag)) + (when (eq (reloc-type reloc) :self) + (x86-lap-directive frag-list :long 0)))) + (x86-lap-directive frag-list :long x8632::function-boundary-marker)) + (:x8664 + (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) - (target-arch-case - (:x8632 - (x86-lap-directive frag-list :long 0)) - (:x8664 - (x86-lap-directive frag-list :quad 0))))) - - (if (logbitp $fbitnonnullenv (the fixnum (afunc-bits afunc))) - (setq bits (+ bits (ash 1 $lfbits-nonnullenv-bit)))) - (setq debug-info (afunc-lfun-info afunc)) - (when (logbitp $fbitccoverage (the fixnum (afunc-bits afunc))) - (setq bits (+ bits (ash 1 $lfbits-code-coverage-bit)))) - (when lambda-form - (setq debug-info - (list* 'function-lambda-expression lambda-form debug-info))) - (when *x862-recorded-symbols* - (setq debug-info - (list* 'function-symbol-map *x862-recorded-symbols* debug-info))) - (when (and (getf debug-info '%function-source-note) *x862-emitted-source-notes*) - (setq debug-info ;; Compressed below - (list* 'pc-source-map *x862-emitted-source-notes* debug-info))) - (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))) - (unless (afunc-parent afunc) - (x862-fixup-fwd-refs afunc)) - (setf (afunc-all-vars afunc) nil) - (setf (afunc-argsword afunc) bits) - (let* ((regsave-label (if (typep *x862-compiler-register-save-note* 'vinsn-note) - (vinsn-note-address *x862-compiler-register-save-note*))) - (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*)))) - (target-arch-case - (:x8632 - (when debug-info - (x86-lap-directive frag-list :long 0)) - (when fname - (x86-lap-directive frag-list :long 0)) - (x86-lap-directive frag-list :long 0)) - (:x8664 - (when debug-info - (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) - (target-arch-case - (:x8632 - (let* ((label (find-x86-lap-label srt-tag)) - (srt-frag (x86-lap-label-frag label)) - (srt-index (x86-lap-label-offset label))) - ;; fill in self-reference offsets - (do-dll-nodes (frag frag-list) - (dolist (reloc (frag-relocs frag)) - (when (eq (reloc-type reloc) :self) - (setf (frag-ref-32 srt-frag srt-index) - (+ (frag-address frag) (reloc-pos reloc))) - (incf srt-index 4))))) - ;;(show-frag-bytes frag-list) - )) - - (x862-lap-process-regsave-info frag-list regsave-label regsave-mask regsave-addr) - - (when (getf debug-info 'pc-source-map) - (setf (getf debug-info 'pc-source-map) (x862-generate-pc-source-map debug-info))) - (when (getf debug-info 'function-symbol-map) - (setf (getf debug-info 'function-symbol-map) (x862-digest-symbols))) - - (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 debug-info))))))) - (backend-remove-labels)))) + (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) + (target-arch-case + (:x8632 + (x86-lap-directive frag-list :long 0)) + (:x8664 + (x86-lap-directive frag-list :quad 0))))) + + (if (logbitp $fbitnonnullenv (the fixnum (afunc-bits afunc))) + (setq bits (+ bits (ash 1 $lfbits-nonnullenv-bit)))) + (setq debug-info (afunc-lfun-info afunc)) + (when (logbitp $fbitccoverage (the fixnum (afunc-bits afunc))) + (setq bits (+ bits (ash 1 $lfbits-code-coverage-bit)))) + (when lambda-form + (setq debug-info + (list* 'function-lambda-expression lambda-form debug-info))) + (when *x862-recorded-symbols* + (setq debug-info + (list* 'function-symbol-map *x862-recorded-symbols* debug-info))) + (when (and (getf debug-info '%function-source-note) *x862-emitted-source-notes*) + (setq debug-info;; Compressed below + (list* 'pc-source-map *x862-emitted-source-notes* debug-info))) + (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))) + (unless (afunc-parent afunc) + (x862-fixup-fwd-refs afunc)) + (setf (afunc-all-vars afunc) nil) + (setf (afunc-argsword afunc) bits) + (let* ((regsave-label (if (typep *x862-compiler-register-save-note* 'vinsn-note) + (vinsn-note-address *x862-compiler-register-save-note*))) + (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*)))) + (target-arch-case + (:x8632 + (when debug-info + (x86-lap-directive frag-list :long 0)) + (when fname + (x86-lap-directive frag-list :long 0)) + (x86-lap-directive frag-list :long 0)) + (:x8664 + (when debug-info + (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) + (target-arch-case + (:x8632 + (let* ((label (find-x86-lap-label srt-tag)) + (srt-frag (x86-lap-label-frag label)) + (srt-index (x86-lap-label-offset label))) + ;; fill in self-reference offsets + (do-dll-nodes (frag frag-list) + (dolist (reloc (frag-relocs frag)) + (when (eq (reloc-type reloc) :self) + (setf (frag-ref-32 srt-frag srt-index) + (+ (frag-address frag) (reloc-pos reloc))) + (incf srt-index 4))))) + ;;(show-frag-bytes frag-list) + )) + + (x862-lap-process-regsave-info frag-list regsave-label regsave-mask regsave-addr) + + (when (getf debug-info 'pc-source-map) + (setf (getf debug-info 'pc-source-map) (x862-generate-pc-source-map debug-info))) + (when (getf debug-info 'function-symbol-map) + (setf (getf debug-info 'function-symbol-map) (x862-digest-symbols))) + + (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 debug-info)))))))) afunc)) @@ -6813,7 +6810,5 @@ (emit-x86-lap-label frag-list note)) (setf (vinsn-note-address note) lab))))) - (setf (vinsn-variable-parts vinsn) nil) - (when vp - (free-varparts-vector vp))))) + (setf (vinsn-variable-parts vinsn) nil)))) Index: /branches/lscan/source/compiler/vinsn.lisp =================================================================== --- /branches/lscan/source/compiler/vinsn.lisp (revision 16276) +++ /branches/lscan/source/compiler/vinsn.lisp (revision 16277) @@ -83,30 +83,7 @@ ) -(def-standard-initial-binding *vinsn-freelist* (make-dll-node-freelist)) (defun make-vinsn (template) - (let* ((vinsn (alloc-dll-node *vinsn-freelist*))) - (loop - ;; Sometimes, the compiler seems to return its node list - ;; to the freelist without first removing the vinsn-labels in it. - #-bootstrapped (when (and (typep vinsn 'vinsn) - (not (> (uvsize vinsn) 8))) - (setf (pool.data *vinsn-freelist*) nil) - (setq vinsn nil)) - (if (or (null vinsn) (typep vinsn 'vinsn)) (return)) - (setq vinsn (alloc-dll-node *vinsn-freelist*))) - (if vinsn - (progn - (setf (vinsn-template vinsn) template - (vinsn-variable-parts vinsn) nil - (vinsn-annotation vinsn) nil - (vinsn-gprs-set vinsn) 0 - (vinsn-fprs-set vinsn) 0 - (vinsn-gprs-read vinsn) 0 - (vinsn-fprs-read vinsn) 0 - (vinsn-notes vinsn) nil) - - vinsn) - (%make-vinsn template)))) + (%make-vinsn template)) (eval-when (:load-toplevel :execute) @@ -120,16 +97,16 @@ ) ) - -(def-standard-initial-binding *vinsn-label-freelist* (make-dll-node-freelist)) +(defstruct (vinsn-list (:include dll-header) + (:constructor %make-vinsn-list)) + lregs + flow-graph + intervals + ) + +(defun make-vinsn-list () + (init-dll-header (%make-vinsn-list))) (defun make-vinsn-label (id) - (let* ((lab (alloc-dll-node *vinsn-label-freelist*))) - (if lab - (progn - (setf (vinsn-label-id lab) id - (vinsn-label-refs lab) nil - (vinsn-label-info lab) nil) - lab) - (%make-vinsn-label id)))) + (%make-vinsn-label id)) ; "Real" labels have fixnum IDs. @@ -297,23 +274,10 @@ ))) -(defparameter *nvp-max* 10 "size of *vinsn-varparts* freelist elements") -(def-standard-initial-binding *vinsn-varparts* (%cons-pool)) - -(defun alloc-varparts-vector () - (without-interrupts - (let* ((v (pool.data *vinsn-varparts*))) - (if v - (progn - (setf (pool.data *vinsn-varparts*) - (svref v 0)) - (%init-misc 0 v) - v) - (make-array (the fixnum *nvp-max*) :initial-element 0))))) - + +;;; This should only be called by old code during bootstrapping. (defun free-varparts-vector (v) - (without-interrupts - (setf (svref v 0) (pool.data *vinsn-varparts*) - (pool.data *vinsn-varparts*) v) - nil)) + (declare (ignore v))) + + (defun distribute-vinsn-notes (notes pred succ) @@ -341,5 +305,4 @@ (setf (lreg-defs v) (delete vinsn (lreg-defs v))) (setf (lreg-refs v) (delete vinsn (lreg-refs v)))))) - (free-varparts-vector vp) (setf (vinsn-variable-parts vinsn) nil) (if (distribute-vinsn-notes (vinsn-notes vinsn) (vinsn-pred vinsn) (vinsn-succ vinsn)) @@ -420,5 +383,5 @@ (ntemps (length temp-specs)) (nvp (vinsn-template-nvp template)) - (vp (alloc-varparts-vector)) + (vp (make-array nvp)) (*available-backend-node-temps* *available-backend-node-temps*) (*available-backend-fp-temps* *available-backend-fp-temps*)