From f5e0fd35f53eddf5e51843542103f5ea85d429a2 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 19 Mar 2008 19:53:51 +0000 Subject: [PATCH] revise scribble/srcdoc so it is extensible; tweak bytecode optimizer to drop more omittable expressions svn: r9028 --- collects/compiler/main.ss | 23 ++- collects/net/gifwrite.ss | 164 ++++++++++-------- collects/scribble/extract.ss | 52 ++++-- collects/scribble/manual.ss | 28 ++- collects/scribble/provide-doc-transform.ss | 15 ++ collects/scribble/srcdoc.ss | 90 ++++++++-- .../scribblings/reference/networking.scrbl | 3 +- collects/scribblings/reference/pipes.scrbl | 4 +- collects/tests/mzscheme/optimize.ss | 18 ++ src/mzscheme/src/eval.c | 41 ++++- src/mzscheme/src/module.c | 31 +++- src/mzscheme/src/syntax.c | 2 +- 12 files changed, 347 insertions(+), 124 deletions(-) create mode 100644 collects/scribble/provide-doc-transform.ss diff --git a/collects/compiler/main.ss b/collects/compiler/main.ss index 8ce687401e..98feb1c31e 100644 --- a/collects/compiler/main.ss +++ b/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 diff --git a/collects/net/gifwrite.ss b/collects/net/gifwrite.ss index 7047b4779a..c5ae5ce83e 100644 --- a/collects/net/gifwrite.ss +++ b/collects/net/gifwrite.ss @@ -27,29 +27,29 @@ (define GifVersionPrefix #"GIF89a") (provide/doc - [gif-stream? ([v any/c] . -> . boolean?) - @{Returns @scheme[@t] if @scheme[v] is a GIF stream created by @scheme[gif-write], - @scheme[#f] otherwise.}] - [image-ready-gif-stream? ([v any/c] . -> . boolean?) - @{Returns @scheme[#t] if @scheme[v] is a GIF stream that is not in - @scheme['done] mode, @scheme[#f] otherwise.}] - [image-or-control-ready-gif-stream? ([v any/c] . -> . boolean?) - @{Returns @scheme[#t] if @scheme[v] is a GIF stream that is in - @scheme['init] or @scheme['image-or-control] mode, @scheme[#f] otherwise.}] - [empty-gif-stream? ([v any/c] . -> . boolean?) - @{Returns @scheme[#t] if @scheme[v] is a GIF stream that in - @scheme['init] mode, @scheme[#f] otherwise.}] - [gif-colormap? ([v any/c] . -> . boolean?) - @{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}, - and whose elements are vectors of size 3 containing colors - (i.e., exact integers between @math{0} and @math{255} inclusive).}] - [color? ([v any/c]. -> . boolean?) - @{The same as @scheme[byte?].}] - [dimension? ([v any/c]. -> . boolean?) - @{Returns @scheme[#t] if @scheme[v] is an exact integer between - @scheme[#x0] and @scheme[#xFFFF] inclusive, @scheme[#f] - otherwise.}]) + (proc-doc gif-stream? (([v any/c]) () . ->d . [_ boolean?]) + @{Returns @scheme[@t] if @scheme[v] is a GIF stream created by @scheme[gif-write], + @scheme[#f] otherwise.}) + (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 + @scheme['done] mode, @scheme[#f] otherwise.}) + (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 + @scheme['init] or @scheme['image-or-control] mode, @scheme[#f] otherwise.}) + (proc-doc empty-gif-stream? (([v any/c]) () . ->d . [_ boolean?]) + @{Returns @scheme[#t] if @scheme[v] is a GIF stream that in + @scheme['init] mode, @scheme[#f] otherwise.}) + (proc-doc gif-colormap? (([v any/c]) () . ->d . [_ boolean?]) + @{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}, + and whose elements are vectors of size 3 containing colors + (i.e., exact integers between @math{0} and @math{255} inclusive).}) + (proc-doc color? (([v any/c]) () . ->d . [_ boolean?]) + @{The same as @scheme[byte?].}) + (proc-doc dimension? (([v any/c]) () . ->d . [_ boolean?]) + @{Returns @scheme[#t] if @scheme[v] is an exact integer between + @scheme[#x0] and @scheme[#xFFFF] inclusive, @scheme[#f] + 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?) - @{Returns the state of @scheme[stream].}]) + (provide/doc (proc-doc gif-state (([stream gif-stream?]) () . ->d . [_ symbol?]) + @{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 - ([out output-port?] - [w dimension?] - [h dimension?] - [bg-color color?] - [cmap (or/c false/c gif-colormap?)] - . -> . gif-stream?) + (provide/doc (proc-doc + gif-start + (([out output-port?] + [w dimension?] + [h dimension?] + [bg-color color?] + [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 - ([stream image-ready-gif-stream?] - [left dimension?] - [top dimension?] - [width dimension?] - [height dimension?] - [interlaced? any/c] - [cmap (or/c false/c gif-colormap?)] - [bstr bytes?] - . -> . void?) + (provide/doc (proc-doc + gif-add-image + (([stream image-ready-gif-stream?] + [left dimension?] + [top dimension?] + [width dimension?] + [height dimension?] + [interlaced? any/c] + [cmap (or/c false/c gif-colormap?)] + [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 - ([stream image-or-control-ready-gif-stream?] - [disposal (one-of/c 'keep 'restore-bg 'restore-prev)] - [wait-for-input? any/c] - [delay dimension?] - [transparent (or/c false/c color?)] - . -> . any) + (provide/doc (proc-doc + gif-add-control + (([stream image-or-control-ready-gif-stream?] + [disposal (one-of/c 'keep 'restore-bg 'restore-prev)] + [wait-for-input? any/c] + [delay dimension?] + [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 - ([stream empty-gif-stream?] - [iteration dimension?] - . -> . any) + (provide/doc (proc-doc + gif-add-loop-control + (([stream empty-gif-stream?] + [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 - ([stream image-or-control-ready-gif-stream?] - [bstr bytes?] - . -> . any) + (provide/doc (proc-doc + gif-add-comment + (([stream image-or-control-ready-gif-stream?] + [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 - ([stream image-or-control-ready-gif-stream?] - . -> . any) + (provide/doc (proc-doc + gif-end + (([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?] - . -> . - (values bytes? gif-colormap? (or/c false/c color?))) + (proc-doc quantize + (([bstr argb-bytes?]) + () + . ->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)] diff --git a/collects/scribble/extract.ss b/collects/scribble/extract.ss index de0896b59d..73d5f79d66 100644 --- a/collects/scribble/extract.ss +++ b/collects/scribble/extract.ss @@ -35,16 +35,14 @@ (mod-beg content ...)) (with-syntax ([(content ...) - (map - strip-context - (apply - append - (map (lambda (c) - (syntax-case c (#%plain-app void quote-syntax provide/doc) - [(#%plain-app void (quote-syntax (provide/doc spec ...))) - (syntax->list #'(spec ...))] - [_ null])) - (syntax->list #'(content ...)))))] + (apply + append + (map (lambda (c) + (syntax-case c (#%plain-app void quote-syntax provide/doc) + [(#%plain-app void (quote-syntax (provide/doc spec ...))) + (syntax->list #'(spec ...))] + [_ 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 - (syntax-rules () - [(_ ((rename old-id id) contract desc)) - (def-it (id contract desc))] - [(_ (id (-> arg ... result) desc)) - (defproc (id arg ...) result . desc)])) +(define-for-syntax (revise-context c orig-tag new-tag tag) + (cond + [(syntax? c) + (datum->syntax + (if (bound-identifier=? tag (datum->syntax c 'tag)) + 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)))]))) diff --git a/collects/scribble/manual.ss b/collects/scribble/manual.ss index cff0353346..9e161721da 100644 --- a/collects/scribble/manual.ss +++ b/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) diff --git a/collects/scribble/provide-doc-transform.ss b/collects/scribble/provide-doc-transform.ss new file mode 100644 index 0000000000..8c126c1da3 --- /dev/null +++ b/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))) diff --git a/collects/scribble/srcdoc.ss b/collects/scribble/srcdoc.ss index 1f5e2c2ba6..01a812d493 100644 --- a/collects/scribble/srcdoc.ss +++ b/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] ...) - (begin - (void (quote-syntax (provide/doc [id contract desc] ...))) - (provide/contracted [id (strip-names contract)]) ...)) +(define-syntax (provide/doc stx) + (syntax-case stx () + [(_ form ...) + (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 - (syntax-rules (->) - [(_ [(rename orig-id new-id) contract]) - (provide/contract (rename orig-id new-id contract))] - [(_ [id contract]) - (provide/contract [id contract])])) +(define-provide/doc-transformer proc-doc + (lambda (stx) + (syntax-case stx () + [(_ id contract desc) + (with-syntax ([(arg ...) + (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])) + diff --git a/collects/scribblings/reference/networking.scrbl b/collects/scribblings/reference/networking.scrbl index 238a3673c2..562c9127f8 100644 --- a/collects/scribblings/reference/networking.scrbl +++ b/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 diff --git a/collects/scribblings/reference/pipes.scrbl b/collects/scribblings/reference/pipes.scrbl index ef4a71693d..6c9ae25802 100644 --- a/collects/scribblings/reference/pipes.scrbl +++ b/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 diff --git a/collects/tests/mzscheme/optimize.ss b/collects/tests/mzscheme/optimize.ss index 85b534f3ee..6aef4c91a9 100644 --- a/collects/tests/mzscheme/optimize.ss +++ b/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 diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c index 564403d5e6..28b5d24bdf 100644 --- a/src/mzscheme/src/eval.c +++ b/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 ]) ...) 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 ...) */ 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 ...) */ 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 ) or (void ) */ 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 ) */ 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 ) */ + 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; diff --git a/src/mzscheme/src/module.c b/src/mzscheme/src/module.c index 925a11779d..4d082c4f82 100644 --- a/src/mzscheme/src/module.c +++ b/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 diff --git a/src/mzscheme/src/syntax.c b/src/mzscheme/src/syntax.c index 205aa0a27e..d7aa7c87c0 100644 --- a/src/mzscheme/src/syntax.c +++ b/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;