Improve schema generation performance on large schemas
authorFrancois-Rene Rideau <tunes@google.com>
Wed, 7 Nov 2012 23:40:50 +0000 (18:40 -0500)
committerFrancois-Rene Rideau <tunes@google.com>
Wed, 7 Nov 2012 23:40:50 +0000 (18:40 -0500)
Avoid SUBTYPEP during macroexpansion, it can be very expensive on SBCL.
Actually recognize LIST-OF:LIST-OF constructs.
In DEFINE-SCHEMA, don't nest the DEFMETHODs inside the LET,
this also can cause SBCL's control flow analysis to blow up.

Work done with Steven Spitz for QPX.

Tested: (asdf:test-system :cl-protobufs)

clos-transform.lisp
define-proto.lisp
utilities.lisp

index 04001e9..18a80d6 100644 (file)
                             :packed  packed)))
             (values field nil enum)))))))
 
+(defun list-of-list-of ()
+  (let ((list-of-package (find-package 'list-of)))
+    (and list-of-package (find-symbol (string 'list-of) list-of-package))))
+
 (defun find-slot-definition-type (class slotd)
   "Given a class and a slot descriptor, find the \"best\" type definition for the slot."
   (let* ((slot-name    (slot-definition-name slotd))
     (if direct-slotd
       ;; The direct slotd will have an unexpanded definition
       ;; Prefer it for 'list-of' so we can get the base type
-      (let ((type (slot-definition-type direct-slotd))
-            (quux-list-of (and (find-package :quux)
-                               (intern "LIST-OF" (find-package :quux)))))
-        (values (if (and (listp type) (member (car type) `(list-of vector-of ,quux-list-of)))
+      (let ((type (slot-definition-type direct-slotd)))
+        (values (if (and (listp type)
+                         (or (member (car type) '(list-of vector-of))
+                             (let ((list-of-list-of (list-of-list-of)))
+                               (and list-of-list-of (eq (car type) list-of-list-of)))))
                   type
                   (slot-definition-type slotd))
                 (if (symbolp type)
                              (class-precedence-list class))))
     (and direct-slotd (first (slot-definition-readers direct-slotd)))))
 
+(defun satisfies-list-of-p (type)
+  (and (consp type)
+       (eq (car type) 'satisfies)
+       (consp (cdr type))
+       (null (cddr type))
+       (let ((function (cadr type)))
+         (and (symbolp function)
+              (string= "LIST-OF" (package-name (symbol-package function)))
+              (let ((name (symbol-name function)))
+                (and (<= #.(length "LIST-OF-_-P") (length name))
+                     (starts-with name "LIST-OF-")
+                     (ends-with name "-P")
+                     (let* ((typestring (subseq name #.(length "LIST-OF-") (- (length name) 2)))
+                            (type (ignore-errors
+                                    (with-standard-io-syntax
+                                        (let ((*package* (find-package :cl)))
+                                          (read-from-string typestring))))))
+                         (and (typep type 'symbol) type))))))))
+
 (defun clos-type-to-protobuf-type (type &optional type-filter enum-filter)
   "Given a Lisp type, returns a Protobuf type, a class or primitive type,
    whether or not to pack the field, and (optionally) a set of enum values."
   (let ((type (if type-filter (funcall type-filter type) type))
-        ;; Hideous, but useful, kludge for those of us at ITA-by-Google
-        (quux-list-of (and (find-package :quux)
-                           (intern "LIST-OF" (find-package :quux)))))
+        (list-of-list-of (list-of-list-of)))
     (flet ()
       (if (listp type)
         (destructuring-bind (head &rest tail) type
                (clos-type-to-protobuf-type (second tail))
                (clos-type-to-protobuf-type (first tail))))
             ((and)
-             (cond ((and quux-list-of
-                         (ignore-errors
-                          (subtypep type `(,quux-list-of t))))
-                    ;; Special knowledge of 'quux:list-of', which uses (and list (satisfies <t>))
-                    (let* ((satisfies (find 'satisfies tail :key #'car))
-                           (pred (second satisfies))
-                           (type (if (starts-with (string pred) "LIST-OF-")
-                                   (intern (subseq (string pred) #.(length "LIST-OF-")) (symbol-package pred))
-                                   pred)))
-                      (multiple-value-bind (type class)
-                          (lisp-type-to-protobuf-type type)
-                        (values type class (packed-type-p class)))))
-                   (t
-                    (let ((new-tail (remove-if #'(lambda (x) (and (listp x) (eq (car x) 'satisfies))) tail)))
-                      (when (> (length new-tail) 1)
-                        (protobufs-warn "The AND type ~S is too complicated, proceeding anyway" type))
-                      (lisp-type-to-protobuf-type (first tail))))))
+             ;; Special knowledge of 'list-of:list-of', which uses (and list (satisfies list-of::FOO-p))
+             (let ((satisfies-list-of
+                    (and list-of-list-of (find-if #'satisfies-list-of-p tail))))
+               (if satisfies-list-of
+                 (multiple-value-bind (type class)
+                     (lisp-type-to-protobuf-type satisfies-list-of)
+                   (values type class (packed-type-p class)))
+                 (let ((new-tail
+                        (remove-if #'(lambda (x) (and (listp x) (eq (car x) 'satisfies))) tail)))
+                   (when (> (length new-tail) 1)
+                     (protobufs-warn "The AND type ~S is too complicated, proceeding anyway" type))
+                   (lisp-type-to-protobuf-type (first tail))))))
             ((member)                           ;maybe generate an enum type
              (if (or (equal type '(member t nil))
                      (equal type '(member nil t)))
             ((float single-float double-float)
              (lisp-type-to-protobuf-type head))
             (otherwise
-             (if (eq head quux-list-of)
+             (if (eq head list-of-list-of)
                (multiple-value-bind (type class)
                    (lisp-type-to-protobuf-type (first tail))
                  (values type class (packed-type-p class)))
   "Given a Lisp type, returns a \"cardinality\": :required, :optional or :repeated.
    If the sceond returned value is true, it's a repeated field that should use a vector."
   (let ((type (if type-filter (funcall type-filter type) type))
-        (quux-list-of (and (find-package :quux)
-                           (intern "LIST-OF" (find-package :quux)))))
+        (list-of-list-of (list-of-list-of)))
     (if (listp type)
       (destructuring-bind (head &rest tail) type
         (case head
                (clos-type-to-protobuf-required repeated)
                (values (if optional :optional :required) nil))))
           ((and)
-           (cond ((or (subtypep type '(list-of t))
-                      (and quux-list-of (subtypep type `(,quux-list-of t))))
+           (cond ((and (subtypep type 'list)
+                       (not (subtypep type 'null)))
                   (values :repeated nil))
                  ((subtypep type '(vector-of t))
                   (values :repeated t))
           ((vector-of)
            (values :repeated t))
           (otherwise
-           (if (eq head quux-list-of)
+           (if (eq head list-of-list-of)
              (values :repeated nil)
              (values :required nil)))))
       (values :required nil))))
index 8af06a0..6ac39fc 100644 (file)
                                    ',type ',name)
                    (map () #'protobufs-warn warnings))))
              (setq ,var new-schema)
-             (record-protobuf ,var)
-             ,@(with-collectors ((messages collect-message))
-                 (labels ((collect-messages (message)
-                            (collect-message message)
-                            (map () #'collect-messages (proto-messages message))))
-                   (map () #'collect-messages (proto-messages schema)))
-                 (append 
-                   (mapcar #'(lambda (m) `(record-protobuf ,m)) messages)
-                   (when (eq optimize :speed)
-                     (append (mapcar #'generate-object-size  messages)
-                             (mapcar #'generate-serializer   messages)
-                             (mapcar #'generate-deserializer messages)))))
-             ,var))))))
+             (record-protobuf ,var))
+           ,@(with-collectors ((messages collect-message))
+               (labels ((collect-messages (message)
+                          (collect-message message)
+                          (map () #'collect-messages (proto-messages message))))
+                 (map () #'collect-messages (proto-messages schema)))
+               (append 
+                (mapcar #'(lambda (m) `(record-protobuf ,m)) messages)
+                (when (eq optimize :speed)
+                  (append (mapcar #'generate-object-size  messages)
+                          (mapcar #'generate-serializer   messages)
+                          (mapcar #'generate-deserializer messages)))))
+           ,var)))))
 
 (defmacro with-proto-source-location ((type name definition-type
                                        &optional pathname start-pos end-pos)
index 4f53ccb..29e8a52 100644 (file)
 ;; A parameterized list type for repeated fields
 ;; The elements aren't type-checked
 (deftype list-of (type)
-  (if (eq type 'null)
+  (if (eq type 'nil) ; a list that cannot have any element (element-type nil) is null.
     'null
     'list))
 
 ;; The same, but use a (stretchy) vector
 (deftype vector-of (type)
-  (if (eq type 'null)
-    'null
+  (if (eq type 'nil); an array that cannot have any element (element-type nil) is of size 0.
+    '(array * (0))
     '(array * (*))))            ;an 1-dimensional array of any type
 
 ;; This corresponds to the :bytes Protobufs type