
;; This module serves as a language module for an optimized version of FrTime.
;; The only thing it exports is a #%module-begin macro that knows how to 
;; perform optimization of FrTime functions.  The rest of the language 
;; (i.e. all the functions needed to actually write FrTime programs) is 
;; provided by the frtime-opt-lang module, which is automatically imported.
(module frtime-opt mzscheme
  (provide (rename my-module-begin #%module-begin)
           #%app #%top #%datum optimize-expr optimize-module dont-optimize)
  
  (require-for-syntax frtime/opt/lowered-equivs)
  (require-for-syntax (only srfi/1 lset-union lset-difference every))
  (require-for-syntax mzlib/list)
  (require (only frtime/core/frp super-lift undefined undefined?))
  (require (rename frtime/lang-ext frtime:lift lift)
           (rename frtime/lang-core frtime:if if)
           (only frtime/lang-core frp:copy-list))
;  (require mzlib/unit mzlib/unitsig)
  
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;; Helper functions
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  ;; prevent a subexpression from being optimized.  Calls to this function
  ;; are specifically recognized, and handled specially.
  (define (dont-optimize x) x)
  
  ;; like module-identifier=?, but returns #f for non-identifier arguments
  ;; instead of throwing an exception
  (define-for-syntax (safe-module-identifier=? id1 id2)
    (and (identifier? id1)
         (identifier? id2)
         (module-identifier=? id1 id2)))
  
  ;; Convert a syntax-object to a datum and back again.  This replaces all
  ;; the context information.  It's necessary to get generated require 
  ;; statements to work, for some reason.
  ;; See http://list.cs.brown.edu/pipermail/plt-scheme/2006-July/014163.html
  (define-for-syntax (so->d->so ref-stx stx)
    (datum->syntax-object ref-stx (syntax-object->datum stx)))
  
  ;; Convert a syntactic module reference to a module-path-index
  (define-for-syntax (module-stx-to-path-index mod-stx)
    (let ([mod (syntax-object->datum mod-stx)])
      (if (symbol? mod) 
          mod
          (module-path-index-join mod #f))))
  
  ;; Convert a syntactic module reference to a module-path (this is 
  ;; subtly different from a module-path-index)
  (define-for-syntax (module-stx-to-path mod-stx)
    (syntax-object->datum mod-stx))
  
  ;; Does the given module export the given id?
  (define-for-syntax (module-exports-id? mod-stx id-stx)
    (not (module-provide-protected? (module-stx-to-path-index mod-stx) 
                                    (syntax-e id-stx))))

  ;; Returns all the identifiers exported by a module
  (define-for-syntax (all-provided-ids mod-stx ref-stx)
    ;; we get exn:fail:filesystem if the module doesn't exist.
    ;; we get exn:fail:contract during compilation if compiling a module that 
    ;; imports mred.
    (with-handlers ([exn:fail:filesystem? (lambda (exn) null)]
                    [exn:fail:contract? (lambda (exn) null)])
      (let ([mod-path (module-stx-to-path mod-stx)]
            [mod-path-index (module-stx-to-path-index mod-stx)])
        ;; instantiate the module so we can call module->namespace on it
        (dynamic-require mod-path #f)
        ;; get the list of provided symbols
        (let* ([all-symbols (namespace-mapped-symbols (module->namespace mod-path))]
               [exported-symbols (filter 
                                  (lambda (id) (not (module-provide-protected? mod-path-index id)))
                                  all-symbols)]
               [exported-ids (map
                              (lambda (symbol) (datum->syntax-object ref-stx symbol))
                              exported-symbols)])
          exported-ids))))
  
  ;; This macro takes a list of variables and an expression.
  ;; The variables are projected before evaluating the expression,
  ;; and the result is then injected into the dataflow graph as a
  ;; single node.
  (require (only frtime/core/frp proc->signal value-now))
  (define-syntax (dip stx)
    (syntax-case stx (begin)
      ;; special case: don't dip lone identifiers
      [(_ (VAR ...) VAR2)
       (identifier? #'VAR2)
       #'VAR2]
      
      ;; special case: strip off unnecessary begins
      [(_ (VAR ...) (begin E))
       #'(dip (VAR ...) E)]

      ;; special case: don't bother dipping if there are no dependencies
      [(_ () EXPR)
       #'EXPR]
      
      ;; general case: wrap the subexpression in a lambda, and lift it
      [(_ (VAR ...) EXPR)
       #'(frtime:lift 
          #t
          (lambda (VAR ...) EXPR)
          VAR ...)]))
  
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;; Module-level optimization
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  

  ;; Wrap the entire module body in an optimize-module macro.
  (define-syntax (my-module-begin stx)
    (syntax-case stx ()
      [(_ FORMS ...)
       (let* (;; get a list of all the symbols provided by the frtime-opt-lang module
              [lang-symbols (all-provided-ids #'frtime/opt/frtime-opt-lang stx)]
              ;; convert those symbols into an equiv-map by pairing up functions
              ;; with their lowered equivalents
              [lang-equiv-map (symbol-list-to-equiv-map lang-symbols)]
              ;; convert the equiv-map to syntax so we can embed it in the call
              ;; to optimize-module
              [equiv-map-stx (equiv-map-to-stx lang-equiv-map)])
         #`(#%plain-module-begin 
            (require-for-syntax #,(so->d->so stx #`mzscheme))
            (require #,(so->d->so stx #`frtime/opt/frtime-opt-lang))
            (optimize-module #,equiv-map-stx FORMS ...)))]))
  
  
  ;; Expand a module body until it's just top-level definitions, and then
  ;; separately optimize each kind of top-level definition.
  (define-syntax (optimize-module stx)
    (syntax-case stx ()
      [(_ EQUIV-MAP)
       #`(begin)]

      [(_ EQUIV-MAP FORM FORMS ...)
       (let ([expanded-form 
              (local-expand #'FORM 'module 
                            (list #'begin #'begin0 #'#%provide #'#%require
                                  #'define-syntaxes #'define-values-for-syntax
                                  #'define-values #'#%app #'unit #'unit/sig))])
         (syntax-case expanded-form (begin begin0 #%provide #%require
                                           define-syntaxes define-values-for-syntax
                                           define-values #%app)
           ;; explode top-level begin statements
           [(begin MORE-FORMS ...)
            #`(optimize-module EQUIV-MAP MORE-FORMS ... FORMS ...)]

           ;; require
           [(#%require . __)
            #`(optimize-require EQUIV-MAP #,expanded-form FORMS ...)]
           
           ;; provide
           [(#%provide . __)
            ;; TBD: provide lowered equivs as well.
            ;; TBD: support frtime-specific provide specs (lifted, etc)
            #`(begin #,expanded-form
                     (optimize-module EQUIV-MAP FORMS ...))]
 
           ;; syntax definitions
           [(define-syntaxes . __)
            #`(begin #,expanded-form
                     (optimize-module EQUIV-MAP FORMS ...))]
           [(define-values-for-syntax . __)
            #`(begin #,expanded-form
                     (optimize-module EQUIV-MAP FORMS ...))]
           
           ;; top-level variable definitions
           [(define-values (ID ...) VAL)
            #`(begin
                (optimize-definition EQUIV-MAP #,expanded-form FORMS ...))]
           
           ;; expressions
           [else
            #`(begin
                (optimize-expr EQUIV-MAP #,expanded-form)
                (optimize-module EQUIV-MAP FORMS ...))]))]))
  
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;; Require/Provide handling
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  
  
  ;; Rewrite require forms so that they import not only regular identifiers,
  ;; but also lowered equivalents, and add those lowered equivs to the equiv map.
  (define-syntax (optimize-require stx)
    
    ;; Take a module and a list of identifiers, and return the list of 
    ;; associated lowered equivalents (for those identifiers that have one).
    (define (module-lowered-equivs mod-stx id-stx-list)
      (map make-lowered-equiv-id 
           (filter (lambda (id-stx)
                     (module-exports-id? mod-stx (make-lowered-equiv-id id-stx)))
                   id-stx-list)))
    
    (syntax-case stx (#%require)
      [(_ EQUIV-MAP (#%require SPEC) FORMS ...)
       ;; In the code below, we must convert syntax objects to datums, and then
       ;; back again.  Otherwise the generated require statement doesn't 
       ;; seem to work properly (it doesn't import the correct identifiers).
       ;; See http://list.cs.brown.edu/pipermail/plt-scheme/2006-July/014163.html
       (syntax-case #'SPEC (only prefix all-except prefix-all-except rename 
                                 lifted lifted:nonstrict as-is as-is:unchecked)
         [(only MOD ID ...)
          ;; Add lowered equivs to the list of ids to import
          (let ([lowered-equivs
                 (module-lowered-equivs #'MOD (syntax->list #'(ID ...)))]
                [new-equiv-map #'EQUIV-MAP])
            #`(begin
                (require #,(so->d->so #'MOD #`(only MOD ID ... . #,lowered-equivs)))
                (optimize-module #,new-equiv-map FORMS ...)))]
      
         [(prefix PFX MOD)
          ;; Requiring the entire module with a prefix will automatically import
          ;; the lowered-equiv bindings with the same prefix.
          (let ([new-equiv-map #'EQUIV-MAP])
            #`(begin
                (require #,(so->d->so #'MOD #`(prefix PFX MOD)))
                (optimize-module #,new-equiv-map FORMS ...)))]
      
         [(all-except MOD ID ...)
          ;; Add the lowered-equiv ids to the exclude list.  If they aren't actually
          ;; provided by the module then they will be silently ignored.
          (let ([lowered-equivs
                 (module-lowered-equivs #'MOD (syntax->list #'(ID ...)))]
                [new-equiv-map #'EQUIV-MAP])
            #`(begin
                (require #,(so->d->so #'MOD #`(all-except MOD ID ... . #,lowered-equivs)))
                (optimize-module #,new-equiv-map FORMS ...)))]
      
         [(prefix-all-except PFX MOD ID ...)
          ;; Add the lowered-equiv bindings to the exclude list.
          (let ([lowered-equivs
                 (module-lowered-equivs #'MOD (syntax->list #'(ID ...)))]
                [new-equiv-map #'EQUIV-MAP])
            #`(begin
                (require #,(so->d->so #'MOD #`(prefix-all-except PFX MOD ID ... . #,lowered-equivs)))
                (optimize-module #,new-equiv-map FORMS ...)))]
      
         [(rename MOD LOCAL-ID EXPORTED-ID)
          ;; Rename the lowered-equiv binding as well.
          (let* ([exported-lowered-equiv-id (make-lowered-equiv-id #'EXPORTED-ID)]
                 [local-lowered-equiv-id (make-lowered-equiv-id #'LOCAL-ID)]
                 [has-lowered-equiv (module-exports-id? #'MOD
                                                        exported-lowered-equiv-id)])
            (if has-lowered-equiv
                #`(begin
                    (require #,(so->d->so #'MOD #`(rename MOD LOCAL-ID EXPORTED-ID)))
                    (require #,(so->d->so #'MOD #`(rename MOD 
                                                          #,local-lowered-equiv-id
                                                          #,exported-lowered-equiv-id)))
                    (optimize-module ((LOCAL-ID #,local-lowered-equiv-id) . EQUIV-MAP) FORMS ...))
                #`(begin
                    (require #,(so->d->so #'MOD #`(rename MOD LOCAL-ID EXPORTED-ID)))
                    (optimize-module EQUIV-MAP FORMS ...))))]
         
         [(LIFTED MOD ID)
          ;; import the identifier itself as the lowered equiv, and define a new, lifted, version.
          (and (identifier? #'LIFTED)
               (or (free-identifier=? #'LIFTED #'lifted)
                   (free-identifier=? #'LIFTED #'lifted:nonstrict)))
          (let* ([lowered-equiv-id (make-lowered-equiv-id #'ID)]
                 [strict? (datum->syntax-object #'MOD (free-identifier=? #'LIFTED #'lifted))])
            #`(begin
                (require #,(so->d->so #'MOD #`(rename MOD #,lowered-equiv-id ID)))
                (define (ID . args) (apply frtime:lift #,strict? #,lowered-equiv-id args))
                (optimize-require ((ID #,lowered-equiv-id) . EQUIV-MAP) FORMS ...)))]
         [(LIFTED MOD ID IDS ...)
          ;; only import one lifted identifier at a time
          (and (identifier? #'LIFTED)
               (or (free-identifier=? #'LIFTED #'lifted)
                   (free-identifier=? #'LIFTED #'lifted:nonstrict)))
          #`(optimize-require EQUIV-MAP 
                              (require (LIFTED MOD ID)) 
                              (require (LIFTED MOD IDS ...)) 
                              FORMS ...)]
         
         [(AS-IS MOD IDS ...)
          ;; as-is and as-is:unchecked are treated just like (require (only ...))
          (and (identifier? #'AS-IS)
               (or (free-identifier=? #'AS-IS #'as-is)
                   (free-identifier=? #'AS-IS #'as-is:unchecked)))
          #`(optimize-require EQUIV-MAP 
                              (require #,(so->d->so #'MOD #`(only MOD IDS ...)))
                              FORMS ...)]
         
         [MOD
          ;; Requiring an entire module will automatically import the lowered-equiv
          ;; bindings, so we don't need to change the require directive itself, just
          ;; the equiv map.
          ;; Vote: it's very important to use #'SPEC as the ref-stx here.  If you 
          ;; use #'MOD or stx instead, then the identifiers returned by all-provided-ids
          ;; will not be module-identifier=? to the identifiers in the actual code.
          ;; TBD: make the initial import of frtime-opt-lang use this same mechanism.
          (let* ([additional-equiv-map (symbol-list-to-equiv-map 
                                        (all-provided-ids #'MOD #'SPEC))]
                 [new-equiv-map-stx (equiv-map-to-stx
                                     (union-equiv-maps additional-equiv-map
                                                       (stx-to-equiv-map #'EQUIV-MAP)))])
            #`(begin (require MOD)
                     (optimize-module #,new-equiv-map-stx FORMS ...)))]
         )]
      
      [(_ EQUIV-MAP (#%require SPECS ...) FORMS ...)
       ;; Process each require spec individually.
       #`(optimize-require EQUIV-MAP (require SPECS) ... FORMS ...)]
      ))

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;; Expression optimization
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  

  ;; Helper functions for working with dipped expressions
  (define-for-syntax (dipped? stx)
    (syntax-case stx (dip)
      [(dip . _) #t]
      [ELSE #f]))
  (define-for-syntax (get-dipped-expr stx)
    (syntax-case stx (dip)
      [(dip DEPS EXPR) 
       #'EXPR]))
  (define-for-syntax (get-dipped-deps stx)
    (syntax-case stx (dip)
      [(dip (DEP ...) EXPR) 
       (syntax->list #'(DEP ...))]))
  (define-for-syntax (union-id-lists . id-lists)
    (foldl (lambda (l1 l2)
             (lset-union bound-identifier=? l1 l2))
           ()
           id-lists))
  (define-for-syntax (diff-id-lists id-list1 id-list2)
    (lset-difference bound-identifier=? id-list1 id-list2))
  
  ;; return the list of identifiers in an argument list.
  ;; #'(a b c) => (list #'a #'b #'c)
  ;; #'(x y . rest) => (list #'x #'y #'rest)
  ;; #'args => (list #'args)
  (define-for-syntax (extract-args stx)
    (syntax-case stx ()
      [ID
       (identifier? #'ID)
       (list #'ID)]
      [(ID . REST)
       (append (extract-args #'ID)
               (extract-args #'REST))]
      [()
       ()]
      [ELSE
       (raise-syntax-error #f "doesn't look like an arg list" stx)]))
  
  ;; return the rest arg from an argument list.
  ;; #'(a b . rest) => #'rest
  ;; #'args => #'args
  (define-for-syntax (extract-rest-arg stx)
    (syntax-case stx ()
      [ID
       (identifier? #'ID)
       #'ID]
      [(ID . REST)
       (identifier? #'REST)
       #'REST]
      [(ID . REST)
       (extract-rest-arg #'REST)]
      [ELSE
       (raise-syntax-error #f "cannot extract rest arg" stx)]))

  ;; search and replace an identifier in a syntax object
  (define-for-syntax (replace-id stx old-id new-id)
    (syntax-case stx ()
      [ID
       (and (identifier? #'ID)
            (module-identifier=? old-id #'ID))
       new-id]
      [(X . Y)
       (datum->syntax-object 
        stx
        (cons (replace-id #'X old-id new-id)
              (replace-id #'Y old-id new-id)))]
      [()
       ()]
      [ELSE
       stx]))

  ;; return #t if a syntax object refers to a given id
  (define-for-syntax (refers-to-id? stx id)
    (syntax-case stx ()
      [ID
       (and (identifier? #'ID)
            (module-identifier=? id #'ID))
       #t]
      [(X . Y)
       (or (refers-to-id? #'X id)
           (refers-to-id? #'Y id))]
      [ELSE #f]))
  
  ;; Optimize an expression by dipping subexpressions wherever possible.
  ;; 
  ;; Note: this function does not intercept syntax errors due to misused
  ;; certificates.  It's up to the caller to handle that.
  (define-for-syntax (recursively-optimize-expr stx equiv-map lower-lambda)
    (syntax-case stx (#%top #%app quote begin begin0 lambda case-lambda 
                      let-values letrec-values letrec-syntaxes+values 
                      unit unit/sig if super-lift undefined? undefined rename
                      frp:copy-list frp:->boolean dont-optimize)
      
      [(#%top . X)
       #`(dip (X) X)]
      
      [X
       (identifier? #'X)
       #`(dip (X) X)]
      
      [(quote EXPR)
       #`(dip () #,stx)]

      [(BEGIN EXPR ...)
       (and (identifier? #'BEGIN)
            (or (module-identifier=? #'BEGIN #'begin)
                (module-identifier=? #'BEGIN #'begin0)))
       (let* ([optimized-exprs (map (lambda (expr)
                                      (recursively-optimize-expr expr equiv-map #f))
                                    (syntax->list #'(EXPR ...)))]
              [all-exprs-were-dipped (every dipped? optimized-exprs)])
         (if all-exprs-were-dipped
             (let ([deps (apply union-id-lists (map get-dipped-deps optimized-exprs))]
                   [lowered-exprs (map get-dipped-expr optimized-exprs)])
               #`(dip #,deps (begin . #,lowered-exprs)))
             ;; we can't dip the entire subexpression, but we may have been able
             ;; to optimize some of the exprs.
             #`(begin . #,optimized-exprs)))]
      
      [(lambda ARGS (let-values (((REST) (#%app frp:copy-list REST_))) EXPRS ...))
       ;; If frtime sees a lambda with a rest arg, it inserts a call to
       ;; frp:copy-list.  Recognize this pattern and ignore it if we're lowering
       ;; instead of dipping.
       (let* ([rest-arg (extract-rest-arg #`ARGS)]
              ;; have to replace REST to avoid "identifier used out of context" errors
              [body (replace-id #`(begin EXPRS ...) #'REST rest-arg)]
              [optimized-body (recursively-optimize-expr body equiv-map #f)])
         (if (and lower-lambda (dipped? optimized-body))
             (let* ([lowered-body (get-dipped-expr optimized-body)]
                    [body-deps (get-dipped-deps optimized-body)]
                    [new-deps (diff-id-lists body-deps (extract-args #`ARGS))])
               #`(dip #,new-deps (lambda ARGS #,lowered-body)))
             (if (refers-to-id? optimized-body rest-arg)
                 #`(lambda ARGS
                     (let-values (((#,rest-arg) (frp:copy-list #,rest-arg)))
                       #,optimized-body))
                 #`(lambda ARGS #,optimized-body))))]
      
      [(lambda ARGS EXPRS ...)
       ;; If "lower-lambda" is true, then we know that it's safe to lower the
       ;; body of the lambda.  "lower-lambda" should only be true if we know 
       ;; that the result will be immediately bound to a variable that is
       ;; guaranteed never to be called except in a lowered context.  In contrast,
       ;; if we always lowered the body of a lambda, the closure might escape
       ;; to where it could be called with time-varying arguments.
       (let* ([body #`(begin EXPRS ...)]
              [optimized-body (recursively-optimize-expr body equiv-map #f)])
         (if (and lower-lambda (dipped? optimized-body))
             (let* ([lowered-body (get-dipped-expr optimized-body)]
                    [body-deps (get-dipped-deps optimized-body)]
                    [new-deps (diff-id-lists body-deps (extract-args #'ARGS))])
               #`(dip #,new-deps (lambda ARGS #,lowered-body)))
             #`(lambda ARGS #,optimized-body)))]

      [(case-lambda (FORMALS EXPR ...) ...)
       ;; dip each clause separately.  TODO: pay attention to lower-lambda
       (let* ([bodies (syntax->list #`((begin EXPR ...) ...))]
              [optimized-bodies (map (lambda (expr)
                                       (recursively-optimize-expr expr equiv-map #f))
                                     bodies)]
              [args (syntax->list #`(FORMALS ...))]
              [clauses (map list args optimized-bodies)])
         #`(case-lambda . #,clauses))]

      ;; special case: recognize the expanded version of "let loop" and allow
      ;; it to be fully lowered.  Otherwise it ends up calling itself, and since
      ;; we don't define a fully lowered equivalent of the loop itself, then
      ;; whole thing ends up using signal:switching, which is slow.
      ;; TBD: "let loop" embeds its letrec-values in an #%app -- we could 
      ;; recognize this and avoid defining the upper version at all.
      [(#%app (letrec-values (((LOOP) BODY))
                LOOP_) ARG ...)
       (and (identifier? #'LOOP)
            (identifier? #'LOOP_)
            (module-identifier=? #'LOOP #'LOOP_))
       (let* ([optimized-args (map (lambda (e)
                                     (recursively-optimize-expr e equiv-map #f))
                                   (syntax->list #'(ARG ...)))]
              [loop-lowered-id (make-lowered-equiv-id #'LOOP)]
              [extended-equiv-map (add-equiv-map equiv-map #'LOOP loop-lowered-id)]
              ;; allow lambdas to be lowered, because "let loop" generates a lambda
              [lowered-body (recursively-optimize-expr #'BODY extended-equiv-map #t)])
         ;; if the body can be fully lowered, and the lower version doesn't refer to
         ;; the upper version, then we can define both an upper and a lower definition, 
         ;; and return the upper one. 
         (if (dipped? lowered-body)
             (if (every dipped? optimized-args)
                 ;; all the args were dippable -- we can lower the *entire* thing, and
                 ;; do away with the upper version of the loop.
                 (let* ([lowered-expr (get-dipped-expr lowered-body)]
                        [lowered-deps (get-dipped-deps lowered-body)]
                        [deps (apply union-id-lists lowered-deps 
                                     (map get-dipped-deps optimized-args))])
                   #`(dip #,deps 
                          (#%app (letrec-values (((#,loop-lowered-id) #,lowered-expr))
                                   #,loop-lowered-id)
                                 #,@(map get-dipped-expr optimized-args))))
                 ;; at least one arg wasn't dippable, so we have to keep the upper version,
                 ;; and we can't dip the entire expression.
                 (let* ([optimized-body (recursively-optimize-expr #'BODY extended-equiv-map #f)]
                        [lowered-expr (get-dipped-expr lowered-body)]
                        [lowered-deps (get-dipped-deps lowered-body)]
                        [deps (diff-id-lists lowered-deps (list #'LOOP))])
                   #`(#%app (dip #,deps 
                                 (letrec-values (((#,loop-lowered-id) #,lowered-expr)
                                                 ((LOOP) #,optimized-body))
                                   LOOP))
                            #,@optimized-args)))
             (let* ([optimized-body (recursively-optimize-expr #'BODY equiv-map #f)])
               #`(#%app (letrec-values (((LOOP) #,optimized-body)) 
                          LOOP)
                        #,@optimized-args))))]
       
      [(LET-VALUES ((VARS VALS) ...) EXPR ...)
       (and (identifier? #'LET-VALUES)
            (or (module-identifier=? #'LET-VALUES #'let-values)
                (module-identifier=? #'LET-VALUES #'letrec-values)))
       (let* ([bindings (syntax->list #'(VARS ...))]
              [flattened-bindings (apply append (map syntax->list bindings))]
              [body #`(begin EXPR ...)]
              [optimized-body (recursively-optimize-expr body equiv-map lower-lambda)]
              ;; TBD: consider defining lowered equivs for local bindings
              [optimized-vals (map (lambda (arg)
                                     (recursively-optimize-expr arg equiv-map #f))
                                   (syntax->list #'(VALS ...)))]
              [all-exprs-were-dipped (and (dipped? optimized-body)
                                          (every dipped? optimized-vals))])
         (if all-exprs-were-dipped
             (let* ([val-deps (apply append (map get-dipped-deps optimized-vals))]
                    [new-deps (union-id-lists
                               (diff-id-lists (get-dipped-deps optimized-body) 
                                              flattened-bindings)
                               val-deps)]
                    [lowered-body (get-dipped-expr optimized-body)]
                    [lowered-vals (map get-dipped-expr optimized-vals)])
               #`(dip #,new-deps
                      (LET-VALUES #,(map list bindings lowered-vals)
                                  #,lowered-body)))
             #`(LET-VALUES #,(map list bindings optimized-vals)
                           #,optimized-body)))]

      [(letrec-syntaxes+values SYNTAX-STUFF ((IDS VALS) ...) EXPR ...)
       (let* ([optimized-vals
               (map (lambda (e)
                      (recursively-optimize-expr e equiv-map #f))
                    (syntax->list #'(VALS ...)))]
              [optimized-bindings
               (map list (syntax->list #'(IDS ...)) optimized-vals)]
              [body #`(begin EXPR ...)]
              [optimized-body (recursively-optimize-expr body equiv-map #f)])
       #`(letrec-syntaxes+values SYNTAX-STUFF #,optimized-bindings #,optimized-body))]
      
      [(if . ARGS)
       (let* ([optimized-args (map (lambda (expr)
                                     (recursively-optimize-expr expr equiv-map #f))
                                   (syntax->list #'ARGS))]
              [all-args-were-dipped (every dipped? optimized-args)])
         (if all-args-were-dipped
             ;; we can dip the entire subexpression
             (let ([deps (apply union-id-lists (map get-dipped-deps optimized-args))]
                   [lowered-args (map get-dipped-expr optimized-args)])
               #`(dip #,deps (if . #,lowered-args)))
             ;; we can't dip the entire subexpression, but we may have been able
             ;; to optimize some of the args.
             #`(if . #,optimized-args)))]
      
      ;; frtime's if expands into a complicated expression involving super-lift.  
      ;; recognize this pattern, and treat it like an if statement.
      [(#%app super-lift
              (lambda (_B) (if (#%app undefined? __B)
                               (begin undefined)
                               (if ___B
                                   TRUE-CASE
                                   FALSE-CASE)))
              (#%app _TO_BOOLEAN CONDITIONAL))
       (let* ([optimized-condition  (recursively-optimize-expr #'CONDITIONAL equiv-map #f)]
              [optimized-true-case  (recursively-optimize-expr #'TRUE-CASE equiv-map #f)]
              [optimized-false-case (recursively-optimize-expr #'FALSE-CASE equiv-map #f)])
         (if (and (dipped? optimized-condition)
                  (dipped? optimized-true-case)
                  (dipped? optimized-false-case))
             (let ([lowered-condition  (get-dipped-expr optimized-condition)]
                   [lowered-true-case  (get-dipped-expr optimized-true-case)]
                   [lowered-false-case (get-dipped-expr optimized-false-case)]
                   [deps (union-id-lists (get-dipped-deps optimized-condition)
                                         (get-dipped-deps optimized-true-case)
                                         (get-dipped-deps optimized-false-case))])
               #`(dip #,deps (if #,lowered-condition #,lowered-true-case #,lowered-false-case)))
             #`(frtime:if #,optimized-condition
                          #,optimized-true-case
                          #,optimized-false-case)))]
      
      [(#%app dont-optimize EXPR)
       #'EXPR]
      
      [(#%app FUNC . ARGS)
       (identifier? #'FUNC)
       (let* ([lowered-equiv (lookup-lowered-equiv equiv-map #'FUNC)]
              [optimized-args (map (lambda (expr)
                                     (recursively-optimize-expr expr equiv-map #f))
                                   (syntax->list #'ARGS))]
              [all-args-were-dipped (every dipped? optimized-args)])
         (if (and lowered-equiv all-args-were-dipped)
             ;; we can dip the entire subexpression
             (let ([deps (apply union-id-lists (map get-dipped-deps optimized-args))]
                   [lowered-args (map get-dipped-expr optimized-args)])
               #`(dip #,deps (#%app #,lowered-equiv #,@lowered-args)))
             ;; we can't dip the entire subexpression, but we may have been able
             ;; to optimize some of the args.
             #`(#%app FUNC #,@optimized-args)))]
      
      ;; first-class functions -- we have no idea what function is being called,
      ;; so we can't optimize it.  But try to optimize the subexpressions.
      [(#%app FUNC ARG ...)
       #`(#%app #,(recursively-optimize-expr #'FUNC equiv-map #f)
                #,@(map (lambda (expr)
                          (recursively-optimize-expr expr equiv-map #f))
                        (syntax->list #'(ARG ...))))]
       
      ;; units expand into complicated code that uses set! to define identifiers.
      ;; Since we don't support set!, we optimize units based on their *unexpanded*
      ;; syntax, which is much easier to work with.
      [(unit IMPORTS EXPORTS EXPRS ...)
       #`(unit IMPORTS EXPORTS 
               (optimize-module #,(equiv-map-to-stx equiv-map) EXPRS ...))]
      [(unit/sig SIG IMPORTS (rename RENAMES ...) EXPRS ...)
       #`(unit/sig SIG IMPORTS (rename RENAMES ...)
           (optimize-module #,(equiv-map-to-stx equiv-map) EXPRS ...))]
      [(unit/sig SIG IMPORTS EXPRS ...)
       #`(unit/sig SIG IMPORTS 
           (optimize-module #,(equiv-map-to-stx equiv-map) EXPRS ...))]

      [ELSE
       (raise-syntax-error #f
                           (format "recursively-lower-expr: unrecognized syntax: ~a" (syntax-object->datum stx))
                           stx)]))
  
  ;; Optimize a single expression.  Raises exn:fail:syntax if the optimized version
  ;; would use a protected identifier in an uncertified context.
  (define-for-syntax (optimize-expr-helper stx equiv-map allow-lambda)
    ;; Expand everything but references to identifiers, and units.
    ;; References to identifiers can't be expanded because they might not be 
    ;; defined yet, in which case we'll get a syntax error.  Units can't be 
    ;; expanded because they expand into highly indirect code that uses set! 
    ;; to define structures, and we don't support set! -- so instead we handle 
    ;; units explicitly.
    (let* ([expanded-stx (local-expand stx 'top-level (list #'#%top #'unit #'unit/sig))]
           [optimized-stx (recursively-optimize-expr expanded-stx equiv-map allow-lambda)])
      ;; expand the result so that if we happen to have a reference to a
      ;; protected identifier in an uncertified context, then we can 
      ;; trigger an exception, thus giving us the chance to rollback our
      ;; changes and return the original code unmodified.
      (local-expand optimized-stx 'top-level (list #'#%top)) ;; expand units, too
      ;; return the unexpanded result, so that callers can figure out whether
      ;; the expression was completely dipped or not.
      optimized-stx))

  ;; Macro to optimize a single expression.  The expression will be dipped
  ;; wherever possible, and its observable semantics will remain unchanged.
  (define-syntax (optimize-expr stx)
    (syntax-case stx ()
      [(_ EQUIV-MAP EXPR)
       (with-handlers ([exn:fail:syntax?
                            (lambda (exn)
                              #`(begin #,(exn-message exn) EXPR))])
         (let* ([equiv-map (stx-to-equiv-map #'EQUIV-MAP)])
            (optimize-expr-helper #'EXPR equiv-map #f)))]))
  
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;; Definitions
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  
  ;; returns multiple values:
  ;;   * new equiv map
  ;;   * optimized value
  ;;   * lowered equiv id (or #f if unlowerable)
  ;;   * lowered equiv value (or #f if unlowerable)
  (define-for-syntax (optimize-definition-helper equiv-map id val)
    (with-handlers 
        ([exn:fail:syntax? (lambda (exn) 
                             (values equiv-map
                                     #`(begin #,(exn-message exn) #,val)
                                     #f
                                    #f))])
      (let* ([lowered-equiv-id (make-lowered-equiv-id id)]
             [new-equiv-map (add-equiv-map equiv-map id lowered-equiv-id)]
             [lowered-val   (optimize-expr-helper val new-equiv-map #t)])
        (if (and (dipped? lowered-val)
                 (null? (get-dipped-deps lowered-val)))
            ;; use new-equiv-map in order to allow the dipped version to call 
            ;; the lowered version for recursive calls.
            (let ([optimized-val (optimize-expr-helper val new-equiv-map #f)])
              (values new-equiv-map 
                      optimized-val
                      lowered-equiv-id
                      (get-dipped-expr lowered-val)))
            ;; use the old equiv-map, since there is no lowered version so the
            ;; dipped version can't call it
            (let ([optimized-val (optimize-expr-helper val equiv-map #f)])
              (values equiv-map
                      optimized-val
                      #f
                      #f))))))
  
  ;; Optimize a top-level variable binding, by lowering its value.
  (define-syntax (optimize-definition stx)
    (syntax-case stx (define-values values)
      [(_ EQUIV-MAP (define-values (ID) VAL) FORMS ...)
       ;; if this is a lowered equiv definition, add it to our equiv map
       (lowered-equiv-id? #'ID)
       (let ([lifted-id (lowered-equiv-id->lifted-id #'ID)])
         #`(begin
             (define-values (ID) VAL)
             (optimize-module ((#,lifted-id ID) . EQUIV-MAP) FORMS ...)))]

      [(_ EQUIV-MAP (define-values (ID) VAL) FORMS ...)
       ;; We're defining a single identifier
       (let-values ([(new-equiv-map optimized-val lowered-equiv-id lowered-val)
                     (optimize-definition-helper (stx-to-equiv-map #'EQUIV-MAP)
                                                 #'ID 
                                                 #'VAL)])
         (if (and lowered-equiv-id lowered-val)
             #`(begin
                 (define ID #,optimized-val)
                 (define #,lowered-equiv-id #,lowered-val)
                 (optimize-module #,(equiv-map-to-stx new-equiv-map) FORMS ...))
             #`(begin
                 (define ID #,optimized-val)
                 (optimize-module #,(equiv-map-to-stx new-equiv-map) FORMS ...))))]
      
      [(_ EQUIV-MAP (define-values (ID ...) (values VAL ...)) FORMS ...)
       (= (length (syntax->list #'(ID ...)))
          (length (syntax->list #'(VAL ...))))
       ;; Very common special case: the multiple identifiers are immediately combined
       ;; with multiple values.  Common enough that it's worth handling specially.
       (let ([new-equiv-map (stx-to-equiv-map #'EQUIV-MAP)]
             [ids null]
             [vals null])
         (for-each (lambda (id val)
                     (let-values ([(em optimized-val lowered-equiv-id lowered-val)
                                   (optimize-definition-helper new-equiv-map id val)])
                       (set! new-equiv-map em)
                       (when (and lowered-equiv-id lowered-val)
                             (set! ids (cons lowered-equiv-id ids))
                             (set! vals (cons lowered-val vals)))
                       (set! ids (cons id ids))
                       (set! vals (cons optimized-val vals))))
                   (syntax->list #'(ID ...)) 
                   (syntax->list #'(VAL ...)))
         #`(begin
             (define-values #,ids (values . #,vals))
             (optimize-module #,(equiv-map-to-stx new-equiv-map) FORMS ...)))]
       
      [(_ EQUIV-MAP (define-values (ID ...) EXPR) FORMS ...)
       ;; We're binding multiple identifiers with some arbitrary set of values,
       ;; so we can't define lowered-equivs because we can't tease apart the
       ;; various values.  So just optimize the value expression as a whole.
       #`(begin
           (define-values (ID ...) (optimize-expr EQUIV-MAP EXPR))
           (optimize-module EQUIV-MAP FORMS ...))]))
)
