head 1.1; access ; symbols ; locks ; strict; comment @@; 1.1 date 90.02.22.16.56.03; author ram; state Exp; branches ; next ; desc @ Working code version as of 2/22/90. @ 1.1 log @Initial revision @ text @;;; -*- Log: code.log; Package: MMlispDefs -*- ;;; ;;;********************************************************************** ;;; This code was written as part of the Spice Lisp project at ;;; Carnegie-Mellon University, and has been placed in the public domain. ;;; Spice Lisp is currently incomplete and under active development. ;;; If you want to use this code or any part of Spice Lisp, please contact ;;; Scott Fahlman (FAHLMAN@@CMUC). ;;;********************************************************************** ;;; ;;; This file contains stuff which needs to be in the compiler environment ;;; when compiling Matchmaker generated Lisp interfaces. ;;; (in-package "MMLISPDEFS" :use '("LISP" "SYSTEM")) (export '(define-field-operator setup-interface do-send do-receive check-msg define-server define-alternate-reply-handler typetype-word0 typetype-word1 typetype-int typetype-long-numobjects typetype-long-typesizeinbits typetype-long-typename server-function bad-request call)) ;;; Suffix-Symbol, Prefix-Symbol -- Internal ;;; ;;; Add a string suffix or prefix to a symbol, returning a new symbol in the ;;; same package. ;;; (defun suffix-symbol (symbol string) (intern (concatenate 'string (symbol-name symbol) string) (symbol-package symbol))) ;;; (defun prefix-symbol (string symbol) (intern (concatenate 'string string (symbol-name symbol)) (symbol-package symbol))) ;;; ;;; This variable is used at run-time to stash the port to reply ;;; to in the case of an alternate reply. ;;; (defvar *reply-port*) ;;;; Macros in the compiler environment. ;;; ;;; To reduce the hair in this Matchmaker, and to make it less sensitive to ;;; the systems issues involved in the sending and receiving, we dump ;;; lots of stuff as calls to macros defined in the compiler environment. ;;; (defvar *in-do-receive* nil) ; True if in expansion of do-receive. (defvar *receive-local-port*) ; Local port in Do-Receive. (defvar *in-define-server* nil) ; True if in expansion of Define-Server. (defvar *send-remote-port*) ; Reply port in Define-Server. (defvar *alien-stack*) ; Stack of reply argblocks for this interface. (defvar *message-size*) ; The byte size of reply messages. (defvar *alternate-reply-handler*) ; Function that deals with alternate replies. ;;; Setup-Interface -- Internal ;;; ;;; Does whatever stuff is necessary to set up an interface. This ;;; could include making an init function, allocating data structures, ;;; and setting up things in the compiler environment. This is only ;;; for user interfaces. ;;; (defmacro setup-interface (name &key message-size alternate-reply) (let ((sname (suffix-symbol name "-REPLY-STACK"))) `(progn (eval-when (compile eval) (setq *alternate-reply-handler* ',(if alternate-reply (suffix-symbol name "-ALTERNATE-REPLY-HANDLER"))) (setq *message-size* ,message-size) (setq *alien-stack* ',sname)) (define-alien-stack ,sname ,(suffix-symbol name "-GENERIC-MSG") (bytes ,message-size))))) ;;; Do-Send -- Internal ;;; ;;; Takes the name of a message to send, binds it to Var, evaluates the ;;; forms, and then does the send. LocalPort defaults to the allocated reply ;;; port if in a do-receive, NullPort otherwise. Error-Return is the name of a ;;; block to return the GR out of if the send doesn't succeed. If it isn't ;;; supplied, an error is signalled. If MsgType is not supplied, the field is ;;; not set. If Alternate-Reply is supplied and true, then we don't return, ;;; but throw out of the original server function instead. In this case, ;;; the Remote-Port argument is ignored, and the message is always ;;; sent to the reply port for the message replied to. ;;; (defmacro do-send ((var name &key local-port remote-port msgtype (option 'mach:send-timeout) (timeout 0) error-return alternate-reply) &body body) (let ((msg (gensym))) `(without-interrupts (alien-bind ((,var ,name) (,msg (,(suffix-symbol name "-MSG") (alien-value ,var)))) (setf (alien-access (mach:msg-localport (alien-value ,msg))) ,(cond (local-port) (*in-do-receive* *receive-local-port*) (t 'mach:nullport))) (setf (alien-access (mach:msg-remoteport (alien-value ,msg))) ,(cond (alternate-reply '*reply-port*) (remote-port) (*in-define-server* *send-remote-port*) (t (error "No Remote-Port for msg-send.")))) ,@@(when msgtype `((setf (alien-access (mach:msg-msgtype (alien-value ,msg))) ,msgtype))) ,@@body (let ((gr (mach:msg-send (alien-value ,var) ,option ,timeout))) (unless (eql gr mach:kern-success) ,(if error-return `(return-from ,error-return gr) '(gr-error 'mach:msg-send gr)))) ,@@(when alternate-reply `((throw 'alternate-reply-sent mach:kern-success))))))) ;;; Do-Receive -- Internal ;;; ;;; Does stuff that we need to do to do a receive. Binds Var to ;;; a receive argblock, evaluates the forms in Before, does the ;;; receive, and then evaluates the body returning the values. ;;; Size and ID specify a check on the returned message. If the ID ;;; is incorrect, then we call interface Alternate-Reply function. ;;; If it returns, we have a bad message ID. If the size is wrong, we ;;; take the error action on BadReply. ;;; (defmacro do-receive ((var name &rest keys &key local-port (timeout 0 todef) error-return size id simple) before &body after) (declare (ignore id size simple)) (let* ((generic (gensym)) (msg (gensym)) (rport (or local-port (gensym))) (stuff `((setf (alien-access (mach:msg-localport (alien-value ,msg))) ,rport) (setf (alien-access (mach:msg-msgsize (alien-value ,msg))) ,*message-size*) ,before (mach:msg-receive (alien-value ,generic) ,(if todef 'mach:rcv-timeout 0) ,timeout)))) `(with-stack-alien (,generic ,*alien-stack*) (alien-bind ((,var (,(suffix-symbol name "-GENERIC") (alien-value ,generic))) (,msg (,(suffix-symbol name "-MSG") (alien-value ,var)))) (let ((gr (compiler-let ((*in-do-receive* t) (*receive-local-port* ',rport)) ,(if local-port `(progn ,@@stuff) `(with-reply-port (,rport) ,@@stuff))))) (unless (eql gr mach:kern-success) ,(if error-return `(return-from ,error-return gr) '(gr-error 'mach:msg-receive gr)))) (check-msg (alien-value ,msg) :allow-other-keys t ,@@keys ,@@(when *alternate-reply-handler* `(:alternate-id-form (,*alternate-reply-handler* (alien-value ,generic))))) ,@@after)))) ;;; Check-Msg -- Internal ;;; ;;; This macro is used to check the values of the Msg header fields. ;;; Error-Return is the block to return a GR from in the case of an error. ;;; Simple, Size, Type and ID specify a check for the values of the ;;; SimpleMsg, MsgSize, MsgType and ID fields of the Msg record. ;;; If any is not supplied, then the corresponding check is not done. ;;; ;;; Alternate-ID-Form is evaulated if the ID is different from the ;;; specified ID. If the form returns, the normal error action is taken. ;;; (defmacro check-msg (msg &key error-return (simple nil simplep) size type id alternate-id-form) (let ((field (gensym))) `(progn ,@@(when id `((let ((,field (alien-access (mach:msg-id ,msg)))) (unless (eql ,field ,id) ,alternate-id-form ,(if error-return `(return-from ,error-return mach:badmsgid) `(error "Bad message ID: ~S" ,field)))))) ,@@(when simplep `((let ((,field (alien-access (mach:msg-simplemsg ,msg)))) (unless (eq ,field ,simple) ,(if error-return `(return-from ,error-return mach:badreply) `(error "Message is~:[~;n't~] simple." ,field)))))) ,@@(when size `((let ((,field (alien-access (mach:msg-msgsize ,msg)))) (unless (eql ,field ,size) ,(if error-return `(return-from ,error-return mach:badreply) `(error "Bad message size ~S, should have been ~S." ,field ,size)))))) ,@@(when type `((let ((,field (alien-access (mach:msg-msgtype ,msg)))) (unless (eql ,field ,size) ,(if error-return `(return-from ,error-return mach:badmsgtype) `(error "Bad message type ~S, should have been ~S." ,field ,type))))))))) ;;; Define-Server -- Internal ;;; ;;; Defines a function Name which takes an object-set and a function ;;; as arguments. When called, the function will establish ID as an ;;; operation in the object set, with the argument function being called ;;; as a handler with appropriately unpacked arguments. Var is the name ;;; of the Alien variable to bind the incoming message to. Simple, Size ;;; and Type specify required values for the Msg header fields. ;;; If supplied and true, Alternate-Reply indicates that an alternate ;;; reply message may result from this call. ;;; ;;; Msg-Name is the type of the message. Operators ;;; SERVER-MESSAGE- and -MSG should be provided. ;;; ;;; The local macro Call is defined within the body. Its syntax ;;; looks like: ;;; Call (Result-Var*) (Argument-Access*) Form* ;;; The Result-Vars are bound to the return values of the call. The ;;; Argument-Access expressions are evaluated, and used as the arguments ;;; to the call. The Forms are evaluated with the Result-Vars bound after ;;; the call returns. One of the Forms should send any normal reply message. ;;; If supplied, :Reply-Port is a variable to bind to the reply port. ;;; ;;; There are two blocks established around the body Server-Function ;;; and Bad-Request. A GR may be returned from either one to indicate ;;; failure. The idea is that lossage caused by broken request messages ;;; should be returned to Bad-Request, and lossage that is the server's ;;; fault should be returned to Server-Function. ;;; ;;; Do-Send has whizzy features for use with this macro. One is that ;;; if Do-Send is called in the expansion, the Remote-Port defaults to ;;; the reply port. The other is that a Do-Send :Alternate-Reply T ;;; anywhere in the dynamic context of the server will send to the ;;; reply port and throw out of the server. ;;; (defmacro define-server (name (var msg-name &key (simple nil simplep) size type alternate-reply reply-port (id (error "No ID for Define-Server."))) &body body) (let* ((msg `(,(suffix-symbol msg-name "-MSG") (alien-value ,var))) (stuff `(block server-function (block bad-request (check-msg ,msg :size ,size :type ,type :error-return bad-request ,@@(when simplep `(:simple ,simple))) (compiler-let ((*in-define-server* t)) ,@@body) (return-from server-function mach:kern-success)) (return-from server-function mach:kern-failure))) (rport `(alien-access (mach:msg-remoteport ,msg)))) `(defun ,name (object-set function) (macrolet ((call (vars args &rest forms) `(multiple-value-bind ,vars (funcall function object ,@@args) ,@@forms))) (setf (object-set-operation object-set ,id) #'(lambda (object) (alien-bind ((,var (,(prefix-symbol "SERVER-MESSAGE-" msg-name) server-message))) ,(cond (reply-port `(compiler-let ((*send-remote-port* ',reply-port)) (let ((,reply-port ,rport)) ,stuff))) (alternate-reply `(compiler-let ((*send-remote-port* '*reply-port*)) (let ((*reply-port* ,rport)) (catch 'alternate-reply-sent ,stuff)))) (t `(compiler-let ((*send-remote-port* ',rport)) ,stuff)))))))))) (defparameter default-reply-error-string "Alternate reply ~A~:[ received.~; ~:*~{~#[~;~S~:;~S, ~]~}~]") ;;; Define-Alternate-Reply-Handler -- Internal ;;; ;;; Surprisingly enough, this macro is used to define alternate reply ;;; handlers. The function takes a generic message and dispatches off ;;; of the ID, funcalling the handler found in a special with the unpacked ;;; arguments. We spit out defvars for these variables, giving them ;;; a default handler that signals an error. Any symbols we make, we export, ;;; since Matchmaker doesn't have the foggiest idea of the semantics of ;;; this operation. ;;; ;;; Interface is the name of the interface. Var is the name of the ;;; Alien variable to be bound to the message. Each case describes a ;;; possible alternate reply, with the following syntax: ;;; (Name Binds &Key ID Simple Size) Arg-Form* ;;; Name is the name of the alternate reply, Binds is a list of Let* ;;; bindings to make. ID is the message ID, and must be supplied. ;;; Simple and Size are assertions on the message header. The Arg-Forms ;;; are expressions to evaluate to obtain the alternate reply arguments. ;;; (defmacro define-alternate-reply-handler (interface (alien-var) &body cases) (let ((msg-op (suffix-symbol interface "-GENERIC-MSG-MSG")) (generic (suffix-symbol interface "-GENERIC-MSG")) (n-alien (gensym)) (n-generic (gensym)) (fname (suffix-symbol interface "-ALTERNATE-REPLY-HANDLER")) (forms ()) (vars ()) (defvars ())) (dolist (case cases) (let* ((args (car case)) (name (first args)) (keys (cddr args)) (op (prefix-symbol "TO-" (suffix-symbol name "-GENERIC"))) (var (prefix-symbol "*" (suffix-symbol name "-HANDLER*")))) (push var vars) (push `(defvar ,var #'(lambda (&rest args) (error default-reply-error-string ',name args))) defvars) (push `(,(or (getf keys :id) (error "No ID in alternate reply case:~% ~S" case)) (check-msg (,msg-op (alien-value ,n-generic)) :size ,(getf keys :size) ,@@(multiple-value-bind (v p) (getf keys :simple) (if p `(:simple ,v)))) (alien-bind ((,alien-var (,op (alien-value ,n-generic)))) (let* ,(second args) (funcall ,var ,@@(cdr case))))) forms))) `(progn (export ',vars) ,@@defvars (defun ,fname (,n-alien) (alien-bind ((,n-generic ,n-alien ,generic t)) (case (alien-access (mach:msg-id (,msg-op (alien-value ,n-generic)))) ,@@forms)))))) ;;; Define-Field-Operator -- Internal ;;; ;;; Defines an operator that grabs a field. This is more to reduce ;;; the size of the MsgDefs file, and thus read time. ;;; (defmacro define-field-operator (name arg-type result-type offset size) `(defoperator (,name ,result-type) ((arg ,arg-type)) `(alien-index (alien-value ,arg) ,',offset ,',size))) ;;; Additional TypeType operators, ;;; ;;; These operators allow a typetype to be treated as a 32bit or two 16bit ;;; integers. The -Long- operators are used on longform typetypes to ;;; access the fields corresponding to the short form field of the same name. ;;; (define-field-operator typetype-word0 mach:typetype (unsigned-byte 16) 0 16) (define-field-operator typetype-word1 mach:typetype (unsigned-byte 16) 16 16) (define-field-operator typetype-int mach:typetype (signed-byte 32) 0 32) (define-field-operator typetype-long-numobjects mach:typetype (signed-byte 32) 64 32) (define-field-operator typetype-long-typesizeinbits mach:typetype (unsigned-byte 16) 48 16) (define-field-operator typetype-long-typename mach:typetype (unsigned-byte 16) 32 16) @