From: Christophe Rhodes Date: Tue, 3 Jan 2006 09:52:37 +0000 (+0000) Subject: 0.9.8.7: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=7fb597b585fc715537ea644f7d84440eca217ca1;p=sbcl.git 0.9.8.7: Merge "merge candidate 1" for SBCL/Win32. ... a lot done, a lot left to do. --- diff --git a/CREDITS b/CREDITS index 53dcb63..6cfe18a 100644 --- a/CREDITS +++ b/CREDITS @@ -518,6 +518,9 @@ Daniel Barlow: asdf-install, sb-bsd-sockets, sb-executable, sb-grovel and sb-posix contrib packages. +Alastair Bridgewater: + He contributed a port of the system to the Windows operating system. + Robert E. Brown: He has reported various bugs and submitted several patches, especially improving removing gratuitous efficiencies in the diff --git a/NEWS b/NEWS index 5857ff5..dbd1513 100644 --- a/NEWS +++ b/NEWS @@ -1,5 +1,7 @@ ;;;; -*- coding: utf-8; -*- changes in sbcl-0.9.9 relative to sbcl-0.9.8: + * new platform: experimental support for the Windows operating + system has been added. (thanks to Alastair Bridgewater) * optimization: faster implementation of EQUAL * fixed segfaults on x86 FreeBSD 7-current (thanks to NIIMI Satoshi) diff --git a/build-order.lisp-expr b/build-order.lisp-expr index f923961..ba71c0e 100644 --- a/build-order.lisp-expr +++ b/build-order.lisp-expr @@ -212,7 +212,7 @@ ;; "src/code/unix.lisp" needs this. It's generated automatically by ;; grovel_headers.c, i.e. it's not in CVS. - ("output/stuff-groveled-from-headers" :not-host) + #!-win32 ("output/stuff-groveled-from-headers" :not-host) ("src/code/unix" :not-host) @@ -224,6 +224,7 @@ #!+irix ("src/code/irix-os" :not-host) #!+bsd ("src/code/bsd-os" :not-host) #!+linux ("src/code/linux-os" :not-host) + #!+win32 ("src/code/win32-os" :not-host) ;; sparc-vm and ppc-vm need sc-offset defined to get at internal ;; error args. This file contains stuff previously in @@ -244,7 +245,8 @@ ;; FIXME: do we really want to keep this? -- CSR, 2002-08-31 #!+rt ("src/code/rt-vm" :not-host) - ("src/code/target-signal" :not-host) ; needs OS-CONTEXT-T from x86-vm + #!-win32 ("src/code/target-signal" :not-host) ; needs OS-CONTEXT-T from x86-vm + #!+win32 ("src/code/target-exception" :not-host) ("src/code/symbol" :not-host) ("src/code/bignum" :not-host) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 3894252..c87ae89 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -43,6 +43,7 @@ of SBCL which maintained the CMU-CL-style split into two packages.)" "UNION" "VALUES" "*") :export ("ADDR" "ALIEN" + #!+win32 "ALIEN-FUNCALL-STDCALL" "ALIEN-FUNCALL" "ALIEN-SAP" "ALIEN-SIZE" "CAST" "C-STRING" "DEFINE-ALIEN-ROUTINE" "DEFINE-ALIEN-TYPE" "DEFINE-ALIEN-VARIABLE" @@ -196,6 +197,7 @@ of SBCL which maintained the CMU-CL-style split into two packages.)" "SB!KERNEL" "SB!SYS") :reexport ("SLOT" "CODE-INSTRUCTIONS" "FLUSHABLE") :export ("%ALIEN-FUNCALL" + #!+win32 "%ALIEN-FUNCALL-STDCALL" "%CATCH-BREAKUP" "%CONTINUE-UNWIND" "%LISTIFY-REST-ARGS" "%MORE-ARG" "%MORE-ARG-VALUES" "%UNWIND-PROTECT-BREAKUP" @@ -1247,6 +1249,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "INTEGER-DECODE-DOUBLE-FLOAT" #!+long-float "INTEGER-DECODE-LONG-FLOAT" "INTEGER-DECODE-SINGLE-FLOAT" "INTERNAL-ERROR" + #!+win32 "HANDLE-WIN32-EXCEPTION" "INTERNAL-TIME" "INTERSECTION-TYPE" "INTERSECTION-TYPE-P" "INTERSECTION-TYPE-TYPES" "INVALID-ARG-COUNT-ERROR" "INVALID-ARRAY-INDEX-ERROR" "INVALID-UNWIND-ERROR" @@ -2307,6 +2310,7 @@ structure representations" "WEAK-POINTER-VALUE-SLOT" "WORD" "N-WORD-BITS" "N-WORD-BYTES" "N-MACHINE-WORD-BITS" "WORD-REG-SC-NUMBER" "WORD-SHIFT" + #!+win32 "CONTEXT-RESTORE-TRAP" "ZERO-SC-NUMBER")) #s(sb-cold:package-data diff --git a/src/code/cold-init.lisp b/src/code/cold-init.lisp index cf82264..4545f0c 100644 --- a/src/code/cold-init.lisp +++ b/src/code/cold-init.lisp @@ -218,7 +218,7 @@ (show-and-call stream-cold-init-or-reset) (show-and-call !loader-cold-init) (show-and-call !foreign-cold-init) - (show-and-call signal-cold-init-or-reinit) + #!-win32 (show-and-call signal-cold-init-or-reinit) (/show0 "enabling internal errors") (setf (sb!alien:extern-alien "internal_errors_enabled" boolean) t) @@ -290,7 +290,7 @@ UNIX-like systems, UNIX-STATUS is used as the status code." (os-cold-init-or-reinit) (thread-init-or-reinit) (stream-reinit) - (signal-cold-init-or-reinit) + #!-win32 (signal-cold-init-or-reinit) (setf (sb!alien:extern-alien "internal_errors_enabled" boolean) t) ;; PRINT seems not to like x86 NPX denormal floats like ;; LEAST-NEGATIVE-SINGLE-FLOAT, so the :UNDERFLOW exceptions are diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index f171394..0e43da7 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -187,7 +187,7 @@ start length) (cond ((not count) - (if (= errno sb!unix:ewouldblock) + (if #!-win32 (= errno sb!unix:ewouldblock) #!+win32 t #!-win32 (error "Write would have blocked, but SERVER told us to go.") (simple-stream-perror "couldn't write to ~S" stream errno))) ((eql count length) ; Hot damn, it worked. @@ -238,7 +238,7 @@ (multiple-value-bind (count errno) (sb!unix:unix-write (fd-stream-fd stream) base start length) (cond ((not count) - (if (= errno sb!unix:ewouldblock) + (if #!-win32 (= errno sb!unix:ewouldblock) #!+win32 t #!-win32 (output-later stream base start end reuse-sap) (simple-stream-perror "couldn't write to ~S" stream @@ -687,7 +687,7 @@ (sb!sys:int-sap (+ (sb!sys:sap-int ibuf-sap) tail)) (- buflen tail)) (cond ((null count) - (if (eql errno sb!unix:ewouldblock) + (if #!-win32 (eql errno sb!unix:ewouldblock) #!+win32 t #!-win32 (progn (unless (sb!sys:wait-until-fd-usable fd :input (fd-stream-timeout stream)) @@ -1879,6 +1879,7 @@ ;;; Rename NAMESTRING to ORIGINAL. First, check whether we have write ;;; access, since we don't want to trash unwritable files even if we ;;; technically can. We return true if we succeed in renaming. +#!-win32 (defun rename-the-old-one (namestring original) (unless (sb!unix:unix-access namestring sb!unix:w_ok) (error "~@" namestring)) diff --git a/src/code/foreign.lisp b/src/code/foreign.lisp index 7503bda..49994d6 100644 --- a/src/code/foreign.lisp +++ b/src/code/foreign.lisp @@ -11,13 +11,13 @@ (in-package "SB!IMPL") -#!-(or elf mach-o) -(error "Not an ELF or Mach-O platform?") +#!-(or elf mach-o win32) +(error "Not an ELF, Mach-O, or Win32 platform?") (defun extern-alien-name (name) (handler-case #!+elf (coerce name 'base-string) - #!+mach-o (concatenate 'base-string "_" name) + #!+(or mach-o win32) (concatenate 'base-string "_" name) (error () (error "invalid external alien name: ~S" name)))) diff --git a/src/code/irrat.lisp b/src/code/irrat.lisp index 07faa5c..1a38ed9 100644 --- a/src/code/irrat.lisp +++ b/src/code/irrat.lisp @@ -73,16 +73,16 @@ #!-x86 (def-math-rtn "atan2" 2) (def-math-rtn "sinh" 1) (def-math-rtn "cosh" 1) -(def-math-rtn "tanh" 1) -(def-math-rtn "asinh" 1) -(def-math-rtn "acosh" 1) -(def-math-rtn "atanh" 1) +#!-win32(def-math-rtn "tanh" 1) +#!-win32(def-math-rtn "asinh" 1) +#!-win32(def-math-rtn "acosh" 1) +#!-win32(def-math-rtn "atanh" 1) ;;; exponential and logarithmic #!-x86 (def-math-rtn "exp" 1) #!-x86 (def-math-rtn "log" 1) #!-x86 (def-math-rtn "log10" 1) -(def-math-rtn "pow" 2) +#!-win32(def-math-rtn "pow" 2) #!-(or x86 x86-64) (def-math-rtn "sqrt" 1) (def-math-rtn "hypot" 2) #!-(or hpux x86) (def-math-rtn "log1p" 1) diff --git a/src/code/octets.lisp b/src/code/octets.lisp index b7dbfd0..f743a4b 100644 --- a/src/code/octets.lisp +++ b/src/code/octets.lisp @@ -640,7 +640,7 @@ one-past-the-end" (defun default-external-format () (or *default-external-format* - (let ((external-format (intern (or (sb!alien:alien-funcall + (let ((external-format (intern (or #!-win32 (sb!alien:alien-funcall (extern-alien "nl_langinfo" (function c-string int)) diff --git a/src/code/save.lisp b/src/code/save.lisp index ac69bb9..cff44fc 100644 --- a/src/code/save.lisp +++ b/src/code/save.lisp @@ -135,7 +135,7 @@ sufficiently motivated to do lengthy fixes." (dolist (hook *save-hooks*) (with-simple-restart (continue "Skip this save hook.") (funcall hook))) - (when (fboundp 'cancel-finalization) + #!-win32 (when (fboundp 'cancel-finalization) (cancel-finalization sb!sys:*tty*)) (profile-deinit) (debug-deinit) diff --git a/src/code/serve-event.lisp b/src/code/serve-event.lisp index 426a48a..908b4ce 100644 --- a/src/code/serve-event.lisp +++ b/src/code/serve-event.lisp @@ -310,7 +310,7 @@ (sb!alien:addr read-fds) (sb!alien:addr write-fds) nil to-sec to-usec) - + #!+win32 (declare (ignorable err)) ;; Now see what it was (if anything) (cond (value (cond ((zerop value) @@ -319,6 +319,7 @@ (funcall *periodic-polling-function*))) (t (call-fd-handler)))) + #!-win32 ((eql err sb!unix:eintr) ;; We did an interrupt. t) diff --git a/src/code/target-alieneval.lisp b/src/code/target-alieneval.lisp index f64a212..70fb7bb 100644 --- a/src/code/target-alieneval.lisp +++ b/src/code/target-alieneval.lisp @@ -587,6 +587,37 @@ (t (error "~S is not an alien function." alien))))) +(defun alien-funcall-stdcall (alien &rest args) + #!+sb-doc + "Call the foreign function ALIEN with the specified arguments. ALIEN's + type specifies the argument and result types." + (declare (type alien-value alien)) + (let ((type (alien-value-type alien))) + (typecase type + (alien-pointer-type + (apply #'alien-funcall-stdcall (deref alien) args)) + (alien-fun-type + (unless (= (length (alien-fun-type-arg-types type)) + (length args)) + (error "wrong number of arguments for ~S~%expected ~W, got ~W" + type + (length (alien-fun-type-arg-types type)) + (length args))) + (let ((stub (alien-fun-type-stub type))) + (unless stub + (setf stub + (let ((fun (gensym)) + (parms (make-gensym-list (length args)))) + (compile nil + `(lambda (,fun ,@parms) + (declare (optimize (sb!c::insert-step-conditions 0))) + (declare (type (alien ,type) ,fun)) + (alien-funcall-stdcall ,fun ,@parms))))) + (setf (alien-fun-type-stub type) stub)) + (apply stub alien args))) + (t + (error "~S is not an alien function." alien))))) + (defmacro define-alien-routine (name result-type &rest args &environment lexenv) diff --git a/src/code/target-exception.lisp b/src/code/target-exception.lisp new file mode 100644 index 0000000..8e25dc0 --- /dev/null +++ b/src/code/target-exception.lisp @@ -0,0 +1,59 @@ +;;;; code for handling Win32 exceptions + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!UNIX") + +;;; +;;; An awful lot of this stuff is stubbed out for now. We basically +;;; only handle inbound exceptions (the local equivalent to unblockable +;;; signals), and we're only picking off the sigsegv and sigfpe traps. +;;; +;;; This file is based on target-signal.lisp, but most of that went +;;; away. Some of it might want to be put back or emulated. +;;; + +;;; SIGINT is handled like BREAK, except that ANSI BREAK ignores +;;; *DEBUGGER-HOOK*, but we want SIGINT's BREAK to respect it, so that +;;; SIGINT in --disable-debugger mode will cleanly terminate the system +;;; (by respecting the *DEBUGGER-HOOK* established in that mode). +;;; +;;; We'd like to have this work, but that would require some method of +;;; delivering a "blockable signal". Windows doesn't really have the +;;; concept, so we need to play with the threading functions to emulate +;;; it (especially since the local equivalent of SIGINT comes in on a +;;; separate thread). This is on the list for fixing later on, and will +;;; be required before we implement threads (because of stop-for-gc). +;;; +;;; This specific bit of functionality may well be implemented entirely +;;; in the runtime. +#| +(defun sigint-%break (format-string &rest format-arguments) + (flet ((break-it () + (apply #'%break 'sigint format-string format-arguments))) + (sb!thread:interrupt-thread (sb!thread::foreground-thread) #'break-it))) +|# + +;;; Actual exception handler. We hit something the runtime doesn't +;;; want to or know how to deal with (that is, not a sigtrap or gc +;;; wp violation), so it calls us here. + +(defun sb!kernel:handle-win32-exception (context exception-record) + (error "An exception occured! Context ~A, exception-record ~A." + context exception-record)) + +;;;; etc. + +;;; CMU CL comment: +;;; Magically converted by the compiler into a break instruction. +;;; SBCL/Win32 comment: +;;; I don't know if we still need this or not. Better safe for now. +(defun receive-pending-interrupt () + (receive-pending-interrupt)) diff --git a/src/code/target-misc.lisp b/src/code/target-misc.lisp index 65fe84d..c636770 100644 --- a/src/code/target-misc.lisp +++ b/src/code/target-misc.lisp @@ -129,7 +129,8 @@ (defun machine-instance () #!+sb-doc "Return a string giving the name of the local machine." - (sb!unix:unix-gethostname)) + #!+win32 "some-random-windows-box" + #!-win32 (sb!unix:unix-gethostname)) (defvar *machine-version*) diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp index 9c01fa9..be58064 100644 --- a/src/code/toplevel.lisp +++ b/src/code/toplevel.lisp @@ -472,7 +472,7 @@ steppers to maintain contextual information.") (init-file-name (maybe-dir-name basename) (and maybe-dir-name (concatenate 'string maybe-dir-name "/" basename)))) - (let ((sysinit-truename + #!-win32 (let ((sysinit-truename (probe-init-files sysinit (init-file-name (posix-getenv "SBCL_HOME") "sbclrc") @@ -561,7 +561,7 @@ steppers to maintain contextual information.") (with-simple-restart (abort "~@") (catch 'toplevel-catcher - (sb!unix::reset-signal-mask) + #!-win32 (sb!unix::reset-signal-mask) ;; In the event of a control-stack-exhausted-error, we ;; should have unwound enough stack by the time we get ;; here that this is now possible. diff --git a/src/code/unix.lisp b/src/code/unix.lisp index 3ef530f..af55732 100644 --- a/src/code/unix.lisp +++ b/src/code/unix.lisp @@ -101,9 +101,36 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." `(let (,value ,errno) (loop (multiple-value-setq (,value ,errno) ,syscall-form) - (unless (eql ,errno sb!unix:eintr) + (unless #!-win32 (eql ,errno sb!unix:eintr) #!+win32 nil (return (values ,value ,errno)))) ,@body)) + +#!+win32 +(progn + (defconstant o_rdonly 0) + (defconstant o_wronly 1) + (defconstant o_rdwr 2) + (defconstant o_creat #x100) + (defconstant o_trunc #x200) + (defconstant o_append #x008) + (defconstant o_excl #x400) + (defconstant enoent 2) + (defconstant eexist 17) + (defconstant espipe 29) + (defconstant o_binary #x8000) + (defconstant s-ifmt #xf000) + (defconstant s-ifdir #x4000) + (defconstant s-ifreg #x8000) + (define-alien-type ino-t short) + (define-alien-type time-t long) + (define-alien-type off-t long) + (define-alien-type size-t long) + (define-alien-type mode-t unsigned-short) + + ;; For stat-wrapper hack (different-type or non-existing win32 fields). + (define-alien-type nlink-t short) + (define-alien-type uid-t short) + (define-alien-type gid-t short)) ;;;; hacking the Unix environment @@ -157,7 +184,7 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (declare (type unix-pathname path) (type fixnum flags) (type unix-file-mode mode)) - (int-syscall ("open" c-string int int) path flags mode)) + (int-syscall ("open" c-string int int) path (logior #!+win32 o_binary flags) mode)) ;;; UNIX-CLOSE accepts a file descriptor and attempts to close the file ;;; associated with it. @@ -212,6 +239,7 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." ;;; w_ok Write permission. ;;; x_ok Execute permission. ;;; f_ok Presence of file. +#!-win32 (defun unix-access (path mode) (declare (type unix-pathname path) (type (mod 8) mode)) @@ -275,16 +303,22 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." ;;; value is the pipe to be read from and the second is can be written ;;; to. If an error occurred the first value is NIL and the second the ;;; unix error code. +#!-win32 (defun unix-pipe () (with-alien ((fds (array int 2))) (syscall ("pipe" (* int)) (values (deref fds 0) (deref fds 1)) (cast fds (* int))))) +;; Windows mkdir() doesn't take the mode argument. It's cdecl, so we could +;; actually call it passing the mode argument, but some sharp-eyed reader +;; would put five and twenty-seven together and ask us about it, so... +;; -- AB, 2005-12-27 (defun unix-mkdir (name mode) (declare (type unix-pathname name) - (type unix-file-mode mode)) - (void-syscall ("mkdir" c-string int) name mode)) + (type unix-file-mode mode) + #!+win32 (ignore mode)) + (void-syscall ("mkdir" c-string #!-win32 int) name #!-win32 mode)) ;;; Given a C char* pointer allocated by malloc(), free it and return a ;;; corresponding Lisp string (or return NIL if the pointer is a C NULL). @@ -311,14 +345,23 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." ;; 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 netbsd sunos osf1 darwin) (,stub,) - #!+(or linux openbsd freebsd netbsd sunos osf1 darwin) - (or (newcharstar-string (alien-funcall (extern-alien "getcwd" + ;; + ;; The Win32 damage here is explained in the comment above wrap_getcwd() + ;; in src/runtime/wrap.c. Short form: We need it now, it goes away later. + ;; + ;; FIXME: The (,stub,) nastiness produces an error message about a + ;; comma not inside a backquote. This error has absolutely nothing + ;; to do with the actual meaning of the error (and little to do with + ;; its location, either). + #!-(or linux openbsd freebsd netbsd sunos osf1 darwin win32) (,stub,) + #!+(or linux openbsd freebsd netbsd sunos osf1 darwin win32) + (or (newcharstar-string (alien-funcall (extern-alien #!-win32 "getcwd" + #!+win32 "wrap_getcwd" (function (* char) (* char) size-t)) nil - #!+(or linux openbsd freebsd netbsd darwin) 0 + #!+(or linux openbsd freebsd netbsd darwin win32) 0 #!+(or sunos osf1) 1025)) (simple-perror "getcwd"))) @@ -345,9 +388,11 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (define-alien-routine ("getpid" unix-getpid) int) ;;; Return the real user id associated with the current process. +#!-win32 (define-alien-routine ("getuid" unix-getuid) int) ;;; Translate a user id into a login name. +#!-win32 (defun uid-username (uid) (or (newcharstar-string (alien-funcall (extern-alien "uid_username" (function (* char) int)) @@ -356,6 +401,7 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." ;;; Return the namestring of the home directory, being careful to ;;; include a trailing #\/ +#!-win32 (defun uid-homedir (uid) (or (newcharstar-string (alien-funcall (extern-alien "uid_homedir" (function (* char) int)) @@ -365,6 +411,7 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." ;;; Invoke readlink(2) on the file name specified by PATH. Return ;;; (VALUES LINKSTRING NIL) on success, or (VALUES NIL ERRNO) on ;;; failure. +#!-win32 (defun unix-readlink (path) (declare (type unix-pathname path)) (with-alien ((ptr (* char) @@ -378,6 +425,12 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (values (with-alien ((c-string c-string ptr)) c-string) nil) (free-alien ptr))))) +#!+win32 +;; Win32 doesn't do links, but something likes to call this anyway. +;; Something in this file, no less. But it only takes one result, so... +(defun unix-readlink (path) + (declare (ignore path)) + nil) ;;; UNIX-UNLINK accepts a name and deletes the directory entry for that ;;; name and the file if this is the last link. @@ -386,12 +439,14 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (void-syscall ("unlink" c-string) name)) ;;; Return the name of the host machine as a string. +#!-win32 (defun unix-gethostname () (with-alien ((buf (array char 256))) (syscall ("gethostname" (* char) int) (cast buf c-string) (cast buf (* char)) 256))) +#!-win32 (defun unix-setsid () (int-syscall ("setsid"))) @@ -400,6 +455,7 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." ;;; UNIX-IOCTL performs a variety of operations on open i/o ;;; descriptors. See the UNIX Programmer's Manual for more ;;; information. +#!-win32 (defun unix-ioctl (fd cmd arg) (declare (type unix-fd fd) (type (signed-byte 32) cmd)) @@ -413,6 +469,7 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." ;;; user time, and returns the seconds and microseconds as separate ;;; values. #!-sb-fluid (declaim (inline unix-fast-getrusage)) +#!-win32 (defun unix-fast-getrusage (who) (declare (values (member t) (unsigned-byte 31) (integer 0 1000000) @@ -431,6 +488,7 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." ;;; (rusage_self) or all of the terminated child processes ;;; (rusage_children). NIL and an error number is returned if the call ;;; fails. +#!-win32 (defun unix-getrusage (who) (with-alien ((usage (struct rusage))) (syscall ("getrusage" int (* (struct rusage))) @@ -664,6 +722,7 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (seconds-west sb!alien:int :out) (daylight-savings-p sb!alien:boolean :out)) +#!-win32 (defun nanosleep (secs nsecs) (with-alien ((req (struct timespec)) (rem (struct timespec))) @@ -720,6 +779,7 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (defconstant itimer-virtual 1) (defconstant itimer-prof 2) +#!-win32 (defun unix-getitimer (which) "Unix-getitimer returns the INTERVAL and VALUE slots of one of three system timers (:real :virtual or :profile). On success, @@ -742,6 +802,7 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (slot (slot itv 'it-value) 'tv-usec)) which (alien-sap (addr itv)))))) +#!-win32 (defun unix-setitimer (which int-secs int-usec val-secs val-usec) " Unix-setitimer sets the INTERVAL and VALUE slots of one of three system timers (:real :virtual or :profile). A SIGALRM signal @@ -797,6 +858,7 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (let ((kind (logand mode s-ifmt))) (cond ((eql kind s-ifdir) :directory) ((eql kind s-ifreg) :file) + #!-win32 ((eql kind s-iflnk) :link) (t :special)))))) diff --git a/src/code/win32-os.lisp b/src/code/win32-os.lisp new file mode 100644 index 0000000..1565897 --- /dev/null +++ b/src/code/win32-os.lisp @@ -0,0 +1,65 @@ +;;;; OS interface functions for SBCL under Win32. + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!SYS") + +;;; Check that target machine features are set up consistently with +;;; this file. +#!-win32 (error "missing :WIN32 feature") + +(defun software-type () + #!+sb-doc + "Return a string describing the supporting software." + (values "Win32")) + +(defvar *software-version* nil) + +(defun software-version () + #!+sb-doc + "Return a string describing version of the supporting software, or NIL + if not available." + nil ;; FIXME: Implement. + #+nil(or *software-version* + (setf *software-version* + (string-trim '(#\newline) + (with-output-to-string (stream) + (sb!ext:run-program "/bin/uname" `("-r") + :output stream)))))) + +(defun os-cold-init-or-reinit () ; KLUDGE: don't know what to do here + (/show0 "entering win32-os.lisp OS-COLD-INIT-OR-REINIT") + (setf *software-version* nil) + (/show0 "setting *DEFAULT-PATHNAME-DEFAULTS*") + (setf *default-pathname-defaults* + ;; (temporary value, so that #'NATIVE-PATHNAME won't blow up when + ;; we call it below:) + (make-trivial-default-pathname) + *default-pathname-defaults* + ;; (final value, constructed using #'NATIVE-PATHNAME:) + (native-pathname (sb!unix:posix-getcwd/))) + (/show0 "leaving linux-os.lisp OS-COLD-INIT-OR-REINIT")) + +;;; Return system time, user time and number of page faults. +(defun get-system-info () +#+nil (multiple-value-bind + (err? utime stime maxrss ixrss idrss isrss minflt majflt) + (sb!unix:unix-getrusage sb!unix:rusage_self) + (declare (ignore maxrss ixrss idrss isrss minflt)) + (unless err? ; FIXME: nonmnemonic (reversed) name for ERR? + (error "Unix system call getrusage failed: ~A." (strerror utime))) + (values utime stime majflt))) + +;;; Return the system page size. +(defun get-page-size () + ;; probably should call getpagesize() + ;; FIXME: Or we could just get rid of this, since the uses of it look + ;; disposable. + 4096) diff --git a/src/cold/warm.lisp b/src/cold/warm.lisp index 3aff541..f4687da 100644 --- a/src/cold/warm.lisp +++ b/src/cold/warm.lisp @@ -168,7 +168,7 @@ "SRC;CODE;PROFILE" "SRC;CODE;NTRACE" "SRC;CODE;STEP" - "SRC;CODE;RUN-PROGRAM" + #-win32 "SRC;CODE;RUN-PROGRAM" ;; Code derived from PCL's pre-ANSI DESCRIBE-OBJECT ;; facility is still used in our ANSI DESCRIBE diff --git a/src/compiler/aliencomp.lisp b/src/compiler/aliencomp.lisp index 92a9128..c7e8f3d 100644 --- a/src/compiler/aliencomp.lisp +++ b/src/compiler/aliencomp.lisp @@ -68,6 +68,9 @@ (defknown alien-funcall (alien-value &rest *) * (any recursive)) +#!+win32 +(defknown alien-funcall-stdcall (alien-value &rest *) * + (any recursive)) ;;;; cosmetic transforms @@ -710,3 +713,122 @@ ((reference-tn-list result-tns t))) (vop dealloc-number-stack-space call block stack-frame-size) (move-lvar-result call block result-tns lvar)))) + +;;;; ALIEN-FUNCALL-STDCALL support + +#!+win32 +(deftransform alien-funcall-stdcall ((function &rest args) + ((alien (* t)) &rest *) * + :important t) + (let ((names (make-gensym-list (length args)))) + (/noshow "entering first DEFTRANSFORM ALIEN-FUNCALL-STDCALL" function args) + `(lambda (function ,@names) + (alien-funcall-stdcall (deref function) ,@names)))) + +#!+win32 +(deftransform alien-funcall-stdcall ((function &rest args) * * :important t) + (let ((type (lvar-type function))) + (unless (alien-type-type-p type) + (give-up-ir1-transform "can't tell function type at compile time")) + (/noshow "entering second DEFTRANSFORM ALIEN-FUNCALL-STDCALL" function) + (let ((alien-type (alien-type-type-alien-type type))) + (unless (alien-fun-type-p alien-type) + (give-up-ir1-transform)) + (let ((arg-types (alien-fun-type-arg-types alien-type))) + (unless (= (length args) (length arg-types)) + (abort-ir1-transform + "wrong number of arguments; expected ~W, got ~W" + (length arg-types) + (length args))) + (collect ((params) (deports)) + (dolist (arg-type arg-types) + (let ((param (gensym))) + (params param) + (deports `(deport ,param ',arg-type)))) + (let ((return-type (alien-fun-type-result-type alien-type)) + (body `(%alien-funcall-stdcall (deport function ',alien-type) + ',alien-type + ,@(deports)))) + (if (alien-values-type-p return-type) + (collect ((temps) (results)) + (dolist (type (alien-values-type-values return-type)) + (let ((temp (gensym))) + (temps temp) + (results `(naturalize ,temp ',type)))) + (setf body + `(multiple-value-bind ,(temps) ,body + (values ,@(results))))) + (setf body `(naturalize ,body ',return-type))) + (/noshow "returning from DEFTRANSFORM ALIEN-FUNCALL-STDCALL" (params) body) + `(lambda (function ,@(params)) + ,body))))))) + +#!+win32 +(defoptimizer (%alien-funcall-stdcall derive-type) ((function type &rest args)) + (declare (ignore function args)) + (unless (constant-lvar-p type) + (error "Something is broken.")) + (let ((type (lvar-value type))) + (unless (alien-fun-type-p type) + (error "Something is broken.")) + (values-specifier-type + (compute-alien-rep-type + (alien-fun-type-result-type type))))) + +#!+win32 +(defoptimizer (%alien-funcall-stdcall ltn-annotate) + ((function type &rest args) node ltn-policy) + (setf (basic-combination-info node) :funny) + (setf (node-tail-p node) nil) + (annotate-ordinary-lvar function) + (dolist (arg args) + (annotate-ordinary-lvar arg))) + +#!+win32 +(defoptimizer (%alien-funcall-stdcall ir2-convert) + ((function type &rest args) call block) + (let ((type (if (constant-lvar-p type) + (lvar-value type) + (error "Something is broken."))) + (lvar (node-lvar call)) + (args args)) + (multiple-value-bind (nsp stack-frame-size arg-tns result-tns) + (make-call-out-tns type) + (vop alloc-number-stack-space call block stack-frame-size nsp) + (dolist (tn arg-tns) + (let* ((arg (pop args)) + (sc (tn-sc tn)) + (scn (sc-number sc)) + #!-x86 (temp-tn (make-representation-tn (tn-primitive-type tn) + scn)) + (move-arg-vops (svref (sc-move-arg-vops sc) scn))) + (aver arg) + (unless (= (length move-arg-vops) 1) + (error "no unique move-arg-vop for moves in SC ~S" (sc-name sc))) + #!+x86 (emit-move-arg-template call + block + (first move-arg-vops) + (lvar-tn call block arg) + nsp + tn) + #!-x86 (progn + (emit-move call + block + (lvar-tn call block arg) + temp-tn) + (emit-move-arg-template call + block + (first move-arg-vops) + temp-tn + nsp + tn)))) + (aver (null args)) + (unless (listp result-tns) + (setf result-tns (list result-tns))) + (vop* call-out call block + ((lvar-tn call block function) + (reference-tn-list arg-tns nil)) + ((reference-tn-list result-tns t))) + ;; This is the stdcall magic: Callee clears args. + #+nil (vop dealloc-number-stack-space call block stack-frame-size) + (move-lvar-result call block result-tns lvar)))) diff --git a/src/compiler/early-aliencomp.lisp b/src/compiler/early-aliencomp.lisp index d19ce05..0e5ad07 100644 --- a/src/compiler/early-aliencomp.lisp +++ b/src/compiler/early-aliencomp.lisp @@ -1,3 +1,4 @@ (in-package "SB!C") (defknown %alien-funcall (system-area-pointer alien-type &rest *) *) +(defknown %alien-funcall-stdcall (system-area-pointer alien-type &rest *) *) diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index 01b7e71..803b7af 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -1260,6 +1260,7 @@ core and return a descriptor to it." (cold-fdefinition-object (cold-intern ',symbol))))) (frob sub-gc) (frob internal-error) + #!+win32 (frob handle-win32-exception) (frob sb!kernel::control-stack-exhausted-error) (frob sb!kernel::undefined-alien-variable-error) (frob sb!kernel::undefined-alien-function-error) diff --git a/src/compiler/x86/c-call.lisp b/src/compiler/x86/c-call.lisp index a85abb1..278c950 100644 --- a/src/compiler/x86/c-call.lisp +++ b/src/compiler/x86/c-call.lisp @@ -181,6 +181,63 @@ ,@(new-args)))))) (sb!c::give-up-ir1-transform)))) +#!+win32 +(deftransform %alien-funcall-stdcall ((function type &rest args) * * :node node) + (aver (sb!c::constant-lvar-p type)) + (let* ((type (sb!c::lvar-value type)) + (env (sb!c::node-lexenv node)) + (arg-types (alien-fun-type-arg-types type)) + (result-type (alien-fun-type-result-type type))) + (aver (= (length arg-types) (length args))) + (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)) + (new-args `(logand ,arg #xffffffff)) + (new-args `(ash ,arg -32)) + (new-arg-types (parse-alien-type '(unsigned 32) env)) + (if (alien-integer-type-signed type) + (new-arg-types (parse-alien-type '(signed 32) env)) + (new-arg-types (parse-alien-type '(unsigned 32) env)))) + (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 (unsigned 32) (signed 32)) + '(values (unsigned 32) (unsigned 32))) + env)))) + `(lambda (function type ,@(lambda-vars)) + (declare (ignore type)) + (multiple-value-bind (low high) + (%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-sap) (:translate foreign-symbol-sap) (:policy :fast-safe) @@ -228,6 +285,8 @@ (dotimes (i 8) (inst fstp fr0-tn)) + #!+win32 (inst cld) + (inst call function) ;; To give the debugger a clue. XX not really internal-error? (note-this-location vop :internal-error) diff --git a/src/compiler/x86/parms.lisp b/src/compiler/x86/parms.lisp index c6edb03..e53929d 100644 --- a/src/compiler/x86/parms.lisp +++ b/src/compiler/x86/parms.lisp @@ -151,6 +151,18 @@ ;;; set the top-down mmap allocation option in the kernel (not yet ;;; the default), all bets are totally off! +#!+win32 +(progn + + (def!constant read-only-space-start #x01000000) + (def!constant read-only-space-end #x037ff000) + + (def!constant static-space-start #x05000000) + (def!constant static-space-end #x07fff000) + + (def!constant dynamic-space-start #x09000000) + (def!constant dynamic-space-end #x29000000)) + #!+linux (progn (def!constant read-only-space-start #x01000000) @@ -240,7 +252,8 @@ cerror breakpoint fun-end-breakpoint - single-step-breakpoint) + single-step-breakpoint + #!+win32 context-restore) ;; HACK: The Win32 exception handling system does wrong things with this. ;;; FIXME: It'd be nice to replace all the DEFENUMs with something like ;;; (WITH-DEF-ENUM (:START 8) ;;; (DEF-ENUM HALT-TRAP) @@ -292,6 +305,7 @@ sb!kernel::memory-fault-error sb!di::handle-breakpoint fdefinition-object + #!+win32 sb!kernel::handle-win32-exception ;; free pointers ;; diff --git a/src/runtime/Config.x86-win32 b/src/runtime/Config.x86-win32 new file mode 100644 index 0000000..cebd135 --- /dev/null +++ b/src/runtime/Config.x86-win32 @@ -0,0 +1,39 @@ +# This software is part of the SBCL system. See the README file for +# more information. +# +# This software is derived from the CMU CL system, which was +# written at Carnegie Mellon University and released into the +# public domain. The software is in the public domain and is +# provided with absolutely no warranty. See the COPYING and CREDITS +# files for more information. + +TARGET=sbcl.exe + +ASSEM_SRC = x86-assem.S +ARCH_SRC = x86-arch.c + +OS_SRC = win32-os.c x86-win32-os.c os-common.c +# The "--Wl,--export-dynamic" flags are here to help people +# experimenting with callbacks from C to SBCL, by allowing linkage to +# SBCL src/runtime/*.c symbols from C. Work on this is good, but it's +# definitely bleeding edge and not particularly stable. In particular, +# not only are the workarounds for the GC relocating Lisp code and +# data unstable, but even the basic calling convention might end up +# being unstable. Unless you want to do some masochistic maintenance +# work when new releases of SBCL come out, please don't try to build +# real code on this until a coherent stable interface has been added. +# (You *are* encouraged to design and implement a coherent stable +# interface, though.:-| As far as I (WHN 2002-05-19) know, no one is +# working on one and it would be a nice thing to have.) +OS_LINK_FLAGS = -Wl,--export-dynamic +OS_LIBS = + +GC_SRC = gencgc.c + +CFLAGS = -g -Wall -O3 +ASFLAGS = $(CFLAGS) + +CPP = /opt/xmingw/bin/i386-mingw32msvc-cpp +CC = /opt/xmingw/bin/i386-mingw32msvc-gcc +LD = /opt/xmingw/bin/i386-mingw32msvc-ld +NM = /opt/xmingw/bin/i386-mingw32msvc-nm diff --git a/src/runtime/GNUmakefile b/src/runtime/GNUmakefile index a426e2f..ac24da3 100644 --- a/src/runtime/GNUmakefile +++ b/src/runtime/GNUmakefile @@ -9,9 +9,10 @@ # provided with absolutely no warranty. See the COPYING and CREDITS # files for more information. -.PHONY: all clean TAGS tags +.PHONY: all clean TAGS tags targets -all: sbcl sbcl.nm +all: targets +TARGET=sbcl # Defaults which might be overridden or modified by values in the # Config file. Most of them are same on most systems right now. @@ -49,11 +50,13 @@ OBJS = $(C_SRC:.c=.o) $(ASSEM_SRC:.S=.o) ${OS_OBJS} LIBS = ${OS_LIBS} -lm -sbcl: $(OBJS) +targets: $(TARGET) sbcl.nm + +$(TARGET): $(OBJS) $(CC) ${LINKFLAGS} -o $@ $^ $(LIBS) -sbcl.nm: sbcl - $(NM) sbcl | $(GREP) -v " F \| U " > ,$@ +sbcl.nm: $(TARGET) + $(NM) $(TARGET) | $(GREP) -v " F \| U " > ,$@ mv -f ,$@ $@ sbcl.h: $(wildcard genesis/*.h) @@ -64,7 +67,7 @@ TAGS tags: $(SRCS) etags $(SRCS) clean: - -rm -f *.[do] sbcl sbcl.nm sbcl.h core *.tmp $(OS_CLEAN_FILES) + -rm -f *.[do] $(TARGET) sbcl.nm sbcl.h core *.tmp $(OS_CLEAN_FILES) # the depend file is obsolete -rm -f depend diff --git a/src/runtime/breakpoint.c b/src/runtime/breakpoint.c index 4c587eb..edee7b3 100644 --- a/src/runtime/breakpoint.c +++ b/src/runtime/breakpoint.c @@ -133,9 +133,11 @@ void handle_breakpoint(int signal, siginfo_t* info, os_context_t *context) context_sap = alloc_sap(context); code = find_code(context); +#ifndef LISP_FEATURE_WIN32 /* Don't disallow recursive breakpoint traps. Otherwise, we can't * use debugger breakpoints anywhere in here. */ thread_sigmask(SIG_SETMASK, os_context_sigmask_addr(context), 0); +#endif funcall3(SymbolFunction(HANDLE_BREAKPOINT), compute_offset(context, code), @@ -157,9 +159,11 @@ void *handle_fun_end_breakpoint(int signal, siginfo_t *info, code = find_code(context); codeptr = (struct code *)native_pointer(code); +#ifndef LISP_FEATURE_WIN32 /* Don't disallow recursive breakpoint traps. Otherwise, we can't * use debugger breakpoints anywhere in here. */ thread_sigmask(SIG_SETMASK, os_context_sigmask_addr(context), 0); +#endif funcall3(SymbolFunction(HANDLE_BREAKPOINT), compute_offset(context, code), diff --git a/src/runtime/coreparse.c b/src/runtime/coreparse.c index c935607..07d1525 100644 --- a/src/runtime/coreparse.c +++ b/src/runtime/coreparse.c @@ -128,7 +128,11 @@ lispobj load_core_file(char *file) { lispobj *header, val, len, *ptr, remaining_len; +#ifndef LISP_FEATURE_WIN32 int fd = open(file, O_RDONLY), count; +#else + int fd = open(file, O_RDONLY | O_BINARY), count; +#endif lispobj initial_function = NIL; FSHOW((stderr, "/entering load_core_file(%s)\n", file)); diff --git a/src/runtime/gencgc.c b/src/runtime/gencgc.c index b8c6726..a6891d0 100644 --- a/src/runtime/gencgc.c +++ b/src/runtime/gencgc.c @@ -3966,6 +3966,7 @@ gc_free_heap(void) page_table[page].allocated = FREE_PAGE_FLAG; page_table[page].bytes_used = 0; +#ifndef LISP_FEATURE_WIN32 /* Pages already zeroed on win32? Not sure about this change. */ /* Zero the page. */ page_start = (void *)page_address(page); @@ -3980,6 +3981,9 @@ gc_free_heap(void) page_start, addr); } +#else + page_table[page].write_protected = 0; +#endif } else if (gencgc_zero_check_during_free_heap) { /* Double-check that the page is zero filled. */ long *page_start; diff --git a/src/runtime/interrupt.c b/src/runtime/interrupt.c index 08bca2e..6a52053 100644 --- a/src/runtime/interrupt.c +++ b/src/runtime/interrupt.c @@ -40,16 +40,18 @@ * * - WHN 20000728, dan 20010128 */ +#include "sbcl.h" #include #include #include #include #include +#ifndef LISP_FEATURE_WIN32 #include +#endif #include -#include "sbcl.h" #include "runtime.h" #include "arch.h" #include "os.h" @@ -69,6 +71,7 @@ static void run_deferred_handler(struct interrupt_data *data, void *v_context); +#ifndef LISP_FEATURE_WIN32 static void store_signal_data_for_later (struct interrupt_data *data, void *handler, int signal, siginfo_t *info, @@ -111,10 +114,12 @@ sigaddset_blockable(sigset_t *s) /* initialized in interrupt_init */ static sigset_t deferrable_sigset; static sigset_t blockable_sigset; +#endif void check_blockables_blocked_or_lose() { +#ifndef LISP_FEATURE_WIN32 /* Get the current sigmask, by blocking the empty set. */ sigset_t empty,current; int i; @@ -124,6 +129,7 @@ check_blockables_blocked_or_lose() if (sigismember(&blockable_sigset, i) && !sigismember(¤t, i)) lose("blockable signal %d not blocked\n",i); } +#endif } inline static void @@ -147,7 +153,9 @@ check_interrupts_enabled_or_lose(os_context_t *context) * becomes 'yes'.) */ boolean internal_errors_enabled = 0; +#ifndef LISP_FEATURE_WIN32 static void (*interrupt_low_level_handlers[NSIG]) (int, siginfo_t*, void*); +#endif union interrupt_handler interrupt_handlers[NSIG]; /* At the toplevel repl we routinely call this function. The signal @@ -157,15 +165,19 @@ union interrupt_handler interrupt_handlers[NSIG]; void reset_signal_mask(void) { +#ifndef LISP_FEATURE_WIN32 sigset_t new; sigemptyset(&new); thread_sigmask(SIG_SETMASK,&new,0); +#endif } void block_blockable_signals(void) { +#ifndef LISP_FEATURE_WIN32 thread_sigmask(SIG_BLOCK, &blockable_sigset, 0); +#endif } @@ -318,7 +330,9 @@ interrupt_internal_error(int signal, siginfo_t *info, os_context_t *context, * disabled. */ context_sap = alloc_sap(context); +#ifndef LISP_FEATURE_WIN32 thread_sigmask(SIG_SETMASK, os_context_sigmask_addr(context), 0); +#endif SHOW("in interrupt_internal_error"); #ifdef QSHOW @@ -394,6 +408,7 @@ interrupt_handle_pending(os_context_t *context) * PSEUDO_ATOMIC_INTERRUPTED only if interrupts are enabled.*/ SetSymbolValue(INTERRUPT_PENDING, NIL,thread); +#ifndef LISP_FEATURE_WIN32 /* restore the saved signal mask from the original signal (the * one that interrupted us during the critical section) into the * os_context for the signal we're currently in the handler for. @@ -402,6 +417,7 @@ interrupt_handle_pending(os_context_t *context) sigcopyset(os_context_sigmask_addr(context), &data->pending_mask); sigemptyset(&data->pending_mask); +#endif /* This will break on sparc linux: the deferred handler really wants * to be called with a void_context */ run_deferred_handler(data,(void *)context); @@ -433,8 +449,10 @@ interrupt_handle_now(int signal, siginfo_t *info, void *void_context) #endif union interrupt_handler handler; check_blockables_blocked_or_lose(); +#ifndef LISP_FEATURE_WIN32 if (sigismember(&deferrable_sigset,signal)) check_interrupts_enabled_or_lose(context); +#endif #ifdef LISP_FEATURE_LINUX /* Under Linux on some architectures, we appear to have to restore @@ -506,8 +524,10 @@ interrupt_handle_now(int signal, siginfo_t *info, void *void_context) FSHOW_SIGNAL((stderr,"/calling C-level handler\n")); +#ifndef LISP_FEATURE_WIN32 /* Allow signals again. */ thread_sigmask(SIG_SETMASK, os_context_sigmask_addr(context), 0); +#endif (*handler.c)(signal, info, void_context); } @@ -540,6 +560,7 @@ run_deferred_handler(struct interrupt_data *data, void *v_context) { (*pending_handler)(data->pending_signal,&(data->pending_info), v_context); } +#ifndef LISP_FEATURE_WIN32 boolean maybe_defer_handler(void *handler, struct interrupt_data *data, int signal, siginfo_t *info, os_context_t *context) @@ -670,6 +691,7 @@ low_level_maybe_now_maybe_later(int signal, siginfo_t *info, void *void_context) DARWIN_FIX_CONTEXT(context); #endif } +#endif #ifdef LISP_FEATURE_SB_THREAD @@ -999,7 +1021,9 @@ boolean interrupt_maybe_gc_int(int signal, siginfo_t *info, void *void_context) { os_context_t *context=(os_context_t *) void_context; +#ifndef LISP_FEATURE_WIN32 struct thread *thread=arch_os_get_current_thread(); +#endif fake_foreign_function_call(context); @@ -1025,6 +1049,7 @@ interrupt_maybe_gc_int(int signal, siginfo_t *info, void *void_context) * A kludgy alternative is to propagate the sigmask change to the * outer context. */ +#ifndef LISP_FEATURE_WIN32 if(SymbolValue(INTERRUPTS_ENABLED,thread)!=NIL) thread_sigmask(SIG_SETMASK, os_context_sigmask_addr(context), 0); #ifdef LISP_FEATURE_SB_THREAD @@ -1035,6 +1060,7 @@ interrupt_maybe_gc_int(int signal, siginfo_t *info, void *void_context) thread_sigmask(SIG_UNBLOCK,&new,0); } #endif +#endif funcall0(SymbolFunction(SUB_GC)); undo_fake_foreign_function_call(context); @@ -1046,6 +1072,7 @@ interrupt_maybe_gc_int(int signal, siginfo_t *info, void *void_context) * noise to install handlers */ +#ifndef LISP_FEATURE_WIN32 /* In Linux 2.4 synchronous signals (sigtrap & co) can be delivered if * they are blocked, in Linux 2.6 the default handler is invoked * instead that usually coredumps. One might hastily think that adding @@ -1154,11 +1181,13 @@ undoably_install_low_level_interrupt_handler (int signal, interrupt_low_level_handlers[signal] = (ARE_SAME_HANDLER(handler, SIG_DFL) ? 0 : handler); } +#endif /* This is called from Lisp. */ unsigned long install_handler(int signal, void handler(int, siginfo_t*, void*)) { +#ifndef LISP_FEATURE_WIN32 struct sigaction sa; sigset_t old, new; union interrupt_handler oldhandler; @@ -1197,11 +1226,16 @@ install_handler(int signal, void handler(int, siginfo_t*, void*)) FSHOW((stderr, "/leaving POSIX install_handler(%d, ..)\n", signal)); return (unsigned long)oldhandler.lisp; +#else + /* Probably-wrong Win32 hack */ + return 0; +#endif } void interrupt_init() { +#ifndef LISP_FEATURE_WIN32 int i; SHOW("entering interrupt_init()"); see_if_sigaction_nodefer_works(); @@ -1222,4 +1256,5 @@ interrupt_init() } SHOW("returning from interrupt_init()"); +#endif } diff --git a/src/runtime/monitor.c b/src/runtime/monitor.c index aff7720..076d948 100644 --- a/src/runtime/monitor.c +++ b/src/runtime/monitor.c @@ -9,16 +9,19 @@ * files for more information. */ +#include "sbcl.h" + #include #include #include #include #include +#ifndef LISP_FEATURE_WIN32 #include +#endif #include #include -#include "sbcl.h" #include "runtime.h" #include "parse.h" #include "vars.h" @@ -177,7 +180,9 @@ print_cmd(char **ptr) static void kill_cmd(char **ptr) { +#ifndef LISP_FEATURE_WIN32 kill(getpid(), parse_number(ptr)); +#endif } static void @@ -444,7 +449,11 @@ sub_monitor(void) int ambig; if (!ldb_in) { +#ifndef LISP_FEATURE_WIN32 ldb_in = fopen("/dev/tty","r+"); +#else + ldb_in = stdin; +#endif ldb_in_fd = fileno(ldb_in); } diff --git a/src/runtime/run-program.c b/src/runtime/run-program.c index 64e4797..110d2b4 100644 --- a/src/runtime/run-program.c +++ b/src/runtime/run-program.c @@ -13,6 +13,10 @@ * files for more information. */ +#include "sbcl.h" + +#ifndef LISP_FEATURE_WIN32 + #include #include #include @@ -117,3 +121,4 @@ int spawn(char *program, char *argv[], char *envp[], char *pty_name, /* The exec didn't work, flame out. */ exit(1); } +#endif /* !LISP_FEATURE_WIN32 */ diff --git a/src/runtime/runtime.c b/src/runtime/runtime.c index e2f4344..876ed3a 100644 --- a/src/runtime/runtime.c +++ b/src/runtime/runtime.c @@ -17,16 +17,22 @@ #include #include +#ifndef LISP_FEATURE_WIN32 #include +#endif #include +#ifndef LISP_FEATURE_WIN32 #include +#endif #include #include #include #include #include #include +#ifndef LISP_FEATURE_WIN32 #include +#endif #include #include @@ -180,6 +186,11 @@ distribution for more information.\n\ int main(int argc, char *argv[], char *envp[]) { +#ifdef LISP_FEATURE_WIN32 + /* Exception handling support structure. Evil Win32 hack. */ + struct lisp_exception_frame exception_frame; +#endif + /* the name of the core file we're to execute. Note that this is * a malloc'ed string which should be freed eventually. */ char *core = 0; @@ -296,7 +307,11 @@ main(int argc, char *argv[], char *envp[]) char *envstring, *copied_core, *dir; char *stem = "SBCL_HOME="; copied_core = copied_string(core); +#ifndef LISP_FEATURE_WIN32 dir = dirname(copied_core); +#else /* LISP_FEATURE_WIN32 */ + dir = ""; +#endif envstring = (char *) calloc(strlen(stem) + strlen(dir) + 1, @@ -332,7 +347,12 @@ main(int argc, char *argv[], char *envp[]) gc_initialize_pointers(); arch_install_interrupt_handlers(); +#ifndef LISP_FEATURE_WIN32 os_install_interrupt_handlers(); +#else +/* wos_install_interrupt_handlers(handler); */ + wos_install_interrupt_handlers(&exception_frame); +#endif /* Convert remaining argv values to something that Lisp can grok. */ SHOW("setting POSIX-ARGV symbol value"); @@ -341,6 +361,13 @@ main(int argc, char *argv[], char *envp[]) FSHOW((stderr, "/funcalling initial_function=0x%lx\n", (unsigned long)initial_function)); +#ifdef LISP_FEATURE_WIN32 + fprintf(stderr, "\n\ +This is experimental prerelease support for the Windows platform: use\n\ +at your own risk. \"Your Kitten of Death awaits!\"\n"); + fflush(stdout); + fflush(stderr); +#endif create_initial_thread(initial_function); lose("CATS. CATS ARE NICE.\n"); return 0; diff --git a/src/runtime/save.c b/src/runtime/save.c index 36b8ae8..f939eec 100644 --- a/src/runtime/save.c +++ b/src/runtime/save.c @@ -43,6 +43,13 @@ write_bytes(FILE *file, char *addr, long bytes) bytes = (bytes+os_vm_page_size-1)&~(os_vm_page_size-1); +#ifdef LISP_FEATURE_WIN32 + /* touch every single page in the space to force it to be mapped. */ + for (count = 0; count < bytes; count += 0x1000) { + volatile int temp = addr[count]; + } +#endif + fflush(file); here = ftell(file); fseek(file, 0, 2); @@ -94,7 +101,7 @@ open_core_for_saving(char *filename) * the fopen() might fail for some reason, and we want to detect * that and back out before we do anything irreversible. */ unlink(filename); - return fopen(filename, "w"); + return fopen(filename, "wb"); } boolean diff --git a/src/runtime/thread.c b/src/runtime/thread.c index 821e4a2..8d3d36a 100644 --- a/src/runtime/thread.c +++ b/src/runtime/thread.c @@ -1,14 +1,30 @@ +/* + * This software is part of the SBCL system. See the README file for + * more information. + * + * This software is derived from the CMU CL system, which was + * written at Carnegie Mellon University and released into the + * public domain. The software is in the public domain and is + * provided with absolutely no warranty. See the COPYING and CREDITS + * files for more information. + */ + +#include "sbcl.h" + #include #include #include +#ifndef LISP_FEATURE_WIN32 #include +#endif #include #include #include #include +#ifndef LISP_FEATURE_WIN32 #include +#endif -#include "sbcl.h" #include "runtime.h" #include "validate.h" /* for CONTROL_STACK_SIZE etc */ #include "alloc.h" @@ -23,6 +39,14 @@ #include "interr.h" /* for lose() */ #include "gc-internal.h" +#ifdef LISP_FEATURE_WIN32 +/* + * Win32 doesn't have SIGSTKSZ, and we're not switching stacks anyway, + * so define it arbitrarily + */ +#define SIGSTKSZ 1024 +#endif + #define ALIEN_STACK_SIZE (1*1024*1024) /* 1Mb size chosen at random */ struct freeable_stack { diff --git a/src/runtime/win32-os.c b/src/runtime/win32-os.c new file mode 100644 index 0000000..8c85f7f --- /dev/null +++ b/src/runtime/win32-os.c @@ -0,0 +1,604 @@ +/* + * the Win32 incarnation of OS-dependent routines. See also + * $(sbcl_arch)-win32-os.c + * + * This file (along with os.h) exports an OS-independent interface to + * the operating system VM facilities. Surprise surprise, this + * interface looks a lot like the Mach interface (but simpler in some + * places). For some operating systems, a subset of these functions + * will have to be emulated. + */ + +/* + * This software is part of the SBCL system. See the README file for + * more information. + * + * This software is derived from the CMU CL system, which was + * written at Carnegie Mellon University and released into the + * public domain. The software is in the public domain and is + * provided with absolutely no warranty. See the COPYING and CREDITS + * files for more information. + */ + +/* + * This file was copied from the Linux version of the same, and + * likely still has some linuxisms in it have haven't been elimiated + * yet. + */ + +#include +#include +#include +#include "sbcl.h" +#include "./signal.h" +#include "os.h" +#include "arch.h" +#include "globals.h" +#include "sbcl.h" +#include "interrupt.h" +#include "interr.h" +#include "lispregs.h" +#include "monitor.h" +#include "alloc.h" +#include "genesis/primitive-objects.h" + +#include +#include +#include +#include +#include + +#include + +#include "validate.h" +#include "thread.h" +size_t os_vm_page_size; + + +#include "gc.h" +#include "gencgc-internal.h" + +#if 0 +int linux_sparc_siginfo_bug = 0; +int linux_supports_futex=0; +#endif + +/* The exception handling function looks like this: */ +EXCEPTION_DISPOSITION handle_exception(EXCEPTION_RECORD *, + struct lisp_exception_frame *, + CONTEXT *, + void *); + +void *base_seh_frame; + +static void *get_seh_frame(void) +{ + void* retval; + asm volatile ("movl %%fs:0,%0": "=r" (retval)); + return retval; +} + +static void set_seh_frame(void *frame) +{ + asm volatile ("movl %0,%%fs:0": : "r" (frame)); +} + +static struct lisp_exception_frame *find_our_seh_frame(void) +{ + struct lisp_exception_frame *frame = get_seh_frame(); + + while (frame->handler != handle_exception) + frame = frame->next_frame; + + return frame; +} + +#if 0 +inline static void *get_stack_frame(void) +{ + void* retval; + asm volatile ("movl %%ebp,%0": "=r" (retval)); + return retval; +} +#endif + +void os_init(char *argv[], char *envp[]) +{ + SYSTEM_INFO system_info; + + GetSystemInfo(&system_info); + os_vm_page_size = system_info.dwPageSize; + + base_seh_frame = get_seh_frame(); +} + + +/* + * So we have three fun scenarios here. + * + * First, we could be being called to reserve the memory areas + * during initialization (prior to loading the core file). + * + * Second, we could be being called by the GC to commit a page + * that has just been decommitted (for easy zero-fill). + * + * Third, we could be being called by create_thread_struct() + * in order to create the sundry and various stacks. + * + * The third case is easy to pick out because it passes an + * addr of 0. + * + * The second case is easy to pick out because it will be for + * a range of memory that is MEM_RESERVE rather than MEM_FREE. + * + * The second case is also an easy implement, because we leave + * the memory as reserved (since we do lazy commits). + */ + +os_vm_address_t +os_validate(os_vm_address_t addr, os_vm_size_t len) +{ + MEMORY_BASIC_INFORMATION mem_info; + + if (!addr) { + /* the simple case first */ + os_vm_address_t real_addr; + if (!(real_addr = VirtualAlloc(addr, len, MEM_COMMIT, PAGE_EXECUTE_READWRITE))) { + perror("VirtualAlloc"); + return 0; + } + + return real_addr; + } + + if (!VirtualQuery(addr, &mem_info, sizeof mem_info)) { + perror("VirtualQuery"); + return 0; + } + + if ((mem_info.State == MEM_RESERVE) && (mem_info.RegionSize >=len)) return addr; + + if (mem_info.State == MEM_RESERVE) { + fprintf(stderr, "validation of reserved space too short.\n"); + fflush(stderr); + } + + if (!VirtualAlloc(addr, len, (mem_info.State == MEM_RESERVE)? MEM_COMMIT: MEM_RESERVE, PAGE_EXECUTE_READWRITE)) { + perror("VirtualAlloc"); + return 0; + } + + return addr; +} + +/* + * For os_invalidate(), we merely decommit the memory rather than + * freeing the address space. This loses when freeing per-thread + * data and related memory since it leaks address space. It's not + * too lossy, however, since the two scenarios I'm aware of are + * fd-stream buffers, which are pooled rather than torched, and + * thread information, which I hope to pool (since windows creates + * threads at its own whim, and we probably want to be able to + * have them callback without funky magic on the part of the user, + * and full-on thread allocation is fairly heavyweight). Someone + * will probably shoot me down on this with some pithy comment on + * the use of (setf symbol-value) on a special variable. I'm happy + * for them. + */ + +void +os_invalidate(os_vm_address_t addr, os_vm_size_t len) +{ + if (!VirtualFree(addr, len, MEM_DECOMMIT)) { + perror("VirtualFree"); + } +} + +/* + * os_map() is called to map a chunk of the core file into memory. + * + * Unfortunately, Windows semantics completely screws this up, so + * we just add backing store from the swapfile to where the chunk + * goes and read it up like a normal file. We could consider using + * a lazy read (demand page) setup, but that would mean keeping an + * open file pointer for the core indefinately (and be one more + * thing to maintain). + */ + +os_vm_address_t +os_map(int fd, int offset, os_vm_address_t addr, os_vm_size_t len) +{ + os_vm_size_t count; + + fprintf(stderr, "os_map: %d, 0x%x, %p, 0x%x.\n", fd, offset, addr, len); + fflush(stderr); + + if (!VirtualAlloc(addr, len, MEM_COMMIT, PAGE_EXECUTE_READWRITE)) { + perror("VirtualAlloc"); + lose("os_map: VirtualAlloc failure"); + } + + if (lseek(fd, offset, SEEK_SET) == -1) { + lose("os_map: Seek failure."); + } + + count = read(fd, addr, len); + if (count != len) { + fprintf(stderr, "expected 0x%x, read 0x%x.\n", len, count); + lose("os_map: Failed to read enough bytes."); + } + + return addr; +} + +static DWORD os_protect_modes[8] = { + PAGE_NOACCESS, + PAGE_READONLY, + PAGE_READWRITE, + PAGE_READWRITE, + PAGE_EXECUTE, + PAGE_EXECUTE_READ, + PAGE_EXECUTE_READWRITE, + PAGE_EXECUTE_READWRITE, +}; + +void +os_protect(os_vm_address_t address, os_vm_size_t length, os_vm_prot_t prot) +{ + DWORD old_prot; + + if (!VirtualProtect(address, length, os_protect_modes[prot], &old_prot)) { + fprintf(stderr, "VirtualProtect failed, code 0x%lx.\n", GetLastError()); + fflush(stderr); + } +} + +/* FIXME: Now that FOO_END, rather than FOO_SIZE, is the fundamental + * description of a space, we could probably punt this and just do + * (FOO_START <= x && x < FOO_END) everywhere it's called. */ +static boolean +in_range_p(os_vm_address_t a, lispobj sbeg, size_t slen) +{ + char* beg = (char*)((long)sbeg); + char* end = (char*)((long)sbeg) + slen; + char* adr = (char*)a; + return (adr >= beg && adr < end); +} + +boolean +is_valid_lisp_addr(os_vm_address_t addr) +{ + struct thread *th; + if(in_range_p(addr, READ_ONLY_SPACE_START, READ_ONLY_SPACE_SIZE) || + in_range_p(addr, STATIC_SPACE_START , STATIC_SPACE_SIZE) || + in_range_p(addr, DYNAMIC_SPACE_START , DYNAMIC_SPACE_SIZE)) + return 1; + for_each_thread(th) { + if(((os_vm_address_t)th->control_stack_start <= addr) && (addr < (os_vm_address_t)th->control_stack_end)) + return 1; + if(in_range_p(addr, (unsigned long)th->binding_stack_start, BINDING_STACK_SIZE)) + return 1; + } + return 0; +} + +/* + * any OS-dependent special low-level handling for signals + */ + +/* A tiny bit of interrupt.c state we want our paws on. */ +extern boolean internal_errors_enabled; + +/* + * FIXME: There is a potential problem with foreign code here. + * If we are running foreign code instead of lisp code and an + * exception occurs we arrange a call into Lisp. If the + * foreign code has installed an exception handler, we run the + * very great risk of throwing through their exception handler + * without asking it to unwind. This is more a problem with + * non-sigtrap (EXCEPTION_BREAKPOINT) exceptions, as they could + * reasonably be expected to happen in foreign code. We need to + * figure out the exception handler unwind semantics and adhere + * to them (probably by abusing the Lisp unwind-protect system) + * if we are going to handle this scenario correctly. + * + * A good explanation of the exception handling semantics is + * http://win32assembly.online.fr/Exceptionhandling.html . + * We will also need to handle this ourselves when foreign + * code tries to unwind -us-. + * + * When unwinding through foreign code we should unwind the + * Lisp stack to the entry from foreign code, then unwind the + * foreign code stack to the entry from Lisp, then resume + * unwinding in Lisp. + */ + +EXCEPTION_DISPOSITION sigtrap_emulator(CONTEXT *context, + struct lisp_exception_frame *exception_frame) +{ + if (*((char *)context->Eip + 1) == trap_ContextRestore) { + /* + * This is the cleanup for what is immediately below, and + * for the generic exception handling further below. We + * have to memcpy() the original context (emulated sigtrap + * or normal exception) over our context and resume it. + */ + memcpy(context, &exception_frame->context, sizeof(CONTEXT)); + return ExceptionContinueExecution; + + } else { /* Not a trap_ContextRestore, must be a sigtrap. */ + /* sigtrap_trampoline is defined in x86-assem.S. */ + extern void sigtrap_trampoline; + + /* + * Unlike some other operating systems, Win32 leaves EIP + * pointing to the breakpoint instruction. + */ + context->Eip++; + + /* + * We're not on an alternate stack like we would be in some + * other operating systems, and we don't want to risk leaking + * any important resources if we throw out of the sigtrap + * handler, so we need to copy off our context to a "safe" + * place and then monkey with the return EIP to point to a + * trampoline which calls another function which copies the + * context out to a really-safe place and then calls the real + * sigtrap handler. When the real sigtrap handler returns, the + * trampoline then contains another breakpoint with a code of + * trap_ContextRestore (see above). Essentially the same + * mechanism is used by the generic exception path. There is + * a small window of opportunity between us copying the + * context to the "safe" place and the sigtrap wrapper copying + * it to the really-safe place (allocated in its stack frame) + * during which the context can be smashed. The only scenario + * I can come up with for this, however, involves a stack + * overflow occuring at just the wrong time (which makes one + * wonder how stack overflow exceptions even happen, given + * that we don't switch stacks for exception processing...) + */ + memcpy(&exception_frame->context, context, sizeof(CONTEXT)); + context->Eax = context->Eip; + context->Eip = (unsigned long)&sigtrap_trampoline; + + /* and return */ + return ExceptionContinueExecution; + } +} + +void sigtrap_wrapper(void) +{ + /* + * This is the wrapper around the sigtrap handler called from + * the trampoline returned to from the function above. + * + * There actually is a point to some of the commented-out code + * in this function, although it really belongs to the callback + * wrappers. Once it is installed there, it can probably be + * removed from here. + */ + + extern void sigtrap_handler(int signal, siginfo_t *info, void *context); + +/* volatile struct { */ +/* void *handler[2]; */ + CONTEXT context; +/* } handler; */ + + struct lisp_exception_frame *frame = find_our_seh_frame(); + +/* wos_install_interrupt_handlers(handler); */ +/* handler.handler[0] = get_seh_frame(); */ +/* handler.handler[1] = &handle_exception; */ +/* set_seh_frame(&handler); */ + + memcpy(&context, &frame->context, sizeof(CONTEXT)); + sigtrap_handler(0, NULL, &context); + memcpy(&frame->context, &context, sizeof(CONTEXT)); + +/* set_seh_frame(handler.handler[0]); */ +} + +EXCEPTION_DISPOSITION handle_exception(EXCEPTION_RECORD *exception_record, + struct lisp_exception_frame *exception_frame, + CONTEXT *context, + void *dc) /* FIXME: What's dc again? */ +{ + + /* For EXCEPTION_ACCESS_VIOLATION only. */ + void *fault_address = (void *)exception_record->ExceptionInformation[1]; + + if (exception_record->ExceptionCode == EXCEPTION_BREAKPOINT) { + /* Pick off sigtrap case first. */ + return sigtrap_emulator(context, exception_frame); + + } else if (exception_record->ExceptionCode == EXCEPTION_ACCESS_VIOLATION && + is_valid_lisp_addr(fault_address)) { + /* Pick off GC-related memory fault next. */ + MEMORY_BASIC_INFORMATION mem_info; + + if (!VirtualQuery(fault_address, &mem_info, sizeof mem_info)) { + fprintf(stderr, "VirtualQuery: 0x%lx.\n", GetLastError()); + lose("handle_exception: VirtualQuery failure"); + } + + if (mem_info.State == MEM_RESERVE) { + /* First use new page, lets get some memory for it. */ + if (!VirtualAlloc(mem_info.BaseAddress, os_vm_page_size, + MEM_COMMIT, PAGE_EXECUTE_READWRITE)) { + fprintf(stderr, "VirtualAlloc: 0x%lx.\n", GetLastError()); + lose("handle_exception: VirtualAlloc failure"); + + } else { + /* + * Now, if the page is supposedly write-protected and this + * is a write, tell the gc that it's been hit. + * + * FIXME: Are we supposed to fall-through to the Lisp + * exception handler if the gc doesn't take the wp violation? + */ + if (exception_record->ExceptionInformation[0]) { + int index = find_page_index(fault_address); + if ((index != -1) && (page_table[index].write_protected)) { + gencgc_handle_wp_violation(fault_address); + } + } + return ExceptionContinueExecution; + } + + } else if (gencgc_handle_wp_violation(fault_address)) { + /* gc accepts the wp violation, so resume where we left off. */ + return ExceptionContinueExecution; + } + + /* All else failed, drop through to the lisp-side exception handler. */ + } + + /* + * If we fall through to here then we need to either forward + * the exception to the lisp-side exception handler if it's + * set up, or drop to LDB. + */ + + if (internal_errors_enabled) { + /* exception_trampoline is defined in x86-assem.S. */ + extern void exception_trampoline; + + /* + * We're making the somewhat arbitrary decision that + * having internal errors enabled means that lisp has + * sufficient marbles to be able to handle exceptions. + * + * Exceptions aren't supposed to happen during cold + * init or reinit anyway. + */ + + /* + * We use the same mechanism as the sigtrap emulator above + * with just a couple changes. We obviously use a different + * trampoline and wrapper function, we kill out any live + * floating point exceptions, and we save off the exception + * record as well as the context. + */ + + /* Save off context and exception information */ + memcpy(&exception_frame->context, context, sizeof(CONTEXT)); + memcpy(&exception_frame->exception, exception_record, sizeof(EXCEPTION_RECORD)); + + /* Set up to activate trampoline when we return */ + context->Eax = context->Eip; + context->Eip = (unsigned long)&exception_trampoline; + + /* Make sure a floating-point trap doesn't kill us */ + context->FloatSave.StatusWord &= ~0x3f; + + /* And return */ + return ExceptionContinueExecution; + } + + fprintf(stderr, "Exception Code: 0x%lx.\n", exception_record->ExceptionCode); + fprintf(stderr, "Faulting IP: 0x%lx.\n", (DWORD)exception_record->ExceptionAddress); + if (exception_record->ExceptionCode == EXCEPTION_ACCESS_VIOLATION) { + MEMORY_BASIC_INFORMATION mem_info; + + if (VirtualQuery(fault_address, &mem_info, sizeof mem_info)) { + fprintf(stderr, "page status: 0x%lx.\n", mem_info.State); + } + + fprintf(stderr, "Was writing: %ld, where: 0x%lx.\n", + exception_record->ExceptionInformation[0], + (DWORD)fault_address); + } + + fflush(stderr); + + fake_foreign_function_call(context); + monitor_or_something(); + + return ExceptionContinueSearch; +} + +void handle_win32_exception_wrapper(void) +{ + struct lisp_exception_frame *frame = find_our_seh_frame(); + CONTEXT context; + EXCEPTION_RECORD exception_record; + lispobj context_sap; + lispobj exception_record_sap; + + memcpy(&context, &frame->context, sizeof(CONTEXT)); + memcpy(&exception_record, &frame->exception, sizeof(EXCEPTION_RECORD)); + + fake_foreign_function_call(&context); + + /* Allocate the SAP objects while the "interrupts" are still + * disabled. */ + context_sap = alloc_sap(&context); + exception_record_sap = alloc_sap(&exception_record); + + funcall2(SymbolFunction(HANDLE_WIN32_EXCEPTION), context_sap, + exception_record_sap); + + undo_fake_foreign_function_call(&context); + + memcpy(&frame->context, &context, sizeof(CONTEXT)); +} + +void +wos_install_interrupt_handlers(struct lisp_exception_frame *handler) +{ + handler->next_frame = get_seh_frame(); + handler->handler = &handle_exception; + set_seh_frame(handler); +} + +void bcopy(const void *src, void *dest, size_t n) +{ + MoveMemory(dest, src, n); +} + +/* + * The stubs below are replacements for the windows versions, + * which can -fail- when used in our memory spaces because they + * validate the memory spaces they are passed in a way that + * denies our exception handler a chance to run. + */ + +void *memmove(void *dest, const void *src, size_t n) +{ + if (dest < src) { + int i; + for (i = 0; i < n; i++) *(((char *)dest)+i) = *(((char *)src)+i); + } else { + while (n--) *(((char *)dest)+n) = *(((char *)src)+n); + } + return dest; +} + +void *memcpy(void *dest, const void *src, size_t n) +{ + while (n--) *(((char *)dest)+n) = *(((char *)src)+n); + return dest; +} + +/* This is a manually-maintained version of ldso_stubs.S. */ + +void scratch(void) +{ + strerror(42); + asin(0); + acos(0); + sinh(0); + cosh(0); + hypot(0, 0); + write(0, 0, 0); + close(0); + rename(0,0); + getcwd(0,0); + dup(0); + LoadLibrary(0); + GetProcAddress(0, 0); + mkdir(0); +} + +/* EOF */ diff --git a/src/runtime/win32-os.h b/src/runtime/win32-os.h new file mode 100644 index 0000000..4435b6f --- /dev/null +++ b/src/runtime/win32-os.h @@ -0,0 +1,50 @@ +/* + * This software is part of the SBCL system. See the README file for + * more information. + * + * This software is derived from the CMU CL system, which was + * written at Carnegie Mellon University and released into the + * public domain. The software is in the public domain and is + * provided with absolutely no warranty. See the COPYING and CREDITS + * files for more information. + */ + +#include +#include +#include +#include +#include +#include + +#define WIN32_LEAN_AND_MEAN +#include +#include "target-arch-os.h" +#include "target-arch.h" + +typedef LPVOID os_vm_address_t; +typedef size_t os_vm_size_t; +typedef off_t os_vm_offset_t; +typedef int os_vm_prot_t; + +typedef void *siginfo_t; + +/* These are used as bitfields, but Win32 doesn't work that way, so we do a translation. */ +#define OS_VM_PROT_READ 1 +#define OS_VM_PROT_WRITE 2 +#define OS_VM_PROT_EXECUTE 4 + +#define SIG_MEMORY_FAULT SIGSEGV + +#define SIG_INTERRUPT_THREAD (SIGRTMIN) +#define SIG_STOP_FOR_GC (SIGRTMIN+1) +#define SIG_DEQUEUE (SIGRTMIN+2) +#define SIG_THREAD_EXIT (SIGRTMIN+3) + +struct lisp_exception_frame { + struct lisp_exception_frame *next_frame; + void *handler; + CONTEXT context; + EXCEPTION_RECORD exception; +}; + +void wos_install_interrupt_handlers(struct lisp_exception_frame *handler); diff --git a/src/runtime/wrap.c b/src/runtime/wrap.c index 365d895..8d576d1 100644 --- a/src/runtime/wrap.c +++ b/src/runtime/wrap.c @@ -23,16 +23,19 @@ * files for more information. */ +#include "sbcl.h" + #include #include #include #include #include #include +#ifndef LISP_FEATURE_WIN32 #include +#endif #include -#include "sbcl.h" #include "runtime.h" #include "util.h" @@ -118,6 +121,7 @@ free_directory_lispy_filenames(char** directory_lispy_filenames) * readlink(2) stuff */ +#ifndef LISP_FEATURE_WIN32 /* a wrapped version of readlink(2): * -- If path isn't a symlink, or is a broken symlink, return 0. * -- If path is a symlink, return a newly allocated string holding @@ -141,6 +145,7 @@ wrapped_readlink(char *path) } } } +#endif /* * stat(2) stuff @@ -182,9 +187,15 @@ struct stat_wrapper { ffi_dev_t wrapped_st_dev; /* device */ ino_t wrapped_st_ino; /* inode */ mode_t wrapped_st_mode; /* protection */ +#ifndef LISP_FEATURE_WIN32 nlink_t wrapped_st_nlink; /* number of hard links */ uid_t wrapped_st_uid; /* user ID of owner */ gid_t wrapped_st_gid; /* group ID of owner */ +#else + short wrapped_st_nlink; /* Win32 doesn't have nlink_t */ + short wrapped_st_uid; /* Win32 doesn't have st_uid */ + short wrapped_st_gid; /* Win32 doesn't have st_gid */ +#endif ffi_dev_t wrapped_st_rdev; /* device type (if inode device) */ ffi_off_t wrapped_st_size; /* total size, in bytes */ unsigned long wrapped_st_blksize; /* blocksize for filesystem I/O */ @@ -198,16 +209,21 @@ static void copy_to_stat_wrapper(struct stat_wrapper *to, struct stat *from) { #define FROB(stem) to->wrapped_st_##stem = from->st_##stem +#ifndef LISP_FEATURE_WIN32 +#define FROB2(stem) to->wrapped_st_##stem = from->st_##stem +#else +#define FROB2(stem) to->wrapped_st_##stem = 0; +#endif FROB(dev); - FROB(ino); + FROB2(ino); FROB(mode); FROB(nlink); - FROB(uid); - FROB(gid); + FROB2(uid); + FROB2(gid); FROB(rdev); FROB(size); - FROB(blksize); - FROB(blocks); + FROB2(blksize); + FROB2(blocks); FROB(atime); FROB(mtime); FROB(ctime); @@ -219,11 +235,25 @@ stat_wrapper(const char *file_name, struct stat_wrapper *buf) { struct stat real_buf; int ret; + +#ifdef LISP_FEATURE_WIN32 + /* + * Windows won't match the last component of a pathname if there is + * a trailing #\/ character. So we do silly things like this: + */ + char file_buf[MAX_PATH]; + strcpy(file_buf, file_name); + int foo = strlen(file_name); + if (foo && (file_name[foo-1] == '/')) file_buf[foo-1] = 0; + file_name = file_buf; +#endif + if ((ret = stat(file_name,&real_buf)) >= 0) copy_to_stat_wrapper(buf, &real_buf); return ret; } +#ifndef LISP_FEATURE_WIN32 int lstat_wrapper(const char *file_name, struct stat_wrapper *buf) { @@ -233,6 +263,13 @@ lstat_wrapper(const char *file_name, struct stat_wrapper *buf) copy_to_stat_wrapper(buf, &real_buf); return ret; } +#else +/* cleaner to do it here than in Lisp */ +int lstat_wrapper(const char *file_name, struct stat_wrapper *buf) +{ + return stat_wrapper(file_name, buf); +} +#endif int fstat_wrapper(int filedes, struct stat_wrapper *buf) @@ -248,6 +285,7 @@ fstat_wrapper(int filedes, struct stat_wrapper *buf) * getpwuid() stuff */ +#ifndef LISP_FEATURE_WIN32 /* Return a newly-allocated string holding the username for "uid", or * NULL if there's no such user. * @@ -294,6 +332,7 @@ uid_homedir(uid_t uid) return 0; } } +#endif /* !LISP_FEATURE_WIN32 */ /* * functions to get miscellaneous C-level variables @@ -308,3 +347,91 @@ wrapped_environ() { return environ; } + +#ifdef LISP_FEATURE_WIN32 +#define WIN32_LEAN_AND_MEAN +#include +/* + * faked-up implementation of select(). Right now just enough to get through + * second genesis. + */ +int select(int top_fd, DWORD *read_set, DWORD *write_set, DWORD *except_set, time_t *timeout) +{ + /* + * FIXME: Going forward, we may want to use MsgWaitForMultipleObjects + * in order to support a windows message loop inside serve-event. + */ + HANDLE handles[MAXIMUM_WAIT_OBJECTS]; + int fds[MAXIMUM_WAIT_OBJECTS]; + int num_handles; + int i; + DWORD retval; + int polling_write; + DWORD win_timeout; + + num_handles = 0; + polling_write = 0; + for (i = 0; i < top_fd; i++) { + if (except_set) except_set[i >> 5] = 0; + if (write_set && (write_set[i >> 5] & (1 << (i & 31)))) polling_write = 1; + if (read_set[i >> 5] & (1 << (i & 31))) { + read_set[i >> 5] &= ~(1 << (i & 31)); + fds[num_handles] = i; + handles[num_handles++] = _get_osfhandle(i); + } + } + + win_timeout = INFINITE; + if (timeout) win_timeout = (timeout[0] * 1000) + timeout[1]; + + /* Last parameter here is timeout in milliseconds. */ + /* retval = WaitForMultipleObjects(num_handles, handles, 0, INFINITE); */ + retval = WaitForMultipleObjects(num_handles, handles, 0, win_timeout); + + if (retval < WAIT_ABANDONED) { + /* retval, at this point, is the index of the single live HANDLE/fd. */ + read_set[fds[retval] >> 5] |= (1 << (fds[retval] & 31)); + return 1; + } + return polling_write; +} + +/* + * SBCL doesn't like backslashes in pathnames from getcwd for some reason. + * Probably because they don't happen in posix systems. Windows doesn't + * mind slashes, so we convert from one to the other. We also strip off + * the drive prefix while we're at it ("C:", or whatever). + * + * The real fix for this problem is to create a windows-host setup that + * parallels the unix-host in src/code/target-pathname.lisp and actually + * parse this junk properly, drive letter and everything. + * + * Also see POSIX-GETCWD in src/code/unix.lisp. + */ +char *wrap_getcwd(char *buf, size_t len) +{ + char *retval = _getcwd(buf, len); + + if (retval[1] == ':') { + char *p; + for (p = retval; (*p = p[2]); p++) + if (*p == '\\') *p = '/'; + } + + return retval; +} + +/* + * Windows doesn't have gettimeofday(), and we need it for the compiler, + * for serve-event, and for a couple other things. We don't need a timezone + * yet, however, and the closest we can easily get to a timeval is the + * seconds part. So that's what we do. + */ +int gettimeofday(long *timeval, long *timezone) +{ + timeval[0] = time(NULL); + timeval[1] = 0; + + return 0; +} +#endif diff --git a/src/runtime/x86-arch.c b/src/runtime/x86-arch.c index 1e84fd7..8f220a2 100644 --- a/src/runtime/x86-arch.c +++ b/src/runtime/x86-arch.c @@ -36,11 +36,13 @@ unsigned long fast_random_state = 1; void arch_init(void) {} +#ifndef LISP_FEATURE_WIN32 os_vm_address_t arch_get_bad_addr(int sig, siginfo_t *code, os_context_t *context) { return (os_vm_address_t)code->si_addr; } +#endif /* @@ -66,6 +68,8 @@ context_eflags_addr(os_context_t *context) return &context->sc_eflags; #elif defined __NetBSD__ return &(context->uc_mcontext.__gregs[_REG_EFL]); +#elif defined LISP_FEATURE_WIN32 + return (int *)&context->EFlags; #else #error unsupported OS #endif @@ -204,10 +208,10 @@ arch_do_displaced_inst(os_context_t *context, unsigned int orig_inst) void sigtrap_handler(int signal, siginfo_t *info, void *void_context) { - int code = info->si_code; os_context_t *context = (os_context_t*)void_context; unsigned int trap; +#ifndef LISP_FEATURE_WIN32 if (single_stepping && (signal==SIGTRAP)) { /* fprintf(stderr,"* single step trap %x\n", single_stepping); */ @@ -231,6 +235,7 @@ sigtrap_handler(int signal, siginfo_t *info, void *void_context) single_stepping = NULL; return; } +#endif /* This is just for info in case the monitor wants to print an * approximation. */ @@ -270,8 +275,8 @@ sigtrap_handler(int signal, siginfo_t *info, void *void_context) case trap_Error: case trap_Cerror: - FSHOW((stderr, "\n", code)); - interrupt_internal_error(signal, info, context, code==trap_Cerror); + FSHOW((stderr, "\n", trap)); + interrupt_internal_error(signal, info, context, trap==trap_Cerror); break; case trap_Breakpoint: @@ -287,7 +292,7 @@ sigtrap_handler(int signal, siginfo_t *info, void *void_context) default: FSHOW((stderr,"/[C--trap default %d %d %x]\n", - signal, code, context)); + signal, trap, context)); interrupt_handle_now(signal, info, context); break; } @@ -315,8 +320,10 @@ arch_install_interrupt_handlers() * OS I haven't tested on?) and we have to go back to the old CMU * CL way, I hope there will at least be a comment to explain * why.. -- WHN 2001-06-07 */ +#ifndef LISP_FEATURE_WIN32 undoably_install_low_level_interrupt_handler(SIGILL , sigill_handler); undoably_install_low_level_interrupt_handler(SIGTRAP, sigtrap_handler); +#endif SHOW("returning from arch_install_interrupt_handlers()"); } diff --git a/src/runtime/x86-assem.S b/src/runtime/x86-assem.S index ad9e089..0a65cd5 100644 --- a/src/runtime/x86-assem.S +++ b/src/runtime/x86-assem.S @@ -28,6 +28,8 @@ * since everyone has converged on ELF. If this generality really * turns out not to matter, perhaps it's just clutter we could get * rid of? -- WHN 2004-04-18) + * + * (Except Win32, which is unlikely ever to be ELF, sorry. -- AB 2005-12-08) */ #if defined __linux__ || defined __FreeBSD__ || defined __NetBSD__ || defined __OpenBSD__ || defined __sun #define GNAME(var) var @@ -44,7 +46,7 @@ * matter any more, perhaps it's just clutter we could get * rid of? -- WHN 2004-04-18) */ -#if defined(__linux__) || defined(__FreeBSD__) || defined(__NetBSD__) || defined(__OpenBSD__) || defined(__sun) +#if defined(__linux__) || defined(__FreeBSD__) || defined(__NetBSD__) || defined(__OpenBSD__) || defined(__sun) || defined(LISP_FEATURE_WIN32) #define align_4byte 4 #define align_8byte 8 #define align_16byte 16 @@ -54,6 +56,20 @@ #define align_16byte 4 #endif +/* + * The assembler used for win32 doesn't like .type or .size directives, + * so we want to conditionally kill them out. So let's wrap them in macros + * that are defined to be no-ops on win32. Hopefully this still works on + * other platforms. + */ +#ifndef LISP_FEATURE_WIN32 +#define TYPE(name) .type name,@function +#define SIZE(name) .size name,.-name +#else +#define TYPE(name) +#define SIZE(name) +#endif + .text .global GNAME(foreign_function_call_active) .global GNAME(all_threads) @@ -72,7 +88,7 @@ .text .align align_16byte,0x90 .global GNAME(call_into_c) - .type GNAME(call_into_c),@function + TYPE(GNAME(call_into_c)) GNAME(call_into_c): movl $1,GNAME(foreign_function_call_active) @@ -89,6 +105,10 @@ GNAME(call_into_c): fstp %st(0) fstp %st(0) +#ifdef LISP_FEATURE_WIN32 + cld +#endif + call *%eax # normal callout using Lisp stack movl %eax,%ecx # remember integer return value @@ -136,12 +156,12 @@ Lfp_rtn_value: /* Return. */ jmp *%ebx - .size GNAME(call_into_c), . - GNAME(call_into_c) + SIZE(GNAME(call_into_c)) .text .global GNAME(call_into_lisp_first_time) - .type GNAME(call_into_lisp_first_time),@function + TYPE(GNAME(call_into_lisp_first_time)) /* The *ALIEN-STACK* pointer is set up on the first call_into_lisp when * the stack changes. We don't worry too much about saving registers @@ -152,17 +172,22 @@ Lfp_rtn_value: GNAME(call_into_lisp_first_time): pushl %ebp # Save old frame pointer. movl %esp,%ebp # Establish new frame. +#ifndef LISP_FEATURE_WIN32 movl %esp,ALIEN_STACK + SYMBOL_VALUE_OFFSET movl GNAME(all_threads),%eax movl THREAD_CONTROL_STACK_START_OFFSET(%eax) ,%esp /* don't think too hard about what happens if we get interrupted * here */ addl $THREAD_CONTROL_STACK_SIZE-4,%esp +#else +/* Win32 -really- doesn't like you switching stacks out from under it. */ + movl GNAME(all_threads),%eax +#endif jmp Lstack .text .global GNAME(call_into_lisp) - .type GNAME(call_into_lisp),@function + TYPE(GNAME(call_into_lisp)) /* The C conventions require that ebx, esi, edi, and ebp be preserved * across function calls. */ @@ -257,27 +282,27 @@ Ldone: popl %ebp # c-sp movl %edx,%eax # c-val ret - .size GNAME(call_into_lisp), . - GNAME(call_into_lisp) + SIZE(GNAME(call_into_lisp)) /* support for saving and restoring the NPX state from C */ .text .global GNAME(fpu_save) - .type GNAME(fpu_save),@function + TYPE(GNAME(fpu_save)) .align 2,0x90 GNAME(fpu_save): movl 4(%esp),%eax fnsave (%eax) # Save the NPX state. (resets NPX) ret - .size GNAME(fpu_save),.-GNAME(fpu_save) + SIZE(GNAME(fpu_save)) .global GNAME(fpu_restore) - .type GNAME(fpu_restore),@function + TYPE(GNAME(fpu_restore)) .align 2,0x90 GNAME(fpu_restore): movl 4(%esp),%eax frstor (%eax) # Restore the NPX state. ret - .size GNAME(fpu_restore),.-GNAME(fpu_restore) + SIZE(GNAME(fpu_restore)) /* * the undefined-function trampoline @@ -285,7 +310,7 @@ GNAME(fpu_restore): .text .align align_4byte,0x90 .global GNAME(undefined_tramp) - .type GNAME(undefined_tramp),@function + TYPE(GNAME(undefined_tramp)) .byte 0, 0, 0, SIMPLE_FUN_HEADER_WIDETAG GNAME(undefined_tramp): int3 @@ -294,7 +319,7 @@ GNAME(undefined_tramp): .byte UNDEFINED_FUN_ERROR .byte sc_DescriptorReg # eax in the Descriptor-reg SC ret - .size GNAME(undefined_tramp), .-GNAME(undefined_tramp) + SIZE(GNAME(undefined_tramp)) /* * the closure trampoline @@ -302,7 +327,7 @@ GNAME(undefined_tramp): .text .align align_4byte,0x90 .global GNAME(closure_tramp) - .type GNAME(closure_tramp),@function + TYPE(GNAME(closure_tramp)) .byte 0, 0, 0, SIMPLE_FUN_HEADER_WIDETAG GNAME(closure_tramp): movl FDEFN_FUN_OFFSET(%eax),%eax @@ -313,7 +338,7 @@ GNAME(closure_tramp): * right. It would be good to find a way to force the flow of * control through here to test it. */ jmp *CLOSURE_FUN_OFFSET(%eax) - .size GNAME(closure_tramp), .-GNAME(closure_tramp) + SIZE(GNAME(closure_tramp)) /* * fun-end breakpoint magic @@ -346,13 +371,13 @@ GNAME(fun_end_breakpoint_end): .global GNAME(do_pending_interrupt) - .type GNAME(do_pending_interrupt),@function + TYPE(GNAME(do_pending_interrupt)) .align align_4byte,0x90 GNAME(do_pending_interrupt): int3 .byte trap_PendingInterrupt ret - .size GNAME(do_pending_interrupt),.-GNAME(do_pending_interrupt) + SIZE(GNAME(do_pending_interrupt)) /* @@ -367,7 +392,7 @@ GNAME(do_pending_interrupt): */ .globl GNAME(alloc_to_eax) - .type GNAME(alloc_to_eax),@function + TYPE(GNAME(alloc_to_eax)) .align align_4byte,0x90 GNAME(alloc_to_eax): pushl %ecx # Save ecx and edx as C could destroy them. @@ -378,10 +403,10 @@ GNAME(alloc_to_eax): popl %edx # Restore ecx and edx. popl %ecx ret - .size GNAME(alloc_to_eax),.-GNAME(alloc_to_eax) + SIZE(GNAME(alloc_to_eax)) .globl GNAME(alloc_8_to_eax) - .type GNAME(alloc_8_to_eax),@function + TYPE(GNAME(alloc_8_to_eax)) .align align_4byte,0x90 GNAME(alloc_8_to_eax): pushl %ecx # Save ecx and edx as C could destroy them. @@ -392,14 +417,14 @@ GNAME(alloc_8_to_eax): popl %edx # Restore ecx and edx. popl %ecx ret - .size GNAME(alloc_8_to_eax),.-GNAME(alloc_8_to_eax) + SIZE(GNAME(alloc_8_to_eax)) .globl GNAME(alloc_8_to_eax) - .type GNAME(alloc_8_to_eax),@function + TYPE(GNAME(alloc_8_to_eax)) .align align_4byte,0x90 .globl GNAME(alloc_16_to_eax) - .type GNAME(alloc_16_to_eax),@function + TYPE(GNAME(alloc_16_to_eax)) .align align_4byte,0x90 GNAME(alloc_16_to_eax): pushl %ecx # Save ecx and edx as C could destroy them. @@ -410,10 +435,10 @@ GNAME(alloc_16_to_eax): popl %edx # Restore ecx and edx. popl %ecx ret - .size GNAME(alloc_16_to_eax),.-GNAME(alloc_16_to_eax) + SIZE(GNAME(alloc_16_to_eax)) .globl GNAME(alloc_to_ecx) - .type GNAME(alloc_to_ecx),@function + TYPE(GNAME(alloc_to_ecx)) .align align_4byte,0x90 GNAME(alloc_to_ecx): pushl %eax # Save eax and edx as C could destroy them. @@ -425,10 +450,10 @@ GNAME(alloc_to_ecx): popl %edx # Restore eax and edx. popl %eax ret - .size GNAME(alloc_to_ecx),.-GNAME(alloc_to_ecx) + SIZE(GNAME(alloc_to_ecx)) .globl GNAME(alloc_8_to_ecx) - .type GNAME(alloc_8_to_ecx),@function + TYPE(GNAME(alloc_8_to_ecx)) .align align_4byte,0x90 GNAME(alloc_8_to_ecx): pushl %eax # Save eax and edx as C could destroy them. @@ -440,10 +465,10 @@ GNAME(alloc_8_to_ecx): popl %edx # Restore eax and edx. popl %eax ret - .size GNAME(alloc_8_to_ecx),.-GNAME(alloc_8_to_ecx) + SIZE(GNAME(alloc_8_to_ecx)) .globl GNAME(alloc_16_to_ecx) - .type GNAME(alloc_16_to_ecx),@function + TYPE(GNAME(alloc_16_to_ecx)) .align align_4byte,0x90 GNAME(alloc_16_to_ecx): pushl %eax # Save eax and edx as C could destroy them. @@ -455,11 +480,11 @@ GNAME(alloc_16_to_ecx): popl %edx # Restore eax and edx. popl %eax ret - .size GNAME(alloc_16_to_ecx),.-GNAME(alloc_16_to_ecx) + SIZE(GNAME(alloc_16_to_ecx)) .globl GNAME(alloc_to_edx) - .type GNAME(alloc_to_edx),@function + TYPE(GNAME(alloc_to_edx)) .align align_4byte,0x90 GNAME(alloc_to_edx): pushl %eax # Save eax and ecx as C could destroy them. @@ -471,10 +496,10 @@ GNAME(alloc_to_edx): popl %ecx # Restore eax and ecx. popl %eax ret - .size GNAME(alloc_to_edx),.-GNAME(alloc_to_edx) + SIZE(GNAME(alloc_to_edx)) .globl GNAME(alloc_8_to_edx) - .type GNAME(alloc_8_to_edx),@function + TYPE(GNAME(alloc_8_to_edx)) .align align_4byte,0x90 GNAME(alloc_8_to_edx): pushl %eax # Save eax and ecx as C could destroy them. @@ -486,10 +511,10 @@ GNAME(alloc_8_to_edx): popl %ecx # Restore eax and ecx. popl %eax ret - .size GNAME(alloc_8_to_edx),.-GNAME(alloc_8_to_edx) + SIZE(GNAME(alloc_8_to_edx)) .globl GNAME(alloc_16_to_edx) - .type GNAME(alloc_16_to_edx),@function + TYPE(GNAME(alloc_16_to_edx)) .align align_4byte,0x90 GNAME(alloc_16_to_edx): pushl %eax # Save eax and ecx as C could destroy them. @@ -501,12 +526,12 @@ GNAME(alloc_16_to_edx): popl %ecx # Restore eax and ecx. popl %eax ret - .size GNAME(alloc_16_to_edx),.-GNAME(alloc_16_to_edx) + SIZE(GNAME(alloc_16_to_edx)) .globl GNAME(alloc_to_ebx) - .type GNAME(alloc_to_ebx),@function + TYPE(GNAME(alloc_to_ebx)) .align align_4byte,0x90 GNAME(alloc_to_ebx): pushl %eax # Save eax, ecx, and edx as C could destroy them. @@ -520,10 +545,10 @@ GNAME(alloc_to_ebx): popl %ecx popl %eax ret - .size GNAME(alloc_to_ebx),.-GNAME(alloc_to_ebx) + SIZE(GNAME(alloc_to_ebx)) .globl GNAME(alloc_8_to_ebx) - .type GNAME(alloc_8_to_ebx),@function + TYPE(GNAME(alloc_8_to_ebx)) .align align_4byte,0x90 GNAME(alloc_8_to_ebx): pushl %eax # Save eax, ecx, and edx as C could destroy them. @@ -537,10 +562,10 @@ GNAME(alloc_8_to_ebx): popl %ecx popl %eax ret - .size GNAME(alloc_8_to_ebx),.-GNAME(alloc_8_to_ebx) + SIZE(GNAME(alloc_8_to_ebx)) .globl GNAME(alloc_16_to_ebx) - .type GNAME(alloc_16_to_ebx),@function + TYPE(GNAME(alloc_16_to_ebx)) .align align_4byte,0x90 GNAME(alloc_16_to_ebx): pushl %eax # Save eax, ecx, and edx as C could destroy them. @@ -554,12 +579,12 @@ GNAME(alloc_16_to_ebx): popl %ecx popl %eax ret - .size GNAME(alloc_16_to_ebx),.-GNAME(alloc_16_to_ebx) + SIZE(GNAME(alloc_16_to_ebx)) .globl GNAME(alloc_to_esi) - .type GNAME(alloc_to_esi),@function + TYPE(GNAME(alloc_to_esi)) .align align_4byte,0x90 GNAME(alloc_to_esi): pushl %eax # Save eax, ecx, and edx as C could destroy them. @@ -573,10 +598,10 @@ GNAME(alloc_to_esi): popl %ecx popl %eax ret - .size GNAME(alloc_to_esi),.-GNAME(alloc_to_esi) + SIZE(GNAME(alloc_to_esi)) .globl GNAME(alloc_8_to_esi) - .type GNAME(alloc_8_to_esi),@function + TYPE(GNAME(alloc_8_to_esi)) .align align_4byte,0x90 GNAME(alloc_8_to_esi): pushl %eax # Save eax, ecx, and edx as C could destroy them. @@ -590,10 +615,10 @@ GNAME(alloc_8_to_esi): popl %ecx popl %eax ret - .size GNAME(alloc_8_to_esi),.-GNAME(alloc_8_to_esi) + SIZE(GNAME(alloc_8_to_esi)) .globl GNAME(alloc_16_to_esi) - .type GNAME(alloc_16_to_esi),@function + TYPE(GNAME(alloc_16_to_esi)) .align align_4byte,0x90 GNAME(alloc_16_to_esi): pushl %eax # Save eax, ecx, and edx as C could destroy them. @@ -607,11 +632,11 @@ GNAME(alloc_16_to_esi): popl %ecx popl %eax ret - .size GNAME(alloc_16_to_esi),.-GNAME(alloc_16_to_esi) + SIZE(GNAME(alloc_16_to_esi)) .globl GNAME(alloc_to_edi) - .type GNAME(alloc_to_edi),@function + TYPE(GNAME(alloc_to_edi)) .align align_4byte,0x90 GNAME(alloc_to_edi): pushl %eax # Save eax, ecx, and edx as C could destroy them. @@ -625,10 +650,10 @@ GNAME(alloc_to_edi): popl %ecx popl %eax ret - .size GNAME(alloc_to_edi),.-GNAME(alloc_to_edi) + SIZE(GNAME(alloc_to_edi)) .globl GNAME(alloc_8_to_edi) - .type GNAME(alloc_8_to_edi),@function + TYPE(GNAME(alloc_8_to_edi)) .align align_4byte,0x90 GNAME(alloc_8_to_edi): pushl %eax # Save eax, ecx, and edx as C could destroy them. @@ -642,10 +667,10 @@ GNAME(alloc_8_to_edi): popl %ecx popl %eax ret - .size GNAME(alloc_8_to_edi),.-GNAME(alloc_8_to_edi) + SIZE(GNAME(alloc_8_to_edi)) .globl GNAME(alloc_16_to_edi) - .type GNAME(alloc_16_to_edi),@function + TYPE(GNAME(alloc_16_to_edi)) .align align_4byte,0x90 GNAME(alloc_16_to_edi): pushl %eax # Save eax, ecx, and edx as C could destroy them. @@ -659,7 +684,7 @@ GNAME(alloc_16_to_edi): popl %ecx popl %eax ret - .size GNAME(alloc_16_to_edi),.-GNAME(alloc_16_to_edi) + SIZE(GNAME(alloc_16_to_edi)) /* Called from lisp when an inline allocation overflows. @@ -670,14 +695,14 @@ GNAME(alloc_16_to_edi): #ifdef LISP_FEATURE_SB_THREAD #define START_REGION %fs:THREAD_ALLOC_REGION_OFFSET #else -#define START_REGION boxed_region +#define START_REGION GNAME(boxed_region) #endif /* This routine handles an overflow with eax=crfp+size. So the size=eax-crfp. */ .align align_4byte .globl GNAME(alloc_overflow_eax) - .type GNAME(alloc_overflow_eax),@function + TYPE(GNAME(alloc_overflow_eax)) GNAME(alloc_overflow_eax): pushl %ecx # Save ecx pushl %edx # Save edx @@ -689,11 +714,11 @@ GNAME(alloc_overflow_eax): popl %edx # Restore edx. popl %ecx # Restore ecx. ret - .size GNAME(alloc_overflow_eax),.-GNAME(alloc_overflow_eax) + SIZE(GNAME(alloc_overflow_eax)) .align align_4byte .globl GNAME(alloc_overflow_ecx) - .type GNAME(alloc_overflow_ecx),@function + TYPE(GNAME(alloc_overflow_ecx)) GNAME(alloc_overflow_ecx): pushl %eax # Save eax pushl %edx # Save edx @@ -706,11 +731,11 @@ GNAME(alloc_overflow_ecx): popl %edx # Restore edx. popl %eax # Restore eax. ret - .size GNAME(alloc_overflow_ecx),.-GNAME(alloc_overflow_ecx) + SIZE(GNAME(alloc_overflow_ecx)) .align align_4byte .globl GNAME(alloc_overflow_edx) - .type GNAME(alloc_overflow_edx),@function + TYPE(GNAME(alloc_overflow_edx)) GNAME(alloc_overflow_edx): pushl %eax # Save eax pushl %ecx # Save ecx @@ -723,13 +748,13 @@ GNAME(alloc_overflow_edx): popl %ecx # Restore ecx. popl %eax # Restore eax. ret - .size GNAME(alloc_overflow_edx),.-GNAME(alloc_overflow_edx) + SIZE(GNAME(alloc_overflow_edx)) /* This routine handles an overflow with ebx=crfp+size. So the size=ebx-crfp. */ .align align_4byte .globl GNAME(alloc_overflow_ebx) - .type GNAME(alloc_overflow_ebx),@function + TYPE(GNAME(alloc_overflow_ebx)) GNAME(alloc_overflow_ebx): pushl %eax # Save eax pushl %ecx # Save ecx @@ -744,13 +769,13 @@ GNAME(alloc_overflow_ebx): popl %ecx # Restore ecx. popl %eax # Restore eax. ret - .size GNAME(alloc_overflow_ebx),.-GNAME(alloc_overflow_ebx) + SIZE(GNAME(alloc_overflow_ebx)) /* This routine handles an overflow with esi=crfp+size. So the size=esi-crfp. */ .align align_4byte .globl GNAME(alloc_overflow_esi) - .type GNAME(alloc_overflow_esi),@function + TYPE(GNAME(alloc_overflow_esi)) GNAME(alloc_overflow_esi): pushl %eax # Save eax pushl %ecx # Save ecx @@ -765,11 +790,11 @@ GNAME(alloc_overflow_esi): popl %ecx # Restore ecx. popl %eax # Restore eax. ret - .size GNAME(alloc_overflow_esi),.-GNAME(alloc_overflow_esi) + SIZE(GNAME(alloc_overflow_esi)) .align align_4byte .globl GNAME(alloc_overflow_edi) - .type GNAME(alloc_overflow_edi),@function + TYPE(GNAME(alloc_overflow_edi)) GNAME(alloc_overflow_edi): pushl %eax # Save eax pushl %ecx # Save ecx @@ -784,11 +809,11 @@ GNAME(alloc_overflow_edi): popl %ecx # Restore ecx. popl %eax # Restore eax. ret - .size GNAME(alloc_overflow_edi),.-GNAME(alloc_overflow_edi) + SIZE(GNAME(alloc_overflow_edi)) .align align_4byte,0x90 .globl GNAME(post_signal_tramp) - .type GNAME(post_signal_tramp),@function + TYPE(GNAME(post_signal_tramp)) GNAME(post_signal_tramp): /* this is notionally the second half of a function whose first half * doesn't exist. This is where call_into_lisp returns when called @@ -798,7 +823,40 @@ GNAME(post_signal_tramp): popfl leave ret - .size GNAME(post_signal_tramp),.-GNAME(post_signal_tramp) + SIZE(GNAME(post_signal_tramp)) + +#ifdef LISP_FEATURE_WIN32 + /* + * This is part of the funky magic for exception handling on win32. + * see sigtrap_emulator() in win32-os.c for details. + */ + .global GNAME(sigtrap_trampoline) +GNAME(sigtrap_trampoline): + pushl %eax + pushl %ebp + movl %esp, %ebp + call GNAME(sigtrap_wrapper) + pop %eax + pop %eax + int3 + .byte trap_ContextRestore + hlt # We should never return here. + /* + * This is part of the funky magic for exception handling on win32. + * see handle_exception() in win32-os.c for details. + */ + .global GNAME(exception_trampoline) +GNAME(exception_trampoline): + pushl %eax + pushl %ebp + movl %esp, %ebp + call GNAME(handle_win32_exception_wrapper) + pop %eax + pop %eax + int3 + .byte trap_ContextRestore + hlt # We should never return here. +#endif .end diff --git a/src/runtime/x86-win32-os.c b/src/runtime/x86-win32-os.c new file mode 100644 index 0000000..ada97e3 --- /dev/null +++ b/src/runtime/x86-win32-os.c @@ -0,0 +1,175 @@ +/* + * The x86 Win32 incarnation of arch-dependent OS-dependent routines. + * See also "win32-os.c". + */ + +/* + * This software is part of the SBCL system. See the README file for + * more information. + * + * This software is derived from the CMU CL system, which was + * written at Carnegie Mellon University and released into the + * public domain. The software is in the public domain and is + * provided with absolutely no warranty. See the COPYING and CREDITS + * files for more information. + */ + +#include +#include +#include +#include +#include +#include +#include + +#include "./signal.h" +#include "os.h" +#include "arch.h" +#include "globals.h" +#include "interrupt.h" +#include "interr.h" +#include "lispregs.h" +#include "sbcl.h" + +#include +#include +#include +#include +#include +#include "thread.h" /* dynamic_values_bytes */ + + +#include "validate.h" +size_t os_vm_page_size; + +int arch_os_thread_init(struct thread *thread) { + { + //unsigned long cur_stack_base; + //unsigned long cur_stack_end; + void *cur_stack_end; + + //asm volatile ("movl %%fs:8,%0": "=r" (cur_stack_base)); + // asm volatile ("movl %%fs:4,%0": "=r" (cur_stack_end)); + + asm volatile ("movl %%fs:0,%0": "=r" (cur_stack_end)); + + // fprintf(stderr, "#x%08lx #x%08lx.\n", cur_stack_base, cur_stack_end); + + //if (cur_stack_base > thread->control_stack_start) { + // cur_stack_base = thread->control_stack_start; + //} + + //if (cur_stack_end < thread->control_stack_end) { + // cur_stack_end = thread->control_stack_end; + //} + + // fprintf(stderr, "#x%08lx #x%08lx.\n", cur_stack_base, cur_stack_end); + //fflush(stderr); + + //getchar(); + + //asm volatile ("movl %0,%%fs:8": : "r" (cur_stack_base)); + //asm volatile ("movl %0,%%fs:4": : "r" (cur_stack_end)); + + thread->control_stack_end = cur_stack_end; + } + +#ifdef LISP_FEATURE_SB_THREAD + /* this must be called from a function that has an exclusive lock + * on all_threads + */ + struct user_desc ldt_entry = { + 1, 0, 0, /* index, address, length filled in later */ + 1, MODIFY_LDT_CONTENTS_DATA, 0, 0, 0, 1 + }; + int n; + get_spinlock(&modify_ldt_lock,thread); + n=modify_ldt(0,local_ldt_copy,sizeof local_ldt_copy); + /* get next free ldt entry */ + + if(n) { + u32 *p; + for(n=0,p=local_ldt_copy;*p;p+=LDT_ENTRY_SIZE/sizeof(u32)) + n++; + } + ldt_entry.entry_number=n; + ldt_entry.base_addr=(unsigned long) thread; + ldt_entry.limit=dynamic_values_bytes; + ldt_entry.limit_in_pages=0; + if (modify_ldt (1, &ldt_entry, sizeof (ldt_entry)) != 0) { + modify_ldt_lock=0; + /* modify_ldt call failed: something magical is not happening */ + return -1; + } + __asm__ __volatile__ ("movw %w0, %%fs" : : "q" + ((n << 3) /* selector number */ + + (1 << 2) /* TI set = LDT */ + + 3)); /* privilege level */ + thread->tls_cookie=n; + modify_ldt_lock=0; + + if(n<0) return 0; +#endif + + return 1; +} + +/* free any arch/os-specific resources used by thread, which is now + * defunct. Not called on live threads + */ + +int arch_os_thread_cleanup(struct thread *thread) { + return 0; +} + +os_context_register_t * +os_context_register_addr(os_context_t *context, int offset) +{ + switch(offset) { + case reg_EAX: return &context->Eax; + case reg_ECX: return &context->Ecx; + case reg_EDX: return &context->Edx; + case reg_EBX: return &context->Ebx; + case reg_ESP: return &context->Esp; + case reg_EBP: return &context->Ebp; + case reg_ESI: return &context->Esi; + case reg_EDI: return &context->Edi; + default: return 0; + } +} + +os_context_register_t * +os_context_pc_addr(os_context_t *context) +{ + return &context->Eip; /* REG_EIP */ +} + +os_context_register_t * +os_context_sp_addr(os_context_t *context) +{ + return &context->Esp; /* REG_UESP */ +} + +os_context_register_t * +os_context_fp_addr(os_context_t *context) +{ + return &context->Ebp; /* REG_EBP */ +} + +unsigned long +os_context_fp_control(os_context_t *context) +{ + return ((((context->FloatSave.ControlWord) & 0xffff) ^ 0x3f) | + (((context->FloatSave.StatusWord) & 0xffff) << 16)); +} + +void +os_restore_fp_control(os_context_t *context) +{ + asm ("fldcw %0" : : "m" (context->FloatSave.ControlWord)); +} + +void +os_flush_icache(os_vm_address_t address, os_vm_size_t length) +{ +} diff --git a/src/runtime/x86-win32-os.h b/src/runtime/x86-win32-os.h new file mode 100644 index 0000000..1f2e748 --- /dev/null +++ b/src/runtime/x86-win32-os.h @@ -0,0 +1,14 @@ +#ifndef _X86_WIN32_OS_H +#define _X86_WIN32_OS_H + +typedef CONTEXT os_context_t; +typedef long os_context_register_t; + +static inline os_context_t *arch_os_get_context(void **void_context) { + return (os_context_t *) *void_context; +} + +unsigned long os_context_fp_control(os_context_t *context); +void os_restore_fp_control(os_context_t *context); + +#endif /* _X86_WIN32_OS_H */ diff --git a/version.lisp-expr b/version.lisp-expr index 0d64e9f..acbd9db 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.9.8.6" +"0.9.8.7"