gnupdate: Use SSAX instead of SXML to reduce the memory & CPU overhead.

* maintainers/scripts/gnu/gnupdate.scm (xml-element->snix): New
  procedure.
  (xml->snix): Rewrite to use a parser generated by `ssax:make-parser'.
  (%options)[sxml]: Remove.
  (main): Update accordingly.

svn path=/nixpkgs/trunk/; revision=21695

1 files changed, 108 insertions, 138 deletions

diff --git a/maintainers/scripts/gnu/gnupdate.scm b/maintainers/scripts/gnu/gnupdate.scm
index e43e5baf32c3..53d52e73ab95 100644
--- a/maintainers/scripts/gnu/gnupdate.scm
+++ b/maintainers/scripts/gnu/gnupdate.scm
@@ -17,13 +17,12 @@
 (cond-expand (guile-2 #t)
              (else (error "GNU Guile 2.0 is required")))
 
-(use-modules (sxml simple)
+(use-modules (sxml ssax)
              (ice-9 popen)
              (ice-9 match)
              (ice-9 rdelim)
              (ice-9 regex)
              (ice-9 vlist)
-             (sxml-match)
              (srfi srfi-1)
              (srfi srfi-9)
              (srfi srfi-11)
@@ -47,6 +46,13 @@
   (and line column path
        (make-location path (string->number line) (string->number column))))
 
+;; XXX: Hack to add missing exports from `(sxml ssax)' as of 1.9.10.
+(let ((ssax (resolve-module '(sxml ssax))))
+  (for-each (lambda (sym)
+              (module-add! (current-module) sym
+                           (module-variable ssax sym)))
+            '(ssax:warn ssax:skip-pi nl)))
+
 ;; Nix object types visible in the XML output of `nix-instantiate' and
 ;; mapping to S-expressions (we map to sexps, not records, so that we
 ;; can do pattern matching):
@@ -58,7 +64,7 @@
 ;;   bool             #f|#t
 ;;   derivation       (derivation drv-path out-path attributes)
 ;;   ellipsis         '...
-;;   expr             (expr loc body ...)
+;;   expr             (snix loc body ...)
 ;;   function         (function loc at|attrspat|varpat)
 ;;   int              int
 ;;   list             list
@@ -73,118 +79,100 @@
 ;; lazily because the whole SXML tree has to be traversed to maintain the
 ;; list of known derivations.
 
-(define (sxml->snix tree)
+(define (xml-element->snix elem attributes body derivations)
+  ;; Return an SNix element corresponding to XML element ELEM.
+
+  (define (loc)
+    (->loc (assq-ref attributes 'line)
+           (assq-ref attributes 'column)
+           (assq-ref attributes 'path)))
+
+  (case elem
+    ((at)
+     (values `(at ,(car body) ,(cadr body)) derivations))
+    ((attr)
+     (let ((name (assq-ref attributes 'name)))
+       (cond ((null? body)
+              (values `(attribute-pattern ,name) derivations))
+             ((and (pair? body) (null? (cdr body)))
+              (values `(attribute ,(loc) ,name ,(car body))
+                      derivations))
+             (else
+              (error "invalid attribute body" name (loc) body)))))
+    ((attrs)
+     (values `(attribute-set ,(reverse body)) derivations))
+    ((attrspat)
+     (values `(attribute-set-pattern ,body) derivations))
+    ((bool)
+     (values (string-ci=? "true" (assq-ref attributes 'value))
+             derivations))
+    ((derivation)
+     (let ((drv-path (assq-ref attributes 'drvPath))
+           (out-path (assq-ref attributes 'outPath)))
+       (if (equal? body '(repeated))
+           (let ((body (vhash-assoc drv-path derivations)))
+             (if (pair? body)
+                 (values `(derivation ,drv-path ,out-path ,(cdr body))
+                         derivations)
+                 (error "no previous occurrence of derivation"
+                        drv-path)))
+           (values `(derivation ,drv-path ,out-path ,body)
+                   (vhash-cons drv-path body derivations)))))
+    ((ellipsis)
+     (values '... derivations))
+    ((expr)
+     (values `(snix ,(loc) ,@body) derivations))
+    ((function)
+     (values `(function ,(loc) ,body) derivations))
+    ((int)
+     (values (string->number (assq-ref attributes 'value))
+             derivations))
+    ((list)
+     (values body derivations))
+    ((null)
+     (values 'null derivations))
+    ((path)
+     (values (assq-ref attributes 'value) derivations))
+    ((repeated)
+     (values 'repeated derivations))
+    ((string)
+     (values (assq-ref attributes 'value) derivations))
+    ((unevaluated)
+     (values 'unevaluated derivations))
+    ((varpat)
+     (values `(varpat ,(assq-ref attributes 'name)) derivations))
+    (else (error "unhandled Nix XML element" elem))))
+
+(define xml->snix
   ;; Return the SNix represention of TREE, an SXML tree as returned by
   ;; parsing the XML output of `nix-instantiate' on Nixpkgs.
-
-  ;; FIXME: We should use SSAX to avoid the SXML step otherwise we end up
-  ;; eating memory up to the point where fork(2) returns ENOMEM!
-
-  (define whitespace
-    ;; The whitespace marker.
-    (cons 'white 'space))
-
-  (let loop ((node        tree)
-             (derivations vlist-null))
-    (define (process-body body)
-      (let ((result+derivations
-             (fold (lambda (node result)
-                     (let-values (((out derivations)
-                                   (loop node (cdr result))))
-                       (if (eq? out whitespace)
-                           result
-                           (cons (cons out (car result))
-                                 derivations))))
-                   (cons '() derivations)
-                   body)))
-        (values (reverse (car result+derivations))
-                (cdr result+derivations))))
-
-    (sxml-match node
-      (,x
-       (guard (and (string? x) (string=? (string-trim-both x) "")))
-       (values whitespace derivations))
-      ((*TOP* (*PI* ,_ ...) (expr ,body ...))
-       ;; The entry/exit point.  Of the two values returned, the second one
-       ;; is likely to be discarded by the caller (thanks to multiple-value
-       ;; truncation).
-       (let-values (((body derivations) (process-body body)))
-         (values (cons* 'snix #f body)
-                 derivations)))
-      ((at ,body ...)
-       (let-values (((body derivations) (process-body body)))
-         (values (list 'at body) derivations)))
-      ((attr (@ (name ,name)
-                (line (,line #f)) (column (,column #f)) (path (,path #f)))
-             ,body ...)
-       (let-values (((body derivations) (process-body body)))
-         (values (cons* 'attribute
-                        (->loc line column path)
-                        name
-                        (if (or (null? body)
-                                (and (pair? body) (null? (cdr body))))
-                            body
-                            (error 'sxml->snix "invalid attribute body"
-                                   body)))
-                 derivations)))
-      ((attrs ,body ...)
-       (let-values (((body derivations) (process-body body)))
-         (values (list 'attribute-set body)
-                 derivations)))
-      ((attrspat ,body ...)
-       (let-values (((body derivations) (process-body body)))
-         (values (cons 'attribute-set-pattern body)
-                 derivations)))
-      ((bool (@ (value ,value)))
-       (values (string-ci=? value "true") derivations))
-      ((derivation (@ (drvPath ,drv-path) (outPath ,out-path)) ,body ...)
-       (let-values (((body derivations) (process-body body)))
-         (let ((repeated? (equal? body '(repeated))))
-           (values (list 'derivation drv-path out-path
-                         (if repeated?
-                             (let ((body (vhash-assoc drv-path derivations)))
-                               (if (pair? body)
-                                   (cdr body)
-                                   (error "no previous occurrence of derivation"
-                                          drv-path)))
-                             body))
-                   (if repeated?
-                       derivations
-                       (vhash-cons drv-path body derivations))))))
-      ((ellipsis)
-       (values '... derivations))
-      ((function (@ (line (,line #f)) (column (,column #f)) (path (,path #f)))
-                 ,body ...)
-       (let-values (((body derivations) (process-body body)))
-         (values (cons* 'function
-                        (->loc line column path)
-                        (if (and (pair? body) (null? (cdr body)))
-                            body
-                            (error 'sxml->snix "invalid function body"
-                                   body)))
-                 derivations)))
-      ((int (@ (value ,value)))
-       (values (string->number value) derivations))
-      (,x
-       ;; We can't use `(list ,body ...)', which has a different meaning,
-       ;; hence the guard hack.
-       (guard (and (pair? x) (eq? (car x) 'list)))
-       (process-body (cdr x)))
-      ((null)
-       (values 'null derivations))
-      ((path (@ (value ,value)))
-       (values value derivations))
-      ((repeated)
-       ;; This is then handled in `derivation' above.
-       (values 'repeated derivations))
-      ((string (@ (value ,value)))
-       (values value derivations))
-      ((unevaluated)
-       (values 'unevaluated derivations))
-      ((varpat (@ (name ,name)))
-       (values (list 'varpat name) derivations))
-      (,x
-       (error 'sxml->snix "unmatched sxml form" x)))))
+  (let ((parse
+         (ssax:make-parser NEW-LEVEL-SEED
+                           (lambda (elem-gi attributes namespaces expected-content
+                                    seed)
+                             (cons '() (cdr seed)))
+
+                           FINISH-ELEMENT
+                           (lambda (elem-gi attributes namespaces parent-seed
+                                            seed)
+                             (let ((snix        (car seed))
+                                   (derivations (cdr seed)))
+                               (let-values (((snix derivations)
+                                             (xml-element->snix elem-gi
+                                                                attributes
+                                                                snix
+                                                                derivations)))
+                                 (cons (cons snix (car parent-seed))
+                                       derivations))))
+
+                           CHAR-DATA-HANDLER
+                           (lambda (string1 string2 seed)
+                             ;; Discard inter-node strings, which are blanks.
+                             seed))))
+    (lambda (port)
+      ;; Discard the second value returned by the parser (the derivation
+      ;; vhash).
+      (caar (parse port (cons '() vlist-null))))))
 
 (define (call-with-package snix proc)
   (match snix
@@ -658,20 +646,15 @@
                   (format #t "~%")
                   (format #t "  -x, --xml=FILE      Read XML output of `nix-instantiate'~%")
                   (format #t "                      from FILE.~%")
-                  (format #t "  -s, --sxml=FILE     Read SXML output of `nix-instantiate'~%")
-                  (format #t "                      from FILE.~%")
                   (format #t "  -h, --help          Give this help list.~%~%")
                   (format #t "Report bugs to <ludo@gnu.org>~%")
                   (exit 0)))
 
         (option '(#\x "xml") #t #f
                 (lambda (opt name arg result)
-                  (alist-cons 'xml-file arg result)))
-        (option '(#\s "sxml") #t #f
-                (lambda (opt name arg result)
-                  (alist-cons 'sxml-file arg result)))))
+                  (alist-cons 'xml-file arg result)))))
 
-(define (main . args)
+(define-public (main . args)
   ;; Assume Nixpkgs is under $NIXPKGS or ~/src/nixpkgs.
   (let* ((opts      (args-fold args %options
                                (lambda (opt name arg result)
@@ -682,24 +665,11 @@
          (home      (getenv "HOME"))
          (path      (or (getenv "NIXPKGS")
                         (string-append home "/src/nixpkgs")))
-         (sxml      (or (and=> (assoc-ref opts 'sxml-file)
-                               (lambda (input)
-                                 (format (current-error-port)
-                                         "reading SXML...~%")
-                                 (read-disable 'positions) ;; reduce memory usage
-                                 (with-input-from-file input read)))
-                        (begin
-                          (format (current-error-port) "parsing XML...~%")
-                          (xml->sxml
-                           (or (and=> (assoc-ref opts 'xml-file)
-                                      open-input-file)
-                               (open-nixpkgs path))))))
-         (snix      (let ((s (begin
-                               (format (current-error-port)
-                                       "producing SNix tree...~%")
-                               (sxml->snix sxml))))
-                      (set! sxml #f) (gc)
-                      s))
+         (snix      (begin
+                      (format (current-error-port) "parsing XML...~%")
+                      (xml->snix
+                       (or (and=> (assoc-ref opts 'xml-file) open-input-file)
+                           (open-nixpkgs path)))))
          (packages  (match snix
                       (('snix _ ('attribute-set attributes))
                        attributes)