From: William Harold Newman Date: Mon, 25 Sep 2000 00:11:06 +0000 (+0000) Subject: integrated Raymond Wiker's patches to port RUN-PROGRAM from CMU CL and X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=8fc5fda05f92d69c95b47e4ad7561d91dab18c3e;p=sbcl.git integrated Raymond Wiker's patches to port RUN-PROGRAM from CMU CL and to generalize dlopen()-ish stuff from Linux to FreeBSD --- diff --git a/CREDITS b/CREDITS index ecb2ffd..8c9cba4 100644 --- a/CREDITS +++ b/CREDITS @@ -477,20 +477,30 @@ whenever I got stuck. CREDITS SINCE THE RELEASE OF SBCL -The PSXHASH code used to implement EQUALP hash tables was originally -copyright (C) 2000 by Cadabra, Inc., then released into the public -domain. - -Daniel Barlow contributed sblisp.lisp, a set of patches to make SBCL -play nicely with ILISP. (Those patches have since disappeared from the -SBCL distribution because ILISP has since been patched to play nicely -with SBCL.) He also figured out how to get the CMU CL dynamic object -file loading code to work under SBCL. - -Raymond Wiker ported sbcl-0.6.3 back to FreeBSD, restoring the -ancestral CMU CL support for FreeBSD and updating it for the changes -made from FreeBSD version 3 to FreeBSD version 4. - -Colin Walters' O(N) implementation of the general case of MAP on the -cmucl-imp@cons.org mailing list was the inspiration for similar MAP -code in sbcl-0.6.8. +Daniel Barlow: + He contributed sblisp.lisp, a set of patches to make SBCL + play nicely with ILISP. (Those patches have since disappeared from the + SBCL distribution because ILISP has since been patched to play nicely + with SBCL.) He also figured out how to get the CMU CL dynamic object + file loading code to work under SBCL. + +Cadabra, Inc.: + They hired William Newman to do some consulting for them, + including the implementation of EQUALP hash tables for CMU CL; + then agreed to release the EQUALP code into the public domain, + giving SBCL, and CMU CL, EQUALP hash tables. + +Peter Van Eynde: + He wrestled the CLISP test suite into a portable test suite which + can be used on SBCL, and submitted many other bug reports as well. + +Colin Walters: + His O(N) implementation of the general case of MAP, posted on the + cmucl-imp@cons.org mailing list, was the inspiration for similar MAP + code added in sbcl-0.6.8. + +Raymond Wiker: + He ported sbcl-0.6.3 back to FreeBSD, restoring the ancestral + CMU CL support for FreeBSD and updating it for the changes made + from FreeBSD version 3 to FreeBSD version 4. He also ported the + CMU CL extension RUN-PROGRAM, and related code, to SBCL. diff --git a/NEWS b/NEWS index f504316..241d001 100644 --- a/NEWS +++ b/NEWS @@ -487,10 +487,18 @@ changes in sbcl-0.6.8 relative to sbcl-0.6.7: single sequence argument). (The old non-inline implementation of the general M-argument sequence-of-length-N case required O(M*N*N) time when any of the sequence arguments were LISTs.) -?? Raymond Wiker's port of CMU CL's RUN-PROGRAM has been added. -(?? Don't forget to mention Raymond Wiker in the CREDITS file.) +* The QUIT :UNIX-CODE keyword argument has been renamed to + QUIT :UNIX-STATUS. (The old name still works, but is deprecated.) +* Raymond Wiker's port of CMU CL's RUN-PROGRAM has been added. + ?? What about the undefined symbols in run-program.lisp? + SB-UNIX:UNIX-DUP + SB-UNIX:UNIX-IOCTL + SB-UNIX:UNIX-PIPE ?? The debugger now flushes standard output streams before it begins its output ("debugger invoked" and so forth). +?? FINISH-OUTPUT now works better than it did before. (It used to + have trouble with characters which weren't followed by a linefeed.) + ?? Remember to remove this from BUGS. ?? The patch for the SUBSEQ bug reported on the cmucl-imp mailing list 12 September 2000 has been applied to SBCL. ?? Martin Atzmueller's versions of two CMU CL patches, as posted on @@ -502,6 +510,5 @@ changes in sbcl-0.6.8 relative to sbcl-0.6.7: ?? The signal handling bug reported by Martin Atzmueller on sbcl-devel 13 September 2000, which caused the debugger to get confused after a Ctrl-C interrupt under ILISP, has been fixed. -?? The QUIT :UNIX-CODE keyword argument has been renamed to - QUIT :UNIX-STATUS. (The old name is still supported, but - deprecated.) +?? added enough DEFTRANSFORMs to allow (SXHASH 'FOO) to be optimized + away by constant folding diff --git a/make.sh b/make.sh index e8d0044..426075e 100755 --- a/make.sh +++ b/make.sh @@ -49,17 +49,16 @@ echo //SBCL_XC_HOST=\"$SBCL_XC_HOST\" # and target machines. sh make-config.sh || exit 1 -# The foo-host-bar.sh scripts are run on the cross-compilation host, -# and the foo-target-bar.sh scripts are run on the target machine. In +# The make-host-*.sh scripts are run on the cross-compilation host, +# and the make-target-*.sh scripts are run on the target machine. In # ordinary compilation, we just do these phases consecutively on the # same machine, but if you wanted to cross-compile from one machine -# which supports Common Lisp to another which does not (yet) support -# Lisp, you could do something like this: -# Create copies of the source tree on both host and target. -# Create links from "target" to "x86" in "src/compiler/" and -# in "src/assembly/", on both the host and the target. (That -# would ordinarily be done by the make.sh code above; if we're -# doing make.sh stuff by hand, we need to do this by hand, too.) +# which supports Common Lisp to another which does not (yet:-) support +# Common Lisp, you could do something like this: +# Create copies of the source tree on both the host and the target. +# Read the make-config.sh script carefully and emulate it by hand +# on both machines (e.g. creating "target"-named symlinks to +# identify the target architecture). # On the host system: # SBCL_XC_HOST= sh make-host-1.sh # Copy src/runtime/sbcl.h from the host system to the target system. diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 2b16cf6..321664b 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -576,9 +576,19 @@ like *STACK-TOP-HINT*" ;; miscellaneous useful supported extensions "QUIT" - ;; running a Unix program from Lisp, not quite working - ;; in sbcl-0.6.6, but maybe soon.. - "RUN-PROGRAM")) + ;; RUN-PROGRAM is not only useful for users, but also + ;; useful to implement parts of SBCL itself, so we're + ;; going to have to implement it anyway, so we might + ;; as well support it. And then once we're committed + ;; to implementing RUN-PROGRAM, it's nice to have it + ;; return a PROCESS object with operations defined on + ;; that object. + "RUN-PROGRAM" + "PROCESS-ALIVE-P" "PROCESS-CLOSE" + "PROCESS-CORE-DUMPED" "PROCESS-ERROR" "PROCESS-EXIT-CODE" + "PROCESS-INPUT" "PROCESS-KILL" "PROCESS-OUTPUT" "PROCESS-P" + "PROCESS-PID" "PROCESS-PLIST" "PROCESS-PTY" "PROCESS-STATUS" + "PROCESS-STATUS-HOOK" "PROCESS-WAIT")) #s(sb-cold:package-data :name "SB!FORMAT" @@ -739,14 +749,6 @@ retained, possibly temporariliy, because it might be used internally." ;; used for FORMAT tilde paren "MAKE-CASE-FROB-STREAM" - ;; Some of these are probably still used for Unix-y processes. - ;; -- WHN 19991206 - "PROCESS-CLOSE" - "PROCESS-CORE-DUMPED" "PROCESS-ERROR" "PROCESS-EXIT-CODE" - "PROCESS-INPUT" "PROCESS-KILL" "PROCESS-OUTPUT" "PROCESS-P" - "PROCESS-PID" "PROCESS-PLIST" "PROCESS-PTY" "PROCESS-STATUS" - "PROCESS-STATUS-HOOK" "PROCESS-WAIT" - ;; debuggers' little helpers #!+sb-show "*/SHOW*" "/SHOW" "/NOSHOW" diff --git a/src/code/cold-init.lisp b/src/code/cold-init.lisp index 79872d9..f50db9e 100644 --- a/src/code/cold-init.lisp +++ b/src/code/cold-init.lisp @@ -114,6 +114,7 @@ (show-and-call !random-cold-init) ;; All sorts of things need INFO and/or (SETF INFO). + (/show0 "about to SHOW-AND-CALL !GLOBALDB-COLD-INIT") (show-and-call !globaldb-cold-init) ;; This needs to be done early, but needs to be after INFO is diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index 62b9bd2..ca7e467 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -1176,14 +1176,15 @@ ;;; type declarations. Values are the values for the slots (in order.) ;;; ;;; This is split four ways because: -;;; 1] list & vector structures need "name" symbols stuck in at various weird -;;; places, whereas STRUCTURE structures have a LAYOUT slot. +;;; 1] list & vector structures need "name" symbols stuck in at +;;; various weird places, whereas STRUCTURE structures have +;;; a LAYOUT slot. ;;; 2] We really want to use LIST to make list structures, instead of ;;; MAKE-LIST/(SETF ELT). -;;; 3] STRUCTURE structures can have raw slots that must also be allocated and -;;; indirectly referenced. We use SLOT-ACCESSOR-FORM to compute how to set -;;; the slots, which deals with raw slots. -;;; 4] funcallable structures are weird. +;;; 3] STRUCTURE structures can have raw slots that must also be +;;; allocated and indirectly referenced. We use SLOT-ACCESSOR-FORM +;;; to compute how to set the slots, which deals with raw slots. +;;; 4] Funcallable structures are weird. (defun create-vector-constructor (defstruct cons-name arglist vars types values) (let ((temp (gensym)) diff --git a/src/code/foreign.lisp b/src/code/foreign.lisp index 6f4b782..da50eac 100644 --- a/src/code/foreign.lisp +++ b/src/code/foreign.lisp @@ -63,7 +63,7 @@ ;;; Linux implementation of GET-DYNAMIC-FOREIGN-SYMBOL-ADDRESS ;;; and functions (e.g. LOAD-FOREIGN) which affect it -#+linux +#+(or linux FreeBSD) (progn ;;; flags for dlopen() diff --git a/src/code/run-program.lisp b/src/code/run-program.lisp index aadfe81..d704435 100644 --- a/src/code/run-program.lisp +++ b/src/code/run-program.lisp @@ -1,20 +1,5 @@ -.. not working .. not working .. not working .. not working .. - -KLUDGE: This is CMU CL code which needs more porting before it can -work on SBCL. At the very least: - * Package references need to be renamed from the CMU CL "SYSTEM" style - to the SBCL "SB-SYS" style. Possibly some referenced symbols have - moved to new packages or been renamed, as well. - * The environment-handling needs to be updated to read directly from - the Unix environment, since SBCL, unlike CMU CL, doesn't maintain - its own local copy. - * The DEFCONSTANT #+SVR4 stuff needs to be checked and cleaned up for - currently supported OSes, since SBCL doesn't use the :SVR4 feature. - * The conditional code for other stuff not supported by SBCL (e.g. - HPUX) should probably go away. --- WHN 20000825 - -;;;; support for running Unix programs from inside Lisp +;;;; RUN-PROGRAM and friends, a facility for running Unix programs +;;;; from inside SBCL ;;;; This software is part of the SBCL system. See the README file for ;;;; more information. @@ -32,10 +17,10 @@ work on SBCL. At the very least: ;;;; Import wait3(2) from Unix. -(alien:def-alien-routine ("wait3" c-wait3) c-call:int - (status c-call:int :out) - (options c-call:int) - (rusage c-call:int)) +(sb-alien:def-alien-routine ("wait3" c-wait3) sb-c-call:int + (status sb-c-call:int :out) + (options sb-c-call:int) + (rusage sb-c-call:int)) (eval-when (load eval compile) (defconstant wait-wnohang #-svr4 1 #+svr4 #o100) @@ -43,15 +28,15 @@ work on SBCL. At the very least: (defconstant wait-wstopped #-svr4 #o177 #+svr4 wait-wuntraced)) (defun wait3 (&optional do-not-hang check-for-stopped) - "Return any available status information on child process." + "Return any available status information on child process. " (multiple-value-bind (pid status) - (c-wait3 (logior (if do-not-hang - wait-wnohang - 0) - (if check-for-stopped - wait-wuntraced - 0)) - 0) + (c-wait3 (logior (if do-not-hang + wait-wnohang + 0) + (if check-for-stopped + wait-wuntraced + 0)) + 0) (cond ((or (minusp pid) (zerop pid)) nil) @@ -67,39 +52,40 @@ work on SBCL. At the very least: (t (let ((signal (ldb (byte 7 0) status))) (values pid - (if (or (eql signal unix:sigstop) - (eql signal unix:sigtstp) - (eql signal unix:sigttin) - (eql signal unix:sigttou)) - :stopped - :signaled) + (if (or (eql signal sb-unix:sigstop) + (eql signal sb-unix:sigtstp) + (eql signal sb-unix:sigttin) + (eql signal sb-unix:sigttou)) + :stopped + :signaled) signal (not (zerop (ldb (byte 1 7) status))))))))) -;;;; stuff for process control +;;;; process control stuff (defvar *active-processes* nil "List of process structures for all active processes.") -(defstruct (process (:print-function %print-process)) - pid ; PID of child process - %status ; either :RUNNING, :STOPPED, :EXITED, or :SIGNALED - exit-code ; either exit code or signal - core-dumped ; T if a core image was dumped - pty ; stream to child's pty, or NIL - input ; stream to child's input, or NIL - output ; stream from child's output, or NIL - error ; stream from child's error output, or NIL - status-hook ; closure to call when PROC changes status - plist ; a place for clients to stash things - cookie ; list of the number of pipes from the subprocess - ) - -(defun %print-process (proc stream depth) - (declare (ignore depth)) - (format stream "#" - (process-pid proc) - (process-status proc))) +(defstruct (process) + pid ; PID of child process + %status ; either :RUNNING, :STOPPED, :EXITED, or :SIGNALED + exit-code ; either exit code or signal + core-dumped ; T if a core image was dumped + pty ; stream to child's pty, or NIL + input ; stream to child's input, or NIL + output ; stream from child's output, or NIL + error ; stream from child's error output, or NIL + status-hook ; closure to call when PROC changes status + plist ; a place for clients to stash things + cookie) ; list of the number of pipes from the subproc + +(defmethod print-object ((process process) stream) + (print-unreadable-object (process stream :type t) + (format stream + "~D ~S" + (process-pid process) + (process-status process))) + process) (defun process-status (proc) "Return the current status of process. The result is one of :RUNNING, @@ -110,36 +96,37 @@ work on SBCL. At the very least: (defun process-wait (proc &optional check-for-stopped) "Wait for PROC to quit running for some reason. Returns PROC." (loop - (case (process-status proc) - (:running) - (:stopped - (when check-for-stopped - (return))) - (t - (when (zerop (car (process-cookie proc))) - (return)))) - (system:serve-all-events 1)) + (case (process-status proc) + (:running) + (:stopped + (when check-for-stopped + (return))) + (t + (when (zerop (car (process-cookie proc))) + (return)))) + (sb-sys:serve-all-events 1)) proc) +#-hpux ;;; Find the current foreground process group id. (defun find-current-foreground-process (proc) - (alien:with-alien ((result c-call:int)) + (sb-alien:with-alien ((result sb-c-call:int)) (multiple-value-bind - (wonp error) - (unix:unix-ioctl (system:fd-stream-fd (ext:process-pty proc)) - unix:TIOCGPGRP - (alien:alien-sap (alien:addr result))) + (wonp error) + (sb-unix:unix-ioctl (sb-sys:fd-stream-fd (process-pty proc)) + sb-unix:TIOCGPGRP + (sb-alien:alien-sap (sb-alien:addr result))) (unless wonp (error "TIOCPGRP ioctl failed: ~S" - (unix:get-unix-error-msg error))) + (sb-unix:get-unix-error-msg error))) result)) (process-pid proc)) (defun process-kill (proc signal &optional (whom :pid)) - "Send SIGNAL to PROC. If WHOM is :PID, then use the kill(2) Unix system - call. If WHOM is :PROCESS-GROUP, use the killpg(2) Unix system call. - If WHOM is :PTY-PROCESS-GROUP, then deliver the signal to whichever - process group is currently in the foreground." + "Hand SIGNAL to PROC. If whom is :pid, use the kill Unix system call. If + whom is :process-group, use the killpg Unix system call. If whom is + :pty-process-group deliver the signal to whichever process group is currently + in the foreground." (let ((pid (ecase whom ((:pid :process-group) (process-pid proc)) @@ -147,22 +134,22 @@ work on SBCL. At the very least: #-hpux (find-current-foreground-process proc))))) (multiple-value-bind - (okay errno) + (okay errno) (case whom #+hpux (:pty-process-group - (unix:unix-ioctl (system:fd-stream-fd (process-pty proc)) - unix:TIOCSIGSEND - (system:int-sap - (unix:unix-signal-number signal)))) + (sb-unix:unix-ioctl (sb-sys:fd-stream-fd (process-pty proc)) + sb-unix:TIOCSIGSEND + (sb-sys:int-sap + (sb-unix:unix-signal-number signal)))) ((:process-group #-hpux :pty-process-group) - (unix:unix-killpg pid signal)) + (sb-unix:unix-killpg pid signal)) (t - (unix:unix-kill pid signal))) + (sb-unix:unix-kill pid signal))) (cond ((not okay) (values nil errno)) ((and (eql pid (process-pid proc)) - (= (unix:unix-signal-number signal) unix:sigcont)) + (= (sb-unix:unix-signal-number signal) sb-unix:sigcont)) (setf (process-%status proc) :running) (setf (process-exit-code proc) nil) (when (process-status-hook proc) @@ -176,8 +163,8 @@ work on SBCL. At the very least: (let ((status (process-status proc))) (if (or (eq status :running) (eq status :stopped)) - t - nil))) + t + nil))) (defun process-close (proc) "Close all streams connected to PROC and stop maintaining the status slot." @@ -187,33 +174,33 @@ work on SBCL. At the very least: (frob (process-input proc) t) ; .. 'cause it will generate SIGPIPE. (frob (process-output proc) nil) (frob (process-error proc) nil)) - (system:without-interrupts + (sb-sys:without-interrupts (setf *active-processes* (delete proc *active-processes*))) proc) -;;; the handler for SIGCHLD signals that RUN-PROGRAM establishes +;;; the handler for sigchld signals that RUN-PROGRAM establishes (defun sigchld-handler (ignore1 ignore2 ignore3) (declare (ignore ignore1 ignore2 ignore3)) (get-processes-status-changes)) (defun get-processes-status-changes () (loop - (multiple-value-bind (pid what code core) - (wait3 t t) - (unless pid - (return)) - (let ((proc (find pid *active-processes* :key #'process-pid))) - (when proc - (setf (process-%status proc) what) - (setf (process-exit-code proc) code) - (setf (process-core-dumped proc) core) - (when (process-status-hook proc) - (funcall (process-status-hook proc) proc)) - (when (or (eq what :exited) - (eq what :signaled)) - (system:without-interrupts - (setf *active-processes* - (delete proc *active-processes*))))))))) + (multiple-value-bind (pid what code core) + (wait3 t t) + (unless pid + (return)) + (let ((proc (find pid *active-processes* :key #'process-pid))) + (when proc + (setf (process-%status proc) what) + (setf (process-exit-code proc) code) + (setf (process-core-dumped proc) core) + (when (process-status-hook proc) + (funcall (process-status-hook proc) proc)) + (when (or (eq what :exited) + (eq what :signaled)) + (sb-sys:without-interrupts + (setf *active-processes* + (delete proc *active-processes*))))))))) ;;;; RUN-PROGRAM and close friends @@ -224,59 +211,69 @@ work on SBCL. At the very least: (defvar *handlers-installed* nil "List of handlers installed by RUN-PROGRAM.") -;;; Find a pty that is not in use. Returns three values: the file +#+FreeBSD +(def-alien-type nil + (struct sgttyb + (sg-ispeed sb-c-call:char) ; input speed + (sg-ospeed sb-c-call:char) ; output speed + (sg-erase sb-c-call:char) ; erase character + (sg-kill sb-c-call:char) ; kill character + (sg-flags sb-c-call:short) ; mode flags + )) + +;;; Find a pty that is not in use. Return three values: the file ;;; descriptor for the master side of the pty, the file descriptor for ;;; the slave side of the pty, and the name of the tty device for the ;;; slave side. (defun find-a-pty () - "Returns the master fd, the slave fd, and the name of the tty" (dolist (char '(#\p #\q)) (dotimes (digit 16) (let* ((master-name (format nil "/dev/pty~C~X" char digit)) - (master-fd (unix:unix-open master-name - unix:o_rdwr - #o666))) + (master-fd (sb-unix:unix-open master-name + sb-unix:o_rdwr + #o666))) (when master-fd (let* ((slave-name (format nil "/dev/tty~C~X" char digit)) - (slave-fd (unix:unix-open slave-name - unix:o_rdwr - #o666))) + (slave-fd (sb-unix:unix-open slave-name + sb-unix:o_rdwr + #o666))) (when slave-fd - ; Maybe put a vhangup here? - #-glibc2 - (alien:with-alien ((stuff (alien:struct unix:sgttyb))) - (let ((sap (alien:alien-sap stuff))) - (unix:unix-ioctl slave-fd unix:TIOCGETP sap) - (setf (alien:slot stuff 'unix:sg-flags) #o300) ; EVENP|ODDP - (unix:unix-ioctl slave-fd unix:TIOCSETP sap) - (unix:unix-ioctl master-fd unix:TIOCGETP sap) - (setf (alien:slot stuff 'unix:sg-flags) - (logand (alien:slot stuff 'unix:sg-flags) + ; Maybe put a vhangup here? + #-linux + (sb-alien:with-alien ((stuff (sb-alien:struct sgttyb))) + (let ((sap (sb-alien:alien-sap stuff))) + (sb-unix:unix-ioctl slave-fd sb-unix:TIOCGETP sap) + (setf (sb-alien:slot stuff 'sg-flags) + #o300) ; EVENP|ODDP + (sb-unix:unix-ioctl slave-fd sb-unix:TIOCSETP sap) + (sb-unix:unix-ioctl master-fd sb-unix:TIOCGETP sap) + (setf (sb-alien:slot stuff 'sg-flags) + (logand (sb-alien:slot stuff 'sg-flags) (lognot 8))) ; ~ECHO - (unix:unix-ioctl master-fd unix:TIOCSETP sap))) + (sb-unix:unix-ioctl master-fd sb-unix:TIOCSETP sap))) (return-from find-a-pty - (values master-fd - slave-fd - slave-name))) - (unix:unix-close master-fd)))))) + (values master-fd + slave-fd + slave-name))) + (sb-unix:unix-close master-fd)))))) (error "could not find a pty")) (defun open-pty (pty cookie) (when pty (multiple-value-bind - (master slave name) + (master slave name) (find-a-pty) (push master *close-on-error*) (push slave *close-in-parent*) (when (streamp pty) - (multiple-value-bind (new-fd errno) (unix:unix-dup master) + (multiple-value-bind (new-fd errno) (sb-unix:unix-dup master) (unless new-fd - (error "could not UNIX:UNIX-DUP ~D: ~A" - master (unix:get-unix-error-msg errno))) + (error "could not SB-UNIX:UNIX-DUP ~D: ~S" + master (sb-unix:get-unix-error-msg errno))) (push new-fd *close-on-error*) (copy-descriptor-to-stream new-fd pty cookie))) (values name - (system:make-fd-stream master :input t :output t))))) + (sb-sys:make-fd-stream master :input t :output t))))) (defmacro round-bytes-to-words (n) `(logand (the fixnum (+ (the fixnum ,n) 3)) (lognot 3))) @@ -294,19 +291,20 @@ work on SBCL. At the very least: (incf string-bytes (round-bytes-to-words (1+ (length s))))) ;; Now allocate the memory and fill it in. (let* ((total-bytes (+ string-bytes vec-bytes)) - (vec-sap (system:allocate-system-memory total-bytes)) + (vec-sap (sb-sys:allocate-system-memory total-bytes)) (string-sap (sap+ vec-sap vec-bytes)) (i #-alpha 4 #+alpha 8)) (declare (type (and unsigned-byte fixnum) total-bytes i) - (type system:system-area-pointer vec-sap string-sap)) + (type sb-sys:system-area-pointer vec-sap string-sap)) (dolist (s string-list) (declare (simple-string s)) (let ((n (length s))) ;; Blast the string into place. - (kernel:copy-to-system-area (the simple-string s) - (* vm:vector-data-offset vm:word-bits) - string-sap 0 - (* (1+ n) vm:byte-bits)) + (sb-kernel:copy-to-system-area (the simple-string s) + (* sb-vm:vector-data-offset + sb-vm:word-bits) + string-sap 0 + (* (1+ n) sb-vm:byte-bits)) ;; Blast the pointer to the string into place. (setf (sap-ref-sap vec-sap i) string-sap) (setf string-sap (sap+ string-sap (round-bytes-to-words (1+ n)))) @@ -319,71 +317,66 @@ work on SBCL. At the very least: (let ((sap (gensym "SAP-")) (size (gensym "SIZE-"))) `(multiple-value-bind - (,sap ,var ,size) - (string-list-to-c-strvec ,str-list) - (unwind-protect + (,sap ,var ,size) + (string-list-to-c-strvec ,str-list) + (unwind-protect (progn ,@body) - (system:deallocate-system-memory ,sap ,size))))) + (sb-sys:deallocate-system-memory ,sap ,size))))) -(alien:def-alien-routine spawn c-call:int - (program c-call:c-string) - (argv (* c-call:c-string)) - (envp (* c-call:c-string)) - (pty-name c-call:c-string) - (stdin c-call:int) - (stdout c-call:int) - (stderr c-call:int)) +(sb-alien:def-alien-routine spawn sb-c-call:int + (program sb-c-call:c-string) + (argv (* sb-c-call:c-string)) + (envp (* sb-c-call:c-string)) + (pty-name sb-c-call:c-string) + (stdin sb-c-call:int) + (stdout sb-c-call:int) + (stderr sb-c-call:int)) ;;; RUN-PROGRAM uses fork and execve to run a different program. ;;; Strange stuff happens to keep the unix state of the world ;;; coherent. ;;; -;;; The child process needs to get it's input from somewhere, and send it's -;;; output (both standard and error) to somewhere. We have to do different -;;; things depending on where these somewheres really are. +;;; The child process needs to get it's input from somewhere, and send +;;; its output (both standard and error) to somewhere. We have to do +;;; different things depending on where these somewheres really are. ;;; ;;; For input, there are five options: -;;; - T: Just leave fd 0 alone. Pretty simple. -;;; - "file": Read from the file. We need to open the file and pull the -;;; descriptor out of the stream. The parent should close this stream after -;;; the child is up and running to free any storage used in the parent. -;;; - NIL: Same as "file", but use "/dev/null" as the file. -;;; - :STREAM: Use unix-pipe to create two descriptors. Use system:make-fd-stream -;;; to create the output stream on the writeable descriptor, and pass the -;;; readable descriptor to the child. The parent must close the readable -;;; descriptor for EOF to be passed up correctly. -;;; - a stream: If it's a fd-stream, just pull the descriptor out of it. -;;; Otherwise make a pipe as in :STREAM, and copy everything across. +;;; -- T: Just leave fd 0 alone. Pretty simple. +;;; -- "file": Read from the file. We need to open the file and +;;; pull the descriptor out of the stream. The parent should close +;;; this stream after the child is up and running to free any +;;; storage used in the parent. +;;; -- NIL: Same as "file", but use "/dev/null" as the file. +;;; -- :STREAM: Use unix-pipe to create two descriptors. Use +;;; sb-sys:make-fd-stream to create the output stream on the +;;; writeable descriptor, and pass the readable descriptor to +;;; the child. The parent must close the readable descriptor for +;;; EOF to be passed up correctly. +;;; -- a stream: If it's a fd-stream, just pull the descriptor out +;;; of it. Otherwise make a pipe as in :STREAM, and copy +;;; everything across. ;;; -;;; For output, there are n options: -;;; - T: Leave descriptor 1 alone. -;;; - "file": dump output to the file. -;;; - NIL: dump output to /dev/null. -;;; - :STREAM: return a stream that can be read from. -;;; - a stream: if it's a fd-stream, use the descriptor in it. Otherwise, copy -;;; stuff from output to stream. +;;; For output, there are five options: +;;; -- T: Leave descriptor 1 alone. +;;; -- "file": dump output to the file. +;;; -- NIL: dump output to /dev/null. +;;; -- :STREAM: return a stream that can be read from. +;;; -- a stream: if it's a fd-stream, use the descriptor in it. +;;; Otherwise, copy stuff from output to stream. ;;; ;;; For error, there are all the same options as output plus: -;;; - :OUTPUT: redirect to the same place as output. +;;; -- :OUTPUT: redirect to the same place as output. ;;; -;;; RUN-PROGRAM returns a process struct for the process if the fork -;;; worked, and NIL if it did not. +;;; RUN-PROGRAM returns a PROCESS structure for the process if +;;; the fork worked, and NIL if it did not. (defun run-program (program args - &key - (env *environment-list*) - (wait t) - pty - input - if-input-does-not-exist - output - (if-output-exists :error) - (error :output) - (if-error-exists :error) - status-hook) - "RUN-PROGRAM creates a new process and runs the unix program in the - file specified by PROGRAM (a SIMPLE-STRING). ARGS are the standard - arguments that can be passed to a Unix program; for no arguments + &key env (wait t) pty input + if-input-does-not-exist output (if-output-exists :error) + (error :output) (if-error-exists :error) status-hook) + "RUN-PROGRAM creates a new process and runs the unix progam in the + file specified by the simple-string program. Args are the standard + arguments that can be passed to a Unix program, for no arguments use NIL (which means just the name of the program is passed as arg 0). RUN-PROGRAM will either return NIL or a PROCESS structure. See the CMU @@ -391,7 +384,7 @@ work on SBCL. At the very least: The keyword arguments have the following meanings: :env - - An alist mapping keyword environment variables to SIMPLE-STRING + An A-LIST mapping keyword environment variables to simple-string values. :wait - If non-NIL (default), wait until the created process finishes. If @@ -434,65 +427,58 @@ work on SBCL. At the very least: This is a function the system calls whenever the status of the process changes. The function takes the process as an argument." - ;; Make sure that the interrupt handler is installed. - (system:enable-interrupt unix:sigchld #'sigchld-handler) - ;; Make sure that all the args are okay. + ;; Make sure the interrupt handler is installed. + (sb-sys:enable-interrupt sb-unix:sigchld #'sigchld-handler) + ;; Make sure all the args are okay. (unless (every #'simple-string-p args) - ;; FIXME: should be some sort of TYPE-ERROR? or perhaps we should - ;; just be nice and call (COERCE FOO 'SIMPLE-STRING) on each of - ;; our arguments, since it's reasonable for the user to pass in - ;; (at least) non-SIMPLE STRING values. - (error "All args to program must be simple strings: ~S." args)) - ;; Prepend the program to the argument list. + (error "All arguments to program must be simple strings: ~S" args)) + ;; Pre-pend the program to the argument list. (push (namestring program) args) ;; Clear various specials used by GET-DESCRIPTOR-FOR to communicate - ;; cleanup info. Also, establish proc at this level so that we can + ;; cleanup info. Also, establish proc at this level so we can ;; return it. (let (*close-on-error* *close-in-parent* *handlers-installed* proc) (unwind-protect - (let ((pfile (unix-namestring (merge-pathnames program "path:") t t)) - (cookie (list 0))) - (unless pfile - (error "no such program: ~S" program)) - (multiple-value-bind - (stdin input-stream) - (get-descriptor-for input cookie - :direction :input - :if-does-not-exist if-input-does-not-exist) - (multiple-value-bind - (stdout output-stream) - (get-descriptor-for output cookie - :direction :output - :if-exists if-output-exists) - (multiple-value-bind - (stderr error-stream) - (if (eq error :output) - (values stdout output-stream) - (get-descriptor-for error cookie - :direction :output - :if-exists if-error-exists)) - (multiple-value-bind (pty-name pty-stream) - (open-pty pty cookie) - ;; Make sure we are not notified about the child - ;; death before we have installed the process struct - ;; in *ACTIVE-PROCESSES*. - (system:without-interrupts + (let ((pfile (unix-namestring (merge-pathnames program "path:") t t)) + (cookie (list 0))) + (unless pfile + (error "no such program: ~S" program)) + (multiple-value-bind + (stdin input-stream) + (get-descriptor-for input cookie :direction :input + :if-does-not-exist if-input-does-not-exist) + (multiple-value-bind + (stdout output-stream) + (get-descriptor-for output cookie :direction :output + :if-exists if-output-exists) + (multiple-value-bind + (stderr error-stream) + (if (eq error :output) + (values stdout output-stream) + (get-descriptor-for error cookie :direction :output + :if-exists if-error-exists)) + (multiple-value-bind (pty-name pty-stream) + (open-pty pty cookie) + ;; Make sure we are not notified about the child + ;; death before we have installed the PROCESS + ;; structure in *ACTIVE-PROCESSES*. + (sb-sys:without-interrupts (with-c-strvec (argv args) (with-c-strvec - (envp (mapcar (lambda (entry) - (concatenate - 'string - (symbol-name (car entry)) - "=" - (cdr entry))) + (envp (mapcar #'(lambda (entry) + (concatenate + 'string + (symbol-name (car entry)) + "=" + (cdr entry))) env)) (let ((child-pid (without-gcing (spawn pfile argv envp pty-name stdin stdout stderr)))) (when (< child-pid 0) - (error "could not fork child process: ~A" - (unix:get-unix-error-msg))) + (error "could not fork child process: ~S" + (sb-unix:get-unix-error-msg))) (setf proc (make-process :pid child-pid :%status :running :pty pty-stream @@ -501,68 +487,79 @@ work on SBCL. At the very least: :error error-stream :status-hook status-hook :cookie cookie)) - (push proc *active-processes*)))))))))) + (push proc *active-processes*)))))))))) (dolist (fd *close-in-parent*) - (unix:unix-close fd)) + (sb-unix:unix-close fd)) (unless proc (dolist (fd *close-on-error*) - (unix:unix-close fd)) + (sb-unix:unix-close fd)) (dolist (handler *handlers-installed*) - (system:remove-fd-handler handler)))) + (sb-sys:remove-fd-handler handler)))) (when (and wait proc) (process-wait proc)) proc)) -;;; Install a handler for any input that shows up on the file -;;; descriptor. The handler reads the data and writes it to the stream. +;;; COPY-DESCRIPTOR-TO-STREAM -- internal +;;; +;;; Installs a handler for any input that shows up on the file descriptor. +;;; The handler reads the data and writes it to the stream. +;;; (defun copy-descriptor-to-stream (descriptor stream cookie) (incf (car cookie)) (let ((string (make-string 256)) handler) (setf handler - (system:add-fd-handler descriptor :input - #'(lambda (fd) - (declare (ignore fd)) - (loop - (unless handler - (return)) - (multiple-value-bind - (result readable/errno) - (unix:unix-select (1+ descriptor) (ash 1 descriptor) - 0 0 0) - (cond ((null result) - (error "could not select on sub-process: ~A" - (unix:get-unix-error-msg readable/errno))) - ((zerop result) - (return)))) - (alien:with-alien ((buf (alien:array c-call:char 256))) - (multiple-value-bind - (count errno) - (unix:unix-read descriptor (alien-sap buf) 256) - (cond ((or (and (null count) - (eql errno unix:eio)) - (eql count 0)) - (system:remove-fd-handler handler) - (setf handler nil) - (decf (car cookie)) - (unix:unix-close descriptor) - (return)) - ((null count) - (system:remove-fd-handler handler) - (setf handler nil) - (decf (car cookie)) - (error "could not read input from sub-process: ~A" - (unix:get-unix-error-msg errno))) - (t - (kernel:copy-from-system-area - (alien-sap buf) 0 - string (* vm:vector-data-offset vm:word-bits) - (* count vm:byte-bits)) - (write-string string stream - :end count))))))))))) + (sb-sys:add-fd-handler + descriptor + :input #'(lambda (fd) + (declare (ignore fd)) + (loop + (unless handler + (return)) + (multiple-value-bind + (result readable/errno) + (sb-unix:unix-select (1+ descriptor) + (ash 1 descriptor) + 0 0 0) + (cond ((null result) + (error "could not select on sub-process: ~S" + (sb-unix:get-unix-error-msg + readable/errno))) + ((zerop result) + (return)))) + (sb-alien:with-alien ((buf (sb-alien:array + sb-c-call:char + 256))) + (multiple-value-bind + (count errno) + (sb-unix:unix-read descriptor + (alien-sap buf) + 256) + (cond ((or (and (null count) + (eql errno sb-unix:eio)) + (eql count 0)) + (sb-sys:remove-fd-handler handler) + (setf handler nil) + (decf (car cookie)) + (sb-unix:unix-close descriptor) + (return)) + ((null count) + (sb-sys:remove-fd-handler handler) + (setf handler nil) + (decf (car cookie)) + (error "could not read input from sub-process: ~S" + (sb-unix:get-unix-error-msg errno))) + (t + (sb-kernel:copy-from-system-area + (alien-sap buf) 0 + string (* sb-vm:vector-data-offset + sb-vm:word-bits) + (* count sb-vm:byte-bits)) + (write-string string stream + :end count))))))))))) ;;; Find a file descriptor to use for object given the direction. -;;; Return the descriptor. If object is :STREAM, return the created +;;; Returns the descriptor. If object is :STREAM, returns the created ;;; stream as the second value. (defun get-descriptor-for (object cookie @@ -575,88 +572,90 @@ work on SBCL. At the very least: ((eq object nil) ;; Use /dev/null. (multiple-value-bind - (fd errno) - (unix:unix-open "/dev/null" - (case direction - (:input unix:o_rdonly) - (:output unix:o_wronly) - (t unix:o_rdwr)) - #o666) + (fd errno) + (sb-unix:unix-open "/dev/null" + (case direction + (:input sb-unix:o_rdonly) + (:output sb-unix:o_wronly) + (t sb-unix:o_rdwr)) + #o666) (unless fd - (error "could not open \"/dev/null\": ~A" - (unix:get-unix-error-msg errno))) + (error "could not open \"/dev/null\": ~S" + (sb-unix:get-unix-error-msg errno))) (push fd *close-in-parent*) (values fd nil))) ((eq object :stream) (multiple-value-bind - (read-fd write-fd) - (unix:unix-pipe) + (read-fd write-fd) + (sb-unix:unix-pipe) (unless read-fd - (error "could not create pipe: ~A" - (unix:get-unix-error-msg write-fd))) + (error "could not create pipe: ~S" + (sb-unix:get-unix-error-msg write-fd))) (case direction (:input (push read-fd *close-in-parent*) (push write-fd *close-on-error*) - (let ((stream (system:make-fd-stream write-fd :output t))) + (let ((stream (sb-sys:make-fd-stream write-fd :output t))) (values read-fd stream))) (:output (push read-fd *close-on-error*) (push write-fd *close-in-parent*) - (let ((stream (system:make-fd-stream read-fd :input t))) + (let ((stream (sb-sys:make-fd-stream read-fd :input t))) (values write-fd stream))) (t - (unix:unix-close read-fd) - (unix:unix-close write-fd) - (error "direction must be either :INPUT or :OUTPUT, not ~S" + (sb-unix:unix-close read-fd) + (sb-unix:unix-close write-fd) + (error "Direction must be either :INPUT or :OUTPUT, not ~S." direction))))) ((or (pathnamep object) (stringp object)) (with-open-stream (file (apply #'open object keys)) (multiple-value-bind - (fd errno) - (unix:unix-dup (system:fd-stream-fd file)) + (fd errno) + (sb-unix:unix-dup (sb-sys:fd-stream-fd file)) (cond (fd (push fd *close-in-parent*) (values fd nil)) (t - (error "could not duplicate file descriptor: ~A" - (unix:get-unix-error-msg errno))))))) - ((system:fd-stream-p object) - (values (system:fd-stream-fd object) nil)) + (error "could not duplicate file descriptor: ~S" + (sb-unix:get-unix-error-msg errno))))))) + ((sb-sys:fd-stream-p object) + (values (sb-sys:fd-stream-fd object) nil)) ((streamp object) (ecase direction (:input + ;; FIXME: We could use a better way of setting up + ;; temporary files, both here and in LOAD-FOREIGN. (dotimes (count - 256 + 256 (error "could not open a temporary file in /tmp")) (let* ((name (format nil "/tmp/.run-program-~D" count)) - (fd (unix:unix-open name - (logior unix:o_rdwr - unix:o_creat - unix:o_excl) - #o666))) - (unix:unix-unlink name) + (fd (sb-unix:unix-open name + (logior sb-unix:o_rdwr + sb-unix:o_creat + sb-unix:o_excl) + #o666))) + (sb-unix:unix-unlink name) (when fd (let ((newline (string #\Newline))) (loop - (multiple-value-bind - (line no-cr) - (read-line object nil nil) - (unless line - (return)) - (unix:unix-write fd line 0 (length line)) - (if no-cr - (return) - (unix:unix-write fd newline 0 1))))) - (unix:unix-lseek fd 0 unix:l_set) + (multiple-value-bind + (line no-cr) + (read-line object nil nil) + (unless line + (return)) + (sb-unix:unix-write fd line 0 (length line)) + (if no-cr + (return) + (sb-unix:unix-write fd newline 0 1))))) + (sb-unix:unix-lseek fd 0 sb-unix:l_set) (push fd *close-in-parent*) (return (values fd nil)))))) (:output (multiple-value-bind (read-fd write-fd) - (unix:unix-pipe) + (sb-unix:unix-pipe) (unless read-fd - (error "could not create pipe: ~A" - (unix:get-unix-error-msg write-fd))) + (error "could not create pipe: ~S" + (sb-unix:get-unix-error-msg write-fd))) (copy-descriptor-to-stream read-fd object cookie) (push read-fd *close-on-error*) (push write-fd *close-in-parent*) diff --git a/src/code/target-load.lisp b/src/code/target-load.lisp index ddfb683..8f8a1f0 100644 --- a/src/code/target-load.lisp +++ b/src/code/target-load.lisp @@ -346,7 +346,7 @@ (gethash (concatenate 'simple-string #!+linux "ldso_stub__" #!+openbsd "_" - #!+freebsd "" + #!+freebsd "ldso_stub__" foreign-symbol) *static-foreign-symbols*) (sb!sys:get-dynamic-foreign-symbol-address foreign-symbol) diff --git a/src/code/target-random.lisp b/src/code/target-random.lisp index 31dbe9d..42e1a58 100644 --- a/src/code/target-random.lisp +++ b/src/code/target-random.lisp @@ -54,7 +54,9 @@ (defvar *random-state*) (defun !random-cold-init () - (setf *random-state* (%make-random-state))) + (/show0 "entering !RANDOM-COLD-INIT") + (setf *random-state* (%make-random-state)) + (/show0 "returning from !RANDOM-COLD-INIT")) (defun make-random-state (&optional state) #!+sb-doc diff --git a/src/code/unix.lisp b/src/code/unix.lisp index 477c728..ce25a36 100644 --- a/src/code/unix.lisp +++ b/src/code/unix.lisp @@ -895,8 +895,6 @@ (tm-gmtoff long) ; Seconds east of UTC. (tm-zone c-string))) ; Timezone abbreviation. -(def-alien-variable ("tzname" unix-tzname) (array c-string 2)) - (def-alien-routine get-timezone sb!c-call:void (when sb!c-call:long :in) (minutes-west sb!c-call:int :out) @@ -911,6 +909,7 @@ (multiple-value-bind (ignore minutes dst) (get-timezone secs) (declare (ignore ignore) (ignore minutes)) (values (deref unix-tzname (if dst 1 0))))) + ;;;; sys/time.h @@ -949,7 +948,9 @@ (def-unix-error ENOENT 2 "No such file or directory") #| (def-unix-error ESRCH 3 "No such process") +|# (def-unix-error EINTR 4 "Interrupted system call") +#| (def-unix-error EIO 5 "I/O error") (def-unix-error ENXIO 6 "No such device or address") (def-unix-error E2BIG 7 "Arg list too long") diff --git a/src/cold/warm.lisp b/src/cold/warm.lisp index de0abbc..8efbc69 100644 --- a/src/cold/warm.lisp +++ b/src/cold/warm.lisp @@ -202,8 +202,8 @@ "src/code/inspect" ; FIXME: should be byte compiled "src/code/profile" "src/code/ntrace" - #+nil "src/code/run-program" ; not working as of 0.6.7 "src/code/foreign" + "src/code/run-program" ;; Code derived from PCL's pre-ANSI DESCRIBE-OBJECT ;; facility is still used in our ANSI DESCRIBE ;; facility, and should be compiled and loaded after diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index 06015e4..566ba54 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -1439,7 +1439,7 @@ ;; ..and the fifth seems to match most ;; actual symbols, at least in RedHat 6.2. "") - #!+freebsd #("") + #!+freebsd #("" "ldso_stub__") #!+openbsd #("_"))) (or (some (lambda (prefix) (gethash (concatenate 'string prefix name) diff --git a/src/compiler/globaldb.lisp b/src/compiler/globaldb.lisp index a158013..9245d14 100644 --- a/src/compiler/globaldb.lisp +++ b/src/compiler/globaldb.lisp @@ -28,6 +28,7 @@ "$Header$") (!begin-collecting-cold-init-forms) +#!+sb-show (!cold-init-forms (/show0 "early in globaldb.lisp cold init")) ;;; The DEFVAR for this appears later. ;;; FIXME: centralize diff --git a/src/compiler/x86/parms.lisp b/src/compiler/x86/parms.lisp index bf89e76..29b4dfe 100644 --- a/src/compiler/x86/parms.lisp +++ b/src/compiler/x86/parms.lisp @@ -116,20 +116,18 @@ ;;; ;;; FIXME: Couldn't/shouldn't these be DEFCONSTANT instead of DEFPARAMETER? #!-linux (defparameter *target-read-only-space-start* #x10000000) -#!-linux (defparameter *target-static-space-start* #x28000000) +#!-linux (defparameter *target-static-space-start* + ;; FIXME: was #x28000000 until RAW's RUN-PROGRAM + ;; patches, why the change? + #x30000000) #!-linux (defparameter *target-dynamic-space-start* #x48000000) #!+linux (defparameter *target-read-only-space-start* #x01000000) #!+linux (defparameter *target-static-space-start* #x05000000) #!+linux (defparameter *target-dynamic-space-start* #x09000000) -;;; Given that NIL is the first things allocated in static space, we +;;; Given that NIL is the first thing allocated in static space, we ;;; know its value at compile time: -;;; -;;; FIXME: Couldn't/shouldn't this be a DEFCONSTANT, and shouldn't it be -;;; calculated from TARGET-STATIC-SPACE-START instead of assigned -;;; separately? -#!-linux (defparameter *nil-value* #x2800000B) -#!+linux (defparameter *nil-value* #x0500000B) +(defparameter *nil-value* (+ *target-static-space-start* #xb)) ;;;; other miscellaneous constants diff --git a/src/pcl/gray-streams-class.lisp b/src/pcl/gray-streams-class.lisp index ac627fc..58301b5 100644 --- a/src/pcl/gray-streams-class.lisp +++ b/src/pcl/gray-streams-class.lisp @@ -21,25 +21,25 @@ (:documentation "the base class for all CLOS streams"))) ;;; Define the stream classes. -(defclass fundamental-input-stream (fundamental-stream)) +(defclass fundamental-input-stream (fundamental-stream) nil) -(defclass fundamental-output-stream (fundamental-stream)) +(defclass fundamental-output-stream (fundamental-stream) nil) -(defclass fundamental-character-stream (fundamental-stream)) +(defclass fundamental-character-stream (fundamental-stream) nil) -(defclass fundamental-binary-stream (fundamental-stream)) +(defclass fundamental-binary-stream (fundamental-stream) nil) (defclass fundamental-character-input-stream - (fundamental-input-stream fundamental-character-stream)) + (fundamental-input-stream fundamental-character-stream) nil) (defclass fundamental-character-output-stream - (fundamental-output-stream fundamental-character-stream)) + (fundamental-output-stream fundamental-character-stream) nil) (defclass fundamental-binary-input-stream - (fundamental-input-stream fundamental-binary-stream)) + (fundamental-input-stream fundamental-binary-stream) nil) (defclass fundamental-binary-output-stream - (fundamental-output-stream fundamental-binary-stream)) + (fundamental-output-stream fundamental-binary-stream) nil) ;;; example character input and output streams diff --git a/src/pcl/gray-streams.lisp b/src/pcl/gray-streams.lisp index f34ebbb..f279a72 100644 --- a/src/pcl/gray-streams.lisp +++ b/src/pcl/gray-streams.lisp @@ -36,7 +36,7 @@ called on the stream.")) (defmethod pcl-open-stream-p ((stream lisp-stream)) - (not (eq (lisp-stream-in stream) #'closed-flame))) + (not (eq (sb-impl::lisp-stream-in stream) #'sb-impl::closed-flame))) (defmethod pcl-open-stream-p ((stream fundamental-stream)) nil) @@ -66,8 +66,8 @@ (:documentation "Returns non-nil if the given Stream can perform input operations.")) (defmethod input-stream-p ((stream lisp-stream)) - (and (not (eq (lisp-stream-in stream) #'closed-flame)) - (or (not (eq (lisp-stream-in stream) #'ill-in)) + (and (not (eq (sb-impl::lisp-stream-in stream) #'sb-impl::closed-flame)) + (or (not (eq (sb-impl::lisp-stream-in stream) #'ill-in)) (not (eq (lisp-stream-bin stream) #'ill-bin))))) (defmethod input-stream-p ((stream fundamental-input-stream)) @@ -80,7 +80,7 @@ (:documentation "Returns non-nil if the given Stream can perform output operations.")) (defmethod output-stream-p ((stream lisp-stream)) - (and (not (eq (lisp-stream-in stream) #'closed-flame)) + (and (not (eq (sb-impl::lisp-stream-in stream) #'sb-impl::closed-flame)) (or (not (eq (lisp-stream-out stream) #'ill-out)) (not (eq (lisp-stream-bout stream) #'ill-bout))))) diff --git a/src/runtime/Config.x86-bsd b/src/runtime/Config.x86-bsd index 170aab8..49d74b6 100644 --- a/src/runtime/Config.x86-bsd +++ b/src/runtime/Config.x86-bsd @@ -12,7 +12,11 @@ ASSEM_SRC = x86-assem.S ARCH_SRC = x86-arch.c OS_SRC = bsd-os.c os-common.c undefineds.c -OS_LINK_FLAGS=-static +# Until version 0.6.7.3, we used "OS_LINK_FLAGS=-static" here, which +# worked fine for most things, but LOAD-FOREIGN & friends require +# dlopen() etc., which in turn depend on dynamic linking of the +# runtime. +OS_LINK_FLAGS=-dynamic -export-dynamic OS_LIBS=-lm # -ldl GC_SRC= gencgc.c diff --git a/src/runtime/GNUmakefile b/src/runtime/GNUmakefile index dbdef41..a8c4e79 100644 --- a/src/runtime/GNUmakefile +++ b/src/runtime/GNUmakefile @@ -25,7 +25,7 @@ include Config SRCS = alloc.c backtrace.c breakpoint.c coreparse.c \ dynbind.c globals.c interr.c interrupt.c \ monitor.c parse.c print.c purify.c \ - regnames.c runtime.c save.c search.c \ + regnames.c runprog.c runtime.c save.c search.c \ time.c validate.c vars.c \ ${ARCH_SRC} ${ASSEM_SRC} ${OS_SRC} ${GC_SRC} diff --git a/src/runtime/bsd-os.c b/src/runtime/bsd-os.c index 1560173..44b5a05 100644 --- a/src/runtime/bsd-os.c +++ b/src/runtime/bsd-os.c @@ -1,5 +1,5 @@ /* - * OS-dependent routines for FreeBSD (and could maybe be extended to all BSD?) + * OS-dependent routines for BSD-ish systems * * This file (along with os.h) exports an OS-independent interface to * the operating system VM facilities. This interface looks a lot like @@ -245,3 +245,271 @@ os_install_interrupt_handlers(void) } #endif /* !defined GENCGC */ + +/* feh! + * + * DL_WORKAROUND enables "stubbing" of various functions from libc et + * al. This is necessary when using dynamic linking in FreeBSD, as the + * symbols in the dynamic libraries will not have known addresses (in + * sbcl.nm). + * + * FIXME: This flag should be set in Config.bsd */ +#define DL_WORKAROUND 1 + +#if DL_WORKAROUND +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +void *ldso_stub__dlopen(const char *path, int mode) +{ + return dlopen(path, mode); +} + +void *ldso_stub__dlsym(void *handle, const char *symbol) +{ + return dlsym(handle, symbol); +} + +const char *ldso_stub__dlerror(void) +{ + return dlerror(); +} +int ldso_stub__access(const char *path, int mode) +{ + return access(path, mode); +} + +double ldso_stub__acos(double x) +{ + return acos(x); +} + +double ldso_stub__acosh(double x) +{ + return acosh(x); +} + +double ldso_stub__asin(double x) +{ + return asin(x); +} + +double ldso_stub__asinh(double x) +{ + return asin(x); +} + +double ldso_stub__atanh(double x) +{ + return atanh(x); +} + + +int ldso_stub__chdir(const char *path) +{ + return chdir(path); +} + +int ldso_stub__close(int d) +{ + return close(d); +} + +int ldso_stub__closedir(DIR *dirp) +{ + return closedir(dirp); +} + +double ldso_stub__cosh(double x) +{ + return cosh(x); +} + +void ldso_stub__exit(int status) +{ + exit(status); +} + +void ldso_stub__free(void *ptr) +{ + free(ptr); +} + +int ldso_stub__fstat(int fd, struct stat *sb) +{ + return fstat(fd, sb); +} + +int ldso_stub__fsync(int fd) +{ + return fsync(fd); +} + +char *ldso_stub__getenv(const char *name) +{ + return getenv(name); +} + +int ldso_stub__gethostname(char *name, int namelen) +{ + return gethostname(name, namelen); +} + +pid_t ldso_stub__getpid(void) +{ + return getpid(); +} + +int ldso_stub__getrusage(int who, struct rusage *rusage) +{ + return getrusage(who, rusage); +} + +int ldso_stub__gettimeofday(struct timeval *tp, struct timezone *tzp) +{ + return gettimeofday(tp, tzp); +} + +uid_t ldso_stub__getuid(void) +{ + return getuid(); +} + +char *ldso_stub__getwd(char *buf) +{ + return getwd(buf); +} + +double ldso_stub__hypot(double x, double y) +{ + return hypot(x, y); +} + +int ldso_stub__kill(pid_t pid, int sig) +{ + return kill(pid, sig); +} + +int ldso_stub__killpg(pid_t pgrp, int sig) +{ + return killpg(pgrp, sig); +} + +off_t ldso_stub__lseek(int fildes, off_t offset, int whence) +{ + return lseek(fildes, offset, whence); +} + +int ldso_stub__lstat(const char *path, struct stat *sb) +{ + return lstat(path, sb); +} + +void *ldso_stub__malloc(size_t size) +{ + return malloc(size); +} + +int ldso_stub__mkdir(const char *path, mode_t mode) +{ + return mkdir(path, mode); +} + +int ldso_stub__open(const char *path, int flags, mode_t mode) +{ + return open(path, flags, mode); +} + +DIR *ldso_stub__opendir(const char *filename) +{ + return opendir(filename); +} + +double ldso_stub__pow(double x, double y) +{ + return pow(x, y); +} + +ssize_t ldso_stub__read(int d, void *buf, size_t nbytes) +{ + return read(d, buf, nbytes); +} + +struct dirent *ldso_stub__readdir(DIR *dirp) +{ + return readdir(dirp); +} + +int ldso_stub__readlink(const char *path, char *buf, int bufsiz) +{ + return readlink(path, buf, bufsiz); +} + +int ldso_stub__rename(const char *from, const char *to) +{ + return rename(from, to); +} + +int ldso_stub__select(int nfds, fd_set *readfs, fd_set *writefds, + fd_set *exceptfds, struct timeval *timeout) +{ + return select(nfds, readfs, writefds, exceptfds, timeout); +} + +int ldso_stub__sigblock(int mask) +{ + return sigblock(mask); +} + +int ldso_stub__sigpause(int sigmask) +{ + return sigpause(sigmask); +} + +int ldso_stub__sigsetmask(int mask) +{ + return sigsetmask(mask); +} + +double ldso_stub__sinh(double x) +{ + return sin(x); +} + +int ldso_stub__stat(const char *path, struct stat *sb) +{ + return stat(path, sb); +} + +double ldso_stub__tanh(double x) +{ + return tanh(x); +} + +/* tzname */ + +int ldso_stub__unlink(const char *path) +{ + return unlink(path); +} + +ssize_t ldso_stub__write(int d, const void *buf, size_t nbytes) +{ + return write(d, buf, nbytes); +} + +pid_t ldso_stub__wait3(int *status, int options, struct rusage *rusage) +{ + return wait3(status, options, rusage); +} + +#endif /* DL_WORKAROUND */ diff --git a/src/runtime/undefineds.h b/src/runtime/undefineds.h index 0826b59..acbf329 100644 --- a/src/runtime/undefineds.h +++ b/src/runtime/undefineds.h @@ -257,12 +257,14 @@ F(gethostbyname) F(gethostbyaddr) /* Other miscellaneous things. */ -#if defined(SVR4) +#if defined(SVR4) || defined(__FreeBSD__) F(setpgid) F(getpgid) D(timezone) +#if !defined(__FreeBSD__) D(altzone) D(daylight) +#endif D(tzname) F(dlopen) F(dlsym) diff --git a/src/runtime/x86-validate.h b/src/runtime/x86-validate.h index f9fcde2..2fdf41e 100644 --- a/src/runtime/x86-validate.h +++ b/src/runtime/x86-validate.h @@ -14,14 +14,14 @@ */ /* - * Address map: + * address map: * * FreeBSD: * 0x00000000->0x0E000000 224M C program and memory allocation. * 0x0E000000->0x10000000 32M Foreign segment. * 0x10000000->0x20000000 256M Read-Only Space. - * 0x20000000->0x28000000 128M Reserved for shared libraries. - * 0x28000000->0x38000000 256M Static Space. + * 0x20000000->0x30000000 256M Reserved for shared libraries. + * 0x30000000->0x38000000 128M Static Space. * 0x38000000->0x40000000 128M Binding stack growing up. * 0x40000000->0x48000000 128M Control stack growing down. * 0x48000000->0xC8000000 2GB Dynamic Space. @@ -40,14 +40,15 @@ * * FIXME: There's something wrong with addressing maps which are so * brittle that they can be commented as fixed addresses. Try to - * parameterize these so they can be set at build time. */ + * parameterize these so they can be set at build time. + */ #if defined(__FreeBSD__) || defined(__OpenBSD__) #define READ_ONLY_SPACE_START (0x10000000) #define READ_ONLY_SPACE_SIZE (0x0ffff000) /* 256MB - 1 page */ -#define STATIC_SPACE_START (0x28000000) -#define STATIC_SPACE_SIZE (0x0ffff000) /* 256MB - 1 page */ +#define STATIC_SPACE_START (0x30000000) +#define STATIC_SPACE_SIZE (0x07fff000) /* 128M - 1 page */ #define BINDING_STACK_START (0x38000000) #define BINDING_STACK_SIZE (0x07fff000) /* 128MB - 1 page */ diff --git a/version.lisp-expr b/version.lisp-expr index 90f18f6..7205a7a 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -15,4 +15,4 @@ ;;; versions, and a string a la "0.6.5.12" is used for versions which ;;; aren't released but correspond only to CVS tags or snapshots. -"0.6.7.3" +"0.6.7.4"