+(define (canonicalize exp)
+ (post-order
+ (lambda (exp)
+ (match exp
+ (($ <primcall> src 'vector
+ (and args
+ ((or ($ <const>) ($ <void>) ($ <lambda>) ($ <lexical-ref>))
+ ...)))
+ ;; Some macros generate calls to "vector" with like 300
+ ;; arguments. Since we eventually compile to make-vector and
+ ;; vector-set!, it reduces live variable pressure to allocate the
+ ;; vector first, then set values as they are produced, if we can
+ ;; prove that no value can capture the continuation. (More on
+ ;; that caveat here:
+ ;; http://wingolog.org/archives/2013/11/02/scheme-quiz-time).
+ ;;
+ ;; Normally we would do this transformation in the compiler, but
+ ;; it's quite tricky there and quite easy here, so hold your nose
+ ;; while we drop some smelly code.
+ (let ((len (length args))
+ (v (gensym "v ")))
+ (make-let src
+ (list 'v)
+ (list v)
+ (list (make-primcall src 'make-vector
+ (list (make-const #f len)
+ (make-const #f #f))))
+ (fold (lambda (arg n tail)
+ (make-seq
+ src
+ (make-primcall
+ src 'vector-set!
+ (list (make-lexical-ref src 'v v)
+ (make-const #f n)
+ arg))
+ tail))
+ (make-lexical-ref src 'v v)
+ (reverse args) (reverse (iota len))))))
+
+ (($ <primcall> src 'struct-set! (struct index value))
+ ;; Unhappily, and undocumentedly, struct-set! returns the value
+ ;; that was set. There is code that relies on this. Hackety
+ ;; hack...
+ (let ((v (gensym "v ")))
+ (make-let src
+ (list 'v)
+ (list v)
+ (list value)
+ (make-seq src
+ (make-primcall src 'struct-set!
+ (list struct
+ index
+ (make-lexical-ref src 'v v)))
+ (make-lexical-ref src 'v v)))))
+
+ (($ <prompt> src escape-only? tag body
+ ($ <lambda> hsrc hmeta
+ ($ <lambda-case> _ hreq #f hrest #f () hsyms hbody #f)))
+ exp)
+
+ ;; Eta-convert prompts without inline handlers.
+ (($ <prompt> src escape-only? tag body handler)
+ (let ((h (gensym "h "))
+ (args (gensym "args ")))
+ (make-let
+ src (list 'h) (list h) (list handler)
+ (make-seq
+ src
+ (make-conditional
+ src
+ (make-primcall src 'procedure? (list (make-lexical-ref #f 'h h)))
+ (make-void src)
+ (make-primcall
+ src 'scm-error
+ (list
+ (make-const #f 'wrong-type-arg)
+ (make-const #f "call-with-prompt")
+ (make-const #f "Wrong type (expecting procedure): ~S")
+ (make-primcall #f 'list (list (make-lexical-ref #f 'h h)))
+ (make-primcall #f 'list (list (make-lexical-ref #f 'h h))))))
+ (make-prompt
+ src escape-only? tag body
+ (make-lambda
+ src '()
+ (make-lambda-case
+ src '() #f 'args #f '() (list args)
+ (make-primcall
+ src 'apply
+ (list (make-lexical-ref #f 'h h)
+ (make-lexical-ref #f 'args args)))
+ #f)))))))
+ (_ exp)))
+ exp))
+