src/code/immobile-code.lisp

   1 ;;;; Reorganization of immobile code space.
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB-KERNEL")
  13
  14 (defun immobile-space-p (obj)
  15   (<= sb-vm:immobile-space-start (get-lisp-obj-address obj) sb-vm:immobile-space-end))
  16
  17 (defun order-by-in-degree ()
  18   (let ((compiler-stuff (make-hash-table :test 'eq))
  19         (other-stuff (make-hash-table :test 'eq)))
  20     (flet ((pick-table (fun-name)
  21              (if (symbolp fun-name)
  22                  (let ((package (symbol-package fun-name)))
  23                    (if (member package
  24                                (load-time-value
  25                                 (cons sb-assem::*backend-instruction-set-package*
  26                                       (mapcar 'find-package
  27                                               '("SB-C" "SB-VM" "SB-FASL"
  28                                                 "SB-ASSEM" "SB-DISASSEM"
  29                                                 "SB-REGALLOC")))
  30                                 t))
  31                        compiler-stuff
  32                        other-stuff))
  33                  other-stuff))
  34            (hashtable-keys-sorted (table)
  35              (mapcar #'car
  36               (sort (%hash-table-alist table)
  37                     (lambda (a b)
  38                       (cond ((> (cdr a) (cdr b)) t) ; higher in-degree
  39                             ((< (cdr a) (cdr b)) nil) ; lower in-degree
  40                             ;; break ties by name, and failing that,
  41                             ;; by address (which = random)
  42                             (t
  43                              (let ((name1
  44                                     (%simple-fun-name (%code-entry-points (car a))))
  45                                    (name2
  46                                     (%simple-fun-name (%code-entry-points (car b)))))
  47                                (if (and (symbolp name1) (symbolp name2))
  48                                    (let ((p1 (package-name (symbol-package name1)))
  49                                          (p2 (package-name (symbol-package name2))))
  50                                      (cond ((string< p1 p2) t)
  51                                            ((string> p1 p2) nil)
  52                                            ((string< name1 name2))))
  53                                    (< (get-lisp-obj-address (car a))
  54                                       (get-lisp-obj-address (car b))))))))))))
  55       (sb-vm::map-allocated-objects
  56        (lambda (obj type size)
  57          size
  58          (when (= type sb-vm:code-header-widetag)
  59            (loop for i from sb-vm:code-constants-offset
  60                  below (code-header-words obj)
  61                  do (let ((ref (code-header-ref obj i)))
  62                       (when (and (fdefn-p ref)
  63                                  (simple-fun-p (fdefn-fun ref)))
  64                         (let ((code (fun-code-header (fdefn-fun ref))))
  65                           (when (immobile-space-p code)
  66                             (let ((ht (pick-table
  67                                        (%simple-fun-name
  68                                         (%code-entry-points code)))))
  69                             (incf (gethash code ht 0))))))))))
  70        :immobile)
  71       (append (hashtable-keys-sorted other-stuff)
  72               (hashtable-keys-sorted compiler-stuff)))))
  73
  74 ;;; Passing your own toplevel functions as the root set
  75 ;;; will encourage the defrag procedure to place them early
  76 ;;; in the space, which should be better than leaving the
  77 ;;; organization to random chance.
  78 ;;; Note that these aren't roots in the GC sense, just a locality sense.
  79 (defun choose-code-component-ordering
  80     (&optional (roots '(read print eval compile)))
  81   (let ((ordering (make-array 10000 :adjustable t :fill-pointer 0))
  82         (hashset (make-hash-table :test 'eq)))
  83     (labels ((visit (thing)
  84                (typecase thing
  85                  (code-component (visit-code thing))
  86                  (simple-fun (visit-code (fun-code-header thing)))
  87                  (closure (visit (%closure-fun thing)))
  88                  (symbol (when (and (fboundp thing)
  89                                     (not (special-operator-p thing))
  90                                     (not (macro-function thing)))
  91                            (visit (symbol-function thing))))))
  92              (visit-code (code-component)
  93                (when (or (not (immobile-space-p code-component))
  94                          (gethash code-component hashset))
  95                  (return-from visit-code))
  96                (setf (gethash code-component hashset) t)
  97                (vector-push-extend code-component ordering)
  98                (loop for i from sb-vm:code-constants-offset
  99                      below (code-header-words code-component)
 100                      do (let ((obj (code-header-ref code-component i)))
 101                           (typecase obj
 102                             (fdefn  (awhen (fdefn-fun obj) (visit it)))
 103                             (symbol (visit obj))
 104                             (vector (map nil #'visit obj)))))))
 105       (mapc #'visit
 106             (mapcar (lambda (x)
 107                       (fun-code-header (the simple-fun (coerce x 'function))))
 108                     roots)))
 109     ; (format t "~&Roots reached ~D code objects~%" (length ordering))
 110
 111     (dolist (code (order-by-in-degree))
 112       (unless (gethash code hashset)
 113         (setf (gethash code hashset) t)
 114         (vector-push-extend code ordering)))
 115     ; (format t "~&Added ~D code objects by static frequency~%" (length ordering))
 116
 117     (sb-vm::map-allocated-objects
 118      (lambda (obj type size)
 119        (declare (ignore size))
 120        (when (and (= type sb-vm:code-header-widetag)
 121                   (not (gethash obj hashset)))
 122          (setf (gethash obj hashset) t)
 123          (vector-push-extend obj ordering)))
 124      :immobile)
 125     ; (format t "~&Total ~D code objects~%" (length ordering))
 126
 127     (let* ((n (length ordering))
 128            (array (make-alien int (1+ (* n 2)))))
 129       (setf (deref array 0) (* n 2))
 130       (loop for i below n
 131             do (setf (deref array (* i 2))
 132                      (get-lisp-obj-address (aref ordering i))))
 133       (setf (extern-alien "code_component_order" unsigned)
 134             (sap-int (alien-value-sap array)))))
 135
 136   (multiple-value-bind (index relocs) (sb-vm::collect-immobile-code-relocs)
 137     (let* ((n (length index))
 138            (array (make-alien int n)))
 139       (dotimes (i n) (setf (deref array i) (aref index i)))
 140       (setf (extern-alien "immobile_space_reloc_index" unsigned)
 141             (sap-int (alien-value-sap array))))
 142     (let* ((n (length relocs))
 143            (array (make-alien int n)))
 144       (dotimes (i n) (setf (deref array i) (aref relocs i)))
 145       (setf (extern-alien "immobile_space_relocs" unsigned)
 146             (sap-int (alien-value-sap array))))))