;;; gethostbyname and gethostbyaddr.
;;;
;;; CLH: getaddrinfo seems to be broken is broken on x86-64/darwin
-#-(and x86-64 darwin)
+#-(or win32 (and x86-64 darwin))
(let ((addr (sb-alien::find-dynamic-foreign-symbol-address "getaddrinfo")))
(when addr
(pushnew :sb-bsd-sockets-addrinfo *features*)))
;;
win32)
printf ' :win32' >> $ltf
+ #
+ # Optional features -- We enable them by default, but the build
+ # ought to work perfectly without them:
+ #
printf ' :sb-futex' >> $ltf
printf ' :sb-qshow' >> $ltf
+ #
+ # Required features -- Some of these used to be optional, but
+ # building without them is no longer considered supported:
+ #
+ # (Of course it doesn't provide dlopen, but there is
+ # roughly-equivalent magic nevertheless:)
+ printf ' :sb-dynamic-core :os-provides-dlopen' >> $ltf
printf ' :sb-thread :sb-safepoint :sb-thruption :sb-wtimer' >> $ltf
+ #
link_or_copy Config.$sbcl_arch-win32 Config
link_or_copy $sbcl_arch-win32-os.h target-arch-os.h
link_or_copy win32-os.h target-os.h
# order to produce the symbol table file that second genesis needs. It
# could come either before or after running the cross compiler; that
# doesn't matter.)
+#
+# Note that the latter requirement does not apply to sb-dynamic-core
+# builds, since the cross compiler does not depend on symbol tables in
+# that case. Only because sbcl.nm is convenient for debugging purposes
+# is its generation left enabled even for those builds.
echo //building runtime system and symbol table file
# The clean is needed for Darwin's readonlyspace hack.
"HANDLE-LISTEN"
"INT-PTR"
"INVALID-HANDLE"
+ "LSEEKI64"
"MAP-VIEW-OF-FILE"
"MILLISLEEP"
"PEEK-CONSOLE-INPUT"
(inst push 0)
(inst push 0)
(inst push ecx-tn)
- (inst call (make-fixup "RtlUnwind@16" :foreign)))
+ (inst call (make-fixup "RtlUnwind" :foreign)))
;; We want no VOP for this one and for it to only happen on Win32
;; targets. Hence the following disaster.
#!+alpha (* 2 n)))
(* os-context-t)))
+;;;; Perform the lookup which FOREIGN-SYMBOL-ADDRESS would do if the
+;;;; linkage table were disabled, i.e. always return the actual symbol
+;;;; address, not the linkage table trampoline, even if the symbol would
+;;;; ordinarily go through the linkage table. Important when
+;;;; SB-DYNAMIC-CORE is enabled and our caller assumes `name' to be a
+;;;; "static" symbol; a concept which doesn't exist in such builds.
+(defun true-foreign-symbol-address (name)
+ #!+linkage-table ;we have dlsym -- let's use it.
+ (find-dynamic-foreign-symbol-address name)
+ #!-linkage-table ;possibly no dlsym, but hence no indirection anyway.
+ (foreign-symbol-address))
+
+;;;; See above.
+(defun true-foreign-symbol-sap (name)
+ (int-sap (true-foreign-symbol-address name)))
+
#!+(or x86 x86-64)
(defun find-escaped-frame (frame-pointer)
(declare (type system-area-pointer frame-pointer))
;; KLUDGE: Detect undefined functions by a range-check
;; against the trampoline address and the following
;; function in the runtime.
- (if (< (foreign-symbol-address "undefined_tramp")
+ (if (< (true-foreign-symbol-address "undefined_tramp")
(sap-int (sb!vm:context-pc context))
- (foreign-symbol-address #!+x86 "closure_tramp"
- #!+x86-64 "alloc_tramp"))
+ (true-foreign-symbol-address #!+x86 "closure_tramp"
+ #!+x86-64 "alloc_tramp"))
(return (values :undefined-function 0 context))
(return (values code 0 context))))
(let* ((code-header-len (* (get-header-data code)
(without-gcing
;; These are really code labels, not variables: but this way we get
;; their addresses.
- (let* ((src-start (foreign-symbol-sap "fun_end_breakpoint_guts"))
- (src-end (foreign-symbol-sap "fun_end_breakpoint_end"))
- (trap-loc (foreign-symbol-sap "fun_end_breakpoint_trap"))
+ (let* ((src-start (true-foreign-symbol-sap "fun_end_breakpoint_guts"))
+ (src-end (true-foreign-symbol-sap "fun_end_breakpoint_end"))
+ (trap-loc (true-foreign-symbol-sap "fun_end_breakpoint_trap"))
(length (sap- src-end src-start))
(code-object
(sb!c:allocate-code-object (1+ bogus-lra-constants) length))
"~S is unsupported as of SBCL 0.8.13. Please use LOAD-SHARED-OBJECT."
(load-1-foreign))
-#!-win32
(progn
(define-alien-variable undefined-alien-address unsigned-long)
(defvar *runtime-dlhandle*))
(setf (shared-object-dont-save obj) dont-save)
;; FIXME: Why doesn's dlopen-or-lose on already loaded stuff work on
;; Windows?
+ ;;
+ ;; Kovalenko 2010-11-24: It would work, but it does nothing
+ ;; useful on Windows: library reference count is increased
+ ;; after each LoadLibrary, making it harder to unload it, and
+ ;; that's all the effect. Also, equal pathnames on Windows
+ ;; always designate _exactly the same library image_; Unix
+ ;; tricks like deleting an open library and replacing it with
+ ;; another version just don't work here.
#!-win32
(dlopen-or-lose obj)
#!+win32
;; FIXME: Why doesn't the linkage table work on Windows? (Or maybe it
;; does and this can be just #!+linkage-table?) Note: remember to change
;; FOREIGN-DEINIT as well then!
- #!+(and linkage-table (not win32))
+ ;;
+ ;; Kovalenko 2010-11-24: I think so. Alien _data_ references
+ ;; are the only thing on win32 that is even slightly
+ ;; problematic. Handle function references in the same way as
+ ;; other linkage-table platforms is easy.
+ ;;
+ #!+linkage-table
(when (or old (undefined-foreign-symbols-p))
(update-linkage-table))))
pathname))
(when old
#!-hpux (dlclose-or-lose old)
(setf *shared-objects* (remove old *shared-objects*))
- #!+(and linkage-table (not win32))
+ #!+linkage-table
(update-linkage-table))))))
(defun try-reopen-shared-object (obj)
;;; initialization.
(defun reopen-shared-objects ()
;; Ensure that the runtime is open
- #!-win32
(setf *runtime-dlhandle* (dlopen-or-lose))
;; Reopen stuff.
(setf *shared-objects*
(unless (shared-object-dont-save obj)
(push obj saved)))
(setf *shared-objects* saved))
- #!-(or win32 hpux)
+ #!-hpux
(dlclose-or-lose))
(let ((symbols (make-hash-table :test #'equal))
is never in the linkage-table."
(declare (ignorable datap))
(let ((addr (find-dynamic-foreign-symbol-address symbol)))
- (cond #!-(and linkage-table (not win32))
+ (cond #!-linkage-table
((not addr)
(error 'undefined-alien-error :name symbol))
- #!+(and linkage-table (not win32))
+ #!+linkage-table
((not addr)
(style-warn 'sb!kernel:undefined-alien-style-warning
:symbol symbol)
(plusp (hash-table-count symbols)))
(defun list-dynamic-foreign-symbols ()
(loop for symbol being each hash-key in symbols
- collect symbol)))
-
+ collect symbol))
+ (defun list-undefined-foreign-symbols ()
+ (loop for symbol being each hash-key in undefineds
+ collect symbol)))
(defun extern-alien-name (name)
(handler-case
- #!-win32 (coerce name 'base-string)
- #!+win32 (concatenate 'base-string "_" name)
+ (coerce name 'base-string)
(error ()
(error "invalid external alien name: ~S" name))))
On non-linkage-table ports signals an error if the symbol isn't found."
(declare (ignorable datap))
- (let ((static (find-foreign-symbol-in-table name *static-foreign-symbols*)))
+ #!+sb-dynamic-core
+ (values (ensure-foreign-symbol-linkage name datap) t)
+ #!-sb-dynamic-core
+ (let ((static (find-foreign-symbol-in-table name *static-foreign-symbols*)))
(if static
(values static nil)
#!+os-provides-dlopen
#!+linkage-table
(multiple-value-bind (addr sharedp)
(foreign-symbol-address symbol datap)
- #+sb-xc-host
- (aver (not sharedp))
+ #+sb-xc-host #!-sb-dynamic-core (aver (not sharedp)) ()
;; If the address is from linkage-table and refers to data
;; we need to do a bit of juggling. It is not the address of the
;; variable, but the address where the real address is stored.
;;; Cleanups before saving a core
#-sb-xc-host
(defun foreign-deinit ()
- #!+(and os-provides-dlopen (or (not linkage-table) win32))
+ #!+(and os-provides-dlopen (not linkage-table))
(when (dynamic-foreign-symbols-p)
(warn "~@<Saving cores with alien definitions referring to non-static ~
foreign symbols is unsupported on this platform: references to ~
#-sb-xc-host
(defun !foreign-cold-init ()
+ #!-sb-dynamic-core
(dolist (symbol *!initial-foreign-symbols*)
(setf (gethash (car symbol) *static-foreign-symbols*) (cdr symbol)))
- #!+(and os-provides-dlopen (not win32))
+ #!+sb-dynamic-core
+ (loop for table-address from sb!vm::linkage-table-space-start
+ by sb!vm::linkage-table-entry-size
+ and reference in sb!vm::*required-runtime-c-symbols*
+ do (setf (gethash reference *linkage-info*)
+ (make-linkage-info :datap (cdr reference)
+ :address table-address)))
+ #!+os-provides-dlopen
(setf *runtime-dlhandle* (dlopen-or-lose))
#!+os-provides-dlopen
(setf *shared-objects* nil))
*restart-clusters*
*in-without-gcing* *gc-inhibit* *gc-pending*
#!+sb-thread *stop-for-gc-pending*
+ #!+sb-dynamic-core sb!vm::*required-runtime-c-symbols*
*software-interrupt-vector* *load-verbose*
*load-print-stuff* *in-compilation-unit*
*aborted-compilation-unit-count* *char-name-alist*
(setf (documentation 'process-pid 'function) "The pid of the child process.")
#+win32
-(define-alien-routine ("GetExitCodeProcess@8" get-exit-code-process)
+(define-alien-routine ("GetExitCodeProcess" get-exit-code-process)
int
(handle unsigned) (exit-code unsigned :out))
;;; should live in SB-SYS or even SB-EXT?
(defmacro syscall ((name &rest arg-types) success-form &rest args)
+ (when (eql 3 (mismatch "[_]" name))
+ (setf name
+ (concatenate 'string #!+win32 "_" (subseq name 3))))
`(locally
(declare (optimize (sb!c::float-accuracy 0)))
(let ((result (alien-funcall (extern-alien ,name (function int ,@arg-types))
(defun unix-access (path mode)
(declare (type unix-pathname path)
(type (mod 8) mode))
- (void-syscall ("access" c-string int) path mode))
+ (void-syscall ("[_]access" c-string int) path mode))
;;; values for the second argument to UNIX-LSEEK
;;; Note that nowadays these are called SEEK_SET, SEEK_CUR, and SEEK_END
;;; Is a stream interactive?
(defun unix-isatty (fd)
(declare (type unix-fd fd))
- (int-syscall ("isatty" int) fd))
+ (int-syscall ("[_]isatty" int) fd))
(defun unix-lseek (fd offset whence)
"Unix-lseek accepts a file descriptor and moves the file pointer by
"
(declare (type unix-fd fd)
(type (integer 0 2) whence))
- (let ((result (alien-funcall (extern-alien #!-largefile "lseek"
+ (let ((result #!-win32
+ (alien-funcall (extern-alien #!-largefile "lseek"
#!+largefile "lseek_largefile"
(function off-t int off-t int))
- fd offset whence)))
+ fd offset whence)
+ #!+win32 (sb!win32:lseeki64 fd offset whence)))
(if (minusp result)
(values nil (get-errno))
(values result 0))))
;;; number are returned.
(defun unix-dup (fd)
(declare (type unix-fd fd))
- (int-syscall ("dup" int) fd))
+ (int-syscall ("[_]dup" int) fd))
;;; Terminate the current process with an optional error code. If
;;; successful, the call doesn't return. If unsuccessful, the call
(os-exit code))
;;; Return the process id of the current process.
-(define-alien-routine ("getpid" unix-getpid) int)
+(define-alien-routine (#!+win32 "_getpid" #!-win32 "getpid" unix-getpid) int)
;;; Return the real user id associated with the current process.
#!-win32
;;; name and the file if this is the last link.
(defun unix-unlink (name)
(declare (type unix-pathname name))
- (void-syscall ("unlink" c-string) name))
+ (void-syscall ("[_]unlink" c-string) name))
;;; Return the name of the host machine as a string.
#!-win32
--- /dev/null
+;;; Fortunately, dynamic linking is already working at this stage. On
+;;; win32, however, dynamic foreign symbols for link-time dependencies
+;;; are not available before explicit LoadLibrary on them.
+
+(in-package "SB-IMPL")
+#+win32
+(progn
+ (load-shared-object "kernel32.dll")
+ (load-shared-object "msvcrt.dll")
+ (load-shared-object "advapi32.dll")
+ (load-shared-object "ws2_32.dll")
+ (load-shared-object "shell32.dll"))
(in-package "SB!ALIEN")
-(define-alien-type hinstance long)
+(define-alien-type hinstance signed)
-(define-alien-routine ("LoadLibraryA@4" loadlibrary) hinstance
+(define-alien-routine ("LoadLibraryA" loadlibrary) hinstance
(file c-string))
-(define-alien-routine ("FreeLibrary@4" freelibrary) int
+(define-alien-routine ("FreeLibrary" freelibrary) int
(handle hinstance))
-(define-alien-routine ("GetProcAddress@8" getprocaddress) system-area-pointer
+(define-alien-routine ("GetProcAddress" getprocaddress) system-area-pointer
(handle hinstance)
(symbol c-string))
-(define-alien-routine ("GetLastError@0" getlasterror) unsigned-int)
+(define-alien-routine ("GetLastError" getlasterror) unsigned-int)
-(defun dlopen-or-lose (obj)
- (let* ((namestring (shared-object-namestring obj))
- (handle (loadlibrary namestring)))
- (aver namestring)
- (when (zerop handle)
- (setf (shared-object-handle obj) nil)
- (error "Error opening shared object ~S:~% ~A."
- namestring (getlasterror)))
- (setf (shared-object-handle obj) handle)
- handle))
+(define-alien-routine ("SetStdHandle" set-std-handle)
+ void
+ (id int)
+ (handle int))
+
+(sb!alien:define-alien-routine ("GetStdHandle" get-std-handle)
+ sb!alien:int
+ (id sb!alien:int))
+
+(define-alien-routine ("GetModuleHandleW" get-module-handle)
+ hinstance
+ (name (c-string :external-format :ucs-2)))
+
+(defvar *reset-stdio-on-dlopen* t)
+
+(defconstant +stdio-handle+ -10)
+
+(defun loadlibrary-without-stdio (namestring)
+ (flet ((loadlibrary (namestring)
+ (loadlibrary namestring)))
+ (if *reset-stdio-on-dlopen*
+ (let ((stdio (get-std-handle +stdio-handle+)))
+ (unwind-protect
+ (progn
+ (set-std-handle +stdio-handle+ -1)
+ (loadlibrary namestring))
+ (set-std-handle +stdio-handle+ stdio)))
+ (loadlibrary namestring))))
+
+(defun dlopen-or-lose (&optional obj)
+ (if obj
+ (let* ((namestring (shared-object-namestring obj))
+ (handle (loadlibrary-without-stdio namestring)))
+ (aver namestring)
+ (when (zerop handle)
+ (setf (shared-object-handle obj) nil)
+ (error "Error opening shared object ~S:~% ~A."
+ namestring (getlasterror)))
+ (setf (shared-object-handle obj) handle)
+ handle)
+ (extern-alien "runtime_module_handle" hinstance)))
(defun dlclose-or-lose (&optional (obj nil objp))
(when (and objp (shared-object-handle obj))
;; GetProcAddress() won't return NULL on success.
(let* ((extern (coerce symbol 'base-string))
(result nil))
- (dolist (obj *shared-objects*)
- (let ((handle (shared-object-handle obj)))
- (when handle
- (setf result (sap-int (getprocaddress handle extern)))
- (when (not (zerop result))
- (return result)))))))
-
+ (dolist (handle
+ (cons *runtime-dlhandle*
+ (mapcar #'shared-object-handle *shared-objects*)))
+ (when handle
+ (setf result (sap-int (getprocaddress handle extern)))
+ (when (not (zerop result))
+ (return result))))))
+(defun runtime-exported-symbols ()
+ ;; TODO: reimplement for x86-64. Not so hard.
+ (let* ((image-base (extern-alien "runtime_module_handle" system-area-pointer))
+ (pe-base (sap+ image-base (sap-ref-32 image-base 60)))
+ (export-directory (sap+ pe-base (- #!+x86 248 #!+x86-64 264 (* 16 8))))
+ (export-data (sap+ image-base (sap-ref-32 export-directory 0)))
+ (n-functions (sap-ref-32 export-data 20))
+ (n-names (sap-ref-32 export-data 24))
+ (functions-sap (sap+ image-base (sap-ref-32 export-data 28)))
+ (names-sap (sap+ image-base (sap-ref-32 export-data 32))))
+ (loop repeat (min n-functions n-names)
+ for offset from 0 by #.sb!vm::n-word-bytes
+ collect
+ (cons
+ (sap-int (sap+ image-base (sap-ref-32 functions-sap offset)))
+ (sap-int (sap+ image-base (sap-ref-32 names-sap offset)))))))
;;; Retrieve the calling thread's last-error code value. The
;;; last-error code is maintained on a per-thread basis.
-(define-alien-routine ("GetLastError@0" get-last-error) dword)
+(define-alien-routine ("GetLastError" get-last-error) dword)
;;; Flag constants for FORMAT-MESSAGE.
(defconstant format-message-from-system #x1000)
;;; Format an error message based on a lookup table. See MSDN for the
;;; full meaning of the all options---most are not used when getting
;;; system error codes.
-(define-alien-routine ("FormatMessageA@28" format-message) dword
+(define-alien-routine ("FormatMessageA" format-message) dword
(flags dword)
(source (* t))
(message-id dword)
;;; Read data from a file handle into a buffer. This may be used
;;; synchronously or with "overlapped" (asynchronous) I/O.
-(define-alien-routine ("ReadFile@20" read-file) bool
+(define-alien-routine ("ReadFile" read-file) bool
(file handle)
(buffer (* t))
(bytes-to-read dword)
;;; Write data from a buffer to a file handle. This may be used
;;; synchronously or with "overlapped" (asynchronous) I/O.
-(define-alien-routine ("WriteFile@20" write-file) bool
+(define-alien-routine ("WriteFile" write-file) bool
(file handle)
(buffer (* t))
(bytes-to-write dword)
;;; removing it from the pipe. BUFFER, BYTES-READ, BYTES-AVAIL, and
;;; BYTES-LEFT-THIS-MESSAGE may be NULL if no data is to be read.
;;; Return TRUE on success, FALSE on failure.
-(define-alien-routine ("PeekNamedPipe@24" peek-named-pipe) bool
+(define-alien-routine ("PeekNamedPipe" peek-named-pipe) bool
(pipe handle)
(buffer (* t))
(buffer-size dword)
;;; Flush the console input buffer if HANDLE is a console handle.
;;; Returns true on success, false if the handle does not refer to a
;;; console.
-(define-alien-routine ("FlushConsoleInputBuffer@4" flush-console-input-buffer) bool
+(define-alien-routine ("FlushConsoleInputBuffer" flush-console-input-buffer) bool
(handle handle))
;;; Read data from the console input buffer without removing it,
;;; without blocking. Buffer should be large enough for LENGTH *
;;; INPUT-RECORD-SIZE bytes.
-(define-alien-routine ("PeekConsoleInputA@16" peek-console-input) bool
+(define-alien-routine ("PeekConsoleInputA" peek-console-input) bool
(handle handle)
(buffer (* t))
(length dword)
;;;; System Functions
#!-sb-thread
-(define-alien-routine ("Sleep@4" millisleep) void
+(define-alien-routine ("Sleep" millisleep) void
(milliseconds dword))
#!+sb-thread
(defun ansi-codepage ()
(or *ansi-codepage*
(setq *ansi-codepage*
- (gethash (alien-funcall (extern-alien "GetACP@0" (function UINT)))
+ (gethash (alien-funcall (extern-alien "GetACP" (function UINT)))
*codepage-to-external-format*
:latin-1))))
(defun oem-codepage ()
(or *oem-codepage*
(setq *oem-codepage*
- (gethash (alien-funcall (extern-alien "GetOEMCP@0" (function UINT)))
+ (gethash (alien-funcall (extern-alien "GetOEMCP" (function UINT)))
*codepage-to-external-format*
:latin-1)))))
(declaim (ftype (function () keyword) console-input-codepage))
(defun console-input-codepage ()
(or #!+sb-unicode
- (gethash (alien-funcall (extern-alien "GetConsoleCP@0" (function UINT)))
+ (gethash (alien-funcall (extern-alien "GetConsoleCP" (function UINT)))
*codepage-to-external-format*)
:latin-1))
(defun console-output-codepage ()
(or #!+sb-unicode
(gethash (alien-funcall
- (extern-alien "GetConsoleOutputCP@0" (function UINT)))
+ (extern-alien "GetConsoleOutputCP" (function UINT)))
*codepage-to-external-format*)
:latin-1))
-(define-alien-routine ("LocalFree@4" local-free) void
+(define-alien-routine ("LocalFree" local-free) void
(lptr (* t)))
(defmacro cast-and-free (value &key (type 'system-string)
`(let
((,name (etypecase ,description
(string ,description)
- (cons (destructuring-bind (s &optional (l 0) c) ,description
- (format nil "~A~A~A" s
- (if c #!-sb-unicode "A@" #!+sb-unicode "W@" "@")
- l))))))
+ (cons (destructuring-bind (s &optional c) ,description
+ (format nil "~A~A" s
+ (if c #!-sb-unicode "A" #!+sb-unicode "W" "")))))))
,@body)))
(defmacro make-system-buffer (x)
(defun get-last-error-message (err)
"http://msdn.microsoft.com/library/default.asp?url=/library/en-us/debug/base/retrieving_the_last_error_code.asp"
(with-alien ((amsg (* char)))
- (syscall (("FormatMessage" 28 t)
+ (syscall (("FormatMessage" t)
dword dword dword dword dword (* (* char)) dword dword)
(cast-and-free amsg :free-function local-free)
(logior FORMAT_MESSAGE_ALLOCATE_BUFFER FORMAT_MESSAGE_FROM_SYSTEM)
(defun get-folder-namestring (csidl)
"http://msdn.microsoft.com/library/en-us/shellcc/platform/shell/reference/functions/shgetfolderpath.asp"
(with-alien ((apath (* char) (make-system-buffer (1+ max_path))))
- (syscall (("SHGetFolderPath" 20 t) int handle int handle dword (* char))
+ (syscall (("SHGetFolderPath" t) int handle int handle dword (* char))
(concatenate 'string (cast-and-free apath) "\\")
0 csidl 0 0 apath)))
(defun sb!unix:posix-getcwd ()
(with-alien ((apath (* char) (make-system-buffer (1+ max_path))))
- (with-sysfun (afunc ("GetCurrentDirectory" 8 t) dword dword (* char))
+ (with-sysfun (afunc ("GetCurrentDirectory" t) dword dword (* char))
(let ((ret (alien-funcall afunc (1+ max_path) apath)))
(when (zerop ret)
(win32-error "GetCurrentDirectory"))
(declare (type sb!unix:unix-pathname name)
(type sb!unix:unix-file-mode mode)
(ignore mode))
- (void-syscall* (("CreateDirectory" 8 t) system-string dword) name 0))
+ (void-syscall* (("CreateDirectory" t) system-string dword) name 0))
(defun sb!unix:unix-rename (name1 name2)
(declare (type sb!unix:unix-pathname name1 name2))
- (void-syscall* (("MoveFile" 8 t) system-string system-string) name1 name2))
+ (void-syscall* (("MoveFile" t) system-string system-string) name1 name2))
(defun sb!unix::posix-getenv (name)
(declare (type simple-string name))
(with-alien ((aenv (* char) (make-system-buffer default-environment-length)))
- (with-sysfun (afunc ("GetEnvironmentVariable" 12 t)
+ (with-sysfun (afunc ("GetEnvironmentVariable" t)
dword system-string (* char) dword)
(let ((ret (alien-funcall afunc name aenv default-environment-length)))
(when (> ret default-environment-length)
;;
;; http://msdn.microsoft.com/library/en-us/dllproc/base/getcurrentprocess.asp
(declaim (inline get-current-process))
-(define-alien-routine ("GetCurrentProcess@0" get-current-process) handle)
+(define-alien-routine ("GetCurrentProcess" get-current-process) handle)
;;;; Process time information
(,exit-time filetime)
(,kernel-time filetime)
(,user-time filetime))
- (syscall* (("GetProcessTimes" 20) handle (* filetime) (* filetime)
+ (syscall* (("GetProcessTimes") handle (* filetime) (* filetime)
(* filetime) (* filetime))
(progn ,@forms)
(get-current-process)
epoch (get-internal-real-time)))
(defun get-internal-real-time ()
(- (with-alien ((system-time filetime))
- (syscall (("GetSystemTimeAsFileTime" 4) void (* filetime))
+ (syscall (("GetSystemTimeAsFileTime") void (* filetime))
(values (floor system-time 100ns-per-internal-time-unit))
(addr system-time)))
epoch)))
"Return the number of seconds and microseconds since the beginning of the
UNIX epoch: January 1st 1970."
(with-alien ((system-time filetime))
- (syscall (("GetSystemTimeAsFileTime" 4) void (* filetime))
+ (syscall (("GetSystemTimeAsFileTime") void (* filetime))
(multiple-value-bind (sec 100ns)
(floor (- system-time +unix-epoch-filetime+)
(* 100ns-per-internal-time-unit
;; http://msdn.microsoft.com/library/en-us/dllproc/base/setenvironmentvariable.asp
(defun setenv (name value)
(declare (type simple-string name value))
- (void-syscall* (("SetEnvironmentVariable" 8 t) system-string system-string)
+ (void-syscall* (("SetEnvironmentVariable" t) system-string system-string)
name value))
(defmacro c-sizeof (s)
(defun get-version-ex ()
(with-alien ((info (struct OSVERSIONINFO)))
(setf (slot info 'dwOSVersionInfoSize) (c-sizeof (struct OSVERSIONINFO)))
- (syscall* (("GetVersionEx" 4 t) (* (struct OSVERSIONINFO)))
+ (syscall* (("GetVersionEx" t) (* (struct OSVERSIONINFO)))
(values (slot info 'dwMajorVersion)
(slot info 'dwMinorVersion)
(slot info 'dwBuildNumber)
(defun get-computer-name ()
(with-alien ((aname (* char) (make-system-buffer (1+ MAX_COMPUTERNAME_LENGTH)))
(length dword (1+ MAX_COMPUTERNAME_LENGTH)))
- (with-sysfun (afunc ("GetComputerName" 8 t) bool (* char) (* dword))
+ (with-sysfun (afunc ("GetComputerName" t) bool (* char) (* dword))
(when (zerop (alien-funcall afunc aname (addr length)))
(let ((err (get-last-error)))
(unless (= err ERROR_BUFFER_OVERFLOW)
(alien-funcall afunc aname (addr length))))
(cast-and-free aname))))
+(define-alien-routine ("_lseeki64" lseeki64)
+ (signed 64)
+ (fd int)
+ (position (signed 64))
+ (whence int))
+
(define-alien-routine ("SetFilePointerEx" set-file-pointer-ex) lispbool
(handle handle)
(offset long-long)
(alien-funcall (extern-alien "_dup2" (function int int int)) 0 fd)
(close-protection nil)
(close-socket handle))
- (sb!unix::void-syscall ("close" int) fd))))))
+ (sb!unix::void-syscall ("_close" int) fd))))))
"SRC;CODE;PROFILE"
"SRC;CODE;NTRACE"
"SRC;CODE;STEP"
+ "SRC;CODE;WARM-LIB"
"SRC;CODE;RUN-PROGRAM"))
(let ((fullname (concatenate 'string "SYS:" stem ".LISP")))
;;; the cold core starts up
(defvar *current-debug-sources*)
+;;; foreign symbol references
+(defparameter *cold-foreign-undefined-symbols* nil)
+
;;; the name of the object file currently being cold loaded (as a string, not a
;;; pathname), or NIL if we're not currently cold loading any object file
(defvar *cold-load-filename* nil)
(when value
(do-cold-fixup (second fixup) (third fixup) value (fourth fixup))))))
+#!+sb-dynamic-core
+(progn
+ (defparameter *dyncore-address* sb!vm::linkage-table-space-start)
+ (defparameter *dyncore-linkage-keys* nil)
+ (defparameter *dyncore-table* (make-hash-table :test 'equal))
+
+ (defun dyncore-note-symbol (symbol-name datap)
+ "Register a symbol and return its address in proto-linkage-table."
+ (let ((key (cons symbol-name datap)))
+ (symbol-macrolet ((entry (gethash key *dyncore-table*)))
+ (or entry
+ (setf entry
+ (prog1 *dyncore-address*
+ (push key *dyncore-linkage-keys*)
+ (incf *dyncore-address* sb!vm::linkage-table-entry-size))))))))
+
;;; *COLD-FOREIGN-SYMBOL-TABLE* becomes *!INITIAL-FOREIGN-SYMBOLS* in
;;; the core. When the core is loaded, !LOADER-COLD-INIT uses this to
;;; create *STATIC-FOREIGN-SYMBOLS*, which the code in
(defun foreign-symbols-to-core ()
(let ((symbols nil)
(result *nil-descriptor*))
- (maphash (lambda (symbol value)
- (push (cons symbol value) symbols))
- *cold-foreign-symbol-table*)
- (setq symbols (sort symbols #'string< :key #'car))
- (dolist (symbol symbols)
- (cold-push (cold-cons (base-string-to-core (car symbol))
- (number-to-core (cdr symbol)))
- result))
- (cold-set (cold-intern 'sb!kernel:*!initial-foreign-symbols*) result))
+ #!-sb-dynamic-core
+ (progn
+ (maphash (lambda (symbol value)
+ (push (cons symbol value) symbols))
+ *cold-foreign-symbol-table*)
+ (setq symbols (sort symbols #'string< :key #'car))
+ (dolist (symbol symbols)
+ (cold-push (cold-cons (base-string-to-core (car symbol))
+ (number-to-core (cdr symbol)))
+ result)))
+ (cold-set (cold-intern 'sb!kernel:*!initial-foreign-symbols*) result)
+ #!+sb-dynamic-core
+ (let ((runtime-linking-list *nil-descriptor*))
+ (dolist (symbol *dyncore-linkage-keys*)
+ (cold-push (cold-cons (base-string-to-core (car symbol))
+ (cdr symbol))
+ runtime-linking-list))
+ (cold-set (cold-intern 'sb!vm::*required-runtime-c-symbols*)
+ runtime-linking-list)))
(let ((result *nil-descriptor*))
(dolist (rtn (sort (copy-list *cold-assembler-routines*) #'string< :key #'car))
(cold-push (cold-cons (cold-intern (car rtn))
(len (read-byte-arg))
(sym (make-string len)))
(read-string-as-bytes *fasl-input-stream* sym)
+ #!+sb-dynamic-core
+ (let ((offset (read-word-arg))
+ (value (dyncore-note-symbol sym nil)))
+ (do-cold-fixup code-object offset value kind))
+ #!- (and) (format t "Bad non-plt fixup: ~S~S~%" sym code-object)
+ #!-sb-dynamic-core
(let ((offset (read-word-arg))
(value (cold-foreign-symbol-address sym)))
(do-cold-fixup code-object offset value kind))
(len (read-byte-arg))
(sym (make-string len)))
(read-string-as-bytes *fasl-input-stream* sym)
- (maphash (lambda (k v)
- (format *error-output* "~&~S = #X~8X~%" k v))
- *cold-foreign-symbol-table*)
- (error "shared foreign symbol in cold load: ~S (~S)" sym kind)))
+ #!+sb-dynamic-core
+ (let ((offset (read-word-arg))
+ (value (dyncore-note-symbol sym t)))
+ (do-cold-fixup code-object offset value kind)
+ code-object)
+ #!-sb-dynamic-core
+ (progn
+ (maphash (lambda (k v)
+ (format *error-output* "~&~S = #X~8X~%" k v))
+ *cold-foreign-symbol-table*)
+ (error "shared foreign symbol in cold load: ~S (~S)" sym kind))))
(define-cold-fop (fop-assembler-code)
(let* ((length (read-word-arg))
symbol-table-file-name
core-file-name
map-file-name
- c-header-dir-name)
+ c-header-dir-name
+ #+nil (list-objects t))
+ #!+sb-dynamic-core
+ (declare (ignorable symbol-table-file-name))
(format t
"~&beginning GENESIS, ~A~%"
(let ((*cold-foreign-symbol-table* (make-hash-table :test 'equal)))
+ #!-sb-dynamic-core
(when core-file-name
(if symbol-table-file-name
(load-cold-foreign-symbol-table symbol-table-file-name)
(error "can't output a core file without symbol table file input")))
+ #!+sb-dynamic-core
+ (progn
+ (setf (gethash (extern-alien-name "undefined_tramp")
+ *cold-foreign-symbol-table*)
+ (dyncore-note-symbol "undefined_tramp" nil))
+ (dyncore-note-symbol "undefined_alien_function" nil))
+
;; Now that we've successfully read our only input file (by
;; loading the symbol table, if any), it's a good time to ensure
;; that there'll be someplace for our output files to go when
#!+sb-thread *free-tls-index*
#!+sb-thread *tls-index-lock*
+ ;; dynamic runtime linking support
+ #!+sb-dynamic-core *required-runtime-c-symbols*
+ sb!kernel::*gc-epoch*
+
;; Dispatch tables for generic array access
sb!impl::%%data-vector-reffers%%
sb!impl::%%data-vector-reffers/check-bounds%%
;;;; DEFKNOWNs
#!+linkage-table
-(deftransform foreign-symbol-address ((symbol &optional datap) (simple-string boolean))
- (if (and (constant-lvar-p symbol) (constant-lvar-p datap))
- `(sap-int (foreign-symbol-sap symbol datap))
+(deftransform foreign-symbol-address ((symbol &optional datap) (simple-string boolean)
+ * :important t :policy :fast-safe)
+ (if (and (constant-lvar-p symbol)
+ (constant-lvar-p datap)
+ #!+sb-dynamic-core (not (lvar-value datap)))
+ (values `(sap-int (foreign-symbol-sap symbol datap))
+ (or #!+sb-dynamic-core t))
(give-up-ir1-transform)))
(deftransform foreign-symbol-sap ((symbol &optional datap)
`(foreign-symbol-sap symbol))
#!+linkage-table
(if (and (constant-lvar-p symbol) (constant-lvar-p datap))
- (let ((name (lvar-value symbol))
+ (let (#!-sb-dynamic-core (name (lvar-value symbol))
(datap (lvar-value datap)))
+ #!-sb-dynamic-core
(if (or #+sb-xc-host t ; only static symbols on host
(not datap)
(find-foreign-symbol-in-table name *static-foreign-symbols*))
`(foreign-symbol-sap ,name) ; VOP
- `(foreign-symbol-dataref-sap ,name))) ; VOP
+ `(foreign-symbol-dataref-sap ,name)) ; VOP
+ #!+sb-dynamic-core
+ (if datap
+ `(foreign-symbol-dataref-sap symbol)
+ `(foreign-symbol-sap symbol)))
(give-up-ir1-transform)))
(defknown (sap< sap<= sap= sap>= sap>)
# (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
+LINKFLAGS = -Wl,-export-all-symbols -Wl,mswin.def
OS_LIBS = -l ws2_32
ifdef LISP_FEATURE_SB_CORE_COMPRESSION
OS_LIBS += -lz
GC_SRC = gencgc.c
-CFLAGS = -g -Wall -O3 -fno-omit-frame-pointer -march=i686 -DWINVER=0x0501
+CFLAGS = -g -Wall -O3 \
+ -fno-omit-frame-pointer -march=i686 -DWINVER=0x0501 \
+ -D__W32API_USE_DLLIMPORT__
ASFLAGS = $(CFLAGS)
CPP = cpp
#include <string.h>
#include "sbcl.h"
+#include "globals.h"
+#include "runtime.h"
+#include "genesis/config.h"
+#include "genesis/constants.h"
+#include "genesis/cons.h"
+#include "genesis/vector.h"
+#include "genesis/symbol.h"
+#include "genesis/static-symbols.h"
+#include "thread.h"
+#include "sbcl.h"
#include "os.h"
#include "interr.h"
+#if defined(LISP_FEATURE_OS_PROVIDES_DLOPEN) && !defined(LISP_FEATURE_WIN32)
+# define __USE_GNU /* needed for RTLD_DEFAULT */
+# include <dlfcn.h>
+#endif
+
/* Except for os_zero, these routines are only called by Lisp code.
* These routines may also be replaced by os-dependent versions
}
#endif
+
+#if defined(LISP_FEATURE_OS_PROVIDES_DLOPEN) && !defined(LISP_FEATURE_WIN32)
+void* os_dlopen(char* name, int flags) {
+ volatile void* ret = dlopen(name,flags);
+ return ret;
+}
+#endif
+
+#if defined(LISP_FEATURE_SB_DYNAMIC_CORE)
+/* When this feature is enabled, the special category of /static/ foreign
+ * symbols disappears. Foreign fixups are resolved to linkage table locations
+ * during genesis, and for each of them a record is added to
+ * REQUIRED_RUNTIME_C_SYMBOLS list, of the form (cons name datap).
+ *
+ * Name is a base-string of a symbol name, and non-nil datap marks data
+ * references.
+ *
+ * Before any code in lisp image can be called, we have to resolve all
+ * references to runtime foreign symbols that used to be static, adding linkage
+ * table entry for each element of REQUIRED_RUNTIME_C_SYMBOLS.
+ */
+
+/* We start with a little greenspunning to make car, cdr and base-string data
+ * accessible. */
+
+/* Object tagged? (dereference (cast (untag (obj)))) */
+#define FOLLOW(obj,lowtagtype,ctype) \
+ (*(struct ctype*)(obj - lowtagtype##_LOWTAG))
+
+/* For all types sharing OTHER_POINTER_LOWTAG: */
+#define FOTHERPTR(obj,ctype) \
+ FOLLOW(obj,OTHER_POINTER,ctype)
+
+static inline lispobj car(lispobj conscell)
+{
+ return FOLLOW(conscell,LIST_POINTER,cons).car;
+}
+
+static inline lispobj cdr(lispobj conscell)
+{
+ return FOLLOW(conscell,LIST_POINTER,cons).cdr;
+}
+
+extern void undefined_alien_function(); /* see interrupt.c */
+
+#ifndef LISP_FEATURE_WIN32
+void *
+os_dlsym_default(char *name)
+{
+ void *frob = dlsym(RTLD_DEFAULT, name);
+ odxprint(misc, "%p", frob);
+ return frob;
+}
+#endif
+
+void os_link_runtime()
+{
+ lispobj head;
+ void *link_target = (void*)(intptr_t)LINKAGE_TABLE_SPACE_START;
+ void *validated_end = link_target;
+ lispobj symbol_name;
+ char *namechars;
+ boolean datap;
+ void* result;
+ int strict /* If in a cold core, fail early and often. */
+ = (SymbolValue(GC_INHIBIT, 0) & WIDETAG_MASK) == UNBOUND_MARKER_WIDETAG;
+ int n = 0, m = 0;
+
+ for (head = SymbolValue(REQUIRED_RUNTIME_C_SYMBOLS,0);
+ head!=NIL; head = cdr(head), n++)
+ {
+ lispobj item = car(head);
+ symbol_name = car(item);
+ datap = (NIL!=(cdr(item)));
+ namechars = (void*)(intptr_t)FOTHERPTR(symbol_name,vector).data;
+ result = os_dlsym_default(namechars);
+ odxprint(runtime_link, "linking %s => %p", namechars, result);
+
+ if (link_target == validated_end) {
+ validated_end += os_vm_page_size;
+#ifdef LISP_FEATURE_WIN32
+ os_validate_recommit(link_target,os_vm_page_size);
+#endif
+ }
+ if (result) {
+ if (datap)
+ arch_write_linkage_table_ref(link_target,result);
+ else
+ arch_write_linkage_table_jmp(link_target,result);
+ } else {
+ m++;
+ if (strict)
+ fprintf(stderr,
+ "undefined foreign symbol in cold init: %s\n",
+ namechars);
+ }
+
+ link_target = (void*)(((uintptr_t)link_target)+LINKAGE_TABLE_ENTRY_SIZE);
+ }
+ odxprint(runtime_link, "%d total symbols linked, %d undefined",
+ n, m);
+ if (strict && m)
+ /* We could proceed, but rather than run into improperly
+ * displayed internal errors, let's make ourselves heard right
+ * here and now. */
+ lose("Undefined aliens in cold init.");
+}
+#endif /* sb-dynamic-core */
* "hp-ux.c" in the old CMU CL code. Perhaps move/merge it in here. */
extern os_vm_address_t os_validate(os_vm_address_t addr, os_vm_size_t len);
+#ifdef LISP_FEATURE_WIN32
+void* os_validate_recommit(os_vm_address_t addr, os_vm_size_t len);
+#endif
+
/* This function seems to undo the effect of os_validate(..). */
extern void os_invalidate(os_vm_address_t addr, os_vm_size_t len);
dyndebug_init1(misc, "MISC");
dyndebug_init1(pagefaults, "PAGEFAULTS");
dyndebug_init1(io, "IO");
+ dyndebug_init1(runtime_link, "RUNTIME_LINK");
int n_output_flags = n;
dyndebug_init1(backtrace_when_lost, "BACKTRACE_WHEN_LOST");
if (initial_function == NIL) {
lose("couldn't find initial function\n");
}
+#ifdef LISP_FEATURE_SB_DYNAMIC_CORE
+ os_link_runtime();
+#endif
#ifdef LISP_FEATURE_HPUX
/* -1 = CLOSURE_FUN_OFFSET, 23 = SIMPLE_FUN_CODE_OFFSET, we are
* not in LANGUAGE_ASSEMBLY so we cant reach them. */
int dyndebug_backtrace_when_lost;
int dyndebug_sleep_when_lost;
int dyndebug_io;
+ int dyndebug_runtime_link;
} dyndebug_config;
#ifdef LISP_FEATURE_GENCGC
# define GENCGC_IS_PRECISE 1
#endif
+void *os_dlsym_default(char *name);
+
#endif /* _SBCL_RUNTIME_H_ */
void *base_seh_frame;
+HMODULE runtime_module_handle = 0u;
+
static void *get_seh_frame(void)
{
void* retval;
#endif
+#if defined(LISP_FEATURE_SB_DYNAMIC_CORE)
+/* This feature has already saved me more development time than it
+ * took to implement. In its current state, ``dynamic RT<->core
+ * linking'' is a protocol of initialization of C runtime and Lisp
+ * core, populating SBCL linkage table with entries for runtime
+ * "foreign" symbols that were referenced in cross-compiled code.
+ *
+ * How it works: a sketch
+ *
+ * Last Genesis (resulting in cold-sbcl.core) binds foreign fixups in
+ * x-compiled lisp-objs to sequential addresses from the beginning of
+ * linkage-table space; that's how it ``resolves'' foreign references.
+ * Obviously, this process doesn't require pre-built runtime presence.
+ *
+ * When the runtime loads the core (cold-sbcl.core initially,
+ * sbcl.core later), runtime should do its part of the protocol by (1)
+ * traversing a list of ``runtime symbols'' prepared by Genesis and
+ * dumped as a static symbol value, (2) resolving each name from this
+ * list to an address (stubbing unresolved ones with
+ * undefined_alien_address or undefined_alien_function), (3) adding an
+ * entry for each symbol somewhere near the beginning of linkage table
+ * space (location is provided by the core).
+ *
+ * The implementation of the part described in the last paragraph
+ * follows. C side is currently more ``hackish'' and less clear than
+ * the Lisp code; OTOH, related Lisp changes are scattered, and some
+ * of them play part in complex interrelations -- beautiful but taking
+ * much time to understand --- but my subset of PE-i386 parser below
+ * is in one place (here) and doesn't have _any_ non-trivial coupling
+ * with the rest of the Runtime.
+ *
+ * What do we gain with this feature, after all?
+ *
+ * One things that I have to do rather frequently: recompile and
+ * replace runtime without rebuilding the core. Doubtlessly, slam.sh
+ * was a great time-saver here, but relinking ``cold'' core and bake a
+ * ``warm'' one takes, as it seems, more than 10x times of bare
+ * SBCL.EXE build time -- even if everything is recompiled, which is
+ * now unnecessary. Today, if I have a new idea for the runtime,
+ * getting from C-x C-s M-x ``compile'' to fully loaded SBCL
+ * installation takes 5-15 seconds.
+ *
+ * Another thing (that I'm not currently using, but obviously
+ * possible) is delivering software patches to remote system on
+ * customer site. As you are doing minor additions or corrections in
+ * Lisp code, it doesn't take much effort to prepare a tiny ``FASL
+ * bundle'' that rolls up your patch, redumps and -- presto -- 100MiB
+ * program is fixed by sending and loading a 50KiB thingie.
+ *
+ * However, until LISP_FEATURE_SB_DYNAMIC_CORE, if your bug were fixed
+ * by modifying two lines of _C_ sources, a customer described above
+ * had to be ready to receive and reinstall a new 100MiB
+ * executable. With the aid of code below, deploying such a fix
+ * requires only sending ~300KiB (when stripped) of SBCL.EXE.
+ *
+ * But there is more to it: as the common linkage-table is used for
+ * DLLs and core, its entries may be overridden almost without a look
+ * into SBCL internals. Therefore, ``patching'' C runtime _without_
+ * restarting target systems is also possible in many situations
+ * (it's not as trivial as loading FASLs into a running daemon, but
+ * easy enough to be a viable alternative if any downtime is highly
+ * undesirable).
+ *
+ * During my (rather limited) commercial Lisp development experience
+ * I've already been through a couple of situations where such
+ * ``deployment'' issues were important; from my _total_ programming
+ * experience I know -- _sometimes_ they are a two orders of magnitude
+ * more important than those I observed.
+ *
+ * The possibility of entire runtime ``hot-swapping'' in running
+ * process is not purely theoretical, as it could seem. There are 2-3
+ * problems whose solution is not obvious (call stack patching, for
+ * instance), but it's literally _nothing_ if compared with
+ * e.g. LISP_FEATURE_SB_AUTO_FPU_SWITCH. By the way, one of the
+ * problems with ``hot-swapping'', that could become a major one in
+ * many other environments, is nonexistent in SBCL: we already have a
+ * ``global quiesce point'' that is generally required for this kind
+ * of worldwide revolution -- around collect_garbage.
+ *
+ * What's almost unnoticeable from the C side (where you are now, dear
+ * reader): using the same style for all linking is beautiful. I tried
+ * to leave old-style linking code in place for the sake of
+ * _non-linkage-table_ platforms (they probably don't have -ldl or its
+ * equivalent, like LL/GPA, at all) -- but i did it usually by moving
+ * the entire `old style' code under #!-sb-dynamic-core and
+ * refactoring the `new style' branch, instead of cutting the tail
+ * piecemeal and increasing #!+-ifdeffery amount & the world enthropy.
+ *
+ * If we look at the majority of the ``new style'' code units, it's a
+ * common thing to observe how #!+-ifdeffery _vanishes_ instead of
+ * multiplying: #!-sb-xc, #!+sb-xc-host and #!-sb-xc-host end up
+ * needing the same code. Runtime checks of static v. dynamic symbol
+ * disappear even faster. STDCALL mangling and leading underscores go
+ * out of scope (and GCed, hopefully) instead of surfacing here and
+ * there as a ``special case for core static symbols''. What I like
+ * the most about CL development in general is a frequency of solving
+ * problems and fixing bugs by simplifying code and dropping special
+ * cases.
+ *
+ * Last important thing about the following code: besides resolving
+ * symbols provided by the core itself, it detects runtime's own
+ * build-time prerequisite DLLs. Any symbol that is unresolved against
+ * the core is looked up in those DLLs (normally kernel32, msvcrt,
+ * ws2_32... I could forget something). This action (1) resembles
+ * implementation of foreign symbol lookup in SBCL itself, (2)
+ * emulates shared library d.l. facilities of OSes that use flat
+ * dynamic symbol namespace (or default to it). Anyone concerned with
+ * portability problems of this PE-i386 stuff below will be glad to
+ * hear that it could be ported to most modern Unices _by deletion_:
+ * raw dlsym() with null handle usually does the same thing that i'm
+ * trying to squeeze out of MS Windows by the brute force.
+ *
+ * My reason for _desiring_ flat symbol namespace, populated from
+ * link-time dependencies, is avoiding any kind of ``requested-by-Lisp
+ * symbol lists to be linked statically'', providing core v. runtime
+ * independence in both directions. Minimizing future maintenance
+ * effort is very important; I had gone for it consistently, starting
+ * by turning "CloseHandle@4" into a simple "CloseHandle", continuing
+ * by adding intermediate Genesis resulting in autogenerated symbol
+ * list (farewell, void scratch(); good riddance), going to take
+ * another great step for core/runtime independence... and _without_
+ * flat namespace emulation, the ghosts and spirits exiled at the
+ * first steps would come and take revenge: well, here are the symbols
+ * that are really in msvcrt.dll.. hmm, let's link statically against
+ * them, so the entry is pulled from the import library.. and those
+ * entry has mangled names that we have to map.. ENOUGH, I though
+ * here: fed up with stuff like that.
+ *
+ * Now here we are, without import libraries, without mangled symbols,
+ * and without nm-generated symbol tables. Every symbol exported by
+ * the runtime is added to SBCL.EXE export directory; every symbol
+ * requested by the core is looked up by GetProcAddress for SBCL.EXE,
+ * falling back to GetProcAddress for MSVCRT.dll, etc etc.. All ties
+ * between SBCL's foreign symbols with object file symbol tables,
+ * import libraries and other pre-linking symbol-resolving entities
+ * _having no representation in SBCL.EXE_ were teared.
+ *
+ * This simplistic approach proved to work well; there is only one
+ * problem introduced by it, and rather minor: in real MSVCRT.dll,
+ * what's used to be available as open() is now called _open();
+ * similar thing happened to many other `lowio' functions, though not
+ * every one, so it's not a kind of name mangling but rather someone's
+ * evil creative mind in action.
+ *
+ * When we look up any of those poor `uglified' functions in CRT
+ * reference on MSDN, we can see a notice resembling this one:
+ *
+ * `unixishname()' is obsolete and provided for backward
+ * compatibility; new standard-compliant function, `_unixishname()',
+ * should be used instead. Sentences of that kind were there for
+ * several years, probably even for a decade or more (a propos,
+ * MSVCRT.dll, as the name to link against, predates year 2000, so
+ * it's actually possible). Reasoning behing it (what MS people had in
+ * mind) always seemed strange to me: if everyone uses open() and that
+ * `everyone' is important to you, why rename the function? If no one
+ * uses open(), why provide or retain _open() at all? <kidding>After
+ * all, names like _open() are entirely non-informative and just plain
+ * ugly; compare that with CreateFileW() or InitCommonControlsEx(),
+ * the real examples of beauty and clarity.</kidding>
+ *
+ * Anyway, if the /standard/ name on Windows is _open() (I start to
+ * recall, vaguely, that it's because of _underscore names being
+ * `reserved to system' and all other ones `available for user', per
+ * ANSI/ISO C89) -- well, if the /standard/ name is _open, SBCL should
+ * use it when it uses MSVCRT and not some ``backward-compatible''
+ * stuff. Deciding this way, I added a hack to SBCL's syscall macros,
+ * so "[_]open" as a syscall name is interpreted as a request to link
+ * agains "_open" on win32 and "open" on every other system.
+ *
+ * Of course, this name-parsing trick lacks conceptual clarity; we're
+ * going to get rid of it eventually. */
+
+u32 os_get_build_time_shared_libraries(u32 excl_maximum,
+ void* opt_root,
+ void** opt_store_handles,
+ const char *opt_store_names[])
+{
+ void* base = opt_root ? opt_root : (void*)runtime_module_handle;
+ /* base defaults to 0x400000 with GCC/mingw32. If you dereference
+ * that location, you'll see 'MZ' bytes */
+ void* base_magic_location =
+ base + ((IMAGE_DOS_HEADER*)base)->e_lfanew;
+
+ /* dos header provided the offset from `base' to
+ * IMAGE_FILE_HEADER where PE-i386 really starts */
+
+ void* check_duplicates[excl_maximum];
+
+ if ((*(u32*)base_magic_location)!=0x4550) {
+ /* We don't need this DLL thingie _that_ much. If the world
+ * has changed to a degree where PE magic isn't found, let's
+ * silently return `no libraries detected'. */
+ return 0;
+ } else {
+ /* We traverse PE-i386 structures of SBCL.EXE in memory (not
+ * in the file). File and memory layout _surely_ differ in
+ * some places and _may_ differ in some other places, but
+ * fortunately, those places are irrelevant to the task at
+ * hand. */
+
+ IMAGE_FILE_HEADER* image_file_header = (base_magic_location + 4);
+ IMAGE_OPTIONAL_HEADER* image_optional_header =
+ (void*)(image_file_header + 1);
+ IMAGE_DATA_DIRECTORY* image_import_direntry =
+ &image_optional_header->DataDirectory[IMAGE_DIRECTORY_ENTRY_IMPORT];
+ IMAGE_IMPORT_DESCRIPTOR* image_import_descriptor =
+ base + image_import_direntry->VirtualAddress;
+ u32 nlibrary, i,j;
+
+ for (nlibrary=0u; nlibrary < excl_maximum
+ && image_import_descriptor->FirstThunk;
+ ++image_import_descriptor)
+ {
+ HMODULE hmodule;
+ odxprint(runtime_link, "Now should know DLL: %s",
+ (char*)(base + image_import_descriptor->Name));
+ /* Code using image thunk data to get its handle was here, with a
+ * number of platform-specific tricks (like using VirtualQuery for
+ * old OSes lacking GetModuleHandleEx).
+ *
+ * It's now replaced with requesting handle by name, which is
+ * theoretically unreliable (with SxS, multiple modules with same
+ * name are quite possible), but good enough to find the
+ * link-time dependencies of our executable or DLL. */
+
+ hmodule = (HMODULE)
+ GetModuleHandle(base + image_import_descriptor->Name);
+
+ if (hmodule)
+ {
+ /* We may encouncer some module more than once while
+ traversing import descriptors (it's usually a
+ result of non-trivial linking process, like doing
+ ld -r on some groups of files before linking
+ everything together.
+
+ Anyway: using a module handle more than once will
+ do no harm, but it slows down the startup (even
+ now, our startup time is not a pleasant topic to
+ discuss when it comes to :sb-dynamic-core; there is
+ an obvious direction to go for speed, though --
+ instead of resolving symbols one-by-one, locate PE
+ export directories -- they are sorted by symbol
+ name -- and merge them, at one pass, with sorted
+ list of required symbols (the best time to sort the
+ latter list is during Genesis -- that's why I don't
+ proceed with memory copying, qsort() and merge
+ right here)). */
+
+ for (j=0; j<nlibrary; ++j)
+ {
+ if(check_duplicates[j] == hmodule)
+ break;
+ }
+ if (j<nlibrary) continue; /* duplicate => skip it in
+ * outer loop */
+
+ check_duplicates[nlibrary] = hmodule;
+ if (opt_store_handles) {
+ opt_store_handles[nlibrary] = hmodule;
+ }
+ if (opt_store_names) {
+ opt_store_names[nlibrary] = (const char *)
+ (base + image_import_descriptor->Name);
+ }
+ odxprint(runtime_link, "DLL detection: %u, base %p: %s",
+ nlibrary, hmodule,
+ (char*)(base + image_import_descriptor->Name));
+ ++ nlibrary;
+ }
+ }
+ return nlibrary;
+ }
+}
+
+static u32 buildTimeImageCount = 0;
+static void* buildTimeImages[16];
+
+/* Resolve symbols against the executable and its build-time dependencies */
+void* os_dlsym_default(char* name)
+{
+ unsigned int i;
+ void* result = 0;
+ if (buildTimeImageCount == 0) {
+ buildTimeImageCount =
+ 1 + os_get_build_time_shared_libraries(15u,
+ NULL, 1+(void**)buildTimeImages, NULL);
+ }
+ for (i = 0; i<buildTimeImageCount && (!result); ++i) {
+ result = GetProcAddress(buildTimeImages[i], name);
+ }
+ return result;
+}
+
+#endif /* SB_DYNAMIC_CORE */
+
#if defined(LISP_FEATURE_SB_THREAD)
/* We want to get a slot in TIB that (1) is available at constant
offset, (2) is our private property, so libraries wouldn't legally
#undef RESOLVE
+intptr_t win32_get_module_handle_by_address(os_vm_address_t addr)
+{
+ HMODULE result = 0;
+ /* So apparently we could use VirtualQuery instead of
+ * GetModuleHandleEx if we wanted to support pre-XP, pre-2003
+ * versions of Windows (i.e. Windows 2000). I've opted against such
+ * special-casing. :-). --DFL */
+ return (intptr_t)(GetModuleHandleEx(
+ GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS |
+ GET_MODULE_HANDLE_EX_FLAG_UNCHANGED_REFCOUNT,
+ (LPCSTR)addr, &result)
+ ? result : 0);
+}
+
void os_init(char *argv[], char *envp[])
{
SYSTEM_INFO system_info;
base_seh_frame = get_seh_frame();
resolve_optional_imports();
+ runtime_module_handle = (HMODULE)win32_get_module_handle_by_address(&runtime_module_handle);
}
static inline boolean local_thread_stack_address_p(os_vm_address_t address)
AVERLAX(VirtualFree(minfo.AllocationBase, 0, MEM_RELEASE));
}
+/* os_validate doesn't commit, i.e. doesn't actually "validate" in the
+ * sense that we could start using the space afterwards. Usually it's
+ * os_map or Lisp code that will run into that, in which case we recommit
+ * elsewhere in this file. For cases where C wants to write into newly
+ * os_validate()d memory, it needs to commit it explicitly first:
+ */
+os_vm_address_t
+os_validate_recommit(os_vm_address_t addr, os_vm_size_t len)
+{
+ return
+ AVERLAX(VirtualAlloc(addr, len, MEM_COMMIT, PAGE_EXECUTE_READWRITE));
+}
+
#define maybe_open_osfhandle _open_osfhandle
#define maybe_get_osfhandle _get_osfhandle
#define FDTYPE int
return read_bytes;
}
-/* This is a manually-maintained version of ldso_stubs.S. */
-
void __stdcall RtlUnwind(void *, void *, void *, void *); /* I don't have winternl.h */
+/* We used to have a scratch() function listing all symbols needed by
+ * Lisp. Much rejoicing commenced upon its removal. However, I would
+ * like cold init to fail aggressively when encountering unused symbols.
+ * That poses a problem, however, since our C code no longer includes
+ * any references to symbols in ws2_32.dll, and hence the linker
+ * completely ignores our request to reference it (--no-as-needed does
+ * not work). Warm init would later load the DLLs explicitly, but then
+ * it's too late for an early sanity check. In the unfortunate spirit
+ * of scratch(), continue to reference some required DLLs explicitly by
+ * means of one scratch symbol per DLL.
+ */
void scratch(void)
{
- LARGE_INTEGER la = {{0}};
- closesocket(0);
- CloseHandle(0);
+ /* a function from ws2_32.dll */
shutdown(0, 0);
- SetHandleInformation(0, 0, 0);
- GetHandleInformation(0, 0);
- getsockopt(0, 0, 0, 0, 0);
- FlushConsoleInputBuffer(0);
- FormatMessageA(0, 0, 0, 0, 0, 0, 0);
- FreeLibrary(0);
- GetACP();
- GetConsoleCP();
- GetConsoleOutputCP();
- GetCurrentProcess();
- GetExitCodeProcess(0, 0);
- GetLastError();
- GetOEMCP();
- GetProcAddress(0, 0);
- GetProcessTimes(0, 0, 0, 0, 0);
- GetSystemTimeAsFileTime(0);
- LoadLibrary(0);
- LocalFree(0);
- PeekConsoleInput(0, 0, 0, 0);
- PeekNamedPipe(0, 0, 0, 0, 0, 0);
- ReadFile(0, 0, 0, 0, 0);
- Sleep(0);
- WriteFile(0, 0, 0, 0, 0);
- _get_osfhandle(0);
- _open_osfhandle(0, 0);
- _rmdir(0);
- _pipe(0,0,0);
- access(0,0);
- close(0);
- dup(0);
- isatty(0);
- strerror(42);
- write(0, 0, 0);
- RtlUnwind(0, 0, 0, 0);
- MapViewOfFile(0,0,0,0,0);
- UnmapViewOfFile(0);
- FlushViewOfFile(0,0);
- SetFilePointerEx(0, la, 0, 0);
- DuplicateHandle(0, 0, 0, 0, 0, 0, 0);
- #ifndef LISP_FEATURE_SB_UNICODE
- CreateDirectoryA(0,0);
- CreateFileMappingA(0,0,0,0,0,0);
- CreateFileA(0,0,0,0,0,0,0);
- GetComputerNameA(0, 0);
- GetCurrentDirectoryA(0,0);
- GetEnvironmentVariableA(0, 0, 0);
- GetFileAttributesA(0);
- GetVersionExA(0);
- MoveFileA(0,0);
- SHGetFolderPathA(0, 0, 0, 0, 0);
- SetCurrentDirectoryA(0);
- SetEnvironmentVariableA(0, 0);
- #else
- CreateDirectoryW(0,0);
- CreateFileMappingW(0,0,0,0,0,0);
- CreateFileW(0,0,0,0,0,0,0);
- FormatMessageW(0, 0, 0, 0, 0, 0, 0);
- GetComputerNameW(0, 0);
- GetCurrentDirectoryW(0,0);
- GetEnvironmentVariableW(0, 0, 0);
- GetFileAttributesW(0);
- GetVersionExW(0);
- MoveFileW(0,0);
- SHGetFolderPathW(0, 0, 0, 0, 0);
- SetCurrentDirectoryW(0);
- SetEnvironmentVariableW(0, 0);
- #endif
- _exit(0);
+
+ /* a function from shell32.dll */
+ SHGetFolderPathA(0, 0, 0, 0, 0);
}
char *
;;; External format support in SB-ALIEN
(with-test (:name (:sb-alien :vanilla))
- (define-alien-routine strdup c-string (str c-string))
+ (define-alien-routine (#-win32 "strdup" #+win32 "_strdup" strdup)
+ c-string
+ (str c-string))
(assert (equal "foo" (strdup "foo"))))
(with-test (:name (:sb-alien :utf-8 :utf-8))
- (define-alien-routine strdup (c-string :external-format :utf-8)
+ (define-alien-routine (#-win32 "strdup" #+win32 "_strdup" strdup)
+ (c-string :external-format :utf-8)
(str (c-string :external-format :utf-8)))
(assert (equal "foo" (strdup "foo"))))
(with-test (:name (:sb-alien :latin-1 :utf-8))
- (define-alien-routine strdup (c-string :external-format :latin-1)
+ (define-alien-routine (#-win32 "strdup" #+win32 "_strdup" strdup)
+ (c-string :external-format :latin-1)
(str (c-string :external-format :utf-8)))
(assert (= (length (strdup (string (code-char 246))))
2)))
(with-test (:name (:sb-alien :utf-8 :latin-1))
- (define-alien-routine strdup (c-string :external-format :utf-8)
+ (define-alien-routine (#-win32 "strdup" #+win32 "_strdup" strdup)
+ (c-string :external-format :utf-8)
(str (c-string :external-format :latin-1)))
(assert (equal (string (code-char 228))
(strdup (concatenate 'string
(list (code-char 164)))))))
(with-test (:name (:sb-alien :ebcdic :ebcdic))
- (define-alien-routine strdup (c-string :external-format :ebcdic-us)
+ (define-alien-routine (#-win32 "strdup" #+win32 "_strdup" strdup)
+ (c-string :external-format :ebcdic-us)
(str (c-string :external-format :ebcdic-us)))
(assert (equal "foo" (strdup "foo"))))
(with-test (:name (:sb-alien :latin-1 :ebcdic))
- (define-alien-routine strdup (c-string :external-format :latin-1)
+ (define-alien-routine (#-win32 "strdup" #+win32 "_strdup" strdup)
+ (c-string :external-format :latin-1)
(str (c-string :external-format :ebcdic-us)))
(assert (not (equal "foo" (strdup "foo")))))
(with-test (:name (:sb-alien :simple-base-string))
- (define-alien-routine strdup (c-string :external-format :ebcdic-us
- :element-type base-char)
+ (define-alien-routine (#-win32 "strdup" #+win32 "_strdup" strdup)
+ (c-string :external-format :ebcdic-us
+ :element-type base-char)
(str (c-string :external-format :ebcdic-us)))
(assert (typep (strdup "foo") 'simple-base-string)))
projects / sbcl.git / commitdiff