Skip to content
Snippets Groups Projects
Commit 2ff25623 authored by pmai's avatar pmai
Browse files

This commit adds the remainder of the outstanding PPC/Darwin port merge.

Besides support for Darwin foreign loading, and updates to the ppc-vm
and bsd-os files, this commit removes unix:unix-errno as a foreign variable
and replaces it with a function named unix-errno, and a (setf unix-errno).
This makes both glibc support cleaner, and enables ports like PPC/Darwin
(and the upcoming win32 port) which have no easy way of accessing errno as
a foreign variable able to support this functionality at all.

The current implementation of this is rather make-shift, it would likely
be much cleaner to go the SBCL way and mediate all access to errno via
defined functions in the C runtime.

As an interim feature, the frobbing of the float-trap-modes is currently
commented out for Darwin because of ongoing breakage.
parent b7dbd336
No related branches found
No related tags found
No related merge requests found
......@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/bsd-os.lisp,v 1.6 2002/11/18 13:52:24 toy Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/bsd-os.lisp,v 1.7 2004/07/25 19:32:37 pmai Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -17,17 +17,25 @@
;;; Hacked into (Free)bsd-os.lisp by Paul Werkowski.
;;; Generalized a bit for OpenBSD by Pierre R. Mai.
;;; Support for NetBSD by Pierre R. Mai.
;;; Support for Darwin by Pierre R. Mai.
(in-package "SYSTEM")
(use-package "EXTENSIONS")
(export '(get-system-info get-page-size os-init))
(pushnew :bsd *features*)
(register-lisp-feature :bsd)
(register-lisp-feature #+OpenBSD :OpenBSD
#+NetBSD :NetBSD
#+FreeBSD :FreeBSD
#+Darwin :Darwin
#-(or FreeBSD NetBSD OpenBSD Darwin) :bsd)
(setq *software-type* #+OpenBSD "OpenBSD"
#+NetBSD "NetBSD"
#+FreeBSD "FreeBSD"
#-(or FreeBSD NetBSD OpenBSD) "BSD")
#+Darwin "Darwin"
#-(or FreeBSD NetBSD OpenBSD Darwin) "BSD")
(defvar *software-version* nil "Version string for supporting software")
......
......@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/float-trap.lisp,v 1.24 2004/03/24 13:26:18 emarsden Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/float-trap.lisp,v 1.25 2004/07/25 19:32:37 pmai Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -130,6 +130,8 @@
(when precision-control-p
(warn "Precision control only available for x86"))
;; Temporarily disabled on darwin due to strange breakage
#-darwin
(setf (floating-point-modes) modes))
(values))
......
......@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/foreign.lisp,v 1.49 2004/07/07 15:03:11 rtoy Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/foreign.lisp,v 1.50 2004/07/25 19:32:37 pmai Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -28,7 +28,7 @@
(defconstant foreign-segment-size #x02000000)
(defvar *previous-linked-object-file* nil)
#-(or openbsd linux irix)
#-(or linux bsd svr4 irix)
(defvar *foreign-segment-free-pointer* foreign-segment-start)
(defun pick-temporary-file-name (&optional (base "/tmp/tmp~D~C"))
......@@ -86,7 +86,7 @@
;;; The following definitions are taken from
;;; /usr/include/sys/elf_common.h and /usr/include/sys/elf32.h.
;;;
#+(or linux bsd svr4)
#+(or linux (and bsd (not darwin)) svr4)
(progn
(alien:def-alien-type elf-address (alien:unsigned 32))
(alien:def-alien-type elf-half-word (alien:unsigned 16))
......@@ -206,7 +206,57 @@
(unix:unix-read fd (alien:alien-sap header) (alien:alien-size eheader :bytes))
(when (elf-p (alien:slot header 'elf-ident))
(eql et-shared-object (alien:slot header 'elf-type)))))))
) ;; #+(or linux bsd svr4)
) ;; #+(or linux (and bsd (not darwin)) svr4)
;; Darwin loading of foreign code. This uses the dlopen shims and thus
;; appears like ELF to the rest of the code in this file. However testing
;; for shared libs obviously needs to test for Mach-O dylibs, and not
;; ELF shared libraries...
#+darwin
(progn
(alien:def-alien-type machheader
(alien:struct nil
(magic (alien:unsigned 32))
(cputype (alien:signed 32))
(cpusubtype (alien:signed 32))
(filetype (alien:unsigned 32))
(ncmds (alien:unsigned 32))
(sizeofcmds (alien:unsigned 32))
(flags (alien:unsigned 32))))
;; values for magic
(defconstant mh-magic #xfeedface)
;; values for filetype
(defconstant mh-object #x1)
(defconstant mh-execute #x2)
(defconstant mh-fvmlib #x3)
(defconstant mh-core #x4)
(defconstant mh-preload #x5)
(defconstant mh-dylib #x6)
(defconstant mh-dylinker #x7)
(defconstant mh-bundle #x8)
(defconstant mh-dylib-stub #x9)
(defun mach-o-p (h)
"Make sure the header starts with the mach-o magic value."
(eql (alien:slot h 'magic) mh-magic))
(defun file-shared-library-p (pathname)
(with-open-file (obj pathname
:direction :input
:element-type '(unsigned-byte 8))
(let ((fd (lisp::fd-stream-fd obj)))
(alien:with-alien ((header machheader))
(unix:unix-read fd (alien:alien-sap header)
(alien:alien-size machheader :bytes))
(when (mach-o-p header)
(or (eql mh-dylib (alien:slot header 'filetype))
(eql mh-bundle (alien:slot header 'filetype))))))))
) ; #+darwin
......@@ -706,11 +756,13 @@ environment passed to Lisp."
(list*
#+(or solaris linux FreeBSD4) "-G"
#+(or OpenBSD NetBSD irix) "-shared"
#+darwin "-dylib"
"-o"
output-file
;; Cause all specified libs to be loaded in full
#+(or OpenBSD linux FreeBSD4 NetBSD) "--whole-archive"
#+solaris "-z" #+solaris "allextract"
#+darwin "-all_load"
(append (mapcar
#'(lambda (name)
(or (unix-namestring name)
......
......@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/internet.lisp,v 1.40 2004/04/23 12:42:04 emarsden Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/internet.lisp,v 1.41 2004/07/25 19:32:38 pmai Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -436,7 +436,7 @@ struct in_addr {
(with-alien ((optval signed))
(if (minusp (unix:unix-getsockopt socket level optname
(alien-sap (addr optval)) 4))
(values nil unix:unix-errno)
(values nil (unix:unix-errno))
(values optval 0))))
(defun set-socket-option (socket level optname optval)
......@@ -446,7 +446,7 @@ struct in_addr {
(with-alien ((optval signed optval))
(if (minusp (unix:unix-setsockopt socket level optname
(alien-sap (addr optval)) 4))
(values nil unix:unix-errno)
(values nil (unix:unix-errno))
(values optval 0))))
(defun create-inet-listener (port &optional (kind :stream)
......@@ -508,7 +508,7 @@ struct in_addr {
(when (minusp (unix:unix-getpeername fd (alien-sap sockaddr)
(alien-sap length)))
(error "Error ~s getting peer host and port on FD ~d."
(unix:get-unix-error-msg unix:unix-errno) fd))
(unix:get-unix-error-msg (unix:unix-errno)) fd))
(values (ext:ntohl (slot sockaddr 'addr))
(ext:ntohs (slot sockaddr 'port)))))
......@@ -519,7 +519,7 @@ struct in_addr {
(when (minusp (unix:unix-getsockname fd (alien-sap sockaddr)
(alien-sap length)))
(error "Error ~s getting socket host and port on FD ~d."
(unix:get-unix-error-msg unix:unix-errno) fd))
(unix:get-unix-error-msg (unix:unix-errno)) fd))
(values (ext:ntohl (slot sockaddr 'addr))
(ext:ntohs (slot sockaddr 'port)))))
......
......@@ -7,11 +7,11 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/ppc-vm.lisp,v 1.1 2001/02/11 14:22:01 dtc Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/ppc-vm.lisp,v 1.2 2004/07/25 19:32:38 pmai Exp $")
;;;
;;; **********************************************************************
;;;
;;; This file contains the SPARC specific runtime stuff.
;;; This file contains the PPC specific runtime stuff.
;;;
(in-package "PPC")
(use-package "SYSTEM")
......@@ -26,6 +26,7 @@
;;;; The sigcontext structure.
;;;; Note that the layout of this thing matches the word offsets PT_xxx, not
;;;; (necessarily) the pt_regs structure.
#-darwin
(def-alien-type sigcontext-regs
(struct nil
(regs (array unsigned-long 32))
......@@ -46,6 +47,37 @@
(pad2 unsigned-long)
(fpscr unsigned-long)))
;; In reality on darwin this is an instance of struct mcontext, which
;; contains 4 sub-structures, all defined in mach/thread_status.h.
;; For our purposes we just combine this into one structure, defining
;; types and layout as we see fit.
#+darwin
(def-alien-type sigcontext-regs
(struct nil
(dar unsigned-long)
(dsisr unsigned-long)
(exception unsigned-long)
(pad1 unsigned-long)
(pad2 (array unsigned-long 4))
(pc system-area-pointer)
(msr unsigned-long)
(regs (array unsigned-long 32))
(cr unsigned-long)
(xer unsigned-long)
(lr unsigned-long)
(ctr unsigned-long)
(mq unsigned-long)
(vrsave unsigned-long)
(fpregs (array unsigned-long 64))
(pad3 unsigned-long)
(fpscr unsigned-long)
(vrregs (array unsigned-long 128))
(vscr (array unsigned-long 4))
(pad4 (array unsigned-long 4))
(vrvalid unsigned-long)
(pad5 (array unsigned-long 7))))
#-darwin
(def-alien-type sigcontext
(struct nil
(sc-unused (array unsigned-long 4))
......@@ -54,6 +86,18 @@
(sc-oldmask unsigned-long)
(sc-regs (* sigcontext-regs))))
;; Use the ucontext_t structure for Darwin
#+darwin
(def-alien-type sigcontext
(struct nil
(sc-onstack int)
(sc-mask int)
(sc-ss-sp int)
(sc-ss-size int)
(sc-ss-flags int)
(sc-link int)
(sc-mcsize int)
(sc-regs (* sigcontext-regs))))
;;;; Add machine specific features to *features*
......@@ -238,8 +282,28 @@
;;;
(defun extern-alien-name (name)
(declare (type simple-base-string name))
#+darwin
(concatenate 'string "_" name)
#-darwin
(concatenate 'string "" name))
(defun lisp::foreign-symbol-address-aux (name flavor)
(declare (ignore flavor))
(multiple-value-bind (value found)
(gethash name lisp::*foreign-symbols* 0)
(if found
value
(multiple-value-bind (value found)
(gethash
(concatenate 'string "ldso_stub__" name)
lisp::*foreign-symbols* 0)
(if found
value
(let ((value (system:alternate-get-global-address name)))
(when (zerop value)
(error "Unknown foreign symbol: ~S" name))
value))))))
;;; SANCTIFY-FOR-EXECUTION -- Interface.
......
......@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/signal.lisp,v 1.35 2003/08/31 10:50:15 gerd Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/signal.lisp,v 1.36 2004/07/25 19:32:38 pmai Rel $")
;;;
;;; **********************************************************************
;;;
......@@ -174,7 +174,7 @@
id pid. Signal should be a valid signal number or a keyword of the
standard UNIX signal name."
(if (minusp (real-unix-kill pid (unix-signal-number signal)))
(values nil unix-errno)
(values nil (unix-errno))
t))
(declaim (inline real-unix-killpg))
......@@ -188,7 +188,7 @@
group PGRP. Signal should be a valid signal number or a keyword of
the standard UNIX signal name."
(if (minusp (real-unix-killpg pgrp (unix-signal-number signal)))
(values nil unix-errno)
(values nil (unix-errno))
t))
(alien:def-alien-routine ("sigblock" unix-sigblock) c-call:unsigned-long
......
......@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/unix-glibc2.lisp,v 1.31 2004/06/01 23:16:00 cwang Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/unix-glibc2.lisp,v 1.32 2004/07/25 19:32:38 pmai Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -312,19 +312,21 @@
;;;; System calls.
(def-alien-variable ("errno" unix-errno) int)
(def-alien-variable ("errno" unix-internal-errno) int)
;;; later...
(defun unix-get-errno ())
(defun unix-errno () (unix-get-errno) unix-internal-errno)
(defun (setf unix-errno) (newvalue) (setf unix-internal-errno newvalue))
;;; GET-UNIX-ERROR-MSG -- public.
;;;
(defun get-unix-error-msg (&optional (error-number unix-errno))
(defun get-unix-error-msg (&optional (error-number (unix-errno)))
"Returns a string describing the error number which was returned by a
UNIX system call."
(declare (type integer error-number))
(unix-get-errno)
(if (array-in-bounds-p *unix-errors* error-number)
(svref *unix-errors* error-number)
(format nil "Unknown error [~d]" error-number)))
......@@ -333,9 +335,7 @@
`(let ((result (alien-funcall (extern-alien ,name (function int ,@arg-types))
,@args)))
(if (minusp result)
(progn
(unix-get-errno)
(values nil unix-errno))
(values nil (unix-errno))
,success-form)))
;;; Like syscall, but if it fails, signal an error instead of returning error
......@@ -469,8 +469,7 @@
c-string))
pathname)))
(if (zerop (sap-int dir-struct))
(progn (unix-get-errno)
(values nil unix-errno))
(values nil (unix-errno))
(make-directory :name pathname :dir-struct dir-struct))))
((nil)
(values nil enoent))
......@@ -1854,9 +1853,7 @@ length LEN and type TYPE."
(extern-alien "lseek64" (function off-t int off-t int))
fd offset whence)))
(if (minusp result)
(progn
(unix-get-errno)
(values nil unix-errno))
(values nil (unix-errno))
(values result 0))))
......
......@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/unix.lisp,v 1.95 2004/07/15 16:26:15 rtoy Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/unix.lisp,v 1.96 2004/07/25 19:32:38 pmai Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -484,7 +484,7 @@
(st-blocks #-alpha long #+alpha int)
(st-spare4 (array long 2))))
#+BSD
#+(and :BSD (not :darwin))
(def-alien-type nil
(struct stat
(st-dev dev-t)
......@@ -505,6 +505,37 @@
(st-flags unsigned-long)
(st-gen unsigned-long)
(st-lspare long)
(st-qspare (array long 4))))
#+(and :BSD :darwin)
(def-alien-type nil
(struct stat
(st-dev dev-t)
(st-ino ino-t)
(st-mode mode-t)
(st-nlink nlink-t)
(st-uid uid-t)
(st-gid gid-t)
(st-rdev dev-t)
(st-atime (struct timespec-t))
(st-mtime (struct timespec-t))
(st-ctime (struct timespec-t))
#+LONG-STAT
(st-size off-t)
#-LONG-STAT
(st-sizeh unsigned-long)
#-LONG-STAT
(st-size unsigned-long)
#+LONG-STAT
(st-blocks int64-t)
#-LONG-STAT
(st-blocksh unsigned-long)
#-LONG-STAT
(st-blocks unsigned-long)
(st-blksize unsigned-long)
(st-flags unsigned-long)
(st-gen unsigned-long)
(st-lspare long)
(st-qspare (array long 4)))) ; 2 quads
#+(or linux svr4)
......@@ -909,11 +940,21 @@
;;; And now for something completely different ...
(emit-unix-errors)
(def-alien-variable ("errno" unix-errno) int)
#-darwin
(progn
(def-alien-variable ("errno" unix-internal-errno) int)
(defun unix-errno () unix-internal-errno)
(defun (setf unix-errno) (newvalue) (setf unix-internal-errno newvalue)))
#+darwin
(progn
(def-alien-routine ("os_get_errno" unix-get-errno) int)
(def-alien-routine ("os_set_errno" unix-set-errno) int (newvalue int))
(defun unix-errno () (unix-get-errno))
(defun (setf unix-errno) (newvalue) (unix-set-errno newvalue)))
;;; GET-UNIX-ERROR-MSG -- public.
;;;
(defun get-unix-error-msg (&optional (error-number unix-errno))
(defun get-unix-error-msg (&optional (error-number (unix-errno)))
"Returns a string describing the error number which was returned by a
UNIX system call."
(declare (type integer error-number))
......@@ -1014,7 +1055,7 @@
`(let* ((fn (extern-alien ,name (function ,result-type ,@arg-types)))
(result (alien-funcall fn ,@args)))
(if (eql -1 result)
(values nil unix-errno)
(values nil (unix-errno))
,success-form)))
(defmacro syscall ((name &rest arg-types) success-form &rest args)
......@@ -1081,7 +1122,7 @@
size-t int int int off-t))
(or addr +null+) length prot flags (or fd -1) offset)))
(if (= result map_failed)
(values nil unix-errno)
(values nil (unix-errno))
(sys:int-sap result))))
(defun unix-munmap (addr length)
......@@ -2438,7 +2479,7 @@
c-string))
pathname)))
(if (zerop (sap-int dir-struct))
(values nil unix-errno)
(values nil (unix-errno))
(make-directory :name pathname :dir-struct dir-struct))))
((nil)
(values nil enoent))
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment