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