changelog shortlog graph tags branches changeset files revisions annotate raw help

Mercurial > core / lisp/std/sys.lisp

changeset 374: d1d64b856fae
parent: 3c60389fab93
child: 8fe057887c17
author: Richard Westhaver <ellis@rwest.io>
date: Mon, 27 May 2024 03:08:21 -0400
permissions: -rw-r--r--
description: rm dexador dependency 
     1 ;;; std/sys.lisp @ 2023-10-14.03:28:40 -*- mode: lisp; -*-
     2 
     3 ;;
     4 
     5 ;;; Code:
     6 (in-package :std/sys)
     7 
     8 ;;; Introspection
     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
    13 ;; 			  :function-type
    14 ;; 			  :who-specializes-directly :who-specializes-generally
    15 ;; 			  :find-function-callees :find-function-callers))
    16 
    17 ;; sys
    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
    20 
    21 (defun current-lisp-implementation ()
    22   "Return the current lisp implemenation as a cons: (TYPE VERSION)"
    23   (list 
    24    (lisp-implementation-type) 
    25    (lisp-implementation-version)
    26    *features*))
    27 
    28 ;; TODO
    29 (defun save-lisp-tree-shake-and-die (path &rest args)
    30   "A naive tree-shaker for lisp."
    31   (sb-ext:gc :full t)
    32   (apply #'sb-ext:save-lisp-and-die path args))
    33 
    34 (defun save-lisp-and-live (filename completion-function restart &rest args)
    35   (flet ((restart-sbcl ()
    36            (sb-debug::enable-debugger)
    37            (setf sb-impl::*descriptor-handlers* nil)
    38            (funcall restart)))
    39     ;; fork it - assumes only one thread is running
    40     (multiple-value-bind (pipe-in pipe-out) (sb-posix:pipe)
    41       (let ((pid (sb-posix:fork)))
    42         (cond ((= pid 0) ;; make simple-restart core
    43                (sb-posix:close pipe-in)
    44                (sb-debug::disable-debugger)
    45                (apply #'sb-ext:save-lisp-and-die filename
    46                       (append
    47                        (list :toplevel #'restart-sbcl)
    48                        args)))
    49               (t
    50                (sb-posix:close pipe-out)
    51                (sb-sys:add-fd-handler
    52                 pipe-in :input
    53                 (lambda (fd)
    54                   (sb-sys:invalidate-descriptor fd)
    55                   (sb-posix:close fd)
    56                   (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0) ;; wait for master
    57                     (assert (= pid rpid))
    58                     (assert (sb-posix:wifexited status))
    59                     (funcall completion-function
    60                              (zerop (sb-posix:wexitstatus status))))))))))))
    61 
    62 ;; TODO 2024-05-09: 
    63 ;; (defun decode-all-debug-data ()
    64 ;;   (dolist (code (sb-vm:list-allocated-objects :all :type sb-vm:code-header-widetag))
    65 ;;     (let ((info (sb-kernel:%code-debug-info code)))
    66 ;;       (when (typep info 'sb-c::compiled-debug-info)
    67 ;;         (let ((fun-map (sb-di::get-debug-info-fun-map
    68 ;;                         (sb-kernel:%code-debug-info code))))
    69 ;;           (loop for i from 0 below (length fun-map) by 2 do
    70 ;;             (let ((cdf (aref fun-map i)))
    71 ;;               (sb-di::debug-fun-lambda-list
    72 ;;                (sb-di::make-compiled-debug-fun cdf code))))))
    73 ;;       (print info))))
    74 
    75 (defun forget-shared-objects ()
    76   "Set the DONT-SAVE slot of all objects in SB-SYS:*SHARED-OBJECTS* to T."
    77   (mapcar (lambda (obj) (setf (sb-alien::shared-object-dont-save obj) t)) sb-sys:*shared-objects*))