From: Christophe Rhodes Date: Tue, 29 Jul 2003 13:01:55 +0000 (+0000) Subject: 0.8.2.8: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=506253505641855dc8bb87033f7af894904f848b;p=sbcl.git 0.8.2.8: MacOS/Darwin merge. Points to note: ... thanks to Patrik Nordebo, Pierre Mai and Brian Mastenbrook; ... mmap()ed simple-streams appear not to work under darwin; ... floating point traps are currently non-functional on both ppc platforms; ... on darwin, hitting ^C, then choosing CONTINUE results in a memory fault; ... there's no lchown under darwin; ... x86/bsd building is also slightly non-functional currently; ... There's a OAOOM problem in src/compiler/ppc/c-call.lisp, and in src/runtime/ppc-assem.S. --- diff --git a/CREDITS b/CREDITS index c6830e9..ebaec7f 100644 --- a/CREDITS +++ b/CREDITS @@ -578,7 +578,8 @@ Robert MacLachlan: Pierre Mai: He has continued to work on CMU CL since the SBCL fork, and also patched code to SBCL to enable dynamic loading of object files - under OpenBSD. + under OpenBSD. He contributed to the port of SBCL to MacOS X, + implementing the Lisp side of the PowerOpen ABI. Eric Marsden: Some of his fixes to CMU CL since the SBCL fork have been ported @@ -587,6 +588,9 @@ Eric Marsden: Antonio Martinez-Shotton: He has contributed a number of bug fixes and bug reports to SBCL. +Brian Mastenbrook: + He contributed to the port of SBCL to MacOS X. + Dave McDonald: He made a lot of progress toward getting SBCL to be bootstrappable under CLISP. @@ -606,6 +610,10 @@ William ("Bill") Newman: updating documentation, and even, for better or worse, getting rid of various functionality (e.g. the byte interpreter). +Patrik Nordebo: + He contributed to the port of SBCL to MacOS X, finding solutions for + ABI and assembly syntax differences between Darwin and Linux. + Kevin M. Rosenberg: He provided the ACL-style toplevel, and a number of MOP-related bug reports. @@ -662,6 +670,7 @@ APD Alexey Dejneka NJF Nathan Froyd AL Arthur Lemmens RAM Robert MacLachlan +PRM Pierre Mai WHN William ("Bill") Newman CSR Christophe Rhodes PVE Peter Van Eynde diff --git a/NEWS b/NEWS index 176b09c..cf3979a 100644 --- a/NEWS +++ b/NEWS @@ -1938,6 +1938,9 @@ changes in sbcl-0.8.2 relative to sbcl-0.8.1: ** (VECTOR NIL) is a subtype of STRING. changes in sbcl-0.8.3 relative to sbcl-0.8.2: + * SBCL now builds and runs on MacOS X (version 10.2), or perhaps + more accurately, on the Darwin kernel running on PowerPC hardware. + (thanks to Brian Mastenbrook, Pierre Mai and Patrik Nordebo) * bug fix: WITH-OUTPUT-TO-STRING (and MAKE-STRING-OUTPUT-STREAM) now accept and act upon their :ELEMENT-TYPE keyword argument. (reported by Edi Weitz) diff --git a/contrib/sb-bsd-sockets/sb-bsd-sockets.asd b/contrib/sb-bsd-sockets/sb-bsd-sockets.asd index 03c32c7..9fa49e5 100644 --- a/contrib/sb-bsd-sockets/sb-bsd-sockets.asd +++ b/contrib/sb-bsd-sockets/sb-bsd-sockets.asd @@ -30,7 +30,8 @@ (unless (zerop (run-shell-command #+sunos "gcc -shared -lresolv -lsocket -lnsl -o ~S ~{~S ~}" - #-sunos "gcc -shared -o ~S ~{~S ~} " + #+darwin "gcc -bundle -o ~S ~{~S ~}" + #-(or darwin sunos) "gcc -shared -o ~S ~{~S ~} " dso-name (mapcar #'unix-name (mapcan (lambda (c) diff --git a/contrib/sb-bsd-sockets/tests.lisp b/contrib/sb-bsd-sockets/tests.lisp index a510c9f..6a7931e 100644 --- a/contrib/sb-bsd-sockets/tests.lisp +++ b/contrib/sb-bsd-sockets/tests.lisp @@ -133,7 +133,7 @@ Tests are in the file tests.lisp and also make good examples. ;;; to look at /etc/syslog.conf or local equivalent to find out where ;;; the message ended up -#-sunos +#-(or sunos darwin) (deftest simple-local-client (let ((s (make-instance 'local-socket :type :datagram))) (format t "Connecting ~A... " s) diff --git a/contrib/sb-posix/interface.lisp b/contrib/sb-posix/interface.lisp index 2aa9fdc..98b4a5e 100644 --- a/contrib/sb-posix/interface.lisp +++ b/contrib/sb-posix/interface.lisp @@ -25,6 +25,8 @@ (define-call "fchown" int minusp (fd file-descriptor) (owner sb-posix::uid-t) (group sb-posix::gid-t)) (define-call "link" int minusp (oldpath filename) (newpath filename)) +;; no lchown on Darwin +#-darwin (define-call "lchown" int minusp (pathname filename) (owner sb-posix::uid-t) (group sb-posix::gid-t)) (define-call "mkdir" int minusp (pathname filename) (mode sb-posix::mode-t)) diff --git a/contrib/sb-simple-streams/simple-stream-tests.lisp b/contrib/sb-simple-streams/simple-stream-tests.lisp index 010d0ab..44b824d 100644 --- a/contrib/sb-simple-streams/simple-stream-tests.lisp +++ b/contrib/sb-simple-streams/simple-stream-tests.lisp @@ -87,6 +87,8 @@ result) t) +;;; FIXME +#-darwin (deftest create-read-mapped-file-1 ;; Read data via a mapped-file-simple-stream object. (let ((result t) diff --git a/make-config.sh b/make-config.sh index 54e2982..625ec6f 100644 --- a/make-config.sh +++ b/make-config.sh @@ -35,6 +35,7 @@ case `uname -m` in sparc*) guessed_sbcl_arch=sparc ;; sun*) guessed_sbcl_arch=sparc ;; ppc) guessed_sbcl_arch=ppc ;; + Power*Macintosh) guessed_sbcl_arch=ppc ;; parisc) guessed_sbcl_arch=hppa ;; mips) guessed_sbcl_arch=mips ;; *) @@ -126,6 +127,13 @@ case `uname` in ;; esac ;; + Darwin) + printf ' :bsd' >> $ltf + ln -s $sbcl_arch-darwin-os.h target-arch-os.h + ln -s bsd-os.h target-os.h + printf ' :darwin' >> $ltf + ln -s Config.$sbcl_arch-darwin Config + ;; SunOS) printf ' :sunos' >> $ltf ln -s Config.$sbcl_arch-sunos Config diff --git a/src/code/bsd-os.lisp b/src/code/bsd-os.lisp index 5567c3f..2e3771d 100644 --- a/src/code/bsd-os.lisp +++ b/src/code/bsd-os.lisp @@ -16,7 +16,8 @@ "Return a string describing the supporting software." (the string ; (to force error in case of unsupported BSD variant) #!+FreeBSD "FreeBSD" - #!+OpenBSD "OpenBSD")) + #!+OpenBSD "OpenBSD" + #!+Darwin "Darwin")) (defvar *software-version* nil) diff --git a/src/code/float-trap.lisp b/src/code/float-trap.lisp index c2e44e5..fcb29d0 100644 --- a/src/code/float-trap.lisp +++ b/src/code/float-trap.lisp @@ -100,7 +100,8 @@ (if fast-mode (setq modes (logior float-fast-bit modes)) (setq modes (logand (lognot float-fast-bit) modes)))) - (setf (floating-point-modes) modes)) + ;; FIXME: This apparently doesn't work on Darwin + #!-darwin (setf (floating-point-modes) modes)) (values)) diff --git a/src/code/foreign.lisp b/src/code/foreign.lisp index b289ba6..54ae8b0 100644 --- a/src/code/foreign.lisp +++ b/src/code/foreign.lisp @@ -52,7 +52,7 @@ ;;; On any OS where we don't support foreign object file loading, any ;;; query of a foreign symbol value is answered with "no definition ;;; known", i.e. NIL. -#-(or linux sunos FreeBSD OpenBSD) +#-(or linux sunos FreeBSD OpenBSD darwin) (defun get-dynamic-foreign-symbol-address (symbol) (declare (type simple-string symbol) (ignore symbol)) nil) @@ -62,7 +62,7 @@ ;;; work on any ELF system with dlopen(3) and dlsym(3) ;;; It also works on OpenBSD, which isn't ELF, but is otherwise modern ;;; enough to have a fairly well working dlopen/dlsym implementation. -#-(or linux sunos FreeBSD OpenBSD) +#-(or linux sunos FreeBSD OpenBSD darwin) (macrolet ((define-unsupported-fun (fun-name) `(defun ,fun-name (&rest rest) "unsupported on this system" @@ -70,7 +70,7 @@ (error 'unsupported-operator :name ',fun-name)))) (define-unsupported-fun load-1-foreign) (define-unsupported-fun load-foreign)) -#+(or linux sunos FreeBSD OpenBSD) +#+(or linux sunos FreeBSD OpenBSD darwin) (progn ;;; flags for dlopen() @@ -112,7 +112,9 @@ *after-save-initializations*) (defvar *dso-linker* "/usr/bin/ld") -(defvar *dso-linker-options* '("-shared" "-o")) +(defvar *dso-linker-options* + #-darwin '("-shared" "-o") + #+darwin '("-bundle" "-o")) (sb-alien:define-alien-routine dlopen system-area-pointer (file sb-alien:c-string) (mode sb-alien:int)) diff --git a/src/code/load.lisp b/src/code/load.lisp index 48c3ccb..e8b9921 100644 --- a/src/code/load.lisp +++ b/src/code/load.lisp @@ -374,7 +374,7 @@ ;;; code for foreign symbol lookup should be here. (defun find-foreign-symbol-in-table (name table) (let ((prefixes - #!+(or osf1 sunos linux freebsd) #("" "ldso_stub__") + #!+(or osf1 sunos linux freebsd darwin) #("" "ldso_stub__") #!+openbsd #(""))) (declare (notinline some)) ; to suppress bug 117 bogowarning (some (lambda (prefix) diff --git a/src/code/ppc-vm.lisp b/src/code/ppc-vm.lisp index 1024998..627599e 100644 --- a/src/code/ppc-vm.lisp +++ b/src/code/ppc-vm.lisp @@ -112,6 +112,9 @@ ;;; Given a signal context, return the floating point modes word in ;;; the same format as returned by FLOATING-POINT-MODES. +;;; +;;; FIXME: surely this must be accessible somewhere under Darwin? +#!-darwin (define-alien-routine ("os_context_fp_control" context-floating-point-modes) (sb!alien:unsigned 32) (context (* os-context-t))) diff --git a/src/code/unix.lisp b/src/code/unix.lisp index 91a8e39..adc5efc 100644 --- a/src/code/unix.lisp +++ b/src/code/unix.lisp @@ -293,14 +293,14 @@ ;; a constant. Going the grovel_headers route doesn't seem to be ;; helpful, either, as Solaris doesn't export PATH_MAX from ;; unistd.h. - #!-(or linux openbsd freebsd sunos osf1) (,stub,) - #!+(or linux openbsd freebsd sunos osf1) + #!-(or linux openbsd freebsd sunos osf1 darwin) (,stub,) + #!+(or linux openbsd freebsd sunos osf1 darwin) (or (newcharstar-string (alien-funcall (extern-alien "getcwd" (function (* char) (* char) size-t)) nil - #!+(or linux openbsd freebsd) 0 + #!+(or linux openbsd freebsd darwin) 0 #!+(or sunos osf1) 1025)) (simple-perror "getcwd"))) diff --git a/src/cold/shared.lisp b/src/cold/shared.lisp index 86dcd58..95f125a 100644 --- a/src/cold/shared.lisp +++ b/src/cold/shared.lisp @@ -46,7 +46,8 @@ ;; that we never explicitly refer to host object file suffixes, ;; only to the result of CL:COMPILE-FILE-PATHNAME. #+lispworks ".ufsl" ; as per Lieven Marchand sbcl-devel 2002-02-01 - #+openmcl ".pfsl" + #+(and openmcl (not darwin)) ".pfsl" + #+(and openmcl darwin) ".dfsl" ;; On most xc hosts, any old extension works, so we use an ;; arbitrary one. ".lisp-obj")) diff --git a/src/compiler/ppc/alloc.lisp b/src/compiler/ppc/alloc.lisp index 9c5c896..43f3bc9 100644 --- a/src/compiler/ppc/alloc.lisp +++ b/src/compiler/ppc/alloc.lisp @@ -101,7 +101,7 @@ (:translate make-fdefn) (:generator 37 (with-fixed-allocation (result pa-flag temp fdefn-widetag fdefn-size) - (inst lr temp (make-fixup "undefined_tramp" :foreign)) + (inst lr temp (make-fixup (extern-alien-name "undefined_tramp") :foreign)) (storew name result fdefn-name-slot other-pointer-lowtag) (storew null-tn result fdefn-fun-slot other-pointer-lowtag) (storew temp result fdefn-raw-addr-slot other-pointer-lowtag)))) diff --git a/src/compiler/ppc/c-call.lisp b/src/compiler/ppc/c-call.lisp index dd6f4bf..def38fe 100644 --- a/src/compiler/ppc/c-call.lisp +++ b/src/compiler/ppc/c-call.lisp @@ -4,6 +4,19 @@ ;;; (in-package "SB!VM") +;;; Return the number of bytes needed for the current non-descriptor stack +;;; frame. Non-descriptor stack frames must be multiples of 16 bytes under +;;; the PPC SVr4 ABI (though the EABI may be less restrictive.) Two words +;;; are reserved for the stack backlink and saved LR (see SB!VM::NUMBER-STACK- +;;; DISPLACEMENT.) +;;; + +(defconstant +stack-alignment-bytes+ + ;; Duh. PPC Linux (and VxWorks) adhere to the EABI. + #!-darwin 7 + ;; But Darwin doesn't + #!+darwin 15) + (defun my-make-wired-tn (prim-type-name sc-name offset) (make-wired-tn (primitive-type-or-lose prim-type-name) (sc-number-or-lose sc-name) @@ -12,8 +25,12 @@ (defstruct arg-state (gpr-args 0) (fpr-args 0) - ;SVR4 [a]abi wants two words on stack (callee saved lr, backpointer). - (stack-frame-size 2)) + ;; SVR4 [a]abi wants two words on stack (callee saved lr, + ;; backpointer). + #!-darwin (stack-frame-size 2) + ;; PowerOpen ABI wants 8 words on the stack corresponding to GPR3-10 + ;; in addition to the 6 words of link area (see number-stack-displacement) + #!+darwin (stack-frame-size (+ 8 6))) (defun int-arg (state prim-type reg-sc stack-sc) (let ((reg-args (arg-state-gpr-args state))) @@ -34,16 +51,17 @@ (declare (ignore type)) (int-arg state 'system-area-pointer 'sap-reg 'sap-stack)) -; If a single-float arg has to go on the stack, it's promoted to -; double. That way, C programs can get subtle rounding errors -; when unrelated arguments are introduced. +;;; If a single-float arg has to go on the stack, it's promoted to +;;; double. That way, C programs can get subtle rounding errors when +;;; unrelated arguments are introduced. +#!-darwin (define-alien-type-method (single-float :arg-tn) (type state) (declare (ignore type)) (let* ((fprs (arg-state-fpr-args state))) (cond ((< fprs 8) (incf (arg-state-fpr-args state)) - ; Assign outgoing FPRs starting at FP1 + ;; Assign outgoing FPRs starting at FP1 (my-make-wired-tn 'single-float 'single-reg (1+ fprs))) (t (let* ((stack-offset (arg-state-stack-frame-size state))) @@ -52,12 +70,39 @@ (setf (arg-state-stack-frame-size state) (+ stack-offset 2)) (my-make-wired-tn 'double-float 'double-stack stack-offset)))))) +#!+darwin +(define-alien-type-method (single-float :arg-tn) (type state) + (declare (ignore type)) + (let* ((fprs (arg-state-fpr-args state)) + (gprs (arg-state-gpr-args state))) + (cond ((< gprs 8) ; and by implication also (< fprs 13) + ;; Corresponding GPR is kept empty for functions with fixed args + (incf (arg-state-gpr-args state)) + (incf (arg-state-fpr-args state)) + ;; Assign outgoing FPRs starting at FP1 + (my-make-wired-tn 'single-float 'single-reg (1+ fprs))) + ((< fprs 13) + ;; According to PowerOpen ABI, we need to pass those both in the + ;; FPRs _and_ the stack. However empiric testing on OS X/gcc + ;; shows they are only passed in FPRs, AFAICT. + ;; + ;; "I" in "AFAICT" probably refers to PRM. -- CSR, still + ;; reverse-engineering comments in 2003 :-) + (incf (arg-state-fpr-args state)) + (incf (arg-state-stack-frame-size state)) + (my-make-wired-tn 'single-float 'single-reg (1+ fprs))) + (t + ;; Pass on stack only + (let ((stack-offset (arg-state-stack-frame-size state))) + (incf (arg-state-stack-frame-size state)) + (my-make-wired-tn 'single-float 'single-stack stack-offset)))))) +#!-darwin (define-alien-type-method (double-float :arg-tn) (type state) (declare (ignore type)) (let* ((fprs (arg-state-fpr-args state))) (cond ((< fprs 8) (incf (arg-state-fpr-args state)) - ; Assign outgoing FPRs starting at FP1 + ;; Assign outgoing FPRs starting at FP1 (my-make-wired-tn 'double-float 'double-reg (1+ fprs))) (t (let* ((stack-offset (arg-state-stack-frame-size state))) @@ -66,29 +111,112 @@ (setf (arg-state-stack-frame-size state) (+ stack-offset 2)) (my-make-wired-tn 'double-float 'double-stack stack-offset)))))) -(define-alien-type-method (integer :result-tn) (type) - (if (alien-integer-type-signed type) - (my-make-wired-tn 'signed-byte-32 'signed-reg nl0-offset) - (my-make-wired-tn 'unsigned-byte-32 'unsigned-reg nl0-offset))) +#!+darwin +(define-alien-type-method (double-float :arg-tn) (type state) + (declare (ignore type)) + (let ((fprs (arg-state-fpr-args state)) + (gprs (arg-state-gpr-args state))) + (cond ((< gprs 8) ; and by implication also (< fprs 13) + ;; Corresponding GPRs are also kept empty + (incf (arg-state-gpr-args state) 2) + (when (> (arg-state-gpr-args state) 8) + ;; Spill one word to stack + (decf (arg-state-gpr-args state)) + (incf (arg-state-stack-frame-size state))) + (incf (arg-state-fpr-args state)) + ;; Assign outgoing FPRs starting at FP1 + (my-make-wired-tn 'double-float 'double-reg (1+ fprs))) + ((< fprs 13) + ;; According to PowerOpen ABI, we need to pass those both in the + ;; FPRs _and_ the stack. However empiric testing on OS X/gcc + ;; shows they are only passed in FPRs, AFAICT. + (incf (arg-state-stack-frame-size state) 2) + (incf (arg-state-fpr-args state)) + (my-make-wired-tn 'double-float 'double-reg (1+ fprs))) + (t + ;; Pass on stack only + (let ((stack-offset (arg-state-stack-frame-size state))) + (incf (arg-state-stack-frame-size state) 2) + (my-make-wired-tn 'double-float 'double-stack stack-offset)))))) + +;;; Result state handling + +(defstruct result-state + (num-results 0)) +(defun result-reg-offset (slot) + (ecase slot + (0 nl0-offset) + (1 nl1-offset))) +;;; FIXME: These #!-DARWIN methods should be adjusted to take a state +;;; argument, firstly because that's our "official" API (see +;;; src/code/host-alieneval) and secondly because that way we can +;;; probably have less duplication of code. -- CSR, 2003-07-29 + +#!-darwin (define-alien-type-method (system-area-pointer :result-tn) (type) (declare (ignore type)) (my-make-wired-tn 'system-area-pointer 'sap-reg nl0-offset)) -(define-alien-type-method (single-float :result-tn) (type) +#!+darwin +(define-alien-type-method (system-area-pointer :result-tn) (type state) (declare (ignore type)) + (let ((num-results (result-state-num-results state))) + (setf (result-state-num-results state) (1+ num-results)) + (my-make-wired-tn 'system-area-pointer 'sap-reg + (result-reg-offset num-results)))) + +#!-darwin +(define-alien-type-method (single-float :result-tn) (type) + (declare (ignore type state)) (my-make-wired-tn 'single-float 'single-reg 1)) +#!+darwin +(define-alien-type-method (single-float :result-tn) (type state) + (declare (ignore type state)) + (my-make-wired-tn 'single-float 'single-reg 1)) + +#!-darwin (define-alien-type-method (double-float :result-tn) (type) (declare (ignore type)) (my-make-wired-tn 'double-float 'double-reg 1)) +#!+darwin +(define-alien-type-method (double-float :result-tn) (type state) + (declare (ignore type state)) + (my-make-wired-tn 'double-float 'double-reg 1)) + +#!-darwin (define-alien-type-method (values :result-tn) (type) (mapcar #'(lambda (type) (invoke-alien-type-method :result-tn type)) (alien-values-type-values type))) +#!+darwin +(define-alien-type-method (values :result-tn) (type state) + (let ((values (alien-values-type-values type))) + (when (> (length values) 2) + (error "Too many result values from c-call.")) + (mapcar #'(lambda (type) + (invoke-alien-type-method :result-tn type state)) + values))) +#!-darwin +(define-alien-type-method (integer :result-tn) (type) + (if (alien-integer-type-signed type) + (my-make-wired-tn 'signed-byte-32 'signed-reg nl0-offset) + (my-make-wired-tn 'unsigned-byte-32 'unsigned-reg nl0-offset))) + +#!+darwin +(define-alien-type-method (integer :result-tn) (type state) + (let ((num-results (result-state-num-results state))) + (setf (result-state-num-results state) (1+ num-results)) + (multiple-value-bind (ptype reg-sc) + (if (alien-integer-type-signed type) + (values 'signed-byte-32 'signed-reg) + (values 'unsigned-byte-32 'unsigned-reg)) + (my-make-wired-tn ptype reg-sc (result-reg-offset num-results))))) + (!def-vm-support-routine make-call-out-tns (type) (declare (type alien-fun-type type)) @@ -101,8 +229,69 @@ (arg-tns) (invoke-alien-type-method :result-tn - (alien-fun-type-result-type type)))))) + (alien-fun-type-result-type type) + #!+darwin (make-result-state)))))) +#!+darwin +(deftransform %alien-funcall ((function type &rest args)) + (assert (sb!c::constant-continuation-p type)) + (let* ((type (sb!c::continuation-value type)) + (arg-types (alien-fun-type-arg-types type)) + (result-type (alien-fun-type-result-type type))) + (assert (= (length arg-types) (length args))) + ;; We need to do something special for 64-bit integer arguments + ;; and results. + (if (or (some #'(lambda (type) + (and (alien-integer-type-p type) + (> (sb!alien::alien-integer-type-bits type) 32))) + arg-types) + (and (alien-integer-type-p result-type) + (> (sb!alien::alien-integer-type-bits result-type) 32))) + (collect ((new-args) (lambda-vars) (new-arg-types)) + (dolist (type arg-types) + (let ((arg (gensym))) + (lambda-vars arg) + (cond ((and (alien-integer-type-p type) + (> (sb!alien::alien-integer-type-bits type) 32)) + ;; 64-bit long long types are stored in + ;; consecutive locations, most significant word + ;; first (big-endian). + (new-args `(ash ,arg -32)) + (new-args `(logand ,arg #xffffffff)) + (if (alien-integer-type-signed type) + (new-arg-types (parse-alien-type '(signed 32) (sb!kernel:make-null-lexenv))) + (new-arg-types (parse-alien-type '(unsigned 32) (sb!kernel:make-null-lexenv)))) + (new-arg-types (parse-alien-type '(unsigned 32) (sb!kernel:make-null-lexenv)))) + (t + (new-args arg) + (new-arg-types type))))) + (cond ((and (alien-integer-type-p result-type) + (> (sb!alien::alien-integer-type-bits result-type) 32)) + (let ((new-result-type + (let ((sb!alien::*values-type-okay* t)) + (parse-alien-type + (if (alien-integer-type-signed result-type) + '(values (signed 32) (unsigned 32)) + '(values (unsigned 32) (unsigned 32))) + (sb!kernel:make-null-lexenv))))) + `(lambda (function type ,@(lambda-vars)) + (declare (ignore type)) + (multiple-value-bind (high low) + (%alien-funcall function + ',(make-alien-fun-type + :arg-types (new-arg-types) + :result-type new-result-type) + ,@(new-args)) + (logior low (ash high 32)))))) + (t + `(lambda (function type ,@(lambda-vars)) + (declare (ignore type)) + (%alien-funcall function + ',(make-alien-fun-type + :arg-types (new-arg-types) + :result-type result-type) + ,@(new-args)))))) + (sb!c::give-up-ir1-transform)))) (define-vop (foreign-symbol-address) (:translate foreign-symbol-address) @@ -113,7 +302,7 @@ (:results (res :scs (sap-reg))) (:result-types system-area-pointer) (:generator 2 - (inst lr res (make-fixup foreign-symbol :foreign)))) + (inst lr res (make-fixup (extern-alien-name foreign-symbol) :foreign)))) (define-vop (call-out) (:args (function :scs (sap-reg) :target cfunc) @@ -130,7 +319,7 @@ (let ((cur-nfp (current-nfp-tn vop))) (when cur-nfp (store-stack-tn nfp-save cur-nfp)) - (inst lr temp (make-fixup "call_into_c" :foreign)) + (inst lr temp (make-fixup (extern-alien-name "call_into_c") :foreign)) (inst mtctr temp) (move cfunc function) (inst bctrl) @@ -144,7 +333,8 @@ (:temporary (:scs (unsigned-reg) :to (:result 0)) temp) (:generator 0 (unless (zerop amount) - (let ((delta (- (logandc2 (+ amount 8 7) 7)))) + (let ((delta (- (logandc2 (+ amount 8 +stack-alignment-bytes+) + +stack-alignment-bytes+)))) (cond ((>= delta (ash -1 16)) (inst stwu nsp-tn nsp-tn delta)) (t @@ -161,7 +351,8 @@ (:policy :fast-safe) (:generator 0 (unless (zerop amount) - (let ((delta (logandc2 (+ amount 8 7) 7))) + (let ((delta (logandc2 (+ amount 8 +stack-alignment-bytes+) + +stack-alignment-bytes+))) (cond ((< delta (ash 1 16)) (inst addi nsp-tn nsp-tn delta)) (t diff --git a/src/compiler/ppc/call.lisp b/src/compiler/ppc/call.lisp index daf6a32..28f9088 100644 --- a/src/compiler/ppc/call.lisp +++ b/src/compiler/ppc/call.lisp @@ -99,20 +99,12 @@ ;;;; Frame hackery: -;;; Return the number of bytes needed for the current non-descriptor stack -;;; frame. Non-descriptor stack frames must be multiples of 16 bytes under -;;; the PPC SVr4 ABI (though the EABI may be less restrictive.) Two words -;;; are reserved for the stack backlink and saved LR (see SB!VM::NUMBER-STACK- -;;; DISPLACEMENT.) -;;; -;;; Duh. PPC Linux (and VxWorks) adhere to the EABI. - ;;; this is the first function in this file that differs materially from ;;; ../alpha/call.lisp (defun bytes-needed-for-non-descriptor-stack-frame () - (logandc2 (+ 7 number-stack-displacement + (logandc2 (+ +stack-alignment-bytes+ number-stack-displacement (* (sb-allocated-size 'non-descriptor-stack) sb!vm:n-word-bytes)) - 7)) + +stack-alignment-bytes+)) ;;; Used for setting up the Old-FP in local call. diff --git a/src/compiler/ppc/cell.lisp b/src/compiler/ppc/cell.lisp index 3d5fb37..bf175f4 100644 --- a/src/compiler/ppc/cell.lisp +++ b/src/compiler/ppc/cell.lisp @@ -113,7 +113,7 @@ (inst addi lip function (- (ash simple-fun-code-offset word-shift) fun-pointer-lowtag)) (inst beq normal-fn) - (inst lr lip (make-fixup "closure_tramp" :foreign)) + (inst lr lip (make-fixup (extern-alien-name "closure_tramp") :foreign)) (emit-label normal-fn) (storew lip fdefn fdefn-raw-addr-slot other-pointer-lowtag) (storew function fdefn fdefn-fun-slot other-pointer-lowtag) @@ -127,7 +127,7 @@ (:results (result :scs (descriptor-reg))) (:generator 38 (storew null-tn fdefn fdefn-fun-slot other-pointer-lowtag) - (inst lr temp (make-fixup "undefined_tramp" :foreign)) + (inst lr temp (make-fixup (extern-alien-name "undefined_tramp") :foreign)) (storew temp fdefn fdefn-raw-addr-slot other-pointer-lowtag) (move result fdefn))) diff --git a/src/compiler/ppc/parms.lisp b/src/compiler/ppc/parms.lisp index 80e4600..9a784d3 100644 --- a/src/compiler/ppc/parms.lisp +++ b/src/compiler/ppc/parms.lisp @@ -83,10 +83,12 @@ ;;; ;;; The number of bytes reserved above the number stack pointer. These ;;; slots are required by architecture, mostly (?) to make C backtrace -;;; work. +;;; work. This must be a power of 2 - see BYTES-REQUIRED-FOR-NUMBER-STACK. ;;; (def!constant number-stack-displacement - (* 2 sb!vm:n-word-bytes)) + (* #!-darwin 2 + #!+darwin 8 + sb!vm:n-word-bytes)) diff --git a/src/compiler/ppc/print.lisp b/src/compiler/ppc/print.lisp index 526b1c2..083824b 100644 --- a/src/compiler/ppc/print.lisp +++ b/src/compiler/ppc/print.lisp @@ -18,10 +18,10 @@ (when cur-nfp (store-stack-tn nfp-save cur-nfp)) (move nl0 object) - (inst lr temp (make-fixup "call_into_c" :foreign)) + (inst lr temp (make-fixup (extern-alien-name "call_into_c") :foreign)) (inst mr lip temp) (inst mtctr lip) - (inst lr cfunc (make-fixup "debug_print" :foreign)) + (inst lr cfunc (make-fixup (extern-alien-name "debug_print") :foreign)) (inst bctrl) (when cur-nfp (load-stack-tn cur-nfp nfp-save)) diff --git a/src/compiler/ppc/show.lisp b/src/compiler/ppc/show.lisp index 526b1c2..083824b 100644 --- a/src/compiler/ppc/show.lisp +++ b/src/compiler/ppc/show.lisp @@ -18,10 +18,10 @@ (when cur-nfp (store-stack-tn nfp-save cur-nfp)) (move nl0 object) - (inst lr temp (make-fixup "call_into_c" :foreign)) + (inst lr temp (make-fixup (extern-alien-name "call_into_c") :foreign)) (inst mr lip temp) (inst mtctr lip) - (inst lr cfunc (make-fixup "debug_print" :foreign)) + (inst lr cfunc (make-fixup (extern-alien-name "debug_print") :foreign)) (inst bctrl) (when cur-nfp (load-stack-tn cur-nfp nfp-save)) diff --git a/src/compiler/ppc/vm.lisp b/src/compiler/ppc/vm.lisp index 1a0333b..3f41b89 100644 --- a/src/compiler/ppc/vm.lisp +++ b/src/compiler/ppc/vm.lisp @@ -31,8 +31,13 @@ (defreg nl6 9) (defreg fdefn 10) ; was nl7 (defreg nargs 11) - (defreg nfp 12) - (defreg cfunc 13) + ;; FIXME: some kind of comment here would be nice. + ;; + ;; FIXME II: this also reveals the need to autogenerate lispregs.h + #!+darwin (defreg cfunc 12) + #!-darwin (defreg nfp 12) + #!+darwin (defreg nfp 13) + #!-darwin (defreg cfunc 13) (defreg bsp 14) (defreg cfp 15) (defreg csp 16) @@ -315,4 +320,7 @@ (defun extern-alien-name (name) (declare (type simple-base-string name)) - name) + ;; Darwin is non-ELF, and needs a _ prefix + #!+darwin (concatenate 'string "_" name) + ;; The other (ELF) ports currently don't need any prefix + #!-darwin name) diff --git a/src/runtime/Config.ppc-darwin b/src/runtime/Config.ppc-darwin new file mode 100644 index 0000000..7f66fd4 --- /dev/null +++ b/src/runtime/Config.ppc-darwin @@ -0,0 +1,19 @@ +# -*- makefile -*- +CFLAGS = -ggdb -Wall -O3 -traditional-cpp +OS_SRC = bsd-os.c os-common.c ppc-darwin-os.c +OS_LIBS = -lSystem -lc -lm /sw/lib/libdl.a + +ASSEM_SRC = ppc-assem.S ldso-stubs.S +ARCH_SRC = ppc-arch.c + +CPP = cpp -traditional-cpp + +# Until sbcl-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 -L/sw/lib + +GC_SRC= cheneygc.c + +CFLAGS=-DDARWIN -Dppc -g -traditional-cpp diff --git a/src/runtime/Config.x86-bsd b/src/runtime/Config.x86-bsd index a7c026e..f066acd 100644 --- a/src/runtime/Config.x86-bsd +++ b/src/runtime/Config.x86-bsd @@ -12,7 +12,7 @@ ASSEM_SRC = x86-assem.S ARCH_SRC = x86-arch.c -OS_SRC = bsd-os.c os-common.c undefineds.c +OS_SRC = bsd-os.c os-common.c undefineds.c x86-bsd-os.c OS_LIBS = -lm # -ldl GC_SRC = gencgc.c diff --git a/src/runtime/bsd-os.c b/src/runtime/bsd-os.c index 64aba2c..4f76233 100644 --- a/src/runtime/bsd-os.c +++ b/src/runtime/bsd-os.c @@ -35,83 +35,35 @@ #include /* #include */ #include "validate.h" -vm_size_t os_vm_page_size; - -/* The different BSD variants have diverged in exactly where they - * store signal context information, but at least they tend to use the - * same stems to name the structure fields, so by using this macro we - * can share a fair amount of code between different variants. */ -#if defined __FreeBSD__ -#define CONTEXT_ADDR_FROM_STEM(stem) &context->uc_mcontext.mc_ ## stem -#elif defined __OpenBSD__ -#define CONTEXT_ADDR_FROM_STEM(stem) &context->sc_ ## stem -#else -#error unsupported BSD variant -#endif -void -os_init(void) -{ - os_vm_page_size = getpagesize(); -} +vm_size_t os_vm_page_size; -/* KLUDGE: There is strong family resemblance in the signal context - * stuff in FreeBSD and OpenBSD, but in detail they're different in - * almost every line of code. It would be nice to find some way to - * factor out the commonality better; failing that, it might be best - * just to split this generic-BSD code into one variant for each BSD. */ - -int * -os_context_register_addr(os_context_t *context, int offset) +void os_init(void) { - switch(offset) { - case 0: - return CONTEXT_ADDR_FROM_STEM(eax); - case 2: - return CONTEXT_ADDR_FROM_STEM(ecx); - case 4: - return CONTEXT_ADDR_FROM_STEM(edx); - case 6: - return CONTEXT_ADDR_FROM_STEM(ebx); - case 8: - return CONTEXT_ADDR_FROM_STEM(esp); - case 10: - return CONTEXT_ADDR_FROM_STEM(ebp); - case 12: - return CONTEXT_ADDR_FROM_STEM(esi); - case 14: - return CONTEXT_ADDR_FROM_STEM(edi); - default: - return 0; - } + os_vm_page_size = getpagesize(); } -int * -os_context_pc_addr(os_context_t *context) +int *os_context_pc_addr(os_context_t *context) { #if defined __FreeBSD__ return CONTEXT_ADDR_FROM_STEM(eip); #elif defined __OpenBSD__ return CONTEXT_ADDR_FROM_STEM(pc); +#elif defined DARWIN + return &context->uc_mcontext->ss.srr0; #else #error unsupported BSD variant #endif } -int * -os_context_sp_addr(os_context_t *context) -{ - return CONTEXT_ADDR_FROM_STEM(esp); -} - sigset_t * os_context_sigmask_addr(os_context_t *context) { /* (Unlike most of the other context fields that we access, the * signal mask field is a field of the basic, outermost context * struct itself both in FreeBSD 4.0 and in OpenBSD 2.6.) */ -#if defined __FreeBSD__ +#if defined __FreeBSD__ || defined DARWIN return &context->uc_sigmask; #elif defined __OpenBSD__ return &context->sc_mask; @@ -161,15 +113,6 @@ os_map(int fd, int offset, os_vm_address_t addr, os_vm_size_t len) return addr; } -/* FIXME: If this can be a no-op on BSD/x86, then it - * deserves a more precise name. - * - * (Perhaps os_prepare_data_area_to_be_executed()?) */ -void -os_flush_icache(os_vm_address_t address, os_vm_size_t length) -{ -} - void os_protect(os_vm_address_t address, os_vm_size_t length, os_vm_prot_t prot) { @@ -223,11 +166,13 @@ memory_fault_handler(int signal, siginfo_t *siginfo, void *void_context) void *fault_addr = siginfo->si_addr; #elif defined __OpenBSD__ void *fault_addr = siginfo->si_addr; +#elif defined DARWIN + void *fault_addr = siginfo->si_addr; #else #error unsupported BSD variant #endif os_context_t *context = arch_os_get_context(&void_context); - if (!gencgc_handle_wp_violation(fault_addr)) + if (!gencgc_handle_wp_violation(fault_addr)) if(!handle_control_stack_guard_triggered(context,fault_addr)) /* FIXME is this context or void_context? not that it */ /* makes a difference currently except on linux/sparc */ @@ -242,12 +187,27 @@ os_install_interrupt_handlers(void) SHOW("leaving os_install_interrupt_handlers()"); } -#else -/* As of 2002.07.31, this configuration has never been tested */ +#else /* Currently Darwin only */ + +static void +sigsegv_handler(int signal, siginfo_t *info, void* void_context) +{ + os_context_t *context = arch_os_get_context(&void_context); + unsigned int pc = (unsigned int *)(*os_context_pc_addr(context)); + os_vm_address_t addr; + + addr = arch_get_bad_addr(signal,info,context); + if(!interrupt_maybe_gc(signal, info, context)) + if(!handle_control_stack_guard_triggered(context,addr)) + interrupt_handle_now(signal, info, context); +} + void os_install_interrupt_handlers(void) { SHOW("os_install_interrupt_handlers()/bsd-os/!defined(GENCGC)"); + undoably_install_low_level_interrupt_handler(SIG_MEMORY_FAULT, + sigsegv_handler); } #endif /* defined GENCGC */ diff --git a/src/runtime/bsd-os.h b/src/runtime/bsd-os.h index de0522f..d95431d 100644 --- a/src/runtime/bsd-os.h +++ b/src/runtime/bsd-os.h @@ -48,6 +48,17 @@ typedef ucontext_t os_context_t; #elif defined __OpenBSD__ typedef struct sigcontext os_context_t; #define SIG_MEMORY_FAULT SIGSEGV +#elif defined DARWIN + /* man pages claim that the third argument is a sigcontext struct, + but ucontext_t is defined, matches sigcontext where sensible, + offers better access to mcontext, and is of course the SUSv2- + mandated type of the third argument, so we use that instead. + If Apple is going to break ucontext_t out of spite, I'm going + to be cross with them ;) -- PRM */ + +#include +typedef ucontext_t os_context_t; +#define SIG_MEMORY_FAULT SIGBUS #else #error unsupported BSD variant #endif diff --git a/src/runtime/globals.h b/src/runtime/globals.h index 13a0447..7a6b59f 100644 --- a/src/runtime/globals.h +++ b/src/runtime/globals.h @@ -59,8 +59,12 @@ extern void globals_init(void); #endif #endif #ifdef ppc +#ifdef DARWIN +#define EXTERN(name,bytes) .globl _/**/name +#else #define EXTERN(name,bytes) .globl name #endif +#endif #ifdef __i386__ #ifdef __linux__ /* I'm very dubious about this. Linux hasn't used _ on external names diff --git a/src/runtime/ldso-stubs.S b/src/runtime/ldso-stubs.S index 65fc520..5e3a86c 100644 --- a/src/runtime/ldso-stubs.S +++ b/src/runtime/ldso-stubs.S @@ -26,6 +26,7 @@ */ #define LANGUAGE_ASSEMBLY #include "sbcl.h" + .text #if defined LISP_FEATURE_X86 @@ -58,7 +59,7 @@ ldso_stub__ ## fct: ; \ .L ## fct ## e1: ; \ .size ldso_stub__ ## fct,.L ## fct ## e1-ldso_stub__ ## fct ; -#elif defined LISP_FEATURE_PPC +#elif ((defined LISP_FEATURE_PPC) && (defined LISP_FEATURE_LINUX)) #define LDSO_STUBIFY(fct) \ .globl ldso_stub__ ## fct ; \ .type ldso_stub__ ## fct,@function ; \ @@ -66,6 +67,24 @@ ldso_stub__ ## fct: ; \ b fct ; \ .L ## fct ## e1: ; \ .size ldso_stub__ ## fct,.L ## fct ## e1-ldso_stub__ ## fct ; + +#elif ((defined LISP_FEATURE_PPC) && (defined LISP_FEATURE_DARWIN)) +#define LDSO_STUBIFY(fct) @\ +.text @\ +.globl ldso_stub___ ## fct @\ +ldso_stub___ ## fct: @\ + b ldso_stub__ ## fct ## stub @\ +.symbol_stub ldso_stub__ ## fct ## stub: @\ +.indirect_symbol _ ## fct @\ + lis r11,ha16(ldso_stub__ ## fct ## $lazy_ptr) @\ + lwz r12,lo16(ldso_stub__ ## fct ## $lazy_ptr)(r11) @\ + mtctr r12 @\ + addi r11,r11,lo16(ldso_stub__ ## fct ## $lazy_ptr) @\ + bctr @\ +.lazy_symbol_pointer @\ +ldso_stub__ ## fct ## $lazy_ptr: @\ + .indirect_symbol _ ## fct @\ + .long dyld_stub_binding_helper #elif defined LISP_FEATURE_SPARC diff --git a/src/runtime/monitor.c b/src/runtime/monitor.c index ccda1d9..5d08022 100644 --- a/src/runtime/monitor.c +++ b/src/runtime/monitor.c @@ -326,6 +326,10 @@ print_context(os_context_t *context) brief_print((lispobj)(*os_context_register_addr(context,i))); #endif } +#ifdef DARWIN + printf("DAR:\t\t 0x%08lx\n", (unsigned long)(*os_context_register_addr(context, 41))); + printf("DSISR:\t\t 0x%08lx\n", (unsigned long)(*os_context_register_addr(context, 42))); +#endif printf("PC:\t\t 0x%08lx\n", (unsigned long)(*os_context_pc_addr(context))); } diff --git a/src/runtime/ppc-arch.c b/src/runtime/ppc-arch.c index 3d209e9..c35fc4c 100644 --- a/src/runtime/ppc-arch.c +++ b/src/runtime/ppc-arch.c @@ -31,16 +31,13 @@ #define PT_DSISR 42 #endif -void arch_init() -{ +void arch_init() { } os_vm_address_t arch_get_bad_addr(int sig, siginfo_t *code, os_context_t *context) { - unsigned long badinstr; unsigned int *pc = (unsigned int *)(*os_context_pc_addr(context)); - int instclass; os_vm_address_t addr; @@ -133,7 +130,6 @@ arch_do_displaced_inst(os_context_t *context,unsigned int orig_inst) static void sigtrap_handler(int signal, siginfo_t *siginfo, os_context_t *context) { - int badinst; u32 code; sigset_t *mask; #ifdef LISP_FEATURE_LINUX @@ -155,7 +151,7 @@ sigtrap_handler(int signal, siginfo_t *siginfo, os_context_t *context) } if ((code >> 16) == ((3 << 10) | (6 << 5))) { /* twllei reg_ZERO,N will always trap if reg_ZERO = 0 */ - int trap = code & 0x1f, extra = (code >> 5) & 0x1f; + int trap = code & 0x1f; switch (trap) { case trap_Halt: diff --git a/src/runtime/ppc-assem.S b/src/runtime/ppc-assem.S index 1135c8a..de36538 100644 --- a/src/runtime/ppc-assem.S +++ b/src/runtime/ppc-assem.S @@ -3,34 +3,79 @@ #include "sbcl.h" #include "lispregs.h" #include "globals.h" + #include "genesis/simple-fun.h" #include "genesis/fdefn.h" #include "genesis/closure.h" #include "genesis/static-symbols.h" +#ifdef DARWIN +#define CSYMBOL(x) _ ## x +#else +#define CSYMBOL(x) x +#endif + +#if defined DARWIN +#define FUNCDEF(x) .text @ \ + .align 3 @ \ +_##x: + +#define GFUNCDEF(x) .globl _/**/x @ \ + FUNCDEF(x) +#else #define FUNCDEF(x) .text ; \ .align 3 ; \ .type x,@function ; \ x: + #define GFUNCDEF(x) .globl x ; \ FUNCDEF(x) +#endif +#if defined DARWIN +#define SET_SIZE(x) +#else #define SET_SIZE(x) .size x,.-x +#endif /* Load a register from a global, using the register as an intermediary */ /* The register will be a fixnum for one instruction, so this is gc-safe */ +#if defined DARWIN +#define load(reg,global) \ + lis reg,ha16(global) @ \ + lwz reg,lo16(global)(reg) ; Comment +#define store(reg,temp,global) \ + lis temp,ha16(global) @\ + stw reg,lo16(global)(temp) ; Comment +#else #define load(reg,global) \ lis reg,global@ha; lwz reg,global@l(reg) #define store(reg,temp,global) \ lis temp,global@ha; stw reg,global@l(temp) +#endif #define FIRST_SAVE_FPR 14 /* lowest-numbered non-volatile FPR */ +#ifdef DARWIN +#define FIRST_SAVE_GPR 13 /* lowest-numbered non-volatile GPR */ +#define NGPR_SAVE_BYTES(n) ((32-(n))*4) +#define FRAME_ARG_BYTES(n) (((((n)+6)*4)+15)&~15) +#else #define FIRST_SAVE_GPR 14 /* lowest-numbered non-volatile GPR */ -#define NFPR_SAVE_BYTES(n) ((32-(n))*8) #define NGPR_SAVE_BYTES(n) ((32-(~1&((n)+1)))*4) #define FRAME_ARG_BYTES(n) (((((n)+2)*4)+15)&~15) +#endif +#define NFPR_SAVE_BYTES(n) ((32-(n))*8) +#ifdef DARWIN +#define FRAME_SIZE(first_g,first_f,out_arg_words,savecr) \ +(NFPR_SAVE_BYTES(first_f)+ NGPR_SAVE_BYTES(first_g)+ FRAME_ARG_BYTES(out_arg_words)) +#define SAVE_FPR(n) stfd f##n,-8*(32- n)(r11) +#define SAVE_GPR(n) stw r##n,-4*(32- n)(r11) +#define FULL_FRAME_SIZE FRAME_SIZE(FIRST_SAVE_GPR,FIRST_SAVE_FPR,8,1) +#define RESTORE_FPR(n) lfd f##n,-8*(32- n)(r11) +#define RESTORE_GPR(n) lwz r##n,-4*(32- n)(r11) +#else #define FRAME_SIZE(first_g,first_f,out_arg_words,savecr) \ (NFPR_SAVE_BYTES(first_f)+ NGPR_SAVE_BYTES(first_g)+ FRAME_ARG_BYTES(out_arg_words+savecr)) #define SAVE_FPR(n) stfd n,-8*(32-(n))(11) @@ -39,6 +84,106 @@ x: #define RESTORE_FPR(n) lfd n,-8*(32-(n))(11) #define RESTORE_GPR(n) lwz n,-4*(32-(n))(11) +#endif + +#ifdef DARWIN +#define C_FULL_PROLOG \ + nop @\ + nop @ \ + mfcr REG(0) @ \ + stw REG(0),4(REG(1)) @ \ + mflr REG(0) @ \ + stw REG(0),8(REG(1)) @ \ + mr REG(11),REG(1) @ \ + stwu REG(1),-FULL_FRAME_SIZE(REG(1)) @ \ + SAVE_FPR(14) @ \ + SAVE_FPR(15) @ \ + SAVE_FPR(16) @ \ + SAVE_FPR(17) @ \ + SAVE_FPR(18) @ \ + SAVE_FPR(19) @ \ + SAVE_FPR(20) @ \ + SAVE_FPR(21) @ \ + SAVE_FPR(22) @ \ + SAVE_FPR(23) @ \ + SAVE_FPR(24) @ \ + SAVE_FPR(25) @ \ + SAVE_FPR(26) @ \ + SAVE_FPR(27) @ \ + SAVE_FPR(28) @ \ + SAVE_FPR(29) @ \ + SAVE_FPR(30) @ \ + SAVE_FPR(31) @ \ + la REG(11),-NFPR_SAVE_BYTES(FIRST_SAVE_FPR)(REG(11)) @ \ + SAVE_GPR(13) @ \ + SAVE_GPR(14) @ \ + SAVE_GPR(15) @ \ + SAVE_GPR(16) @ \ + SAVE_GPR(17) @ \ + SAVE_GPR(18) @ \ + SAVE_GPR(19) @ \ + SAVE_GPR(20) @ \ + SAVE_GPR(21) @ \ + SAVE_GPR(22) @ \ + SAVE_GPR(23) @ \ + SAVE_GPR(24) @ \ + SAVE_GPR(25) @ \ + SAVE_GPR(26) @ \ + SAVE_GPR(27) @ \ + SAVE_GPR(28) @ \ + SAVE_GPR(29) @ \ + SAVE_GPR(30) @ \ + SAVE_GPR(31) + + +#define C_FULL_EPILOG \ + la REG(11),FULL_FRAME_SIZE-NFPR_SAVE_BYTES(FIRST_SAVE_FPR)(REG(1)) @ \ + RESTORE_GPR(13) @ \ + RESTORE_GPR(14) @ \ + RESTORE_GPR(15) @ \ + RESTORE_GPR(16) @ \ + RESTORE_GPR(17) @ \ + RESTORE_GPR(18) @ \ + RESTORE_GPR(19) @ \ + RESTORE_GPR(20) @ \ + RESTORE_GPR(21) @ \ + RESTORE_GPR(22) @ \ + RESTORE_GPR(23) @ \ + RESTORE_GPR(24) @ \ + RESTORE_GPR(25) @ \ + RESTORE_GPR(26) @ \ + RESTORE_GPR(27) @ \ + RESTORE_GPR(28) @ \ + RESTORE_GPR(29) @ \ + RESTORE_GPR(30) @ \ + RESTORE_GPR(31) @ \ + la REG(11),NFPR_SAVE_BYTES(FIRST_SAVE_FPR)(REG(11)) @ \ + RESTORE_FPR(14) @ \ + RESTORE_FPR(15) @ \ + RESTORE_FPR(16) @ \ + RESTORE_FPR(17) @ \ + RESTORE_FPR(18) @ \ + RESTORE_FPR(19) @ \ + RESTORE_FPR(20) @ \ + RESTORE_FPR(21) @ \ + RESTORE_FPR(22) @ \ + RESTORE_FPR(23) @ \ + RESTORE_FPR(24) @ \ + RESTORE_FPR(25) @ \ + RESTORE_FPR(26) @ \ + RESTORE_FPR(27) @ \ + RESTORE_FPR(28) @ \ + RESTORE_FPR(29) @ \ + RESTORE_FPR(30) @ \ + RESTORE_FPR(31) @ \ + lwz REG(1),0(REG(1)) @ \ + lwz REG(0),4(REG(1)) @ \ + mtcr REG(0) @ \ + lwz REG(0),8(REG(1)) @ \ + mtlr REG(0) @ \ + +#else + #define C_FULL_PROLOG \ mflr 0 ; \ stw 0,4(1) ; \ @@ -80,10 +225,13 @@ x: SAVE_GPR(28) ; \ SAVE_GPR(29) ; \ SAVE_GPR(30) ; \ - SAVE_GPR(31) - + SAVE_GPR(31) ; \ + mfcr 0 ; \ + stw 0,8(1) #define C_FULL_EPILOG \ + lwz 5,8(1) ; \ + mtcrf 255,5 ; \ la 11,FULL_FRAME_SIZE-NFPR_SAVE_BYTES(FIRST_SAVE_FPR)(1) ; \ RESTORE_GPR(14) ; \ RESTORE_GPR(15) ; \ @@ -126,8 +274,7 @@ x: lwz 0,4(1) ; \ mtlr 0 ; \ - - +#endif .text @@ -138,8 +285,6 @@ x: GFUNCDEF(call_into_lisp) C_FULL_PROLOG - mfcr 0 - stw 0,8(1) /* store(reg_POLL,11,saver2) */ /* Initialize tagged registers */ li reg_ZERO,0 @@ -157,19 +302,23 @@ x: li reg_L1,0 li reg_L2,0 li reg_LIP,0 +#ifdef DARWIN + lis reg_NULL,hi16(NIL) + ori reg_NULL,reg_NULL,lo16(NIL) +#else lis reg_NULL,NIL@h ori reg_NULL,reg_NULL,NIL@l - +#endif /* Turn on pseudo-atomic */ li reg_NL3,-4 li reg_ALLOC,4 - store(reg_ZERO,reg_NL4,foreign_function_call_active) - load(reg_NL4,dynamic_space_free_pointer) + store(reg_ZERO,reg_NL4,CSYMBOL(foreign_function_call_active)) + load(reg_NL4,CSYMBOL(dynamic_space_free_pointer)) add reg_ALLOC,reg_ALLOC,reg_NL4 - load(reg_BSP,current_binding_stack_pointer) - load(reg_CSP,current_control_stack_pointer) - load(reg_OCFP,current_control_frame_pointer) + load(reg_BSP,CSYMBOL(current_binding_stack_pointer)) + load(reg_CSP,CSYMBOL(current_control_stack_pointer)) + load(reg_OCFP,CSYMBOL(current_control_frame_pointer)) /* No longer atomic, and check for interrupt */ add reg_ALLOC,reg_ALLOC,reg_NL3 @@ -185,8 +334,13 @@ x: lwz reg_A3,12(reg_CFP) /* Calculate LRA */ - lis reg_LRA,lra@ha +#ifdef DARWIN + lis reg_LRA,ha16(lra) + addi reg_LRA,reg_LRA,lo16(lra) +#else + lis reg_LRA,lra@h addi reg_LRA,reg_LRA,lra@l +#endif addi reg_LRA,reg_LRA,OTHER_POINTER_LOWTAG /* Function is an indirect closure */ @@ -206,7 +360,7 @@ lra: /* Return the one value. */ - mr 3,reg_A0 + mr REG(3),reg_A0 /* Turn on pseudo-atomic */ li reg_NL3,-4 @@ -214,24 +368,22 @@ lra: /* Store lisp state */ clrrwi reg_NL1,reg_ALLOC,3 - store(reg_NL1,reg_NL2,dynamic_space_free_pointer) + store(reg_NL1,reg_NL2,CSYMBOL(dynamic_space_free_pointer)) /* store(reg_POLL,reg_NL2,poll_flag) */ /* load(reg_NL2,current_thread) */ - store(reg_BSP,reg_NL2,current_binding_stack_pointer) - store(reg_CSP,reg_NL2,current_control_stack_pointer) - store(reg_CFP,reg_NL2,current_control_frame_pointer) + store(reg_BSP,reg_NL2,CSYMBOL(current_binding_stack_pointer)) + store(reg_CSP,reg_NL2,CSYMBOL(current_control_stack_pointer)) + store(reg_CFP,reg_NL2,CSYMBOL(current_control_frame_pointer)) /* load(reg_POLL,saver2) */ /* No longer in Lisp. */ - store(reg_NL1,reg_NL2,foreign_function_call_active) + store(reg_NL1,reg_NL2,CSYMBOL(foreign_function_call_active)) /* Check for interrupt */ add reg_ALLOC,reg_ALLOC,reg_NL3 twlti reg_ALLOC,0 /* Back to C */ - lwz 5,8(1) - mtcrf 255,5 C_FULL_EPILOG blr SET_SIZE(call_into_lisp) @@ -269,27 +421,37 @@ lra: /* Store Lisp state */ clrrwi reg_NFP,reg_ALLOC,3 - store(reg_NFP,reg_CFUNC,dynamic_space_free_pointer) + store(reg_NFP,reg_CFUNC,CSYMBOL(dynamic_space_free_pointer)) /* load(reg_CFUNC,current_thread) */ - store(reg_BSP,reg_CFUNC,current_binding_stack_pointer) - store(reg_CSP,reg_CFUNC,current_control_stack_pointer) - store(reg_CFP,reg_CFUNC,current_control_frame_pointer) + store(reg_BSP,reg_CFUNC,CSYMBOL(current_binding_stack_pointer)) + store(reg_CSP,reg_CFUNC,CSYMBOL(current_control_stack_pointer)) + store(reg_CFP,reg_CFUNC,CSYMBOL(current_control_frame_pointer)) /* No longer in Lisp */ - store(reg_CSP,reg_CFUNC,foreign_function_call_active) + store(reg_CSP,reg_CFUNC,CSYMBOL(foreign_function_call_active)) /* load(reg_POLL,saver2) */ /* Disable pseudo-atomic; check pending interrupt */ add reg_ALLOC,reg_ALLOC,reg_NL3 twlti reg_ALLOC,0 mr reg_NL3,reg_NARGS +#ifdef DARWIN + /* PowerOpen (i.e. OS X) requires the callee address in r12 + (a.k.a. CFUNC), so move it back there, too. */ + mfctr reg_CFUNC +#endif /* Into C we go. */ bctrl /* Re-establish NIL */ +#ifdef DARWIN + lis reg_NULL,hi16(NIL) + ori reg_NULL,reg_NULL,lo16(NIL) +#else lis reg_NULL,NIL@h ori reg_NULL,reg_NULL,NIL@l +#endif /* And reg_ZERO */ li reg_ZERO,0 @@ -316,14 +478,14 @@ lra: li reg_ALLOC,4 /* No long in foreign function call. */ - store(reg_ZERO,reg_NL2,foreign_function_call_active) + store(reg_ZERO,reg_NL2,CSYMBOL(foreign_function_call_active)) /* The free pointer may have moved */ - load(reg_NL4,dynamic_space_free_pointer) + load(reg_NL4,CSYMBOL(dynamic_space_free_pointer)) add reg_ALLOC,reg_ALLOC,reg_NL4 /* The BSP wasn't preserved by C, so load it */ - load(reg_BSP,current_binding_stack_pointer) + load(reg_BSP,CSYMBOL(current_binding_stack_pointer)) /* Other lisp stack/frame pointers were preserved by C. I can't imagine why they'd have moved */ @@ -349,12 +511,12 @@ lra: SET_SIZE(call_into_c) GFUNCDEF(xundefined_tramp) - .globl undefined_tramp + .globl CSYMBOL(undefined_tramp) .byte 0,0,0,SIMPLE_FUN_HEADER_WIDETAG .byte 18<<2 -undefined_tramp: +CSYMBOL(undefined_tramp): .byte 0,0,24 - .long undefined_tramp + .long CSYMBOL(undefined_tramp) .long NIL .long NIL .long NIL @@ -372,12 +534,12 @@ undefined_tramp: SET_SIZE(xundefined_tramp) GFUNCDEF(xclosure_tramp) - .globl closure_tramp + .globl CSYMBOL(closure_tramp) .byte 0,0,0,SIMPLE_FUN_HEADER_WIDETAG .byte 18<<2 -closure_tramp: +CSYMBOL(closure_tramp): .byte 0,0,24 - .long closure_tramp + .long CSYMBOL(closure_tramp) .long NIL .long NIL .long NIL @@ -408,9 +570,9 @@ closure_tramp: GFUNCDEF(ppc_flush_cache_line) - dcbf 0,3 + dcbf 0,REG(3) sync - icbi 0,3 + icbi 0,REG(3) sync isync blr diff --git a/src/runtime/ppc-darwin-os.c b/src/runtime/ppc-darwin-os.c new file mode 100644 index 0000000..8e16094 --- /dev/null +++ b/src/runtime/ppc-darwin-os.c @@ -0,0 +1,95 @@ +#include "globals.h" +#include +#include +#include "bsd-os.h" + +os_context_register_t * +os_context_register_addr(os_context_t *context, int offset) +{ + ppc_saved_state_t *state = &context->uc_mcontext->ss; + switch(offset) { + case 0: + return &state->r0; + case 1: + return &state->r1; + case 2: + return &state->r2; + case 3: + return &state->r3; + case 4: + return &state->r4; + case 5: + return &state->r5; + case 6: + return &state->r6; + case 7: + return &state->r7; + case 8: + return &state->r8; + case 9: + return &state->r9; + case 10: + return &state->r10; + case 11: + return &state->r11; + case 12: + return &state->r12; + case 13: + return &state->r13; + case 14: + return &state->r14; + case 15: + return &state->r15; + case 16: + return &state->r16; + case 17: + return &state->r17; + case 18: + return &state->r18; + case 19: + return &state->r19; + case 20: + return &state->r20; + case 21: + return &state->r21; + case 22: + return &state->r22; + case 23: + return &state->r23; + case 24: + return &state->r24; + case 25: + return &state->r25; + case 26: + return &state->r26; + case 27: + return &state->r27; + case 28: + return &state->r28; + case 29: + return &state->r29; + case 30: + return &state->r30; + case 31: + return &state->r31; + case 41: + /* PT_DAR */ + return &context->uc_mcontext->es.dar; + case 42: + /* PT_DSISR */ + return &context->uc_mcontext->es.dsisr; + } +} + +os_context_register_t * +os_context_lr_addr(os_context_t *context) +{ + return &context->uc_mcontext->ss.lr; +} + +void +os_flush_icache(os_vm_address_t address, os_vm_size_t length) +{ + /* see ppc-arch.c */ + ppc_flush_icache(address,length); +} diff --git a/src/runtime/ppc-darwin-os.h b/src/runtime/ppc-darwin-os.h new file mode 100644 index 0000000..a40699b --- /dev/null +++ b/src/runtime/ppc-darwin-os.h @@ -0,0 +1,9 @@ +#ifndef _PPC_DARWIN_OS_H +#define _PPC_DARWIN_OS_H + +static inline os_context_t *arch_os_get_context(void **void_context) { + return (os_context_t *) *void_context; +} + + +#endif /* _PPC_DARWIN_OS_H */ diff --git a/src/runtime/ppc-linux-os.c b/src/runtime/ppc-linux-os.c index 9b806d3..abd7c0f 100644 --- a/src/runtime/ppc-linux-os.c +++ b/src/runtime/ppc-linux-os.c @@ -87,36 +87,23 @@ void os_restore_fp_control(os_context_t *context) { unsigned long control; + double d; control = os_context_fp_control(context) & - /* FIXME: Should we preserve the user's requested rounding mode? + /* FIXME: Should we preserve the user's requested rounding mode? - Note that doing + Note that doing + + ~(FLOAT_STICKY_BITS_MASK | FLOAT_EXCEPTIONS_BYTE_MASK) + + here leads to infinite SIGFPE for invalid operations, as + there are bits in the control register that need to be + cleared that are let through by that mask. -- CSR, 2002-07-16 */ - ~(FLOAT_STICKY_BITS_MASK | FLOAT_EXCEPTIONS_BYTE_MASK) - - here leads to infinite SIGFPE for invalid operations, as - there are bits in the control register that need to be - cleared that are let through by that mask. -- CSR, 2002-07-16 */ - FLOAT_TRAPS_BYTE_MASK; + FLOAT_TRAPS_BYTE_MASK; - /* FIXME: Shoot me now. - - Hardcoded nastiness: the "0"s below refer to the first floating - point registers -- we should let gcc deal with that. The 8(31) - refers to the position on the stack, less one, of control (we - need for control to be the high word of the double loaded by - lfd; how do I know that r31 contains the stack? I don't, I'm - just guessing. The 255, on the other hand, is a valid constant - -- it says "move everything in the upper word into the floating - point control register. -- CSR, 2002-07-16 */ - - /* FIXME: it appears that the above text is quite accurate, in the - sense that this - - asm ("stw %0, 12(31); lfd 0, 8(31); mtfsf 255, 0" : : "r" (control) : "r31"); - - no longer works. */ + d = *((double *) &control); + asm volatile ("mtfsf 0xff,%0" : : "f" (d)); } void diff --git a/src/runtime/ppc-lispregs.h b/src/runtime/ppc-lispregs.h index 956c11d..e47791b 100644 --- a/src/runtime/ppc-lispregs.h +++ b/src/runtime/ppc-lispregs.h @@ -1,4 +1,13 @@ +#if defined DARWIN +#if defined LANGUAGE_ASSEMBLY +#define REG(num) r##num +#else #define REG(num) num +#endif +#else +#define REG(num) num +#endif + #define NREGS 32 #define reg_ZERO REG(0) /* Should always contain 0 in lisp */ @@ -13,8 +22,13 @@ #define reg_NL6 REG(9) /* Last (7th) FF param */ #define reg_FDEFN REG(10) /* was NL7 until recently -dan */ #define reg_NARGS REG(11) +#ifdef DARWIN +#define reg_CFUNC REG(12) /* Silly to blow a reg on FF-name */ +#define reg_NFP REG(13) /* Lisp may save around FF-call */ +#else #define reg_NFP REG(12) /* Lisp may save around FF-call */ #define reg_CFUNC REG(13) /* Silly to blow a reg on FF-name */ +#endif #define reg_BSP REG(14) /* Binding stack pointer */ #define reg_CFP REG(15) /* Control/value stack frame pointer */ #define reg_CSP REG(16) /* Control/value stack top */ @@ -38,7 +52,7 @@ "ZERO", "NSP", "???", "NL0", \ "NL1", "NL2", "NL3P", "NL4", \ "NL5", "NL6", "FDEFN", "NARGS", \ - "NFP", "CFUNC" "BSP", "CFP", \ + "NFP", "CFUNC", "BSP", "CFP", \ "CSP", "ALLOC", "NULL", "CODE", \ "CNAME", "LEXENV", "OCFP", "LRA", \ "A0", "A1", "A2", "A3", \ diff --git a/src/runtime/x86-bsd-os.c b/src/runtime/x86-bsd-os.c new file mode 100644 index 0000000..12c57d5 --- /dev/null +++ b/src/runtime/x86-bsd-os.c @@ -0,0 +1,55 @@ +#include +#include "target-arch-os.h" +#include "target-os.h" + +/* KLUDGE: There is strong family resemblance in the signal context + * stuff in FreeBSD and OpenBSD, but in detail they're different in + * almost every line of code. It would be nice to find some way to + * factor out the commonality better; failing that, it might be best + * just to split this generic-BSD code into one variant for each BSD. + * + * KLUDGE II: this split has begun with the addition of the Darwin BSD + * flavour, with the cross-architecture complications that this + * entails; unfortunately, currently the situation is worse, not + * better, than in the above paragraph. */ + +int * +os_context_register_addr(os_context_t *context, int offset) +{ + switch(offset) { + case 0: + return CONTEXT_ADDR_FROM_STEM(eax); + case 2: + return CONTEXT_ADDR_FROM_STEM(ecx); + case 4: + return CONTEXT_ADDR_FROM_STEM(edx); + case 6: + return CONTEXT_ADDR_FROM_STEM(ebx); + case 8: + return CONTEXT_ADDR_FROM_STEM(esp); + case 10: + return CONTEXT_ADDR_FROM_STEM(ebp); + case 12: + return CONTEXT_ADDR_FROM_STEM(esi); + case 14: + return CONTEXT_ADDR_FROM_STEM(edi); + default: + return 0; + } +} + +int * +os_context_sp_addr(os_context_t *context) +{ + return CONTEXT_ADDR_FROM_STEM(esp); +} + + +/* FIXME: If this can be a no-op on BSD/x86, then it + * deserves a more precise name. + * + * (Perhaps os_prepare_data_area_to_be_executed()?) */ +void +os_flush_icache(os_vm_address_t address, os_vm_size_t length) +{ +} diff --git a/src/runtime/x86-bsd-os.h b/src/runtime/x86-bsd-os.h index 1340cb4..5f1e242 100644 --- a/src/runtime/x86-bsd-os.h +++ b/src/runtime/x86-bsd-os.h @@ -1,8 +1,20 @@ -#ifndef _X86_LINUX_OS_H -#define _X86_LINUX_OS_H +#ifndef _X86_BSD_OS_H +#define _X86_BSD_OS_H static inline os_context_t *arch_os_get_context(void **void_context) { return (os_context_t *) *void_context; } -#endif /* _X86_LINUX_OS_H */ +/* The different BSD variants have diverged in exactly where they + * store signal context information, but at least they tend to use the + * same stems to name the structure fields, so by using this macro we + * can share a fair amount of code between different variants. */ +#if defined __FreeBSD__ +#define CONTEXT_ADDR_FROM_STEM(stem) &context->uc_mcontext.mc_ ## stem +#elif defined __OpenBSD__ +#define CONTEXT_ADDR_FROM_STEM(stem) &context->sc_ ## stem +#else +#error unsupported BSD variant +#endif + +#endif /* _X86_BSD_OS_H */ diff --git a/version.lisp-expr b/version.lisp-expr index 4ce0253..d9234c2 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.8.2.7" +"0.8.2.8"