Merge "merge candidate 1" for SBCL/Win32.
... a lot done, a lot left to do.
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
;;;; -*- 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)
;; "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)
#!+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
;; 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)
"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"
"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"
"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"
"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
(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)
(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
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.
(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
(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))
;;; 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 "~@<The file ~2I~_~S ~I~_is not writable.~:>" namestring))
(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))))
#!-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)
(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))
(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)
(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)
(funcall *periodic-polling-function*)))
(t
(call-fd-handler))))
+ #!-win32
((eql err sb!unix:eintr)
;; We did an interrupt.
t)
(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)
--- /dev/null
+;;;; 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.
+;;;
+\f
+;;; 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)))
+|#
+\f
+;;; 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))
+\f
+;;;; 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))
(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*)
(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")
(with-simple-restart
(abort "~@<Exit debugger, returning to top level.~@:>")
(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.
`(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))
\f
;;;; hacking the Unix environment
(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.
;;; 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))
;;; 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).
;; 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")))
(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))
;;; 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))
;;; 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)
(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.
(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")))
;;; 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))
;;; 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)
;;; (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)))
(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)))
(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,
(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
(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))))))
--- /dev/null
+;;;; 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)
"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
(defknown alien-funcall (alien-value &rest *) *
(any recursive))
+#!+win32
+(defknown alien-funcall-stdcall (alien-value &rest *) *
+ (any recursive))
\f
;;;; cosmetic transforms
((reference-tn-list result-tns t)))
(vop dealloc-number-stack-space call block stack-frame-size)
(move-lvar-result call block result-tns lvar))))
+\f
+;;;; 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))))
(in-package "SB!C")
(defknown %alien-funcall (system-area-pointer alien-type &rest *) *)
+(defknown %alien-funcall-stdcall (system-area-pointer alien-type &rest *) *)
(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)
,@(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)
(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)
;;; 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)
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)
sb!kernel::memory-fault-error
sb!di::handle-breakpoint
fdefinition-object
+ #!+win32 sb!kernel::handle-win32-exception
;; free pointers
;;
--- /dev/null
+# 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
# 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.
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)
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
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),
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),
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));
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);
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;
*
* - WHN 20000728, dan 20010128 */
+#include "sbcl.h"
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <signal.h>
#include <sys/types.h>
+#ifndef LISP_FEATURE_WIN32
#include <sys/wait.h>
+#endif
#include <errno.h>
-#include "sbcl.h"
#include "runtime.h"
#include "arch.h"
#include "os.h"
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,
/* 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;
if (sigismember(&blockable_sigset, i) && !sigismember(¤t, i))
lose("blockable signal %d not blocked\n",i);
}
+#endif
}
inline static void
* 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
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
}
\f
* 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
* 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.
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);
#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
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);
}
(*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)
DARWIN_FIX_CONTEXT(context);
#endif
}
+#endif
#ifdef LISP_FEATURE_SB_THREAD
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);
* 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
thread_sigmask(SIG_UNBLOCK,&new,0);
}
#endif
+#endif
funcall0(SymbolFunction(SUB_GC));
undo_fake_foreign_function_call(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
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;
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();
}
SHOW("returning from interrupt_init()");
+#endif
}
* files for more information.
*/
+#include "sbcl.h"
+
#include <stdio.h>
#include <sys/types.h>
#include <stdlib.h>
#include <setjmp.h>
#include <sys/time.h>
+#ifndef LISP_FEATURE_WIN32
#include <sys/resource.h>
+#endif
#include <signal.h>
#include <unistd.h>
-#include "sbcl.h"
#include "runtime.h"
#include "parse.h"
#include "vars.h"
static void
kill_cmd(char **ptr)
{
+#ifndef LISP_FEATURE_WIN32
kill(getpid(), parse_number(ptr));
+#endif
}
static 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);
}
* files for more information.
*/
+#include "sbcl.h"
+
+#ifndef LISP_FEATURE_WIN32
+
#include <stdlib.h>
#include <sys/file.h>
#include <sys/types.h>
/* The exec didn't work, flame out. */
exit(1);
}
+#endif /* !LISP_FEATURE_WIN32 */
#include <stdio.h>
#include <string.h>
+#ifndef LISP_FEATURE_WIN32
#include <libgen.h>
+#endif
#include <sys/types.h>
+#ifndef LISP_FEATURE_WIN32
#include <sys/wait.h>
+#endif
#include <stdlib.h>
#include <unistd.h>
#include <sys/file.h>
#include <sys/param.h>
#include <sys/stat.h>
#include <signal.h>
+#ifndef LISP_FEATURE_WIN32
#include <sched.h>
+#endif
#include <errno.h>
#include <locale.h>
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;
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,
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");
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;
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);
* 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
+/*
+ * 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 <stdlib.h>
#include <stdio.h>
#include <string.h>
+#ifndef LISP_FEATURE_WIN32
#include <sched.h>
+#endif
#include <signal.h>
#include <stddef.h>
#include <errno.h>
#include <sys/types.h>
+#ifndef LISP_FEATURE_WIN32
#include <sys/wait.h>
+#endif
-#include "sbcl.h"
#include "runtime.h"
#include "validate.h" /* for CONTROL_STACK_SIZE etc */
#include "alloc.h"
#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 {
--- /dev/null
+/*
+ * 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 <stdio.h>
+#include <sys/param.h>
+#include <sys/file.h>
+#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 <sys/types.h>
+#include <signal.h>
+#include <sys/time.h>
+#include <sys/stat.h>
+#include <unistd.h>
+
+#include <excpt.h>
+
+#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 */
--- /dev/null
+/*
+ * 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 <stdlib.h>
+#include <sys/types.h>
+#include <string.h>
+#include <sys/time.h>
+#include <sys/stat.h>
+#include <unistd.h>
+
+#define WIN32_LEAN_AND_MEAN
+#include <windows.h>
+#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);
* files for more information.
*/
+#include "sbcl.h"
+
#include <sys/types.h>
#include <dirent.h>
#include <sys/stat.h>
#include <stdlib.h>
#include <string.h>
#include <unistd.h>
+#ifndef LISP_FEATURE_WIN32
#include <pwd.h>
+#endif
#include <stdio.h>
-#include "sbcl.h"
#include "runtime.h"
#include "util.h"
* 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
}
}
}
+#endif
\f
/*
* stat(2) stuff
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 */
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);
{
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)
{
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)
* getpwuid() stuff
*/
+#ifndef LISP_FEATURE_WIN32
/* Return a newly-allocated string holding the username for "uid", or
* NULL if there's no such user.
*
return 0;
}
}
+#endif /* !LISP_FEATURE_WIN32 */
\f
/*
* functions to get miscellaneous C-level variables
{
return environ;
}
+
+#ifdef LISP_FEATURE_WIN32
+#define WIN32_LEAN_AND_MEAN
+#include <windows.h>
+/*
+ * 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
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
\f
/*
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
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); */
single_stepping = NULL;
return;
}
+#endif
/* This is just for info in case the monitor wants to print an
* approximation. */
case trap_Error:
case trap_Cerror:
- FSHOW((stderr, "<trap error/cerror %d>\n", code));
- interrupt_internal_error(signal, info, context, code==trap_Cerror);
+ FSHOW((stderr, "<trap error/cerror %d>\n", trap));
+ interrupt_internal_error(signal, info, context, trap==trap_Cerror);
break;
case trap_Breakpoint:
default:
FSHOW((stderr,"/[C--trap default %d %d %x]\n",
- signal, code, context));
+ signal, trap, context));
interrupt_handle_now(signal, info, context);
break;
}
* 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()");
}
* 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
* 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
#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)
.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)
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
/* Return. */
jmp *%ebx
- .size GNAME(call_into_c), . - GNAME(call_into_c)
+ SIZE(GNAME(call_into_c))
\f
.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
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
\f
.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. */
popl %ebp # c-sp
movl %edx,%eax # c-val
ret
- .size GNAME(call_into_lisp), . - GNAME(call_into_lisp)
+ SIZE(GNAME(call_into_lisp))
\f
/* 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))
\f
/*
* the undefined-function trampoline
.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
.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
.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
* 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
\f
.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))
\f
/*
*/
.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.
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.
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.
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.
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.
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.
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.
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.
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.
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.
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.
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.
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.
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.
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.
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.
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.
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.
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.
#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
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
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
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
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
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
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
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
--- /dev/null
+/*
+ * 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 <stdio.h>
+#include <stddef.h>
+#include <sys/param.h>
+#include <sys/file.h>
+#include <sys/types.h>
+#include <unistd.h>
+#include <errno.h>
+
+#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 <sys/types.h>
+#include <signal.h>
+#include <sys/time.h>
+#include <sys/stat.h>
+#include <unistd.h>
+#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)
+{
+}
--- /dev/null
+#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 */
;;; 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"
projects / sbcl.git / commitdiff