source: branches/working-0710/ccl/cocoa-ide/hemlock/src/wire/wire.lisp

Last change on this file was 6, checked in by Gary Byers, 21 years ago

Initial revision
  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 17.2 KB
Line 
1;;; -*- Log: code.log; Package: wire -*-
2;;;
3;;; **********************************************************************
4;;; This code was written as part of the CMU Common Lisp project at
5;;; Carnegie Mellon University, and has been placed in the public domain.
6;;;
7#+NIL
8(ext:file-comment
9 "$Header$")
10;;;
11;;; **********************************************************************
12;;;
13;;; This file contains an interface to internet domain sockets.
14;;;
15;;; Written by William Lott.
16;;;
17
18(defpackage :hemlock.wire
19 (:use :common-lisp)
20 (:nicknames :wire)
21 (:export
22 ;; wire.lisp
23 #:remote-object-p
24 #:remote-object
25 #:remote-object-local-p
26 #:remote-object-eq
27 #:remote-object-value
28 #:make-remote-object
29 #:forget-remote-translation
30 #:make-wire
31 #:wire-p
32 #:wire-fd
33 #:wire-listen
34 #:wire-get-byte
35 #:wire-get-number
36 #:wire-get-string
37 #:wire-get-object
38 #:wire-force-output
39 #:wire-output-byte
40 #:wire-output-number
41 #:wire-output-string
42 #:wire-output-object
43 #:wire-output-funcall
44 #:wire-error
45 #:wire-eof
46 #:wire-io-error
47 #:*current-wire*
48 #:wire-get-bignum
49 #:wire-output-bignum
50 ;; remote.lisp
51 #:remote
52 #:remote-value
53 #:remote-value-bind
54 #:create-request-server
55 #:destroy-request-server
56 #:connect-to-remote-server))
57
58(in-package :hemlock.wire)
59
60;;; Stuff that needs to be ported:
61
62(eval-when (compile load eval) ;For macros in remote.lisp.
63
64(defconstant buffer-size 2048)
65
66(defconstant initial-cache-size 16)
67
68(defconstant funcall0-op 0)
69(defconstant funcall1-op 1)
70(defconstant funcall2-op 2)
71(defconstant funcall3-op 3)
72(defconstant funcall4-op 4)
73(defconstant funcall5-op 5)
74(defconstant funcall-op 6)
75(defconstant number-op 7)
76(defconstant string-op 8)
77(defconstant symbol-op 9)
78(defconstant save-op 10)
79(defconstant lookup-op 11)
80(defconstant remote-op 12)
81(defconstant cons-op 13)
82(defconstant bignum-op 14)
83
84) ;eval-when
85
86
87(defvar *current-wire* nil
88 "The wire the form we are currently evaluating came across.")
89
90(defvar *this-host* nil
91 "Unique identifier for this host.")
92(defvar *this-pid* nil
93 "Unique identifier for this process.")
94
95(defvar *object-to-id* (make-hash-table :test 'eq)
96 "Hash table mapping local objects to the corresponding remote id.")
97(defvar *id-to-object* (make-hash-table :test 'eql)
98 "Hash table mapping remote id's to the curresponding local object.")
99(defvar *next-id* 0
100 "Next available id for remote objects.")
101
102
103(defstruct (wire
104 (:constructor make-wire (stream))
105 (:print-function
106 (lambda (wire stream depth)
107 (declare (ignore depth))
108 (format stream
109 "#<wire ~s>"
110 (wire-stream wire)))))
111 stream
112 (object-cache (make-array initial-cache-size))
113 (cache-index 0)
114 (object-hash (make-hash-table :test 'eq)))
115
116(defstruct (remote-object
117 (:constructor %make-remote-object (host pid id))
118 (:print-function
119 (lambda (obj stream depth)
120 (declare (ignore depth))
121 (format stream "#<Remote Object: [~x:~a] ~s>"
122 (remote-object-host obj)
123 (remote-object-pid obj)
124 (remote-object-id obj)))))
125 host
126 pid
127 id)
128
129(define-condition wire-error (error)
130 ((wire :reader wire-error-wire :initarg :wire))
131 (:report (lambda (condition stream)
132 (format stream "There is a problem with ~A."
133 (wire-error-wire condition)))))
134
135(define-condition wire-eof (wire-error)
136 ()
137 (:report (lambda (condition stream)
138 (format stream "Recieved EOF on ~A."
139 (wire-error-wire condition)))))
140
141(define-condition wire-io-error (wire-error)
142 ((when :reader wire-io-error-when :initarg :when :initform "using")
143 (msg :reader wire-io-error-msg :initarg :msg :initform "Failed."))
144 (:report (lambda (condition stream)
145 (format stream "Error ~A ~A: ~A."
146 (wire-io-error-when condition)
147 (wire-error-wire condition)
148 (wire-io-error-msg condition)))))
149
150
151
152;;; Remote Object Randomness
153
154;;; REMOTE-OBJECT-LOCAL-P -- public
155;;;
156;;; First, make sure the *this-host* and *this-pid* are set. Then test to
157;;; see if the remote object's host and pid fields are *this-host* and
158;;; *this-pid*
159
160(defun remote-object-local-p (remote)
161 "Returns T iff the given remote object is defined locally."
162 (declare (type remote-object remote))
163 (unless *this-host*
164 (setf *this-host* (unix-gethostid))
165 (setf *this-pid* (unix-getpid)))
166 (and (eql (remote-object-host remote) *this-host*)
167 (eql (remote-object-pid remote) *this-pid*)))
168
169;;; REMOTE-OBJECT-EQ -- public
170;;;
171;;; Remote objects are considered EQ if they refer to the same object, ie
172;;; Their host, pid, and id fields are the same (eql, cause they are all
173;;; numbers).
174
175(defun remote-object-eq (remote1 remote2)
176 "Returns T iff the two objects refer to the same (eq) object in the same
177 process."
178 (declare (type remote-object remote1 remote2))
179 (and (eql (remote-object-host remote1)
180 (remote-object-host remote2))
181 (eql (remote-object-pid remote1)
182 (remote-object-pid remote2))
183 (eql (remote-object-id remote1)
184 (remote-object-id remote2))))
185
186;;; REMOTE-OBJECT-VALUE --- public
187;;;
188;;; First assure that the remote object is defined locally. If so, look up
189;;; the id in *id-to-objects*.
190;;; table. This will only happen if FORGET-REMOTE-TRANSLATION has been called
191;;; on the local object.
192
193(defun remote-object-value (remote)
194 "Return the associated value for the given remote object. It is an error if
195 the remote object was not created in this process or if
196 FORGET-REMOTE-TRANSLATION has been called on this remote object."
197 (declare (type remote-object remote))
198 (unless (remote-object-local-p remote)
199 (error "~S is defined is a different process." remote))
200 (multiple-value-bind
201 (value found)
202 (gethash (remote-object-id remote)
203 *id-to-object*)
204 (unless found
205 (cerror
206 "Use the value of NIL"
207 "No value for ~S -- FORGET-REMOTE-TRANSLATION was called to early."
208 remote))
209 value))
210
211;;; MAKE-REMOTE-OBJECT --- public
212;;;
213;;; Convert the given local object to a remote object. If the local object is
214;;; alread entered in the *object-to-id* hash table, just use the old id.
215;;; Otherwise, grab the next id and put add both mappings to the two hash
216;;; tables.
217
218(defun make-remote-object (local)
219 "Convert the given local object to a remote object."
220 (unless *this-host*
221 (setf *this-host* (unix-gethostid))
222 (setf *this-pid* (unix-getpid)))
223 (let ((id (gethash local *object-to-id*)))
224 (unless id
225 (setf id *next-id*)
226 (setf (gethash local *object-to-id*) id)
227 (setf (gethash id *id-to-object*) local)
228 (incf *next-id*))
229 (%make-remote-object *this-host* *this-pid* id)))
230
231;;; FORGET-REMOTE-TRANSLATION -- public
232;;;
233;;; Remove any translation information about the given object. If there is
234;;; currenlt no translation for the object, don't bother doing anything.
235;;; Otherwise remove it from the *object-to-id* hashtable, and remove the id
236;;; from the *id-to-object* hashtable.
237
238(defun forget-remote-translation (local)
239 "Forget the translation from the given local to the corresponding remote
240object. Passing that remote object to remote-object-value will new return NIL."
241 (let ((id (gethash local *object-to-id*)))
242 (when id
243 (remhash local *object-to-id*)
244 (remhash id *id-to-object*)))
245 (values))
246
247
248
249;;; Wire input routeins.
250
251;;; WIRE-LISTEN -- public
252;;;
253;;; If nothing is in the current input buffer, select on the file descriptor.
254
255(defun wire-listen (wire)
256 "Return T iff anything is in the input buffer or available on the socket."
257 (or
258 (listen (wire-stream wire))))
259
260;;; WIRE-GET-BYTE -- public
261;;;
262;;; Return the next byte.
263
264(defun wire-get-byte (wire)
265 "Return the next byte from the wire."
266 (let ((c (read-char (wire-stream wire) nil :eof)))
267 (cond ((eql c :eof)
268 (error 'wire-eof :wire wire))
269 (t
270 (char-int c)))))
271
272;;; WIRE-GET-NUMBER -- public
273;;;
274;;; Just read four bytes and pack them together with normal math ops.
275
276(defun wire-get-number (wire &optional (signed t))
277 "Read a number off the wire. Numbers are 4 bytes in network order.
278The optional argument controls weather or not the number should be considered
279signed (defaults to T)."
280 (let* ((b1 (wire-get-byte wire))
281 (b2 (wire-get-byte wire))
282 (b3 (wire-get-byte wire))
283 (b4 (wire-get-byte wire))
284 (unsigned
285 (+ b4 (* 256 (+ b3 (* 256 (+ b2 (* 256 b1))))))))
286 (if (and signed (> b1 127))
287 (logior (ash -1 32) unsigned)
288 unsigned)))
289
290;;; WIRE-GET-BIGNUM -- public
291;;;
292;;; Extracts a number, which might be a bignum.
293;;;
294(defun wire-get-bignum (wire)
295 "Reads an arbitrary integer sent by WIRE-OUTPUT-BIGNUM from the wire and
296 return it."
297 (let ((count-and-sign (wire-get-number wire)))
298 (do ((count (abs count-and-sign) (1- count))
299 (result 0 (+ (ash result 32) (wire-get-number wire nil))))
300 ((not (plusp count))
301 (if (minusp count-and-sign)
302 (- result)
303 result)))))
304
305;;; WIRE-GET-STRING -- public
306;;;
307;;; Use WIRE-GET-NUMBER to read the length, and then read the string
308;;; contents.
309
310(defun wire-get-string (wire)
311 "Reads a string from the wire. The first four bytes spec the size."
312 (let* ((length (wire-get-number wire))
313 (result (make-string length)))
314 (declare (simple-string result)
315 (integer length))
316 (read-sequence result (wire-stream wire))
317 result))
318
319;;; WIRE-GET-OBJECT -- public
320;;;
321;;; First, read a byte to determine the type of the object to read. Then,
322;;; depending on the type, call WIRE-GET-NUMBER, WIRE-GET-STRING, or whatever
323;;; to read the necessary data. Note, funcall objects are funcalled.
324
325(defun wire-get-object (wire)
326 "Reads the next object from the wire and returns it."
327 (let ((identifier (wire-get-byte wire))
328 (*current-wire* wire))
329 (declare (fixnum identifier))
330 (cond ((eql identifier lookup-op)
331 (let ((index (wire-get-number wire))
332 (cache (wire-object-cache wire)))
333 (declare (integer index))
334 (declare (simple-vector cache))
335 (when (< index (length cache))
336 (svref cache index))))
337 ((eql identifier number-op)
338 (wire-get-number wire))
339 ((eql identifier bignum-op)
340 (wire-get-bignum wire))
341 ((eql identifier string-op)
342 (wire-get-string wire))
343 ((eql identifier symbol-op)
344 (let* ((symbol-name (wire-get-string wire))
345 (package-name (wire-get-string wire))
346 (package (find-package package-name)))
347 (unless package
348 (error "Attempt to read symbol, ~A, of wire into non-existent ~
349 package, ~A."
350 symbol-name package-name))
351 (intern symbol-name package)))
352 ((eql identifier cons-op)
353 (cons (wire-get-object wire)
354 (wire-get-object wire)))
355 ((eql identifier remote-op)
356 (let ((host (wire-get-number wire nil))
357 (pid (wire-get-number wire))
358 (id (wire-get-number wire)))
359 (%make-remote-object host pid id)))
360 ((eql identifier save-op)
361 (let ((index (wire-get-number wire))
362 (cache (wire-object-cache wire)))
363 (declare (integer index))
364 (declare (simple-vector cache))
365 (when (>= index (length cache))
366 (do ((newsize (* (length cache) 2)
367 (* newsize 2)))
368 ((< index newsize)
369 (let ((newcache (make-array newsize)))
370 (declare (simple-vector newcache))
371 (replace newcache cache)
372 (setf cache newcache)
373 (setf (wire-object-cache wire) cache)))))
374 (setf (svref cache index)
375 (wire-get-object wire))))
376 ((eql identifier funcall0-op)
377 (funcall (wire-get-object wire)))
378 ((eql identifier funcall1-op)
379 (funcall (wire-get-object wire)
380 (wire-get-object wire)))
381 ((eql identifier funcall2-op)
382 (funcall (wire-get-object wire)
383 (wire-get-object wire)
384 (wire-get-object wire)))
385 ((eql identifier funcall3-op)
386 (funcall (wire-get-object wire)
387 (wire-get-object wire)
388 (wire-get-object wire)
389 (wire-get-object wire)))
390 ((eql identifier funcall4-op)
391 (funcall (wire-get-object wire)
392 (wire-get-object wire)
393 (wire-get-object wire)
394 (wire-get-object wire)
395 (wire-get-object wire)))
396 ((eql identifier funcall5-op)
397 (funcall (wire-get-object wire)
398 (wire-get-object wire)
399 (wire-get-object wire)
400 (wire-get-object wire)
401 (wire-get-object wire)
402 (wire-get-object wire)))
403 ((eql identifier funcall-op)
404 (let ((arg-count (wire-get-byte wire))
405 (function (wire-get-object wire))
406 (args '())
407 (last-cons nil)
408 (this-cons nil))
409 (loop
410 (when (zerop arg-count)
411 (return nil))
412 (setf this-cons (cons (wire-get-object wire)
413 nil))
414 (if (null last-cons)
415 (setf args this-cons)
416 (setf (cdr last-cons) this-cons))
417 (setf last-cons this-cons)
418 (decf arg-count))
419 (apply function args))))))
420
421
422
423;;; Wire output routines.
424
425;;; WIRE-FORCE-OUTPUT -- internal
426;;;
427;;; Output any stuff remaining in the output buffer.
428
429(defun wire-force-output (wire)
430 "Send any info still in the output buffer down the wire and clear it. Nothing
431harmfull will happen if called when the output buffer is empty."
432 (force-output (wire-stream wire))
433 (values))
434
435;;; WIRE-OUTPUT-BYTE -- public
436;;;
437;;; Stick the byte in the output buffer. If there is no space, flush the
438;;; buffer using WIRE-FORCE-OUTPUT.
439
440(defun wire-output-byte (wire byte)
441 "Output the given (8-bit) byte on the wire."
442 (declare (integer byte))
443 (write-char (code-char byte) (wire-stream wire))
444 (values))
445
446;;; WIRE-OUTPUT-NUMBER -- public
447;;;
448;;; Output the number. Note, we don't care if the number is signed or not,
449;;; because we just crank out the low 32 bits.
450;;;
451(defun wire-output-number (wire number)
452 "Output the given (32-bit) number on the wire."
453 (declare (integer number))
454 (wire-output-byte wire (+ 0 (ldb (byte 8 24) number)))
455 (wire-output-byte wire (ldb (byte 8 16) number))
456 (wire-output-byte wire (ldb (byte 8 8) number))
457 (wire-output-byte wire (ldb (byte 8 0) number))
458 (values))
459
460;;; WIRE-OUTPUT-BIGNUM -- public
461;;;
462;;; Output an arbitrary integer.
463;;;
464(defun wire-output-bignum (wire number)
465 "Outputs an arbitrary integer, but less effeciently than WIRE-OUTPUT-NUMBER."
466 (do ((digits 0 (1+ digits))
467 (remaining (abs number) (ash remaining -32))
468 (words nil (cons (ldb (byte 32 0) remaining) words)))
469 ((zerop remaining)
470 (wire-output-number wire
471 (if (minusp number)
472 (- digits)
473 digits))
474 (dolist (word words)
475 (wire-output-number wire word)))))
476
477;;; WIRE-OUTPUT-STRING -- public
478;;;
479;;; Output the string. Strings are represented by the length as a number,
480;;; followed by the bytes of the string.
481;;;
482(defun wire-output-string (wire string)
483 "Output the given string. First output the length using WIRE-OUTPUT-NUMBER,
484then output the bytes."
485 (declare (simple-string string))
486 (let ((length (length string)))
487 (declare (integer length))
488 (wire-output-number wire length)
489 (write-sequence string (wire-stream wire)))
490 (values))
491
492;;; WIRE-OUTPUT-OBJECT -- public
493;;;
494;;; Output the given object. If the optional argument is non-nil, cache
495;;; the object to enhance the performance of sending it multiple times.
496;;; Caching defaults to yes for symbols, and nil for everything else.
497
498(defun wire-output-object (wire object &optional (cache-it (symbolp object)))
499 "Output the given object on the given wire. If cache-it is T, enter this
500object in the cache for future reference."
501 (let ((cache-index (gethash object
502 (wire-object-hash wire))))
503 (cond
504 (cache-index
505 (wire-output-byte wire lookup-op)
506 (wire-output-number wire cache-index))
507 (t
508 (when cache-it
509 (wire-output-byte wire save-op)
510 (let ((index (wire-cache-index wire)))
511 (wire-output-number wire index)
512 (setf (gethash object (wire-object-hash wire))
513 index)
514 (setf (wire-cache-index wire) (1+ index))))
515 (typecase object
516 (integer
517 (cond ((typep object '(signed-byte 32))
518 (wire-output-byte wire number-op)
519 (wire-output-number wire object))
520 (t
521 (wire-output-byte wire bignum-op)
522 (wire-output-bignum wire object))))
523 (simple-string
524 (wire-output-byte wire string-op)
525 (wire-output-string wire object))
526 (symbol
527 (wire-output-byte wire symbol-op)
528 (wire-output-string wire (symbol-name object))
529 (wire-output-string wire (package-name (symbol-package object))))
530 (cons
531 (wire-output-byte wire cons-op)
532 (wire-output-object wire (car object))
533 (wire-output-object wire (cdr object)))
534 (remote-object
535 (wire-output-byte wire remote-op)
536 (wire-output-number wire (remote-object-host object))
537 (wire-output-number wire (remote-object-pid object))
538 (wire-output-number wire (remote-object-id object)))
539 (t
540 (error "Error: Cannot output objects of type ~s across a wire."
541 (type-of object)))))))
542 (values))
543
544;;; WIRE-OUTPUT-FUNCALL -- public
545;;;
546;;; Send the funcall down the wire. Arguments are evaluated locally in the
547;;; lexical environment of the WIRE-OUTPUT-FUNCALL.
548
549(defmacro wire-output-funcall (wire-form function &rest args)
550 "Send the function and args down the wire as a funcall."
551 (let ((num-args (length args))
552 (wire (gensym)))
553 `(let ((,wire ,wire-form))
554 ,@(if (> num-args 5)
555 `((wire-output-byte ,wire funcall-op)
556 (wire-output-byte ,wire ,num-args))
557 `((wire-output-byte ,wire ,(+ funcall0-op num-args))))
558 (wire-output-object ,wire ,function)
559 ,@(mapcar #'(lambda (arg)
560 `(wire-output-object ,wire ,arg))
561 args)
562 (values))))
563
Note: See TracBrowser for help on using the repository browser.