;;; -*- Mode: LISP; Package: MAKE -*-

(in-package "COMMON-LISP-USER")

(setf *load-verbose* t)

;;;
;;; we have a modern eval-when()
;;;
(eval-when (:execute :load-toplevel :compile-toplevel)
  (pushnew :ansi-eval-when *features*))

;;;
;;; load the portable defsystem() from CMU
;;;
#-:mk-defsystem
(load (make-pathname :directory general-dir :name "defsystem"))

(in-package "MAKE")

(defvar %binary-dir-name%
  (or
   #+(and :x86 :linux) ".kuf"
   #+(and :x86-64 :linux) ".luf"
   #+(and :x86-64 :darwin) ".duf"
   #+(and :arm64 :darwin) ".muf"
   #+(not :unix) ".wuf"
   ".cuf"))
   
;;;
;;; determine the system type (in terms of hardware and os) in order to set
;;; `bin-dir' (the location of external platform-specific executables)
;;; accordingly (6-feb-96 -- oe@csli)
;;;

(defvar %system-binaries%
  (or
   #+(and :x86 :linux) "linux.x86.32"
   #+(and :x86-64 :linux) "linux.x86.64"
   #+(and :x86-64 :darwin) "darwin.x86.64"
   #+(and :arm64 :darwin) "darwin.arm64"
   #+(not :unix) "windows"
   (error "~&loadup: unable to determine system type; see file ~
           `sbcl-patches.lisp'.~%")))


;;;
;;; The Allegro CL style run-shell-command() (since acl is home sweet home - for better
;;; or for worse...). Could get this from UIOP but that brings in lots of other stuff
;;; we don't use, and besides, UIOP seems to have no maintainer
;;;

(defun run-process (command &rest args 
                    &key (wait t) &allow-other-keys)
  ;; NB Allegro CL interpretation of :input/:output/:error-output being nil is inherit
  ;; appropriate stream from Lisp process - different from sb-ext:run-program behaviour
  (let* ((args
           (loop for (key val) on args by #'cddr
             unless (eq key :if-error-output-does-not-exist)
             do
             (case key
               (:error-output (setq key :error))
               (:if-error-output-exists (setq key :if-error-exists)))
             (cond
               ((eq val nil)
                 (case key
                   (:input (setq val *standard-input*))
                   (:output (setq val *standard-output*))
                   (:error (setq val *error-output*))))
               ((equal val "/dev/null")
                 (setq val nil)))
             nconc
             (list key val)))
         (process
           (apply #'sb-ext:run-program
                  "/bin/sh" (list "-c" command) :wait wait args)))
    (when (sb-ext:process-p process)
      (if wait 
        (sb-ext:process-exit-code process)
        (let* ((input (sb-ext:process-input process))
               (output (sb-ext:process-output process))
               (stream-or-nil
                 (cond
                   ((and input output) (make-two-way-stream output input))
                   (input)
                   (output)
                   (t nil)))
              (stderr (sb-ext:process-error process))
              (pid (sb-ext:process-pid process)))
          (values stream-or-nil stderr pid))))))

(defun getenv (name) 
  (sb-ext:posix-getenv name))


;;;
;;; Customise memory management for typical LKB use
;;;

(setf (sb-ext:bytes-consed-between-gcs) (* 150 (expt 2 20))) ; don't GC too often during build

