revise scribble/srcdoc so it is extensible; tweak bytecode optimizer to drop more omittable expressions

svn: r9028

collects/compiler/main.ss

@@ -30,6 +30,7 @@
 	   dynext/file
 	   dynext/compile
 	   dynext/link
+           scheme/pretty
 	   (lib "pack.ss" "setup")
 	   (lib "getinfo.ss" "setup")
 	   setup/dirs)
@@ -138,7 +139,10 @@
 	 (,(format "Output ~a file(s) from Scheme source(s)" (extract-suffix append-zo-suffix)))]
 	[("--collection-zos")
 	 ,(lambda (f) 'collection-zos)
-	 (,(format "Compile specified collection to ~a files" (extract-suffix append-zo-suffix)))]]
+	 ((,(format "Compile specified collection to ~a files" (extract-suffix append-zo-suffix)) ""))]
+        [("--expand")
+	 ,(lambda (f) 'expand)
+	 (,(format "Write macro-expanded Scheme source(s) to stdout"))]]
        [help-labels ""]
        [once-any
 	[("--3m")
@@ -461,6 +465,23 @@
      ((compile-zos prefix) source-files (if (auto-dest-dir)
 					    'auto
 					    (dest-dir)))]
+    [(expand)
+     (for-each (lambda (src-file)
+                 (let ([src-file (path->complete-path src-file)])
+                   (let-values ([(base name dir?) (split-path src-file)])
+                     (parameterize ([current-load-relative-directory base]
+                                    [current-namespace (make-base-namespace)]
+                                    [read-accept-reader #t])
+                       (call-with-input-file* 
+                        src-file
+                        (lambda (in)
+                          (port-count-lines! in)
+                          (let loop ()
+                            (let ([e (read-syntax src-file in)])
+                              (unless (eof-object? e)
+                                (pretty-print (syntax->datum (expand e)))
+                                (loop))))))))))
+               source-files)]
     [(make-zo)
      (let ([n (make-base-empty-namespace)]
 	   [mc (dynamic-require 'mzlib/cm

collects/net/gifwrite.ss

@@ -27,29 +27,29 @@
   (define GifVersionPrefix #"GIF89a")
 
   (provide/doc
-   [gif-stream? ([v any/c] . -> . boolean?)
+   (proc-doc gif-stream? (([v any/c]) () . ->d . [_ boolean?])
-                @{Returns @scheme[@t] if @scheme[v] is a GIF stream created by @scheme[gif-write],
+             @{Returns @scheme[@t] if @scheme[v] is a GIF stream created by @scheme[gif-write],
-                          @scheme[#f] otherwise.}]
+                       @scheme[#f] otherwise.})
-   [image-ready-gif-stream? ([v any/c] . -> . boolean?)
+   (proc-doc image-ready-gif-stream? (([v any/c]) () . ->d . [_ boolean?])
-                            @{Returns @scheme[#t] if @scheme[v] is a GIF stream that is not in 
+             @{Returns @scheme[#t] if @scheme[v] is a GIF stream that is not in 
-                                      @scheme['done] mode, @scheme[#f] otherwise.}]
+                       @scheme['done] mode, @scheme[#f] otherwise.})
-   [image-or-control-ready-gif-stream? ([v any/c] . -> . boolean?)
+   (proc-doc image-or-control-ready-gif-stream? (([v any/c]) () . ->d . [_ boolean?])
-                                       @{Returns @scheme[#t] if @scheme[v] is a GIF stream that is in 
+             @{Returns @scheme[#t] if @scheme[v] is a GIF stream that is in 
-                                                 @scheme['init] or @scheme['image-or-control] mode, @scheme[#f] otherwise.}]
+                       @scheme['init] or @scheme['image-or-control] mode, @scheme[#f] otherwise.})
-   [empty-gif-stream?  ([v any/c] . -> . boolean?)
+   (proc-doc empty-gif-stream?  (([v any/c]) () . ->d . [_ boolean?])
-                       @{Returns @scheme[#t] if @scheme[v] is a GIF stream that in 
+             @{Returns @scheme[#t] if @scheme[v] is a GIF stream that in 
-                                 @scheme['init] mode, @scheme[#f] otherwise.}]
+                       @scheme['init] mode, @scheme[#f] otherwise.})
-   [gif-colormap? ([v any/c] . -> . boolean?)
+   (proc-doc gif-colormap? (([v any/c]) () . ->d . [_ boolean?])
-                  @{Returns @scheme[#t] if @scheme[v] represets a colormap, @scheme[#f] otherwise.
+             @{Returns @scheme[#t] if @scheme[v] represets a colormap, @scheme[#f] otherwise.
-                            A colormap is a list whose size is a power of @math{2} between @math{2^1} and @math{2^8},
+                       A colormap is a list whose size is a power of @math{2} between @math{2^1} and @math{2^8},
-                            and whose elements are vectors of size 3 containing colors
+                       and whose elements are vectors of size 3 containing colors
-                            (i.e., exact integers between @math{0} and @math{255} inclusive).}]
+                       (i.e., exact integers between @math{0} and @math{255} inclusive).})
-   [color? ([v any/c]. -> . boolean?)
+   (proc-doc color? (([v any/c]) () . ->d . [_ boolean?])
-           @{The same as @scheme[byte?].}]
+             @{The same as @scheme[byte?].})
-   [dimension? ([v any/c]. -> . boolean?)
+   (proc-doc dimension? (([v any/c]) () . ->d . [_ boolean?])
-               @{Returns @scheme[#t] if @scheme[v] is an exact integer between
+             @{Returns @scheme[#t] if @scheme[v] is an exact integer between
-                         @scheme[#x0] and @scheme[#xFFFF] inclusive, @scheme[#f]
+                       @scheme[#x0] and @scheme[#xFFFF] inclusive, @scheme[#f]
-                         otherwise.}])
+                       otherwise.}))
 
   (define-struct gif-stream (port 
                              SWidth
@@ -104,8 +104,8 @@
   (define (WRITE g bytes)
     (write-bytes bytes (gif-stream-port g)))
 
-  (provide/doc [gif-state ([stream gif-stream?] . -> . symbol?)
+  (provide/doc (proc-doc gif-state (([stream gif-stream?]) () . ->d . [_ symbol?])
-                          @{Returns the state of @scheme[stream].}])
+                         @{Returns the state of @scheme[stream].}))
   (define (gif-state GifFile)
     (gif-stream-FileState GifFile))
 
@@ -113,13 +113,15 @@
   ;; * This routine should be called before any other EGif calls, immediately
   ;; * follows the GIF file openning.
   ;; *****************************************************************************/
-  (provide/doc [gif-start
+  (provide/doc (proc-doc
-                ([out output-port?]
+                gif-start
-                 [w dimension?]
+                (([out output-port?]
-                 [h dimension?]
+                  [w dimension?]
-                 [bg-color color?]
+                  [h dimension?]
-                 [cmap (or/c false/c gif-colormap?)]
+                  [bg-color color?]
-                 . -> . gif-stream?)
+                  [cmap (or/c false/c gif-colormap?)])
+                 ()
+                 . ->d . [_ gif-stream?])
                 @{Writes the start of a GIF file to the given output port, and returns
                          a GIF stream that adds to the output port.
 
@@ -133,7 +135,7 @@
                          
                          A global colormap need not be supplied, in which case a colormap must
                          be supplied for each image. Beware that the bg-color is ill-defined if
-                         a global colormap is not provided.}])
+                         a global colormap is not provided.}))
   (define (gif-start port
                      Width
                      Height
@@ -186,16 +188,18 @@
   ;; * This routine should be called before any attempt to dump an image - any
   ;; * call to any of the pixel dump routines.
   ;; *****************************************************************************/
-  (provide/doc [gif-add-image
+  (provide/doc (proc-doc
-                ([stream image-ready-gif-stream?]
+                gif-add-image
-                 [left dimension?]
+                (([stream image-ready-gif-stream?]
-                 [top dimension?]
+                  [left dimension?]
-                 [width dimension?]
+                  [top dimension?]
-                 [height dimension?]
+                  [width dimension?]
-                 [interlaced? any/c]
+                  [height dimension?]
-                 [cmap (or/c false/c gif-colormap?)]
+                  [interlaced? any/c]
-                 [bstr bytes?]
+                  [cmap (or/c false/c gif-colormap?)]
-                 . -> . void?)
+                  [bstr bytes?])
+                 ()
+                 . ->d . [_ void?])
                 @{Writes an image to the given GIF stream. The @scheme[left], @scheme[top], 
                          @scheme[width], and @scheme[height] values specify the location and 
                          size of the image within the overall GIF image's virtual space.
@@ -224,7 +228,7 @@
                          colormap's length, if the @scheme[bstr] length is not @scheme[width] times
                          @scheme[height], or if the @scheme[top], @scheme[left], @scheme[width], and 
                          @scheme[height] dimensions specify a region beyond the overall GIF image's
-                         virtual space.}])
+                         virtual space.}))
   (define (gif-add-image GifFile
                         Left
                         Top
@@ -293,13 +297,15 @@
   ;;/******************************************************************************
   ;; * This routine should be called to add graphic control before the next image
   ;; *****************************************************************************/
-  (provide/doc [gif-add-control
+  (provide/doc (proc-doc
-                ([stream image-or-control-ready-gif-stream?]
+                gif-add-control
-                 [disposal (one-of/c 'keep 'restore-bg 'restore-prev)]
+                (([stream image-or-control-ready-gif-stream?]
-                 [wait-for-input? any/c]
+                  [disposal (one-of/c 'keep 'restore-bg 'restore-prev)]
-                 [delay dimension?]
+                  [wait-for-input? any/c]
-                 [transparent (or/c false/c color?)]
+                  [delay dimension?]
-                 . -> . any)
+                  [transparent (or/c false/c color?)])
+                 ()
+                 . ->d . [_ void?])
                 @{Writes an image-control command to a GIF stream. Such a control must
                          appear just before an image, and it applies to the following image.
 
@@ -332,7 +338,7 @@
                          follow image (as opposed to the color specified by the colormap for the index).
 
                          An exception is raised if a control is already added to @scheme[stream]
-                         without a corresponding image.}])
+                         without a corresponding image.}))
 
   (define (gif-add-control GifFile
                            Disposal
@@ -359,17 +365,19 @@
   ;; * This routine should be called to add the "loop" graphic control
   ;;   before adding any images
   ;; *****************************************************************************/
-  (provide/doc [gif-add-loop-control
+  (provide/doc (proc-doc
-                ([stream empty-gif-stream?]
+                gif-add-loop-control
-                 [iteration dimension?]
+                (([stream empty-gif-stream?]
-                 . -> . any)
+                  [iteration dimension?])
+                 ()
+                 . ->d . [_ void?])
                 @{Writes a control command to a GIF stream for which no images or other
                          commands have already been written. The command causes the animating
                          sequence of images in the GIF to be repeated `iteration-dimension'
                          times, where 0 can be used to mean ``infinity.''
                          
                          An exception is raise if some control or image has been added to the
-                         stream already.}])
+                         stream already.}))
   (define (gif-add-loop-control GifFile
                                 Iterations)
     (WRITE GifFile #"\x21\xFF\x0BNETSCAPE2.0\x03\x01")
@@ -380,14 +388,16 @@
   ;;/******************************************************************************
   ;; * This routine should be called to add arbitrary comment text
   ;; *****************************************************************************/
-  (provide/doc [gif-add-comment
+  (provide/doc (proc-doc
-                ([stream image-or-control-ready-gif-stream?]
+                gif-add-comment
-                 [bstr bytes?]
+                (([stream image-or-control-ready-gif-stream?]
-                 . -> . any)
+                  [bstr bytes?])
+                 ()
+                 . ->d . [_ void?])
                 @{Adds a generic comment to the GIF stream.
                        
                        An exception is raised if an image-control command was just written to
-                       the stream (so that an image is required next).}])
+                       the stream (so that an image is required next).}))
   (define (gif-add-comment GifFile
                            Str)
     (WRITE GifFile #"\x21\xFE")
@@ -403,15 +413,17 @@
   ;;/******************************************************************************
   ;; * This routine should be called last, to end GIF file.
   ;; *****************************************************************************/
-  (provide/doc [gif-end
+  (provide/doc (proc-doc
-                ([stream image-or-control-ready-gif-stream?]
+                gif-end
-                 . -> . any)
+                (([stream image-or-control-ready-gif-stream?])
+                 ()
+                 . ->d . [_ void?])
                 @{Finishes 
                   writing a GIF file. The GIF stream's output port is not
                   automatically closed.
                   
                   An exception is raised if an image-control command was just written to
-                  the stream (so that an image is required next).}])
+                  the stream (so that an image is required next).}))
   (define (gif-end GifFile)
     (WRITE GifFile #";")
     (set-gif-stream-FileState! GifFile 'done))
@@ -556,36 +568,38 @@
          (zero? (remainder (bytes-length b) 4))))
   
   (provide/doc
-   [quantize ([bstr argb-bytes?]
+   (proc-doc quantize 
-              . -> . 
+             (([bstr argb-bytes?])
-              (values bytes? gif-colormap? (or/c false/c color?)))
+              ()
+              . ->d . 
+              (values [_ bytes?] [_ gif-colormap?] [_ (or/c false/c color?)]))
              @{Each
                image in a GIF stream is limited to 256 colors, including the
                transparent ``color,'' if any. The @scheme[quantize] function helps converts a
                24-bit image (plus alpha channel) into an indexed-color image,reducing
                the number of colors if necessary.
-
+               
                Given a set of pixels expressed in ARGB format 
                (i.e., each four bytes is a set of values for one pixel: alpha, red, blue, and green),
                @scheme[quantize] produces produces
-
+               
                @(itemize
                  @item{bytes for the image (i.e., a array of colors, expressed as a byte string)}
                  @item{a colormap}
                  @item{either @scheme[#f] or a color index for the transparent ``color''})
-
+               
                The conversion treats alpha values less than 128 as transparent
                pixels, and other alpha values as solid.
-
+               
                The quantization process first attempts to use all (non-transparent)
                colors in the image. if that fails, it reduces the image to 12-bit
                color (3 bits per each of red, green, and blue) by rounding up pixel
                values, and tries again. If that fails, it reduces the image to 6-bit
                color (2 bits per each of red, green, and blue).
-
+               
                To convert a collection of images all with the same quantization,
                simply append them for the input of a single call of @scheme[quantize], and
-               then break apart the result bytes.}])
+               then break apart the result bytes.}))
   (define (quantize argb)
     (let* ([len (quotient (bytes-length argb) 4)]
            [result (make-bytes len)]

collects/scribble/extract.ss

@@ -35,16 +35,14 @@
                  (mod-beg
                   content ...))
             (with-syntax ([(content ...)
-                           (map
+                           (apply
-                            strip-context
+                            append
-                            (apply
+                            (map (lambda (c)
-                             append
+                                   (syntax-case c (#%plain-app void quote-syntax provide/doc)
-                             (map (lambda (c)
+                                     [(#%plain-app void (quote-syntax (provide/doc spec ...)))
-                                    (syntax-case c (#%plain-app void quote-syntax provide/doc)
+                                      (syntax->list #'(spec ...))]
-                                      [(#%plain-app void (quote-syntax (provide/doc spec ...)))
+                                     [_ null]))
-                                       (syntax->list #'(spec ...))]
+                                 (syntax->list #'(content ...))))]
-                                      [_ null]))
-                                  (syntax->list #'(content ...)))))]
                           [(req ...)
                            (map
                             strip-context
@@ -57,16 +55,34 @@
                                       [(#%plain-app void (quote-syntax (require/doc spec ...)))
                                        (syntax->list #'(spec ...))]
                                       [_ null]))
-                                  (syntax->list #'(content ...)))))])
+                                  (syntax->list #'(content ...)))))]
+                          [orig-tag (datum->syntax #f 'orig)])
               #`(begin
                   (#%require (for-label #,(strip-context #'lang))
                              (for-label #,(strip-context #'orig-path)) 
                              req ...)
-                  (def-it content) ...))])))]))
+                  (def-it orig-tag content) ...))])))]))
 
-(define-syntax def-it
+(define-for-syntax (revise-context c orig-tag new-tag tag)
-  (syntax-rules ()
+  (cond
-    [(_ ((rename old-id id) contract desc))
+   [(syntax? c) 
-     (def-it (id contract desc))]
+    (datum->syntax
-    [(_ (id (-> arg ... result) desc))
+     (if (bound-identifier=? tag (datum->syntax c 'tag))
-     (defproc (id arg ...) result . desc)]))
+         new-tag
+         orig-tag)
+     (revise-context (syntax-e c) orig-tag new-tag tag)
+     c)]
+   [(pair? c) (cons (revise-context (car c) orig-tag new-tag tag)
+                    (revise-context (cdr c) orig-tag new-tag tag))]
+   [else c]))
+
+(define-syntax (def-it stx)
+  (syntax-local-introduce
+   (syntax-case (syntax-local-introduce stx) ()
+     [(_ orig-path (reqs doc tag))
+      (let ([new-tag ((make-syntax-introducer) 
+                      (datum->syntax #'orig-path 'new-tag))]
+            [orig-tag #'orig-path])
+        #`(begin
+            (require . #,(revise-context #'reqs orig-tag new-tag #'tag))
+            #,(revise-context #'doc orig-tag new-tag #'tag)))])))

collects/scribble/manual.ss

@@ -713,7 +713,9 @@
        (raise-syntax-error 'defproc "bad prototype" stx)]))
 
   (define-syntax (result-contract stx)
-    (syntax-case stx ()
+    (syntax-case stx (values)
+      [(_ (values c ...))
+       #'(list (schemeblock0 c) ...)]
       [(_ c)
        (if (string? (syntax-e #'c))
            (raise-syntax-error
@@ -1233,7 +1235,29 @@
                                                (element-width tagged))]
                                [(short?) (or (flat-size . < . 40)
                                              ((length args) . < . 2))]
-                               [(res) (result-contract)]
+                               [(res) (let ([res (result-contract)])
+                                        (if (list? res)
+                                            ;; multiple results
+                                            (if (null? res)
+                                                'nbsp
+                                                (let ([w (apply max 0 (map flow-element-width res))])
+                                                  (if (or (ormap table? res)
+                                                          (w . > . 30))
+                                                      (make-table
+                                                       #f
+                                                       (map (lambda (fe)
+                                                              (list (make-flow (list fe))))
+                                                            res))
+                                                      (make-table 
+                                                       #f 
+                                                       (list
+                                                        (let loop ([res res])
+                                                          (if (null? (cdr res))
+                                                              (list (make-flow (list (car res))))
+                                                              (list* (make-flow (list (car res)))
+                                                                     (to-flow (hspace 1))
+                                                                     (loop (cdr res))))))))))
+                                            res))]
                                [(result-next-line?) ((+ (if short? 
                                                             flat-size
                                                             (+ (prototype-size args max max)

collects/scribble/provide-doc-transform.ss

@@ -0,0 +1,15 @@
+#lang scheme/base
+
+(require (for-syntax scheme/base))
+
+(provide define-provide/doc-transformer
+         (for-syntax
+          provide/doc-transformer?
+          provide/doc-transformer-proc))
+
+(begin-for-syntax
+ (define-struct provide/doc-transformer (proc) #:omit-define-syntaxes))
+
+(define-syntax-rule (define-provide/doc-transformer id rhs)
+  (define-syntax id
+    (make-provide/doc-transformer rhs)))

collects/scribble/srcdoc.ss

@@ -1,27 +1,83 @@
 #lang scheme/base
 
-(require scheme/contract)
+(require scheme/contract
+         (for-syntax scheme/base)
+         "provide-doc-transform.ss")
 
 (provide require/doc
-         provide/doc)
+         provide/doc
+         proc-doc)
 
 (define-syntax-rule (require/doc spec ...)
   (void (quote-syntax (require/doc spec ...))))
 
-(define-syntax-rule (provide/doc [id contract desc] ...)
+(define-syntax (provide/doc stx)
-  (begin
+  (syntax-case stx ()
-    (void (quote-syntax (provide/doc [id contract desc] ...)))
+    [(_ form ...)
-    (provide/contracted [id (strip-names contract)]) ...))
+     (let ([forms (syntax->list #'(form ...))])
+       (with-syntax ([((for-provide/contract for-docs) ...)
+                      (map (lambda (form)
+                             (syntax-case form ()
+                               [(id . _)
+                                (identifier? #'id)
+                                (let ([t (syntax-local-value #'id (lambda () #f))])
+                                  (unless (provide/doc-transformer? t)
+                                    (raise-syntax-error
+                                     #f
+                                     "not bound as a provide/doc transformer"
+                                     stx
+                                     #'id))
+                                  (let* ([i (make-syntax-introducer)]
+                                         [i2 (lambda (x) (syntax-local-introduce (i x)))])
+                                    (let-values ([(p/c d req/d) ((provide/doc-transformer-proc t)
+                                                                 (i (syntax-local-introduce form)))])
+                                      (list (i2 p/c) (list (i2 req/d) (i2 d) (i2 (quote-syntax tag)))))))]
+                               [_
+                                (raise-syntax-error
+                                 #f
+                                 "not a provide/doc sub-form"
+                                 stx
+                                 form)]))
+                           forms)])
+         (with-syntax ([(p/c ...)
+                        (map (lambda (form f)
+                               (quasisyntax/loc form
+                                 (provide/contract #,f)))
+                             forms
+                             (syntax->list #'(for-provide/contract ...)))])
+           #'(begin
+               p/c ...
+               (void (quote-syntax (provide/doc for-docs ...)))))))]))
 
-(define-syntax provide/contracted
+(define-provide/doc-transformer proc-doc
-  (syntax-rules (->)
+  (lambda (stx)
-    [(_ [(rename orig-id new-id) contract])
+    (syntax-case stx ()
-     (provide/contract (rename orig-id new-id contract))]
+      [(_ id contract desc)
-    [(_ [id contract])
+       (with-syntax ([(arg ...)
-     (provide/contract [id contract])]))
+                      (syntax-case #'contract (->d)
+                        [(->d (req ...) () result)
+                         #'(req ...)]
+                        [else
+                         (raise-syntax-error
+                          #f
+                          "unsupported procedure contract form (arguments)"
+                          stx
+                          #'contract)])]
+                     [result
+                      (syntax-case #'contract (->d)
+                        [(->d reqs opts (values [name res] ...))
+                         #'(values res ...)]
+                        [(->d reqs opts [name res])
+                         #'res]
+                        [else
+                         (raise-syntax-error
+                          #f
+                          "unsupported procedure contract form (arguments)"
+                          stx
+                          #'contract)])])
+         (values
+          #'[id contract]
+          #'(defproc (id arg ...) result . desc)
+          #'(scribble/manual)))])))
 
-(define-syntax strip-names
+        
-  (syntax-rules (->)
-    [(_ (-> [id contract] ... result))
-     (-> contract ... result)]
-    [(_ other) other]))

collects/scribblings/reference/networking.scrbl

@@ -67,7 +67,8 @@ If the server cannot be started by @scheme[tcp-listen], the
                       [local-hostname (or/c string? false/c) #f]
                       [local-port-no (or/c (and/c nonnegative-exact-integer?
                                                   (integer-in 1 65535))
-                                           false/c)])
+                                           false/c)
+                                     #f])
           (values input-port? output-port?)]{
 
 Attempts to connect as a client to a listening server.  The

collects/scribblings/reference/pipes.scrbl

@@ -10,7 +10,7 @@ between different processes.
 @defproc[(make-pipe [limit positive-exact-integer? #f]
                     [input-name any/c 'pipe]
                     [output-name any/c 'pipe])
-         any]{
+         (values input-port? output-port?)]{
 
 Returns two port values: the first port is an input port and the
 second is an output port. Data written to the output port is read from
@@ -28,7 +28,7 @@ port's capacity until the peeked bytes are read.)
 The optional @scheme[input-name] and @scheme[output-name] are used
 as the names for the returned input and out ports, respectively.}
 
-@defproc[(pipe-content-length [pipe-port port?]) any]{
+@defproc[(pipe-content-length [pipe-port port?]) exact-nonnegative-integer?]{
 
 Returns the number of bytes contained in a pipe, where
 @scheme[pipe-port] is either of the pipe's ports produced by

collects/tests/mzscheme/optimize.ss

@@ -609,6 +609,24 @@
               (define foo integer?)
               (display #t)))
 
+(test-comp '(module m mzscheme
+              (void 10))
+           '(module m mzscheme))
+
+(test-comp '(module m mzscheme
+              (void (quote-syntax unused!)))
+           '(module m mzscheme))
+
+(test-comp '(module m mzscheme
+              (values 1 2))
+           '(module m mzscheme))
+
+(test-comp '(module m mzscheme
+              (printf "pre\n")
+              (void 10))
+           '(module m mzscheme
+              (printf "pre\n")))
+
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Check bytecode verification of lifted functions
 

src/mzscheme/src/eval.c

@@ -903,6 +903,20 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved)
     goto try_again;
   }
 
+  if ((vtype == scheme_compiled_let_void_type)) {
+    /* recognize another (let ([x <omittable>]) ...) pattern: */
+    Scheme_Let_Header *lh = (Scheme_Let_Header *)o;
+    if ((lh->count == 1) && (lh->num_clauses == 1)) {
+      if (SAME_TYPE(SCHEME_TYPE(lh->body), scheme_compiled_let_value_type)) {
+        Scheme_Compiled_Let_Value *lv = (Scheme_Compiled_Let_Value *)lh->body;
+        if (scheme_omittable_expr(lv->value, 1, fuel - 1, resolved)) {
+          o = lv->body;
+          goto try_again;
+        }
+      }
+    }
+  }
+
   if ((vtype == scheme_letrec_type)) {
     o = ((Scheme_Letrec *)o)->body;
     goto try_again;
@@ -937,6 +951,7 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved)
         return 1;
       }
     }
+    /* (values <omittable> ...) */
     if ((app->num_args == vals) || (vals < 0)) {
       if (SAME_OBJ(scheme_values_func, app->args[0])) {
 	int i;
@@ -947,24 +962,34 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved)
 	return 1;
       }
     }
+    /* (void <omittable> ...) */
     if ((vals == 1) || (vals < 0)) {
-      
+      if (SAME_OBJ(scheme_void_proc, app->args[0])) {
+        int i;
+	for (i = app->num_args; i--; ) {
+	  if (!scheme_omittable_expr(app->args[i + 1], 1, fuel - 1, resolved))
+	    return 0;
+	}
+	return 1;
+      }
     }
     return 0;
   }
 
   if ((vtype == scheme_application2_type)) {
+    /* (values <omittable>) or (void <omittable>) */
     if ((vals == 1) || (vals < 0)) {
       Scheme_App2_Rec *app = (Scheme_App2_Rec *)o;
-      if (SAME_OBJ(scheme_values_func, app->rator)) {
+      if (SAME_OBJ(scheme_values_func, app->rator)
+          || SAME_OBJ(scheme_void_proc, app->rator)) {
 	if (scheme_omittable_expr(app->rand, 1, fuel - 1, resolved))
 	  return 1;
       }
     }
-    
   }
 
   if ((vtype == scheme_application3_type)) {
+    /* (values <omittable> <omittable>) */
     if ((vals == 2) || (vals < 0)) {
       Scheme_App3_Rec *app = (Scheme_App3_Rec *)o;
       if (SAME_OBJ(scheme_values_func, app->rator)) {
@@ -973,7 +998,15 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved)
 	  return 1;
       }
     }
-    
+    /* (void <omittable> <omittable>) */
+    if ((vals == 1) || (vals < 0)) {
+      Scheme_App3_Rec *app = (Scheme_App3_Rec *)o;
+      if (SAME_OBJ(scheme_void_proc, app->rator)) {
+	if (scheme_omittable_expr(app->rand1, 1, fuel - 1, resolved)
+	    && scheme_omittable_expr(app->rand2, 1, fuel - 1, resolved))
+	  return 1;
+      }
+    }
   }
 
   return 0;

src/mzscheme/src/module.c

@@ -4323,7 +4323,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info)
 	  }
 	}
       } else {
-	cont = scheme_omittable_expr(e, 1, -1, 0);
+	cont = scheme_omittable_expr(e, -1, -1, 0);
       }
       if (i_m + 1 == cnt)
 	cont = 0;
@@ -4380,6 +4380,31 @@ module_optimize(Scheme_Object *data, Optimize_Info *info)
     }
   }
 
+  /* Check one more time for expressions that we can omit: */
+  {
+    int can_omit = 0;
+    for (i_m = 0; i_m < cnt; i_m++) {
+      /* Optimize this expression: */
+      e = SCHEME_VEC_ELS(m->body)[i_m];
+      if (scheme_omittable_expr(e, -1, -1, 0)) {
+        can_omit++;
+      }
+    }
+    if (can_omit) {
+      Scheme_Object *vec;
+      int j = 0;
+      vec = scheme_make_vector(cnt - can_omit, NULL);
+      for (i_m = 0; i_m < cnt; i_m++) {
+        /* Optimize this expression: */
+        e = SCHEME_VEC_ELS(m->body)[i_m];
+        if (!scheme_omittable_expr(e, -1, -1, 0)) {
+          SCHEME_VEC_ELS(vec)[j++] = e;
+        }
+      }
+      m->body = vec;
+    }
+  }
+
   /* Exp-time body was optimized during compilation */
 
   return scheme_make_syntax_compiled(MODULE_EXPD, data);
@@ -5724,9 +5749,9 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
     Scheme_Object *prev = NULL, *next;
     for (p = first; !SCHEME_NULLP(p); p = next) {
       next = SCHEME_CDR(p);
-      if (scheme_omittable_expr(SCHEME_CAR(p), 1, -1, 0)) {
+      if (scheme_omittable_expr(SCHEME_CAR(p), -1, -1, 0)) {
 	if (prev)
-	  SCHEME_CDR(p) = next;
+	  SCHEME_CDR(prev) = next;
 	else
 	  first = next;
       } else

src/mzscheme/src/syntax.c

@@ -3227,7 +3227,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline)
   /* Optimized away all clauses? */
   if (!head->num_clauses)
     return head->body;
-
+  
   if (is_rec && !not_simply_let_star) {
     /* We can simplify letrec to let* */
     SCHEME_LET_FLAGS(head) -= SCHEME_LET_RECURSIVE;