From 74fab9d286412e5f4bedcc0832101a0cd95857c8 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Sat, 19 Jun 2004 20:03:35 +0000 Subject: [PATCH] 0.8.11.17: Fix ridiculous slowness (and verbosity) of sb-posix STAT/TERMIOS ... construction is still a bit baroque. --- NEWS | 3 + contrib/sb-posix/interface.lisp | 143 +++++++++++++++++++++------------------ version.lisp-expr | 2 +- 3 files changed, 83 insertions(+), 65 deletions(-) diff --git a/NEWS b/NEWS index ceda5b4..534ea29 100644 --- a/NEWS +++ b/NEWS @@ -2543,6 +2543,9 @@ changes in sbcl-0.8.12 relative to sbcl-0.8.11: * fixed another bug in backquote printing: no more destructive modification of the form's list structure. (reported by Brian Downing) + * the SB-POSIX contrib implementation has been adjusted so that it + no longer exhibits ridiculously poor performance when constructing + instances corresponding to C structs. planned incompatible changes in 0.8.x: * (not done yet, but planned:) When the profiling interface settles diff --git a/contrib/sb-posix/interface.lisp b/contrib/sb-posix/interface.lisp index 4152a20..1e78322 100644 --- a/contrib/sb-posix/interface.lisp +++ b/contrib/sb-posix/interface.lisp @@ -1,25 +1,58 @@ (cl:in-package :sb-posix-internal) -(defun make-alien-slot-name (alien-type slot-name) - (intern (format nil "~A-~A" alien-type slot-name) - (symbol-package slot-name))) - -(declaim (inline alien-to-protocol-class)) -(defun alien-to-protocol-class (alien alien-type instance protocol-class slots) - "Copy SLOTS from the alien object ALIEN of type ALIEN-TYPE to INSTANCE, an instance of PROTOCOL-CLASS. -We assume that SLOT names are the same in the alien object and in -the protocol-class." - (unless instance - (setf instance (make-instance protocol-class))) - (loop for slot in slots - do (setf (slot-value instance slot) - (sb-alien:slot alien slot))) - instance) - -(defun protocol-class-to-alien (instance protocol-class alien alien-type slots) - (loop for slot in slots - do (setf (sb-alien:slot alien slot) (slot-value instance slot))) - instance) +(defmacro define-protocol-class + (name alien-type superclasses slots &rest options) + (let ((to-protocol (intern (format nil "ALIEN-TO-~A" name))) + (to-alien (intern (format nil "~A-TO-ALIEN" name)))) + `(progn + (defclass ,name ,superclasses + ,(loop for slotd in slots + collect (ldiff slotd (member :array-length slotd))) + ,@options) + (declaim (inline ,to-alien ,to-protocol)) + (defun ,to-protocol (alien &optional instance) + (declare (type (sb-alien:alien (* ,alien-type)) alien) + (type (or null ,name) instance)) + (unless instance + (setf instance (make-instance ',name))) + ,@(loop for slotd in slots + ;; FIXME: slotds in source are more complicated in general + ;; + ;; FIXME: baroque construction of intricate fragility + for array-length = (getf (cdr slotd) :array-length) + if array-length + collect `(progn + (let ((array (make-array ,array-length))) + (setf (slot-value instance ',(car slotd)) + array) + (dotimes (i ,array-length) + (setf (aref array i) + (sb-alien:deref + (sb-alien:slot alien ',(car slotd)) + i))))) + else + collect `(setf (slot-value instance ',(car slotd)) + (sb-alien:slot alien ',(car slotd)))) + instance) + (defun ,to-alien (instance &optional alien) + (declare (type (or null (sb-alien:alien (* ,alien-type))) alien) + (type ,name instance)) + (unless alien + (setf alien (sb-alien:make-alien ,alien-type))) + ,@(loop for slotd in slots + for array-length = (getf (cdr slotd) :array-length) + if array-length + collect `(progn + (let ((array (slot-value instance ',(car slotd)))) + (dotimes (i ,array-length) + (setf (sb-alien:deref + (sb-alien:slot alien ',(car slotd)) + i) + (aref array i))))) + else + collect `(setf (sb-alien:slot alien ',(car slotd)) + (slot-value instance ',(car slotd))))) + (find-class ',name)))) (define-condition sb-posix:syscall-error (error) ((errno :initarg :errno :reader sb-posix:syscall-errno)) @@ -162,17 +195,17 @@ the protocol-class." (define-call "getpagesize" int minusp) -(defclass sb-posix::stat () - ((sb-posix::mode :initarg :mode :accessor sb-posix:stat-mode) - (sb-posix::ino :initarg :ino :accessor sb-posix:stat-ino) - (sb-posix::dev :initarg :dev :accessor sb-posix:stat-dev) - (sb-posix::nlink :initarg :nlink :accessor sb-posix:stat-nlink) - (sb-posix::uid :initarg :uid :accessor sb-posix:stat-uid) - (sb-posix::gid :initarg :gid :accessor sb-posix:stat-gid) - (sb-posix::size :initarg :size :accessor sb-posix:stat-size) - (sb-posix::atime :initarg :atime :accessor sb-posix:stat-atime) - (sb-posix::mtime :initarg :mtime :accessor sb-posix:stat-mtime) - (sb-posix::ctime :initarg :ctime :accessor sb-posix:stat-ctime))) +(define-protocol-class sb-posix::stat sb-posix::alien-stat () + ((sb-posix::mode :initarg :mode :accessor sb-posix:stat-mode) + (sb-posix::ino :initarg :ino :accessor sb-posix:stat-ino) + (sb-posix::dev :initarg :dev :accessor sb-posix:stat-dev) + (sb-posix::nlink :initarg :nlink :accessor sb-posix:stat-nlink) + (sb-posix::uid :initarg :uid :accessor sb-posix:stat-uid) + (sb-posix::gid :initarg :gid :accessor sb-posix:stat-gid) + (sb-posix::size :initarg :size :accessor sb-posix:stat-size) + (sb-posix::atime :initarg :atime :accessor sb-posix:stat-atime) + (sb-posix::mtime :initarg :mtime :accessor sb-posix:stat-mtime) + (sb-posix::ctime :initarg :ctime :accessor sb-posix:stat-ctime))) (defmacro define-stat-call (name arg designator-fun type) ;; FIXME: this isn't the documented way of doing this, surely? @@ -189,12 +222,7 @@ the protocol-class." a-stat))) (when (minusp r) (syscall-error)) - (alien-to-protocol-class a-stat 'sb-posix::alien-stat - stat 'sb-posix::stat - '(sb-posix::mode sb-posix::ino sb-posix::dev - sb-posix::nlink sb-posix::uid sb-posix::gid - sb-posix::size sb-posix::atime - sb-posix::mtime sb-posix::ctime)))))))) + (alien-to-stat a-stat stat))))))) (define-stat-call "stat" pathname sb-posix::filename (function int c-string (* sb-posix::alien-stat))) @@ -227,29 +255,24 @@ the protocol-class." (syscall-error))) (values (aref filedes2 0) (aref filedes2 1))) -(defclass sb-posix::termios () - ((sb-posix::iflag :initarg :iflag :accessor sb-posix:termios-iflag) - (sb-posix::oflag :initarg :oflag :accessor sb-posix:termios-oflag) - (sb-posix::cflag :initarg :cflag :accessor sb-posix:termios-cflag) - (sb-posix::lflag :initarg :lflag :accessor sb-posix:termios-lflag) - (sb-posix::cc :initarg :cc :accessor sb-posix:termios-cc))) +(define-protocol-class sb-posix::termios sb-posix::alien-termios () + ((sb-posix::iflag :initarg :iflag :accessor sb-posix:termios-iflag) + (sb-posix::oflag :initarg :oflag :accessor sb-posix:termios-oflag) + (sb-posix::cflag :initarg :cflag :accessor sb-posix:termios-cflag) + (sb-posix::lflag :initarg :lflag :accessor sb-posix:termios-lflag) + (sb-posix::cc :initarg :cc :accessor sb-posix:termios-cc :array-length sb-posix::nccs))) (export 'sb-posix::tcsetattr :sb-posix) (declaim (inline sb-posix::tcsetattr)) (defun sb-posix::tcsetattr (fd actions termios) (sb-posix::with-alien-termios a-termios () - (protocol-class-to-alien termios 'sb-posix::termios - a-termios 'sb-posix::alien-termios - '(sb-posix::iflag sb-posix::oflag - sb-posix::cflag sb-posix::lflag)) - (loop with ccs = (sb-posix::alien-termios-cc a-termios) - for i from 0 below sb-posix::nccs - do (setf (sb-alien:deref ccs i) - (aref (sb-posix::termios-cc termios) i))) + (termios-to-alien termios a-termios) (let ((fd (sb-posix::file-descriptor fd))) (let* ((r (alien-funcall - (extern-alien "tcsetattr" (function int int int sb-posix::alien-termios)) - fd actions termios))) + (extern-alien + "tcsetattr" + (function int int int (* sb-posix::alien-termios))) + fd actions a-termios))) (when (minusp r) (syscall-error))) (values)))) @@ -258,19 +281,11 @@ the protocol-class." (defun sb-posix::tcgetattr (fd &optional termios) (sb-posix::with-alien-termios a-termios () (let ((r (alien-funcall - (extern-alien "tcgetattr" (function int int sb-posix::alien-termios)) + (extern-alien "tcgetattr" + (function int int (* sb-posix::alien-termios))) (sb-posix::file-descriptor fd) a-termios))) (when (minusp r) (syscall-error)) - (setf termios - (alien-to-protocol-class a-termios 'alien-termios - termios 'termios - '(sb-posix::iflag sb-posix::oflag - sb-posix::cflag sb-posix::lflag))) - (setf (sb-posix::termios-cc termios) (make-array sb-posix::nccs)) - (loop with ccs = (sb-posix::alien-termios-cc a-termios) - for i from 0 below sb-posix::nccs - do (setf (aref (sb-posix::termios-cc termios) i) - (sb-alien:deref ccs i))))) + (setf termios (alien-to-termios a-termios termios)))) termios) diff --git a/version.lisp-expr b/version.lisp-expr index 33dffdd..020294c 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.11.16" +"0.8.11.17" -- 1.7.10.4