(defun set-lkb-memory-management-parameters ()
  ;; These parameters assume a generous maximum memory size: either specified via a large
  ;; value for --dynamic-space-size (e.g. 32000 for 64 bit and 2500 for 32 bit) on LKB
  ;; startup, or hardwired into a binary through
  ;; (sb-ext:save-lisp-and-die ... :save-runtime-options t)
  ;;
  ;; Run with only a nursery and a single non-nursery generation; although unconventional,
  ;; this works well in practice.
  ;; To a first approximation, there are only two kinds of data in the LKB: long-lived dag
  ;; structures etc in the grammar, and very short-lived data created during parsing or
  ;; generating a single sentence. (This is actually not strictly true since the LKB is a
  ;; grammar development environment as well as a linguistic processor, so the user can opt
  ;; to keep previous parse/generation results accessible via the GUI for as long as they
  ;; they like, until they next reload the grammar). But anyway, we don't want to allow
  ;; parse/generation data to be promoted to older generations. Therefore, prevent any
  ;; object being promoted out of the youngest generation - except through an explicit
  ;; programmer call (sb-ext:gc :full t)
  (setf (sb-ext:generation-number-of-gcs-before-promotion 0) 1000000)
  ;;
  ;; don't GC too often - only after 500MB of new allocation; this setting is appropriate
  ;; for a machine with 8GB memory or more, but could be revised downwards if necessary
  (setf (sb-ext:bytes-consed-between-gcs) (* #+:64-bit 500 #-:64-bit 250 (expt 2 20))))


;;; Turn off the option for the Lisp reader to normalize symbols to Normalization Form KC
;;; (NFKC) - otherwise trouble with grammars such as Zhong

(setf (sb-ext:readtable-normalization *readtable*) nil)


;;; A variant toplevel read function that avoids unexpected exits by requiring 3 Control-D's
;;; in a row (like Clozure CL's default behaviour)

(let ((eof-count 0))
  (defun sbcl-repl-read-form (in out)
    (declare (type stream in out))
    ;; Based on repl-read-form-fun in SBCL src/code/toplevel.lisp
    (when *read-suppress*
      (warn "Setting *READ-SUPPRESS* to NIL to restore toplevel usability.")
      (setf *read-suppress* nil))
    (let* ((eof-marker (cons nil nil))
           (form (read in nil eof-marker)))
      (cond
        ((not (eq form eof-marker))
          (setq eof-count 0)
          form)
        ((>= eof-count 2)
          (sb-ext:exit))
        (t
          (incf eof-count)
          (funcall sb-int:*repl-prompt-fun* *standard-output*)
          (force-output *standard-output*)
          (sbcl-repl-read-form in out))))))

;;; Make entry to the Lisp debugger a bit less verbose - users will either already know
;;; "Type HELP for debugger help, or (SB-EXT:EXIT) to exit from SBCL."
;;; or not find this information relevant

(setq sb-debug:*debug-beginner-help-p* nil)


;;;
;;; Set up :multiprocessing package. Disappointingly, acl-compat contains a couple of bugs
;;; which can lead to memory leaks - fixes below.
;;;

(ql:quickload :acl-compat)

(defpackage :multiprocessing
  (:use #:common-lisp #:acl-compat.mp)
  (:nicknames #:mp)
  (:export 
   #:*current-process*         ;*
   #:process-kill              ;*
   #:process-preset            ;*
   #:process-name              ;*

   #:process-wait-function
   #:process-run-reasons 
   #:process-arrest-reasons
   #:process-whostate
   #:without-interrupts
   #:process-wait
   #:process-enable
   #:process-disable
   #:process-reset
   #:process-interrupt

   #:process-run-function      ;*
   #:process-property-list     ;*
   #:without-scheduling        ;*
   #:process-allow-schedule    ;*
   #:make-process              ;*
   #:process-add-run-reason    ;*
   #:process-revoke-run-reason ;*
   #:process-add-arrest-reason    ;* missing, so defined below
   #:process-revoke-arrest-reason ;* missing, so defined below
   #:process-allow-schedule    ;*
   #:with-timeout              ;*
   #:make-process-lock         ;*
   #:with-process-lock         ;*
   #:process-lock
   #:process-unlock

   #:current-process
   #:process-name-to-process
   #:process-wait-with-timeout
   #:wait-for-input-available
   #:process-active-p
   
   #:process-p ; missing from acl-compat.mp so defined below
   #:run-function ; used as an alias of process-run-function
   ))

(in-package :acl-compat.mp)

(locally
    (declare (sb-ext:muffle-conditions sb-kernel:redefinition-warning))
  (handler-bind
      ((sb-kernel:redefinition-warning #'muffle-warning))
    (defun/sb-thread process-preset (process function &rest arguments)
      ;; Bug fix: the sbcl-internal thread exits when its associated function returns, but
      ;; this can't be detected by acl-compat.mp so the process structure wrapping the
      ;; terminated thread hangs around - we therefore kill it explicitly.
      (setf (process-function process)
            #'(lambda (&rest args)
                (unwind-protect (apply function args)
                  ;; kill if not explicitly done already
                  (ignore-errors (process-kill process))))
            (process-arguments process)
            arguments)
      (when (process-id process) (restart-process process)))
    
    (defun/sb-thread process-kill (process)
      ;; Bug fix: move terminate-thread call to the end. Why? If the currently running
      ;; process calls process-kill on itself then terminate-thread will not return,
      ;; so it has to be called last - not first!
      (sb-thread:with-mutex (*all-processes-lock*)
        (setf *all-processes* (delete process *all-processes*)))
      (let ((id (process-id process)))
        (setf (process-id process) nil)
        (sb-thread:terminate-thread id)))))

(defun mp:process-add-arrest-reason (process reason)
  ;; Run reasons are implemented in acl-compat, but not arrest reasons
  ;; !!! Fragile. Assumes that only a single arrest reason is used for any process, and
  ;; that a run reason is not added while a process is suspended due to an arrest reason.
  (declare (ignore reason))
  (sb-thread:with-recursive-lock ((process-%lock process))
    (when (process-id process)
      (if (eq process *current-process*)
          (progn
            (unless (getf (process-property-list process) 'saved-run-reasons)
              (setf (getf (process-property-list process) 'saved-run-reasons)
                (process-run-reasons process)))
            (setf (process-run-reasons process) nil)
            (disable-process process))
          (warn
"Attempt by one process to suspend another - not supported since can result in a deadlock"
            )))))

(defun mp:process-revoke-arrest-reason (process reason)
  ;; Also missing from acl-compat
  ;; !!! Same caveats as above
  (declare (ignore reason))
  (sb-thread:with-recursive-lock ((process-%lock process))
    (setf (process-run-reasons process)
      (getf (process-property-list process) 'saved-run-reasons))
    (remf (process-property-list process) 'saved-run-reasons)
    (cond
      ((null (process-run-reasons process)))
      ((process-id process)
        (enable-process process))
      (t
        (restart-process process)))))

(defun mp:process-p (x) (processp x))

(eval-when (:execute :load-toplevel :compile-toplevel)
  (setf (symbol-function 'mp:run-function) 
        (symbol-function 'process-run-function)))

(defmethod print-object ((obj process) stream)
  ;; ... since the default printed representation for process structures is very verbose
  (print-unreadable-object (obj stream :type t :identity t)
    (princ (process-name obj) stream)))

(eval-when (:execute :load-toplevel :compile-toplevel)
  (pushnew :multiprocessing *features*))


;;; Make sure that sb-posix:kill, sb-posix:sigterm, etc. are available

(eval-when (:load-toplevel :compile-toplevel :execute)
  (require :sb-posix))


;;; A few remaining Allegro CL-specific functions in [incr tsdb()] that haven't been
;;; conditionalised out or replaced with portable alternatives

(defpackage :system
  (:nicknames :sys)
  (:use :common-lisp)
  (:export #:os-wait #:getenv))

(defun sys:os-wait (&optional nowait pid)
  ;; in unix, a child process sends a SIGCHLD signal to its parent when it terminates;
  ;; in SBCL, there's a handler for SIGCHLD which calls wait() so we don't have to do this
  ;; - see https://www.mail-archive.com/asdf-devel@common-lisp.net/msg05196.html
  (declare (ignore pid))
  (when nowait
    (warn "sys:os-wait called with a non-nil nowait argument, which is not supported"))
  ;; assert that it's now gone, and guess the exit status
  0)

(defun system:getenv (x) (make::getenv x))

#|
(defpackage :excl
  (:use :common-lisp)
  (:export #:*initial-terminal-io*))

(defvar excl:*initial-terminal-io* (make-synonym-stream '*terminal-io*))
|#