changeset 691: |
295ea43ceb2d |
parent: |
af486e0a40c9
|
author: |
Richard Westhaver <ellis@rwest.io> |
date: |
Wed, 02 Oct 2024 23:39:07 -0400 |
permissions: |
-rw-r--r-- |
description: |
tasks |
1 ;;; std/sys.lisp --- Lisp System Utilities 9 ;; (reexport-from :sb-introspect 10 ;; :include '(:function-lambda-list :lambda-list-keywords :lambda-parameters-limit 11 ;; :method-combination-lambda-list :deftype-lambda-list 12 ;; :primitive-object-size :allocation-information 14 ;; :who-specializes-directly :who-specializes-generally 15 ;; :find-function-callees :find-function-callers)) 18 ;; sb-sys:*linkage-info* *machine-version* *runtime-dlhandle* *periodic-polling-function* 19 ;; *periodic-polling-period* io-timeout nlx-protect serve-event os-deinit os-exit with-deadline dlopen-or-lose deallocate-system-memory 21 (defvar *default-arena-size* (* 10 1024 1024 1024)) 23 (defun current-lisp-implementation () 24 "Return the current lisp implemenation as a list: (TYPE VERSION FEATURES)" 26 (lisp-implementation-type) 27 (lisp-implementation-version) 30 (defun current-machine () 31 "Return the current machine spec as a list: (HOST TYPE VERSION)" 37 (defun list-package-symbols (&optional (pkg *package*)) 38 (loop for s being the external-symbol of pkg 41 (defun package-symbols (&optional (package *package*) test) 43 (do-external-symbols (symbol package) 45 (when (funcall test symbol) 46 (push symbol symbols)) 47 (push symbol symbols))) 50 (defun package-symbol-names (&optional (package *package*) test) 51 (sort (mapcar (lambda (x) (string-downcase (symbol-name x))) 52 (package-symbols package test)) 55 (defun standard-symbol-names (test) 56 (package-symbol-names :common-lisp test)) 58 (defun append-logical-hosts (&rest hosts) 59 "Reinitialize SB-IMPL::*LOGICAL-HOSTS* with a freshly allocated vector 60 consisting of the old contents appended to the new." 62 (concatenate 'vector hosts *logical-hosts*))) 65 (defun save-lisp-tree-shake-and-die (path &rest args) 66 "A naive tree-shaker for lisp." 68 (apply #'sb-ext:save-lisp-and-die path args)) 70 (defun save-lisp-and-live (filename completion-function restart &rest args) 71 (flet ((restart-sbcl () 72 (sb-debug::enable-debugger) 73 (setf sb-impl::*descriptor-handlers* nil) 75 ;; fork it - assumes only one thread is running 76 (multiple-value-bind (pipe-in pipe-out) (sb-posix:pipe) 77 (let ((pid (sb-posix:fork))) 78 (cond ((= pid 0) ;; make simple-restart core 79 (sb-posix:close pipe-in) 80 (sb-debug::disable-debugger) 81 (apply #'sb-ext:save-lisp-and-die filename 83 (list :toplevel #'restart-sbcl) 86 (sb-posix:close pipe-out) 87 (sb-sys:add-fd-handler 90 (sb-sys:invalidate-descriptor fd) 92 (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0) ;; wait for master 94 (assert (sb-posix:wifexited status)) 95 (funcall completion-function 96 (zerop (sb-posix:wexitstatus status)))))))))))) 98 (defparameter *gc-logfile* #P"gc.log") 100 (defun enable-gc-logfile (&optional (file *gc-logfile*)) 101 (setf (sb-ext:gc-logfile) file)) 103 (defun forget-shared-object (name) 104 (setf (sb-alien::shared-object-dont-save 105 (find name sb-sys:*shared-objects* 106 :key 'sb-alien::shared-object-namestring 107 :test 'string-equal)) 110 (defun forget-shared-objects (&optional (objects sb-sys:*shared-objects*)) 111 "Set the DONT-SAVE slot of all objects in SB-SYS:*SHARED-OBJECTS* to T." 112 (mapcar (lambda (obj) (setf (sb-alien::shared-object-dont-save obj) t)) objects)) 114 (defun compile-lisp (name &key force save make package compression verbose version callable-exports executable (toplevel #'sb-impl::toplevel-init) forget save-runtime-options root-structures (purify t)) 115 (pkg:with-package (or package *package*) 116 (asdf:compile-system name :force force :verbose verbose :version version) 118 (apply 'asdf:make name (unless (eq t make) make))) 120 (forget-shared-objects (unless (eq t forget) forget))) 122 (when (probe-file save) 124 (sb-ext:save-lisp-and-die save :executable executable 126 :callable-exports callable-exports 127 :save-runtime-options save-runtime-options 128 :root-structures root-structures 130 :compression compression))))