ikarus/scheme/ikarus.compiler.altcogen.ss

;;; Ikarus Scheme -- A compiler for R6RS Scheme.
;;; Copyright (C) 2006,2007,2008  Abdulaziz Ghuloum
;;; 
;;; This program is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License version 3 as
;;; published by the Free Software Foundation.
;;; 
;;; This program is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; General Public License for more details.
;;; 
;;; You should have received a copy of the GNU General Public License
;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.


(module (alt-cogen compile-call-frame)
;;; input to cogen is <Program>:
;;;  <Expr> ::= (constant x)
;;;           | (var)
;;;           | (primref name)
;;;           | (bind var* <Expr>* <Expr>)
;;;           | (fix var* <FixRhs>* <Expr>)
;;;           | (conditional <Expr> <Expr> <Expr>)
;;;           | (seq <Expr> <Expr>)
;;;           | (closure <codeloc> <var>*)  ; thunk special case
;;;           | (forcall "name" <Expr>*)
;;;           | (funcall <Expr> <Expr>*)
;;;           | (jmpcall <label> <Expr> <Expr>*)
;;;           | (mvcall <Expr> <clambda>)
;;;  <codeloc> ::= (code-loc <label>)
;;;  <clambda> ::= (clambda <label> <case>* <cp> <free var>*) 
;;;  <case>    ::= (clambda-case <info> <body>)
;;;  <info>    ::= (clambda-info label <arg var>* proper)
;;;  <Program> ::= (codes <clambda>* <Expr>)


(define (introduce-primcalls x)
  ;;;
  (define who 'introduce-primcalls)
  ;;;
  (define (check-gensym x)
    (unless (gensym? x)
      (error who "invalid gensym" x)))
  ;;;
  (define (check-label x)
    (struct-case x
      [(code-loc label)
       (check-gensym label)]
      [else (error who "invalid label" x)]))
  ;;;
  (define (check-var x)
    (struct-case x 
      [(var) (void)]
      [else (error who "invalid var" x)]))
  ;;;
  (define (check-closure x)
    (struct-case x
      [(closure label free*)
       (check-label label)
       (for-each check-var free*)]
      [else (error who "invalid closure" x)]))
  ;;;
  (define (mkfuncall op arg*)
    (define (primop? x)
      (import primops)
      (or (eq? x 'debug-call) (primop? x)))
    (struct-case op
      [(known x t)
       (struct-case x
         [(primref name)
          (if (primop? name)
              (make-primcall name arg*)
              (make-funcall op arg*))]
         [else (make-funcall op arg*)])]
      [(primref name)
       (cond
         [(primop? name)
          (make-primcall name arg*)]
         [else (make-funcall op arg*)])]
      [else (make-funcall op arg*)]))
  ;;;
  (define (A x)
    (struct-case x
      [(known x t) (make-known (Expr x) t)]
      [else (Expr x)]))
  (define (Expr x)
    (struct-case x
      [(constant) x]
      [(var)      x]
      [(primref)  x]
      [(bind lhs* rhs* body)
       (make-bind lhs* (map Expr rhs*) (Expr body))]
      [(fix lhs* rhs* body)
       (make-fix lhs* rhs* (Expr body))]
      [(conditional e0 e1 e2) 
       (make-conditional (Expr e0) (Expr e1) (Expr e2))]
      [(seq e0 e1)
       (make-seq (Expr e0) (Expr e1))]
      [(closure) x]
      [(forcall op arg*)
       (make-forcall op (map Expr arg*))]
      [(funcall rator arg*)
       (mkfuncall (A rator) (map A arg*))]
      [(jmpcall label rator arg*)
       (make-jmpcall label (Expr rator) (map Expr arg*))]
      [else (error who "invalid expr" x)]))
  ;;;
  (define (ClambdaCase x)
    (struct-case x
      [(clambda-case info body)
       (make-clambda-case info (Expr body))]
      [else (error who "invalid clambda-case" x)]))
  ;;;
  (define (Clambda x)
    (struct-case x
      [(clambda label case* cp free* name)
       (make-clambda label (map ClambdaCase case*) cp free* name)]
      [else (error who "invalid clambda" x)]))
  ;;;
  (define (Program x)
    (struct-case x 
      [(codes code* body)
       (make-codes (map Clambda code*) (Expr body))]
      [else (error who "invalid program" x)]))
  ;;;
  (Program x))


(define (eliminate-fix x)
  ;;;
  (define who 'eliminate-fix)
  ;;;
  (define (Expr main-cpvar cpvar free*)
    ;;;
    (define (Var x)
      (cond
        [(eq? x main-cpvar) cpvar]
        [else
         (let f ([free* free*] [i 0])
           (cond
             [(null? free*) x]
             [(eq? x (car free*))
              (make-primcall '$cpref (list cpvar (make-constant i)))]
             [else (f (cdr free*) (fxadd1 i))]))]))
    (define (do-fix lhs* rhs* body)
      (define (handle-closure x)
        (struct-case x
          [(closure code free* well-known?) 
           (make-closure code (map Var free*) well-known?)]))
      (make-fix lhs* (map handle-closure rhs*) body))
    (define (A x)
      (struct-case x
        [(known x t) (make-known (Expr x) t)]
        [else (Expr x)]))
    (define (Expr x)
      (struct-case x
        [(constant) x]
        [(var)      (Var x)]
        [(primref)  x]
        [(bind lhs* rhs* body)
         (make-bind lhs* (map Expr rhs*) (Expr body))]
        [(fix lhs* rhs* body)
         (do-fix lhs* rhs* (Expr body))]
        [(conditional e0 e1 e2) 
         (make-conditional (Expr e0) (Expr e1) (Expr e2))]
        [(seq e0 e1)
         (make-seq (Expr e0) (Expr e1))]
        [(closure)
         (let ([t (unique-var 'tmp)])
           (Expr (make-fix (list t) (list x) t)))]
        [(primcall op arg*)
         (make-primcall op (map A arg*))]
        [(forcall op arg*)
         (make-forcall op (map Expr arg*))]
        [(funcall rator arg*)
         (make-funcall (A rator) (map A arg*))]
        [(jmpcall label rator arg*)
         (make-jmpcall label (Expr rator) (map Expr arg*))]
        [else (error who "invalid expr" x)]))
    Expr)
  ;;;
  (define (ClambdaCase main-cp free*)
    (lambda (x)
      (struct-case x
        [(clambda-case info body)
         (struct-case info
           [(case-info label args proper)
            (let ([cp (unique-var 'cp)])
              (make-clambda-case 
                (make-case-info label (cons cp args) proper)
                ((Expr main-cp cp free*) body)))])]
        [else (error who "invalid clambda-case" x)])))
  ;;;
  (define (Clambda x)
    (struct-case x
      [(clambda label case* cp free* name)
       (make-clambda label (map (ClambdaCase cp free*) case*) 
                     #f free* name)]
      [else (error who "invalid clambda" x)]))
  ;;;
  (define (Program x)
    (struct-case x 
      [(codes code* body)
       (make-codes (map Clambda code*) ((Expr #f #f '()) body))]
      [else (error who "invalid program" x)]))
  ;;;
  (Program x))


(define-syntax seq*
  (syntax-rules ()
    [(_ e) e]
    [(_ e* ... e) 
     (make-seq (seq* e* ...) e)]))

(define (insert-engine-checks x)
  (define who 'insert-engine-checks)
  (define (known-primref? x)
    (struct-case x
      [(known x t) (known-primref? x)]
      [(primref)   #t]
      [else #f]))
  (define (A x)
    (struct-case x
      [(known x t) (Expr x)]
      [else (Expr x)]))
  (define (Expr x) 
    (struct-case x
      [(constant)                 #f]
      [(var)                      #f]
      [(primref)                  #f]
      [(jmpcall label rator arg*) #t]
      [(funcall rator arg*)
       (if (known-primref? rator) (ormap A arg*) #t)]
      [(bind lhs* rhs* body)      (or (ormap Expr rhs*) (Expr body))]
      [(fix lhs* rhs* body)       (Expr body)]
      [(conditional e0 e1 e2)     (or (Expr e0) (Expr e1) (Expr e2))]
      [(seq e0 e1)                (or (Expr e0) (Expr e1))]
      [(primcall op arg*)         (ormap A arg*)]
      [(forcall op arg*)          (ormap Expr arg*)]
      [else (error who "invalid expr" x)]))
  (define (Main x)
    (if (Expr x)
        (make-seq (make-primcall '$do-event '()) x)
        x))
  (define (CaseExpr x)
    (struct-case x 
      [(clambda-case info body)
       (make-clambda-case info (Main body))]))
  (define (CodeExpr x)
    (struct-case x
      [(clambda L cases cp free name)
       (make-clambda L (map CaseExpr cases) cp free name)]))
  (define (CodesExpr x)
    (struct-case x 
      [(codes list body)
       (make-codes (map CodeExpr list) (Main body))]))
  (CodesExpr x))


(define (insert-stack-overflow-check x)
  (define who 'insert-stack-overflow-check)
  (define (A x)
    (struct-case x
      [(known x t) (NonTail x)]
      [else (NonTail x)]))
  (define (NonTail x)
    (struct-case x
      [(constant)                 #f]
      [(var)                      #f]
      [(primref)                  #f]
      [(funcall rator arg*)       #t]
      [(jmpcall label rator arg*) #t]
      [(mvcall rator k)           #t] 
      [(primcall op arg*)     (ormap A arg*)] ;PUNT!!! FIXME!
      [(bind lhs* rhs* body)  (or (ormap NonTail rhs*) (NonTail body))]
      [(fix lhs* rhs* body)   (NonTail body)]
      [(conditional e0 e1 e2) (or (NonTail e0) (NonTail e1) (NonTail e2))]
      [(seq e0 e1)            (or (NonTail e0) (NonTail e1))]
      [(forcall op arg*)      (ormap NonTail arg*)]
      [(known x t) (NonTail x)]
      [else (error who "invalid expr" x)]))
  (define (Tail x) 
    (struct-case x
      [(constant) #f]
      [(var)      #f]
      [(primref)  #f]
      [(bind lhs* rhs* body)      (or (ormap NonTail rhs*) (Tail body))]
      [(fix lhs* rhs* body)       (Tail body)]
      [(conditional e0 e1 e2)     (or (NonTail e0) (Tail e1) (Tail e2))]
      [(seq e0 e1)                (or (NonTail e0) (Tail e1))]
      [(primcall op arg*)         (ormap NonTail arg*)]
      [(forcall op arg*)          (ormap NonTail arg*)]
      [(funcall rator arg*)       (or (NonTail rator) (ormap NonTail arg*))]
      [(jmpcall label rator arg*) (or (NonTail rator) (ormap NonTail arg*))]
      [(mvcall rator k) #t] ; punt
      [else (error who "invalid expr" x)]))
  (define (insert-check x)
    (make-seq (make-primcall '$stack-overflow-check '()) x))
  (define (ClambdaCase x)
    (struct-case x
      [(clambda-case info body)
       (make-clambda-case info (Main body))]))
  (define (Clambda x)
    (struct-case x
      [(clambda label case* cp free* name)
       (make-clambda label (map ClambdaCase case*) cp free* name)]))
  (define (Main x)
    (if (Tail x)
        (insert-check x) 
        x))
  (define (Program x)
    (struct-case x 
      [(codes code* body)
       (make-codes (map Clambda code*) (Main body))]))
  (Program x))

(include "pass-specify-rep.ss")

(define parameter-registers '(%edi)) 
(define return-value-register '%eax)
(define cp-register '%edi)
(define all-registers 
  (case wordsize
    [(4) '(%eax %edi %ebx %edx %ecx)]
    [else '(%eax %edi %ebx %edx %ecx %r8 %r9 %r10 %r11 %r14 %r15)]))

(define non-8bit-registers 
  (case wordsize
    [(4) '(%edi)]
    [else '(%edi)]))

(define argc-register '%eax)

;;; apr = %ebp
;;; esp = %esp
;;; pcr = %esi
;;; cpr = %edi

(define (register-index x)
  (cond
    [(assq x '([%eax 0] [%edi 1] [%ebx 2] [%edx 3] 
               [%ecx 4] [%esi 5] [%esp 6] [%ebp 7])) 
     => cadr]
    [else (error 'register-index "not a register" x)]))

(define (impose-calling-convention/evaluation-order x)
  (define who 'impose-calling-convention/evaluation-order)
  ;;;
  ;;;
  (define (S* x* k)
    (cond
      [(null? x*) (k '())]
      [else
       (S (car x*)
          (lambda (a)
            (S* (cdr x*)
                (lambda (d)
                  (k (cons a d))))))]))
  ;;;
  (define (S x k)
    (struct-case x
      [(bind lhs* rhs* body)
       (do-bind lhs* rhs* (S body k))]
      [(seq e0 e1)
       (make-seq (E e0) (S e1 k))]
      [(known x) (S x k)]
      [else
       (cond
         [(or (constant? x) (symbol? x)) (k x)]
         [(var? x) 
          (cond
            [(var-loc x) => k]
            [else (k x)])]
         [(or (funcall? x) (primcall? x) (jmpcall? x)
              (forcall? x) (shortcut? x)
              (conditional? x))
          (let ([t (unique-var 'tmp)])
            (do-bind (list t) (list x)
              (k t)))]
         [else (error who "invalid S" x)])]))
  (define (Mem x k) 
    (struct-case x 
      [(primcall op arg*) 
       (if (eq? op 'mref)
           (S* arg*
              (lambda (arg*)
                 (k (make-disp (car arg*) (cadr arg*)))))
           (S x k))]
      [else (S x k)]))
  ;;;
  (define (do-bind lhs* rhs* body)
    (cond
      [(null? lhs*) body]
      [else
       (set! locals (cons (car lhs*) locals))
       (make-seq 
         (V (car lhs*) (car rhs*))
         (do-bind (cdr lhs*) (cdr rhs*) body))]))
  ;;;
  (define (nontail-locations args)
    (let f ([regs parameter-registers] [args args])
      (cond
        [(null? args) (values '() '() '())]
        [(null? regs) (values '() '() args)]
        [else
         (let-values ([(r* rl* f*) (f (cdr regs) (cdr args))])
            (values (cons (car regs) r*)
                    (cons (car args) rl*)
                    f*))])))
  (define (make-set lhs rhs)
    (make-asm-instr 'move lhs rhs))
  (define (do-bind-frmt* nf* v* ac)
    (cond
      [(null? nf*) ac]
      [else
       (make-seq
         (V (car nf*) (car v*))
         (do-bind-frmt* (cdr nf*) (cdr v*) ac))]))
  ;;;
  (define (handle-nontail-call rator rands value-dest call-targ)
    (let-values ([(reg-locs reg-args frm-args)
                  (nontail-locations (cons rator rands))])
      (let ([regt* (map (lambda (x) (unique-var 'rt)) reg-args)]
            [frmt* (map (lambda (x) (make-nfv 'unset-conflicts #f #f #f #f))
                        frm-args)])
        (let* ([call 
                (make-ntcall call-targ value-dest 
                  (cons* argc-register 
                         pcr esp apr
                         (append reg-locs frmt*))
                  #f #f)]
               [body
                (make-nframe frmt* #f
                  (do-bind-frmt* frmt* frm-args
                    (do-bind (cdr regt*) (cdr reg-args)
                      ;;; evaluate cpt last
                      (do-bind (list (car regt*)) (list (car reg-args))
                        (assign* reg-locs regt*
                          (make-seq 
                            (make-set argc-register 
                               (make-constant
                                 (argc-convention (length rands))))
                            call))))))])
          (if value-dest
              (make-seq body (make-set value-dest return-value-register))
              body)))))
  ;;; (define (alloc-check size)
  ;;;   (E (make-conditional ;;; PCB ALLOC-REDLINE
  ;;;        (make-primcall '<= 
  ;;;          (list (make-primcall 'int+ (list apr size)) 
  ;;;                (make-primcall 'mref (list pcr (make-constant 4)))))
  ;;;        (make-primcall 'nop '())
  ;;;        (make-funcall 
  ;;;          (make-primcall 'mref
  ;;;            (list
  ;;;              (make-constant (make-object (primref->symbol 'do-overflow)))
  ;;;              (make-constant (- disp-symbol-record-proc symbol-ptag))))
  ;;;          (list size)))))
  (define (alloc-check size)
    (define (test size)
      (if (struct-case size 
             [(constant i) (<= i 4096)]
             [else #f])
          (make-primcall '<= 
             (list 
               apr
               (make-primcall 'mref 
                 (list pcr (make-constant pcb-allocation-redline)))))
          (make-primcall '>= 
            (list (make-primcall 'int- 
                     (list 
                       (make-primcall 'mref 
                         (list pcr (make-constant pcb-allocation-redline))) 
                       apr))
                  size))))
    (E (make-shortcut
         (make-conditional ;;; PCB ALLOC-REDLINE
           (test size)
           (make-primcall 'nop '())
           (make-primcall 'interrupt '()))
         (make-funcall 
           (make-primcall 'mref
             (list
               (make-constant (make-object (primref->symbol 'do-overflow)))
               (make-constant (- disp-symbol-record-proc symbol-ptag))))
           (list size)))))
  ;;; impose value
  (define (V d x)
    (struct-case x 
      [(constant) (make-set d x)]
      [(var)      
       (cond
         [(var-loc x) => (lambda (loc) (make-set d loc))]
         [else (make-set d x)])]
      [(bind lhs* rhs* e)
       (do-bind lhs* rhs* (V d e))]
      [(seq e0 e1)
       (make-seq (E e0) (V d e1))]
      [(conditional e0 e1 e2)
       (make-conditional (P e0) (V d e1) (V d e2))]
      [(primcall op rands)
       (case op
         [(alloc) 
          (S (car rands)
             (lambda (size)
               (make-seq
                 (alloc-check size)
                 (S (cadr rands)
                    (lambda (tag)
                      (make-seq
                        (make-seq 
                          (make-set d apr)
                          (make-asm-instr 'logor d tag))
                        (make-asm-instr 'int+ apr size)))))))]
         [(mref) 
          (S* rands
              (lambda (rands)
                (make-set d (make-disp (car rands) (cadr rands)))))]
         [(mref32) 
          (S* rands
              (lambda (rands)
                (make-asm-instr 'load32 d 
                  (make-disp (car rands) (cadr rands)))))]
         [(bref) 
          (S* rands
              (lambda (rands)
                (make-asm-instr 'load8 d 
                  (make-disp (car rands) (cadr rands)))))]
         [(logand logxor logor int+ int- int*
                  int-/overflow int+/overflow int*/overflow)
          (make-seq
            (V d (car rands))
            (S (cadr rands)
               (lambda (s)
                 (make-asm-instr op d s))))]
         [(int-quotient)
          (S* rands
              (lambda (rands)
                (seq* 
                  (make-set eax (car rands))
                  (make-asm-instr 'cltd edx eax)
                  (make-asm-instr 'idiv eax (cadr rands))
                  (make-set d eax))))]
         [(int-remainder) 
          (S* rands
              (lambda (rands)
                (seq* 
                  (make-set eax (car rands))
                  (make-asm-instr 'cltd edx eax)
                  (make-asm-instr 'idiv edx (cadr rands))
                  (make-set d edx))))]
         [(sll sra srl sll/overflow)
          (let ([a (car rands)] [b (cadr rands)])
            (cond
              [(constant? b)
               (make-seq
                 (V d a)
                 (make-asm-instr op d b))]
              [else 
               (S b
                  (lambda (b)
                    (seq*
                      (V d a)
                      (make-set ecx b)
                      (make-asm-instr op d ecx))))]))]
         [else (error who "invalid value op" op)])]
      [(funcall rator rands) 
       (handle-nontail-call rator rands d #f)]
      [(jmpcall label rator rands) 
       (handle-nontail-call rator rands d label)]
      [(forcall op rands)
       (handle-nontail-call 
         (make-constant (make-foreign-label op))
         rands d op)] 
      [(shortcut body handler)
       (make-shortcut 
          (V d body)
          (V d handler))] 
      [(known x) (V d x)]
      [else 
       (if (symbol? x) 
           (make-set d x)
           (error who "invalid value" (unparse x)))]))
  ;;;
  (define (assign* lhs* rhs* ac)
    (cond
      [(null? lhs*) ac]
      [else
       (make-seq 
         (make-set (car lhs*) (car rhs*))
         (assign* (cdr lhs*) (cdr rhs*) ac))]))
  ;;;
  (define (VT x)
    (S x
       (lambda (x)
         (make-seq
           (make-set return-value-register x)
           (make-primcall 'return 
             (list pcr esp apr return-value-register))))))
  ;;; impose effect
  (define (E x)
    (struct-case x
      [(seq e0 e1) (make-seq (E e0) (E e1))]
      [(conditional e0 e1 e2)
       (make-conditional (P e0) (E e1) (E e2))]
      [(bind lhs* rhs* e)
       (do-bind lhs* rhs* (E e))]
      [(primcall op rands)
       (case op
         [(mset bset mset32)
          (S* rands
              (lambda (s*)
                (make-asm-instr op
                  (make-disp (car s*) (cadr s*))
                  (caddr s*))))]
         [(fl:load fl:store fl:add! fl:sub! fl:mul! fl:div!
                   fl:from-int fl:shuffle bswap!
                   fl:store-single fl:load-single) 
          (S* rands
              (lambda (s*)
                (make-asm-instr op (car s*) (cadr s*))))]
         [(nop interrupt incr/zero? fl:double->single
               fl:single->double) x]
         [else (error 'impose-effect "invalid instr" x)])]
      [(funcall rator rands)
       (handle-nontail-call rator rands #f #f)]
      [(jmpcall label rator rands) 
       (handle-nontail-call rator rands #f label)]
      [(forcall op rands)
       (handle-nontail-call 
         (make-constant (make-foreign-label op))
         rands #f op)]
      [(shortcut body handler)
       (make-shortcut (E body) (E handler))]
      [else (error who "invalid effect" x)]))
  ;;; impose pred
  (define (P x)
    (struct-case x
      [(constant) x]
      [(seq e0 e1) (make-seq (E e0) (P e1))]
      [(conditional e0 e1 e2)
       (make-conditional (P e0) (P e1) (P e2))]
      [(bind lhs* rhs* e)
       (do-bind lhs* rhs* (P e))]
      [(primcall op rands)
       (let ([a (car rands)] [b (cadr rands)])
         (cond
           [(and (constant? a) (constant? b))
            (let ([t (unique-var 'tmp)])
              (P (make-bind (list t) (list a)
                    (make-primcall op (list t b)))))]
           [else
            (Mem a
              (lambda (a)
                (Mem b 
                  (lambda (b)
                    (make-asm-instr op a b)))))]))]
         ;(cond
         ;  [(and (constant? a) (constant? b))
         ;   (let ([t (unique-var 'tmp)])
         ;     (P (make-bind (list t) (list a)
         ;           (make-primcall op (list t b)))))]
         ;  [(constant? a)
         ;   (Mem b (lambda (b) (make-asm-instr op a b)))]
         ;  [(constant? b)
         ;   (Mem a (lambda (a) (make-asm-instr op a b)))]
         ;  [else
         ;   (S* rands
         ;       (lambda (rands)
         ;         (let ([a (car rands)] [b (cadr rands)])
         ;           (make-asm-instr op a b))))]))]
        [(shortcut body handler)
         (make-shortcut (P body) (P handler))]
      [else (error who "invalid pred" x)]))
  ;;;
  (define (handle-tail-call target rator rands)
    (let* ([args (cons rator rands)]
           [locs (formals-locations args)]
           [rest 
            (make-seq
              (make-set argc-register 
                (make-constant
                  (argc-convention (length rands))))
              (cond
                [target 
                 (make-primcall 'direct-jump 
                   (cons target 
                    (cons* argc-register
                           pcr esp apr
                           locs)))]
                [else 
                 (make-primcall 'indirect-jump 
                   (cons* argc-register 
                          pcr esp apr
                          locs))]))])
       (let f ([args (reverse args)] 
               [locs (reverse locs)] 
               [targs '()]
               [tlocs '()])
         (cond
           [(null? args) (assign* tlocs targs rest)]
           [(constant? (car args))
            (f (cdr args) (cdr locs)
               (cons (car args) targs) 
               (cons (car locs) tlocs))]
           [(and (fvar? (car locs)) 
                 (var? (car args))
                 (eq? (car locs) (var-loc (car args))))
            (f (cdr args) (cdr locs) targs tlocs)]
           [else
            (let ([t (unique-var 'tmp)])
              (set! locals (cons t locals))
              (make-seq
                (V t (car args))
                (f (cdr args) (cdr locs) 
                   (cons t targs) (cons (car locs) tlocs))))]))))
  (define (Tail x)
    (struct-case x 
      [(constant) (VT x)]
      [(var)      (VT x)]
      [(primcall op rands) 
       (case op
         [($call-with-underflow-handler) 
          (let ([t0 (unique-var 't)]
                [t1 (unique-var 't)]
                [t2 (unique-var 't)]
                [handler (car rands)]
                [proc (cadr rands)]
                [k (caddr rands)])
            (set! locals (cons* t0 t1 t2 locals))