From e2c1c7d11cb1f3d946c244bfa17b8d774f4168d2 Mon Sep 17 00:00:00 2001 From: Douglas Katzman Date: Wed, 24 Feb 2016 10:14:11 -0500 Subject: [PATCH] Compile disassembler inst-printers in warm load. lp#1543840 --- make-target-2-load.lisp | 7 +--- src/compiler/disassem.lisp | 25 +++++--------- src/compiler/main.lisp | 5 --- src/compiler/target-disassem.lisp | 71 ++++++++++++++++++++++++++++----------- 4 files changed, 61 insertions(+), 47 deletions(-) diff --git a/make-target-2-load.lisp b/make-target-2-load.lisp index b90af221f..3d47a54e2 100644 --- a/make-target-2-load.lisp +++ b/make-target-2-load.lisp @@ -6,12 +6,7 @@ (*print-circle* t)) (load "src/cold/warm.lisp")) -;;; Test that BUILD-INST-SPACE will work - there are assertions -;;; in there about correctness of all instructions' operands. -(progn - (sb-disassem::get-inst-space :force t) - ;; Saving the memoized result is a waste of memory. - (setq sb-disassem::*disassem-inst-space* nil)) +(sb-disassem::!compile-inst-printers) ;;; Unintern no-longer-needed stuff before the possible PURIFY in ;;; SAVE-LISP-AND-DIE. diff --git a/src/compiler/disassem.lisp b/src/compiler/disassem.lisp index 0beb12766..621963408 100644 --- a/src/compiler/disassem.lisp +++ b/src/compiler/disassem.lisp @@ -191,7 +191,7 @@ (defstruct (instruction (:conc-name inst-) (:constructor make-instruction (name format-name print-name - length mask id %printer labeller + length mask id printer labeller prefilters control)) (:copier nil)) (name nil :type (or symbol string) :read-only t) @@ -205,9 +205,9 @@ (print-name nil :type symbol :read-only t) ;; disassembly "functions" - (prefilters nil :type list) - (labeller nil :type (or list vector)) - (%printer nil) + (prefilters nil :type list :read-only t) + (labeller nil :type (or list vector) :read-only t) + (printer nil :type (or null function) :read-only t) (control nil :type (or null function) :read-only t) ;; instructions that are the same as this instruction but with more @@ -669,16 +669,7 @@ (guts `(let* ,bindings ,@forms)) (sub-table (assq :printer cache))) (or (cdr (assoc guts (cdr sub-table) :test #'equal-mod-gensyms)) - (let ((cell (list guts))) - (push (cons guts cell) (cdr sub-table)) - cell)))) - -(defun inst-printer (inst &aux (printer (inst-%printer inst)) - (function (car printer))) - (unless (consp function) ; if not a cons, it is NIL or a function - (return-from inst-printer function)) - (let - ((template + (let ((template '(lambda (chunk inst stream dstate &aux (chunk (truly-the dchunk chunk)) (inst (truly-the instruction inst)) @@ -725,9 +716,9 @@ local-filtered-value local-extract lookup-label adjust-label)) :body))))) - (setf (car printer) - (compile nil (subst function :body template))))) - + (cdar (push (cons guts (compile nil (subst guts :body template))) + (cdr sub-table))))))) + (defun preprocess-test (subj form args) (multiple-value-bind (subj test) (if (and (consp form) (symbolp (car form)) (not (keywordp (car form)))) diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index c2e328104..77ecac9a6 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -1894,11 +1894,6 @@ SPEED and COMPILATION-SPEED optimization values, and the #-sb-xc-host t)) ; can't track, no SBCL streams (*compiler-trace-output* nil)) ; might be modified below - (when trace-file - ;; Avoid calling COMPILE from disassembler within a dynamic binding - ;; of *COMPILER-TRACE-OUTPUT* to a non-nil value. - (sb!disassem::precompile-inst-printers)) - (unwind-protect (progn (when output-file diff --git a/src/compiler/target-disassem.lisp b/src/compiler/target-disassem.lisp index dab893759..b0610fa1c 100644 --- a/src/compiler/target-disassem.lisp +++ b/src/compiler/target-disassem.lisp @@ -204,17 +204,6 @@ (print-inst-space (ischoice-subspace choice) (+ 4 indent))) (ispace-choices inst-space))))) - -(defun precompile-inst-printers () - (named-let recurse ((obj (get-inst-space))) - (etypecase obj - (inst-space - (map nil - (lambda (x) (recurse (ischoice-subspace x))) - (ispace-choices obj))) - (instruction - (inst-printer obj) ; for side-effect - (mapc #'recurse (inst-specializers obj)))))) ;;;; (The actual disassembly part follows.) @@ -767,21 +756,24 @@ (collect-prefiltering-args args cache) control)))))) +(defun !compile-inst-printers () + (let ((package sb!assem::*backend-instruction-set-package*) + (cache (list (list :printer) (list :prefilter) (list :labeller)))) + (do-symbols (symbol package) + (awhen (get symbol 'instruction-flavors) + (setf (get symbol 'instruction-flavors) + (collect-inst-variants + (string-upcase symbol) package it cache)))))) + ;;; Get the instruction-space, creating it if necessary. (defun get-inst-space (&key (package sb!assem::*backend-instruction-set-package*) force) (let ((ispace *disassem-inst-space*)) (when (or force (null ispace)) - (let ((insts nil) - (cache (list (list :printer) (list :prefilter) (list :labeller)))) + (let ((insts nil)) (do-symbols (symbol package) - (setq insts (nconc (collect-inst-variants - (string-upcase symbol) package - (get symbol 'instruction-flavors) cache) + (setq insts (nconc (copy-list (get symbol 'instruction-flavors)) insts))) - (when force - (format t "~&~:{~@(~A~)s: ~D~:^, ~}~%" - (mapcar (lambda (x) (list (car x) (length (cdr x)))) cache))) (setf ispace (build-inst-space insts))) (setf *disassem-inst-space* ispace)) ispace)) @@ -2129,3 +2121,44 @@ (table (assq :prefilter cache))) (or (find repr (cdr table) :test 'equalp) (car (push repr (cdr table))))))) + +(defun unintern-init-only-stuff () + ;; Remove compile-time-only metadata. This preserves compatibility with the + ;; older disassembler macros which wrapped GEN-ARG-TYPE-DEF-FORM and such + ;; in (EVAL-WHEN (:COMPILE-TOPLEVEL :EXECUTE)), which in turn required that + ;; all prefilters, labellers, and printers be defined at cross-compile-time. + ;; A consequence of :LOAD-TOPLEVEL not being there was that was not possible + ;; to add instruction definitions to an image without also recompiling + ;; the backend's "insts" file. It also was not possible to incrementally + ;; recompile and/or use slam.sh because of a bunch of mostly harmless bugs + ;; in the function cache (a/k/a identical-code-folding) logic that was only + ;; guaranteed to do the right thing from a clean compile. Additionally, + ;; you had to use (GET-INST-SPACE :FORCE T) to pick up new definitions. + ;; Given those considerations which made extending a running disassembler + ;; nontrivial, the code-generating code is not so useful after the + ;; initial instruction space is built, so it can all be removed. + ;; But if you need all these macros to exist for some reason, + ;; then define one of the two following features to keep them: + #!+(or sb-fluid sb-retain-assembler-macros) + (return-from unintern-init-only-stuff) + + (do-symbols (symbol sb!assem::*backend-instruction-set-package*) + (remf (symbol-plist symbol) 'arg-type) + (remf (symbol-plist symbol) 'inst-format)) + + ;; Get rid of functions that only make sense with metadata available. + (dolist (s '(%def-arg-type %def-inst-format %gen-arg-forms + all-arg-refs-relevant-p arg-or-lose arg-position arg-value-form + collect-labelish-operands collect-prefiltering-args + compare-fields-form compile-inst-printer compile-print + compile-printer-body compile-printer-list compile-test + correct-dchunk-bytespec-for-endianness + define-arg-type define-instruction-format equal-mod-gensyms + find-first-field-name find-printer-fun format-or-lose + gen-arg-forms make-arg-temp-bindings make-funstate massage-arg + maybe-listify modify-arg pd-error pick-printer-choice + preprocess-chooses preprocess-conditionals preprocess-printer + preprocess-test sharing-cons sharing-mapcar + string-or-qsym-p strip-quote)) + (fmakunbound s) + (unintern s 'sb-disassem))) -- 2.11.4.GIT