From: Daniel Barlow Date: Sat, 7 Jun 2003 15:52:03 +0000 (+0000) Subject: 0.8.0.45 X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=e411bd41397e1df2423838a4f9c2fdaa27727e93;p=sbcl.git 0.8.0.45 64 bit alien support on x86, by reference to CMUCL ... x86/sap.lisp gets transforms for *-sap-ref-64 which do the reference a word at a time ... teach define-alien-type-method (integer :extract-gen) to know about *-sap-ref-64 ... #!+alpha removed from defknowns for *-sap-ref-64 ... compiler/x86/c-call gets hairy great deftransform %alien-funcall that transforms 64 bit args and return values appropriately. Lifted & ported from CMUCL by rude mechanicals This all could use generifying for endianness and putting somewhere that all 32 bit platforms (i.e. everything but Alpha, I think) can see it. Fix the BSD-specific mess in unix-lseek to use off-t like the other platforms do. Should now work (untested) Add mmap/munmap/getpagesize support to SB-POSIX, courtesy Rudi Schlatte. SB-UNIX:UNIX-IOCTL second argument is signed, as per sbcl-devel mail from Vincent Arkesteijn --- diff --git a/contrib/sb-posix/TODO b/contrib/sb-posix/TODO index 4f5cde1..4abc9d0 100644 --- a/contrib/sb-posix/TODO +++ b/contrib/sb-posix/TODO @@ -11,12 +11,12 @@ FD_CLR FD_ISSET FD_SET FD_ZERO accept acct adjtime adjtimex bdflush bind break brk cacheflush capget capset chroot clone connect creat create_module delete_module execve exit fcntl fdatasync flock fork fstat fstatfs fsync ftime ftruncate getcontext getdents getdomainname -getdtablesize getgroups gethostid gethostname getitimer getpagesize +getdtablesize getgroups gethostid gethostname getitimer getpeername getpriority getrlimit getrusage getsockname getsockopt gettimeofday gtty idle init_module ioctl ioctl_list ioperm iopl listen -llseek lock lseek lstat madvise mincore mknod mlock mlockall mmap +llseek lock lseek lstat madvise mincore mknod mlock mlockall modify_ldt mount mprotect mpx mremap msgctl msgget msgop msgrcv msgsnd -msync munlock munlockall munmap nanosleep nice open pause pipe poll +msync munlock munlockall nanosleep nice open pause pipe poll prctl pread prof profil pselect ptrace pwrite query_module quotactl read readdir readlink readv reboot recv recvfrom recvmsg rename rmdir sbrk sched_get_priority_max sched_get_priority_min sched_getparam diff --git a/contrib/sb-posix/constants.lisp b/contrib/sb-posix/constants.lisp index 587261f..a6284a8 100644 --- a/contrib/sb-posix/constants.lisp +++ b/contrib/sb-posix/constants.lisp @@ -10,7 +10,7 @@ "sys/socket.h" "sys/un.h" "netinet/in.h" "netinet/in_systm.h" "netinet/ip.h" "net/if.h" "netdb.h" "errno.h" "netinet/tcp.h" - "fcntl.h" ) + "fcntl.h" "sys/mman.h") ;;; then the stuff we're looking for ((:integer af-inet "AF_INET" "IP Protocol family") @@ -43,4 +43,13 @@ (:integer w-ok "W_OK") (:integer x-ok "X_OK") (:integer f-ok "F_OK") + + ;; mmap() + (:integer prot-none "PROT_NONE" "mmap: no protection") + (:integer prot-read "PROT_READ" "mmap: read protection") + (:integer prot-write "PROT_WRITE" "mmap: write protection") + (:integer prot-exec "PROT_EXEC" "mmap: execute protection") + (:integer map-shared "MAP_SHARED" "mmap: shared memory") + (:integer map-private "MAP_PRIVATE" "mmap: private mapping") + (:integer map-fixed "MAP_FIXED" "mmap: map at given location") ) \ No newline at end of file diff --git a/contrib/sb-posix/defpackage.lisp b/contrib/sb-posix/defpackage.lisp index 0b94cdb..751c3c0 100644 --- a/contrib/sb-posix/defpackage.lisp +++ b/contrib/sb-posix/defpackage.lisp @@ -1,2 +1,4 @@ -(defpackage :sb-posix (:use )) +(defpackage :sb-posix (:use ) + (:export #:syscall-error)) + (defpackage :sb-posix-internal (:use #:sb-alien #:cl)) diff --git a/contrib/sb-posix/designator.lisp b/contrib/sb-posix/designator.lisp index 2aa33e2..5094a94 100644 --- a/contrib/sb-posix/designator.lisp +++ b/contrib/sb-posix/designator.lisp @@ -22,3 +22,6 @@ (sb-impl::file-stream (sb-impl::fd-stream-fd file-descriptor)) (fixnum file-descriptor)) +(define-designator sap-or-nil sb-sys:system-area-pointer + (null (sb-sys:int-sap 0)) + (sb-sys:system-area-pointer sap-or-nil)) diff --git a/contrib/sb-posix/interface.lisp b/contrib/sb-posix/interface.lisp index 932cc96..a310e54 100644 --- a/contrib/sb-posix/interface.lisp +++ b/contrib/sb-posix/interface.lisp @@ -8,7 +8,7 @@ errno (sb-int:strerror errno)))))) (defun syscall-error () - (error 'sb-posix::syscall-error :errno (get-errno))) + (error 'sb-posix:syscall-error :errno (get-errno))) ;;; filesystem access @@ -73,3 +73,18 @@ (define-call "setpgid" int minusp (pid sb-posix::pid-t) (pgid sb-posix::pid-t)) (define-call "setpgrp" int minusp) + +;;; mmap +(define-call "mmap" sb-sys:system-area-pointer + ;; KLUDGE: #XFFFFFFFF is (void *)-1, which is the charming return + ;; value of mmap on failure. Except on 64 bit systems ... + (lambda (res) + (= (sb-sys:sap-int res) #-alpha #XFFFFFFFF #+alpha #xffffffffffffffff)) + (addr sap-or-nil) (length unsigned) (prot unsigned) + (flags unsigned) (fd file-descriptor) (offset int)) + +(define-call "munmap" int minusp + (start sb-sys:system-area-pointer) (length unsigned)) + +(define-call "getpagesize" int minusp) + diff --git a/src/code/host-alieneval.lisp b/src/code/host-alieneval.lisp index 413beba..0003d8b 100644 --- a/src/code/host-alieneval.lisp +++ b/src/code/host-alieneval.lisp @@ -558,12 +558,12 @@ (8 'signed-sap-ref-8) (16 'signed-sap-ref-16) (32 'signed-sap-ref-32) - #!+alpha (64 'signed-sap-ref-64)) + (64 'signed-sap-ref-64)) (case (alien-integer-type-bits type) (8 'sap-ref-8) (16 'sap-ref-16) (32 'sap-ref-32) - #!+alpha (64 'sap-ref-64))))) + (64 'sap-ref-64))))) (if ref-fun `(,ref-fun ,sap (/ ,offset sb!vm:n-byte-bits)) (error "cannot extract ~W-bit integers" diff --git a/src/code/unix.lisp b/src/code/unix.lisp index 1e973f3..382d034 100644 --- a/src/code/unix.lisp +++ b/src/code/unix.lisp @@ -216,15 +216,8 @@ ;;; L_XTND Extend the file size. (defun unix-lseek (fd offset whence) (declare (type unix-fd fd) - (type (unsigned-byte 32) offset) (type (integer 0 2) whence)) - #!-(and x86 bsd) - (int-syscall ("lseek" int off-t int) fd offset whence) - ;; Need a 64-bit return value type for this. TBD. For now, - ;; don't use this with any 2G+ partitions. - #!+(and x86 bsd) - (int-syscall ("lseek" int unsigned-long unsigned-long int) - fd offset 0 whence)) + (int-syscall ("lseek" int off-t int) fd offset whence)) ;;; UNIX-READ accepts a file descriptor, a buffer, and the length to read. ;;; It attempts to read len bytes from the device associated with fd @@ -407,8 +400,8 @@ ;;; information. (defun unix-ioctl (fd cmd arg) (declare (type unix-fd fd) - (type (unsigned-byte 32) cmd)) - (void-syscall ("ioctl" int unsigned-int (* char)) fd cmd arg)) + (type (signed-byte 32) cmd)) + (void-syscall ("ioctl" int signed-int (* char)) fd cmd arg)) ;;;; sys/resource.h diff --git a/src/compiler/saptran.lisp b/src/compiler/saptran.lisp index 4270fed..aa0b505 100644 --- a/src/compiler/saptran.lisp +++ b/src/compiler/saptran.lisp @@ -48,10 +48,11 @@ (unsigned-byte 32) ()) -#!+alpha +;; FIXME These are supported natively on alpha and using deftransforms +;; in compiler/x86/sap.lisp, which in OAO$n$ style need copying to +;; other 32 bit systems (defknown sap-ref-64 (system-area-pointer fixnum) (unsigned-byte 64) (flushable)) -#!+alpha (defknown %set-sap-ref-64 (system-area-pointer fixnum (unsigned-byte 64)) (unsigned-byte 64) ()) @@ -74,10 +75,8 @@ (signed-byte 32) ()) -#!+alpha (defknown signed-sap-ref-64 (system-area-pointer fixnum) (signed-byte 64) (flushable)) -#!+alpha (defknown %set-signed-sap-ref-64 (system-area-pointer fixnum (signed-byte 64)) (signed-byte 64) ()) @@ -146,6 +145,10 @@ (def %set-sap-ref-32) (def signed-sap-ref-32) (def %set-signed-sap-ref-32) + (def sap-ref-64) + (def %set-sap-ref-64) + (def signed-sap-ref-64) + (def %set-signed-sap-ref-64) (def sap-ref-sap) (def %set-sap-ref-sap) (def sap-ref-single) diff --git a/src/compiler/x86/c-call.lisp b/src/compiler/x86/c-call.lisp index 6f09cb7..e0cdd9c 100644 --- a/src/compiler/x86/c-call.lisp +++ b/src/compiler/x86/c-call.lisp @@ -132,6 +132,66 @@ (alien-fun-type-result-type type) (make-result-state)))))) + +(deftransform %alien-funcall ((function type &rest args) * * :node node) + (aver (sb!c::constant-continuation-p type)) + (let* ((type (sb!c::continuation-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-address) (:translate foreign-symbol-address) (:policy :fast-safe) diff --git a/src/compiler/x86/sap.lisp b/src/compiler/x86/sap.lisp index c834de3..7de8ab9 100644 --- a/src/compiler/x86/sap.lisp +++ b/src/compiler/x86/sap.lisp @@ -499,3 +499,23 @@ (inst add sap (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)))) + +;;; Transforms for 64-bit SAP accessors. + +(deftransform sap-ref-64 ((sap offset) (* *)) + '(logior (sap-ref-32 sap offset) + (ash (sap-ref-32 sap (+ offset 4)) 32))) + +(deftransform signed-sap-ref-64 ((sap offset) (* *)) + '(logior (sap-ref-32 sap offset) + (ash (signed-sap-ref-32 sap (+ offset 4)) 32))) + +(deftransform %set-sap-ref-64 ((sap offset value) (* * *)) + '(progn + (%set-sap-ref-32 sap offset (logand value #xffffffff)) + (%set-sap-ref-32 sap (+ offset 4) (ash value -32)))) + +(deftransform %set-signed-sap-ref-64 ((sap offset value) (* * *)) + '(progn + (%set-sap-ref-32 sap offset (logand value #xffffffff)) + (%set-signed-sap-ref-32 sap (+ offset 4) (ash value -32)))) diff --git a/version.lisp-expr b/version.lisp-expr index ac56de0..6715542 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.8.0.44" +"0.8.0.45"