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
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.
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.
NJF Nathan Froyd
AL Arthur Lemmens
RAM Robert MacLachlan
+PRM Pierre Mai
WHN William ("Bill") Newman
CSR Christophe Rhodes
PVE Peter Van Eynde
** (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)
(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)
;;; 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)
(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))
result)
t)
+;;; FIXME
+#-darwin
(deftest create-read-mapped-file-1
;; Read data via a mapped-file-simple-stream object.
(let ((result t)
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 ;;
*)
;;
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
"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)
(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))
;;; 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)
;;; 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"
(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()
*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))
;;; 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)
;;; 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)))
;; 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")))
;; 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"))
(: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))))
;;;
(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)
(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)))
(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)))
(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)))
(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))
(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)
(: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)
(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)
(: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
(: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
\f
;;;; 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.
(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)
(: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)))
;;;
;;; 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))
\f
(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))
(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))
(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)
(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)
--- /dev/null
+# -*- 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
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
#include <signal.h>
/* #include <sys/sysinfo.h> */
#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
\f
-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;
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)
{
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 */
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 */
#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 <ucontext.h>
+typedef ucontext_t os_context_t;
+#define SIG_MEMORY_FAULT SIGBUS
#else
#error unsupported BSD variant
#endif
#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
*/
#define LANGUAGE_ASSEMBLY
#include "sbcl.h"
+
.text
#if defined LISP_FEATURE_X86
.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 ; \
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
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)));
}
#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;
static void
sigtrap_handler(int signal, siginfo_t *siginfo, os_context_t *context)
{
- int badinst;
u32 code;
sigset_t *mask;
#ifdef LISP_FEATURE_LINUX
}
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:
#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)
#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) ; \
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) ; \
lwz 0,4(1) ; \
mtlr 0 ; \
-
-
+#endif
.text
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
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
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 */
/* Return the one value. */
- mr 3,reg_A0
+ mr REG(3),reg_A0
/* Turn on pseudo-atomic */
li reg_NL3,-4
/* 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)
/* 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
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 */
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
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
GFUNCDEF(ppc_flush_cache_line)
- dcbf 0,3
+ dcbf 0,REG(3)
sync
- icbi 0,3
+ icbi 0,REG(3)
sync
isync
blr
--- /dev/null
+#include "globals.h"
+#include <signal.h>
+#include <ucontext.h>
+#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);
+}
--- /dev/null
+#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 */
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
+#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 */
#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 */
"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", \
--- /dev/null
+#include <signal.h>
+#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)
+{
+}
-#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 */
;;; 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"
projects / sbcl.git / commitdiff