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
"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")
(: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
-(defpackage :sb-posix (:use ))
+(defpackage :sb-posix (:use )
+ (:export #:syscall-error))
+
(defpackage :sb-posix-internal (:use #:sb-alien #:cl))
(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))
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
(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)
+
(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"
;;; 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
;;; 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))
\f
;;;; sys/resource.h
(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)
())
(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)
())
(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)
(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)
(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))))
;;; 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"
projects / sbcl.git / commitdiff