3.sf

; #F, part 3:  SFC front-end

; Copyright (C) 2007 by Sergei Egorov, All Rights Reserved.
;
; This code is based on the "90 minute Scheme to C compiler" presented at the
; Montreal Scheme/Lisp User Group on October 20, 2004. The original code was
; Copyright (C) 2004 by Marc Feeley, All Rights Reserved.

#fload "0.sf"
; also refers to prim-ctype c-argref-ctype letrec-exp c-undecorate-alvar


;------------------------------------------------------------------------------

; errors

(define (c-error* reason args)
  (let ([ep (current-error-port)])
    (newline ep)
    (display "Compiler error: " ep)
    (display reason ep)
    (for-each (lambda (arg) (display " " ep) (write arg ep)) args)
    (newline ep)
    (reset)))

(define-syntax c-error
  (syntax-rules () [(_ r a ...) (c-error* r (list a ...))]))


;------------------------------------------------------------------------------

; utilities

; andmap ormap list* come from 0.sf / host Scheme

(define-inline compose
  (lambda (f g) (lambda (x) (f (g x)))))

(define-inline complement
  (lambda (f) (lambda (x) (not (f x)))))

(define-integrable (iota n m) ; returns the list (n n+1 n+2 ... m-1)
  (if (< n m) (cons n (iota (+ n 1) m)) '()))

(define-integrable (keep f lst)
  (cond [(null? lst) '()]
        [(f (car lst)) (cons (car lst) (keep f (cdr lst)))]
        [else (keep f (cdr lst))]))

(define-inline (adjoinq x s)
  (if (memq x s) s (cons x s)))

(define-integrable (subsetq? s1 s2)
  (andmap (lambda (x) (memq x s2)) s1))

(define-integrable (seteq? s1 s2)
  (and (subsetq? s1 s2) (subsetq? s2 s1)))
  
(define-integrable (unionq s1 s2)
  (cond [(null? s1) s2]
        [(memq (car s1) s2) (unionq (cdr s1) s2)]
        [else (cons (car s1) (unionq (cdr s1) s2))]))

(define-integrable (intersectionq s1 s2)
  (cond [(null? s1) '()]
        [(memq (car s1) s2) (cons (car s1) (intersectionq (cdr s1) s2))]
        [else (intersectionq (cdr s1) s2)]))

(define-integrable (setdiffq s1 s2)
  (cond [(null? s1) '()]
        [(memq (car s1) s2) (setdiffq (cdr s1) s2)]
        [else (cons (car s1) (setdiffq (cdr s1) s2))]))

(define (reduce-right f base lst)
  (if (null? lst)
      base
      (f (car lst) (reduce-right f base (cdr lst))))) 

(define (reduce-left f base lst)
  (if (null? lst)
      base
      (reduce-left f (f (car lst) base) (cdr lst))))

(define (reduce-right/singular-identity f base lst)
  (if (null? lst) 
      base
      (let loop ([lst lst])
        (if (null? (cdr lst))
            (car lst)
            (f (car lst) (loop (cdr lst)))))))

(define (reduce-right/right-seed f base lst)
   (if (null? lst)
       base
       (let loop ([lst lst])
         (if (null? (cdr lst))
             (f (car lst) base)
             (f (car lst) (loop (cdr lst)))))))

(define (posq x lst)
  (let loop ([lst lst] [i 0])
    (cond [(null? lst) #f]
          [(eq? (car lst) x) i]
          [else (loop (cdr lst) (+ i 1))])))

(define (string-append* lst)
  (define (rslen lst)
    (let loop ([lst lst] [len 0])
      (if (null? lst) 
          len 
          (loop (cdr lst) (+ len (string-length (car lst)))))))
  (let ([str (make-string (rslen lst))])
    (let copy ([lst lst] [pos 0])
      (if (null? lst)
          str
          (let ([s (car lst)])
            (let ([endpos (+ pos (string-length s))])
              (let loop ([i 0])
                (if (= (+ pos i) endpos)
                    (copy (cdr lst) endpos)
                    (begin
                      (string-set! str (+ pos i) (string-ref s i))
                      (loop (+ i 1)))))))))))

(define (symbol* args)
  (string->symbol
    (string-append*
      (map (lambda (x) 
        (if (symbol? x) (symbol->string x)
          (if (number? x) (number->string x) x)))
        args))))

(define-syntax symbol
  (syntax-rules () [(_ a ...) (symbol* (list a ...))]))

(define-syntax andapp 
  (syntax-rules () [(_ f a ...) (andmap f (list a ...))]))

(define-syntax orapp 
  (syntax-rules () [(_ f a ...) (ormap f (list a ...))]))



;------------------------------------------------------------------------------

; effects are used to classify primitives

(define-inline (no-effect) 'no-effect) ; functional, can be eliminated if not used
(define-inline (*-effect) '*-effect) ; allocates, but has no other effects
(define-inline (?-effect) '?-effect) ; only observes effects of others; doesn't alloc
(define-inline (!-effect) '!-effect) ; produces effects; doesn't alloc
(define-inline (?!-effect) '?!-effect) ; has & observes effects; doesn't alloc
(define-inline (*?-effect) '*?-effect) ; allocates, observes effects of others
(define-inline (*!-effect) '*!-effect) ; allocates, produces effects
(define-inline (*?!-effect) '*?!-effect) ; anything but the nasal demons

(define-inline (ref-transparent-effect? eff) ; exp can be moved freely
  (eq? eff 'no-effect))

(define-inline (removable-if-dead-effect? eff) ; exp can be removed
  (memq eff '(no-effect *-effect ?-effect *?-effect)))

(define-inline (gc-safe-effect? eff) ; cannot cause gc
  (memq eff '(no-effect ?-effect !-effect ?!-effect)))


;------------------------------------------------------------------------------

; ids/variables and id lists/environments:

(define-integrable (var-id? bnd) (and (pair? bnd) (eq? (car bnd) 'var)))
(define-inline (var-id sym ts xt) (list 'var sym ts xt))
(define-inline id->symbol cadr)
(define-inline id->ts caddr)
(define-inline id->ctype cadddr)

(define (id<? i1 i2) ; total ordering used for sets
  (< (id->ts i1) (id->ts i2)))

(define-inline (extendify bindings env)
  (append bindings env))

(define-integrable (lookupicate sym env)
  (cond [(null? env) #f]
        [(eq? (id->symbol (car env)) sym) (car env)]
        [else (lookupicate sym (cdr env))]))

(define last-id-timestamp 0)

(define (reset-timestamps)
  (set! last-id-timestamp 0))
  
(define (timestamp)
  (set! last-id-timestamp (+ last-id-timestamp 1))
  last-id-timestamp)

(define-integrable (global-id sym)
  (var-id sym (- (timestamp)) #f))

(define-integrable (global-id? id)
  (negative? (id->ts id)))

(define-integrable (global-id-constant sym)
  (var-id sym (- (timestamp)) #t))

(define-integrable (global-id-constant? id)
  (and (negative? (id->ts id)) (id->ctype id)))

(define-integrable (global-id-private-constant name)
  (let ([ts (timestamp)])
    (var-id (symbol name "#" ts) (- ts) 'private)))

(define-integrable (global-id-private-constant? id)
  (and (negative? (id->ts id)) (eq? (id->ctype id) 'private)))

(define-integrable (lexical-id sym)
  (var-id sym (timestamp) #f))

(define-integrable (rename-id id)
  (var-id (id->symbol id) (timestamp) #f))

(define-integrable (prefix-id p id)
  (var-id (symbol p (id->symbol id)) (timestamp) #f))

(define-integrable (postfix-id id p)
  (var-id (symbol (id->symbol id) p) (timestamp) #f))

(define-integrable (label-id sym)
  (var-id sym (timestamp) #t))

(define-integrable (label-id? id)
  (and (not (global-id? id)) (eq? (id->ctype id) #t)))

(define-integrable (cvar-id sym ctype)
  (var-id sym (timestamp) ctype))

(define-integrable (cvar-id? id)
  (and (not (global-id? id)) (string? (id->ctype id))))

(define (id->uname id) ; comments and debugging
  (cond [(global-id-private-constant? id) (id->symbol id)] 
        [(global-id-constant? id) (symbol (id->symbol id) "$")] 
        [(global-id? id) (id->symbol id)]
        [(string? (id->ctype id)) (symbol (id->symbol id) "." (id->ts id) "::" (id->ctype id))]
        [(id->ctype id) (symbol (id->symbol id) ":" (id->ts id))]
        [else (symbol (id->symbol id) "." (id->ts id))]))

(define begin-id-symbol (symbol "."))

;------------------------------------------------------------------------------

; core expressions, stored directly as abstract syntax tree nodes

(define-variant var-exp (id))                         ; variable reference
(define-variant varassign-exp (id exp))               ; variable assignment
(define-variant if-exp (test-exp then-exp else-exp))  ; conditional
(define-variant primapp-exp (effect prim rands))      ; primitive application
(define-variant app-exp (rator rands))                ; application
(define-variant lambda-exp (ids body))                ; lambda expression

(define-variant fix-exp (ids lams body))              ; lambda-only letrec
(define-variant letcc-exp (id body))                  ; reify continuation
(define-variant withcc-exp (cont-exp exp))            ; reflect continuation


;------------------------------------------------------------------------------

; void expression is a distinguished literal expression
; (define-variant void-exp ()), virtual

(define-integrable (void-exp) 
  (primapp-exp (no-effect) "void(0)" '()))
(define-integrable (void-exp? exp) 
  (and (primapp-exp? exp) (equal? (primapp-exp->prim exp) "void(0)")))


;------------------------------------------------------------------------------

; gvarassign expression is an assignment to a global variable
; (define-variant gvarassign-exp (id exp)), virtual

(define-inline (gvarassign-exp id exp) 
  (varassign-exp id exp))

(define-integrable (gvarassign-exp? exp) 
  (and (varassign-exp? exp) (global-id? (varassign-exp->id exp))))

(define-inline (gvarassign-exp->id exp)  (varassign-exp->id exp))
(define-inline (gvarassign-exp->exp exp)  (varassign-exp->exp exp))


;------------------------------------------------------------------------------

; let expression is a pattern for lambda applications
; (define-variant let-exp (ids rands body)), virtual

(define-integrable (let-exp ids rands body) 
  (app-exp (lambda-exp ids body) rands))

(define-integrable (let-exp? exp) 
  (and (app-exp? exp)
       (let ([rator (app-exp->rator exp)])
         (and (lambda-exp? rator)
              (= (length (lambda-exp->ids rator)) 
                 (length (app-exp->rands exp)))))))

(define-inline (let-exp->ids exp) 
  (lambda-exp->ids (app-exp->rator exp)))

(define-inline (let-exp->rands exp) 
  (app-exp->rands exp))

(define-inline (let-exp->body exp) 
  (lambda-exp->body (app-exp->rator exp)))


;------------------------------------------------------------------------------

; identity-lambda expression is a pattern for likes of (lambda (x) x)
; (define-variant identity-lambda-exp ()), virtual

(define-integrable (identity-lambda-exp)
  (let ([id (lexical-id '_)])
    (lambda-exp (list id) (var-exp id)))) 

(define-integrable (identity-lambda-exp? exp)
  (and (lambda-exp? exp)
       (let ([ids (lambda-exp->ids exp)] 
             [body (lambda-exp->body exp)])
         (and (pair? ids) (null? (cdr ids))
              (var-exp? body) (eq? (car ids) (var-exp->id body))))))


;------------------------------------------------------------------------------

; identity-let expression is a pattern for identity lambda applications
; (define-variant identity-let-exp (exp)), virtual

(define-integrable (identity-let-exp exp)
  (app-exp (identity-lambda-exp) (list exp)))

(define-integrable (identity-let-exp? exp)
  (and (app-exp? exp)
       (identity-lambda-exp? (app-exp->rator exp))
       (let ([rands (app-exp->rands exp)]) 
         (and (pair? rands) (null? (cdr rands))))))

(define-inline (identity-let-exp->exp exp) 
  (car (app-exp->rands exp)))


;------------------------------------------------------------------------------

; null-let expression is a pattern for superfluous lambda applications
; (define-variant null-let-exp (body)), virtual

(define-integrable (null-let-exp body) 
  (app-exp (lambda-exp '() body) '()))

(define-integrable (null-let-exp? exp)
  (and (app-exp? exp)
       (null? (app-exp->rands exp))
       (let ([rator (app-exp->rator exp)]) 
         (and (lambda-exp? rator)
              (null? (lambda-exp->ids rator))))))

(define-inline (null-let-exp->body exp) 
  (lambda-exp->body (app-exp->rator exp)))


;------------------------------------------------------------------------------

; degenerate-let expression is either identity-let or null-let
; (define-variant degenerate-let-exp (body)), virtual

(define-integrable (degenerate-let-exp? exp)
  (or (null-let-exp? exp) (identity-let-exp? exp)))

(define-integrable (degenerate-let-exp->body exp)
  (if (null? (app-exp->rands exp))
      (null-let-exp->body exp)
      (identity-let-exp->exp exp)))


;------------------------------------------------------------------------------

; begin expression is a pattern for lambda applications with unreferenced vars
; (define-variant begin-exp (exp1 exp2)), virtual

(define-integrable (begin-exp exp1 exp2) 
  (app-exp (lambda-exp (list (lexical-id '_)) exp2) 
    (list exp1)))

(define-integrable (begin-exp? exp) 
  (variant-case exp
    [let-exp (ids rands body)
     (and (pair? ids) (null? (cdr ids))
          (not (var-referenced-in-exp? (car ids) body)))]
    [else #f]))

(define-inline (begin-exp->exp1 exp) 
  (car (app-exp->rands exp)))

(define-inline (begin-exp->exp2 exp) 
  (lambda-exp->body (app-exp->rator exp)))


;------------------------------------------------------------------------------

; rec expression is a pattern for self-recursive lambda definition
; (define-variant rec-exp (id lam)), virtual

(define-integrable (rec-exp? exp)
  (and (fix-exp? exp)
       (let ([ids (fix-exp->ids exp)] [body (fix-exp->body exp)])
         (and (pair? ids) (null? (cdr ids)) (var-exp? body)
              (eq? (car ids) (var-exp->id body))))))

(define-inline (rec-exp->id exp) 
  (car (fix-exp->ids exp)))

(define-inline (rec-exp->lam exp) 
  (car (fix-exp->lams exp)))


;------------------------------------------------------------------------------

; loop expression is a pattern for self-recursive lambda application
; (define-variant loop-exp (id lam rands)), virtual

(define-integrable (loop-exp? exp)
  (and (app-exp? exp) (rec-exp? (app-exp->rator exp))))

(define-inline (loop-exp->id exp) 
  (rec-exp->id (app-exp->rator exp)))

(define-inline (loop-exp->lam exp) 
  (rec-exp->lam (app-exp->rator exp)))

(define-inline (loop-exp->rands exp) 
  (app-exp->rands exp))


;------------------------------------------------------------------------------

; labelapp expression is a pattern for label variable applications
; (define-variant labelapp-exp (id rands)), virtual

(define (labelapp-exp id rands) 
  (app-exp (var-exp id) rands)) 

(define (labelapp-exp? exp)
  (and (app-exp? exp) 
    (var-exp? (app-exp->rator exp))
    (label-id? (var-exp->id (app-exp->rator exp)))))

(define-inline (labelapp-exp->id exp) 
  (var-exp->id (app-exp->rator exp)))

(define-inline (labelapp-exp->rands exp) 
  (app-exp->rands exp))


;------------------------------------------------------------------------------

; curry expression is a pattern for simple, closure-like lambdas
; (define-variant curry-exp (id ids rands)), virtual

(define-integrable (curry-exp id ids rands) 
  (lambda-exp ids
    (app-exp (var-exp id) 
      (append (map var-exp ids) rands)))) 

(define-integrable (curry-exp? exp)
  (variant-case exp
    [lambda-exp (ids body)
     (variant-case body
       [labelapp-exp (id rands)
        (let loop ([ids ids] [rands rands])
          (or (null? ids)
              (and (pair? rands) (var-exp? (car rands))
                (eq? (var-exp->id (car rands)) (car ids))
                (loop (cdr ids) (cdr rands)))))]
       [else #f])]
    [else #f]))

(define-inline (curry-exp->id exp) 
  (var-exp->id (app-exp->rator (lambda-exp->body exp))))

(define-inline (curry-exp->ids exp) 
  (lambda-exp->ids exp))

(define-integrable (curry-exp->rands exp) 
  (list-tail (app-exp->rands (lambda-exp->body exp))
    (length (lambda-exp->ids exp))))


;------------------------------------------------------------------------------

; halt expression ends module initializer (implemented as a primitive)
; (define-variant halt-exp (exp)), virtual

(define the-halt-prim
   "r[$live+0] = r[0];
    pc = 0; /* exit from module init */
    r[$live+1] = obj_from_$arg;
    r += $live; /* shift reg wnd */
    rc = 2;
    goto jump;")

(define-integrable (halt-exp exp) 
  ; program (module init) ends here, returning exp
  (primapp-exp (*?!-effect) the-halt-prim (list exp)))

(define-integrable (halt-exp? exp) 
  (and (primapp-exp? exp) 
       (eq? (primapp-exp->prim exp) the-halt-prim)))

(define-inline (halt-exp->exp exp)
  (car (primapp-exp->rands exp)))
  
   
;------------------------------------------------------------------------------

; memoization of var/exp attributes (ideally, it should use weak hash table)

(define *memoization-optsz* 500)
(define *memoization-limit* 1000)

(define (memoizate-exp-attribute fn)
  (define memo '())
  (define mlen 0)
  (lambda (exp)
    (cond [(not exp) (set! memo '()) (set! mlen 0)]
          [(assq exp memo) => cdr]
          [else (let ([res (fn exp)]) 
                  (set! memo (cons (cons exp res) memo))
                  (set! mlen (+ mlen 1))
                  (when (> mlen *memoization-limit*)
                    (set-cdr! (list-tail memo *memoization-optsz*) '())
                    (set! mlen (length memo)))
                  res)])))

(define (memoizate-var-attribute fn)
  (define memo '())
  (define mlen 0)
  (lambda (id exp)
    (cond [(not id) (set! memo '()) (set! mlen 0)]
          [(assq exp memo) => 
           (lambda (exp&idmemo)
             (cond [(assq id (cdr exp&idmemo)) => cdr]
                   [else (let ([res (fn id exp)]) 
                           (set-cdr! exp&idmemo
                             (cons (cons id res) (cdr exp&idmemo)))
                           res)]))]
          [else (let ([res (fn id exp)]) 
                  (set! memo 
                    (cons (cons exp (list (cons id res))) memo))
                  (set! mlen (+ mlen 1))
                  (when (> mlen *memoization-limit*)
                    (set-cdr! (list-tail memo *memoization-optsz*) '())
                    (set! mlen (length memo)))
                  res)])))


;------------------------------------------------------------------------------

; parser for macroexpanded source code

(define keywords
 '(begin define if lambda letrec letcc withcc %include %% load
   %quote %const %prim %prim?! %prim* %prim*?! 
   %definition %localdef))

(define (<id>? x) (and (symbol? x) (not (memq x keywords))))
(define (<literal>? x) (or (integer? x) (boolean? x)))
(define (string-forest? x) 
  (or (string? x) (and (list? x) (andmap string-forest? x))
      (and (vector? x) (andmap string-forest? (vector->list x)))))

(define (string-forest-length x)
  (cond [(string? x) 
         (string-length x)]
        [(null? x) 0]
        [(pair? x) 
         (+ (string-forest-length (car x)) 
            (string-forest-length (cdr x)))]
        [else
         (let ([vlen (vector-length x)]) 
           (let loop ([i 0] [sum 0])
             (if (< i vlen)
                 (loop (+ i 1) 
                   (+ sum (string-forest-length (vector-ref x i))))
                 sum)))]))

(define (string-forest->string x)
  (define str 
    (make-string (string-forest-length x)))
  (define (copy x pos)
    (cond [(string? x)
           (let ([endpos (+ pos (string-length x))])
             (let loop ([i 0])
               (if (= (+ pos i) endpos)
                   endpos
                   (begin
                     (string-set! str (+ pos i) (string-ref x i))
                     (loop (+ i 1))))))]
          [(null? x) pos]
          [(pair? x)
           (let ([pos (copy (car x) pos)])
             (copy (cdr x) pos))] 
          [else
           (let ([vlen (vector-length x)]) 
             (let loop ([i 0] [pos pos])
               (if (< i vlen)
                   (loop (+ i 1) (copy (vector-ref x i) pos))
                   pos)))]))
  (copy x 0)
  str)
  
(define (sexp-match? pat x)
    (or (eq? pat '*)
        (and (eq? pat '<id>) (<id>? x))
        (and (eq? pat '<symbol>) (symbol? x))
        (and (eq? pat '<string>) (string? x))
        (and (eq? pat '<literal>) (<literal>? x))
        (and (eq? pat '<string-forest>) (string-forest? x))
        (eq? x pat)
        (and (pair? pat)
             (cond [(and (eq? (car pat) '...)
                         (pair? (cdr pat))
                         (null? (cddr pat)))
                    (eq? x (cadr pat))]
                   [(and (pair? (cdr pat))
                         (eq? (cadr pat) '...)
                         (null? (cddr pat)))
                    (let ([pat (car pat)])
                      (if (eq? pat '*)
                          (list? x)
                          (let loop ([lst x])
                            (or (null? lst)
                                (and (pair? lst)
                                     (sexp-match? pat (car lst))
                                     (loop (cdr lst)))))))]
                   [else
                    (and (pair? x)
                         (sexp-match? (car pat) (car x))
                         (sexp-match? (cdr pat) (cdr x)))]))))

(define-syntax sexp-case
  (syntax-rules (else)
    [(_ (key ...) clauses ...)
     (let ([atom-key (key ...)])
       (sexp-case atom-key clauses ...))]
    [(_ key (else result1 result2 ...))
     (begin result1 result2 ...)]
    [(_ key (pat result1 result2 ...))
     (if (sexp-match? 'pat key)
         (begin result1 result2 ...))]
    [(_ key (pat result1 result2 ...) clause clauses ...)
     (if (sexp-match? 'pat key)
         (begin result1 result2 ...)
         (sexp-case key clause clauses ...))]))

(define (parse-program lst return) ;=> (return exp known-refs)
  (define (psexp x e)
    (let p ([x x])
      (sexp-case x
        [(if * * *)
         (if-exp (p (cadr x)) (p (caddr x)) (p (cadddr x)))]
        [(if * *)
         (if-exp (p (cadr x)) (p (caddr x)) (void-exp))]
        [(set! <id> *)
         (let ([id (make-id (cadr x) e)]) 
           (varassign-exp id (p (caddr x))))]
        [(begin * ...)
         (reduce-right/singular-identity 
           begin-exp (void-exp) (map p (cdr x)))]
        [(lambda (<id> ...) *)
         (let ([ids (map lexical-id (cadr x))])
           (lambda-exp ids (psexp (caddr x) (extendify ids e))))]
        [(letrec ((<id> *) ...) *)
         (let* ([ids (map lexical-id (map car (cadr x)))] [e+ (extendify ids e)])
           (letrec-exp ids (map (lambda (x) (psexp x e+)) (map cadr (cadr x)))
             (psexp (caddr x) e+)))]
        [(letcc <id> *)
         (let ([id (lexical-id (cadr x))])
           (letcc-exp id (psexp (caddr x) (extendify (list id) e))))]
        [(withcc * *)
         (withcc-exp (p (cadr x)) (p (caddr x)))]
        [(%quote *)
         (let ([c (cadr x)])
           (sexp-case c
             [(%prim <string-forest>) 
              (if (vector? (cadr c)) ; "expensive" hint
                  (var-exp (liftc c))
                  (p c))]
             [else (var-exp (liftc c))]))]
        [(%const * ...) 
         (c-error "unsupported constant syntax" x)]
        [(%prim <string-forest> * ...) 
         (primapp-exp (no-effect) (string-forest->string (cadr x)) (map p (cddr x)))] 
        [(%prim* <string-forest> * ...) 
         (primapp-exp (*-effect) (string-forest->string (cadr x)) (map p (cddr x)))] 
        [(%prim? <string-forest> * ...) 
         (primapp-exp (?-effect) (string-forest->string (cadr x)) (map p (cddr x)))] 
        [(%prim! <string-forest> * ...) 
         (primapp-exp (!-effect) (string-forest->string (cadr x)) (map p (cddr x)))] 
        [(%prim?! <string-forest> * ...) 
         (primapp-exp (?!-effect) (string-forest->string (cadr x)) (map p (cddr x)))] 
        [(%prim*? <string-forest> * ...) 
         (primapp-exp (*?-effect) (string-forest->string (cadr x)) (map p (cddr x)))] 
        [(%prim*! <string-forest> * ...) 
         (primapp-exp (*!-effect) (string-forest->string (cadr x)) (map p (cddr x)))] 
        [(%prim*?! <string-forest> * ...) 
         (primapp-exp (*?!-effect) (string-forest->string (cadr x)) (map p (cddr x)))] 
        [(* * ...) (app-exp (p (car x)) (map p (cdr x)))]
        [<id> (var-exp (make-id x e))]
        [else (c-error "syntax error in expression" x)])))
  (define (pprog prog e)
    (define (ptop x)
      (sexp-case x
        [(define * *) 
         (varassign-exp (make-id (cadr x) e) (psexp (caddr x) e))]
        [else (psexp x e)]))
    (reduce-right begin-exp (void-exp)
      (let loop ([prog prog] [exps '()]) ;map left-to-right
        (if (null? prog) (reverse exps)
          (let ([exp (ptop (car prog))])
            (loop (cdr prog) (cons exp exps))))))) 
  (define lifted-const-alist
    '())
  (define (lname c)
    (if (sexp-match? '(letrec ([<id> *]) <id>) c)
        (c-undecorate-alvar (caddr c))
        ""))
  (define (liftc c) ; todo: share substructure?
    (let ([c&exp&id (assoc c lifted-const-alist)])
      (if c&exp&id (caddr c&exp&id)
        (let ([exp (psexp c '())]
              [gqid (global-id-private-constant (lname c))])
          (set! lifted-const-alist
            (cons (list c exp gqid) lifted-const-alist))
          gqid))))
  (define (add-lifted-consts exp)
    (reduce-left
      (lambda (c&exp&id exp)
        (begin-exp 
          (varassign-exp (caddr c&exp&id) (cadr c&exp&id))
          exp))
      exp lifted-const-alist))
  (define global-e 
    '())
  (define (make-id sym e)
    (or (lookupicate sym e)
        (lookupicate sym global-e)
        (let ([id (global-id sym)])
          (set! global-e (cons id global-e))
          id)))
  (let ([exp (add-lifted-consts (pprog lst '()))])
    (return exp (map id->symbol global-e))))


;------------------------------------------------------------------------------

; information on variable use (free/global variables) and ctypes

; description of single instance of variable use
(define-variant var-use (assignment-to? application-of? primapp-ref-ctype))

(define exp-vinfo 
  (memoizate-exp-attribute
    (lambda (exp) ; => ((id . var-use) ...)
      (variant-case exp
        [var-exp (id) (list (cons id (var-use #f #f #f)))]
        [varassign-exp (id exp)
         (cons (cons id (var-use #t #f #f)) (exp-vinfo exp))]
        [if-exp (test-exp then-exp else-exp) 
         (append (exp-vinfo test-exp) (exp-vinfo then-exp) (exp-vinfo else-exp))]
        [primapp-exp (effect prim rands)
         (let loop ([rands rands] [n 0] [vi '()])
           (if (null? rands) vi
             (let ([exp (car rands)])
               (variant-case exp
                 [var-exp (id) 
                  (let ([id&vu (cons id (var-use #f #f (c-argref-ctype prim n)))])
                    (loop (cdr rands) (+ n 1) (cons id&vu vi)))]
                 [else (loop (cdr rands) (+ n 1) (append (exp-vinfo exp) vi))]))))]
        [app-exp (rator rands)
         (reduce-right (lambda (exp vi) (append (exp-vinfo exp) vi))
           (variant-case rator
             [var-exp (id) (list (cons id (var-use #f #t #f)))]
             [else (exp-vinfo rator)])
           rands)]
        [lambda-exp (ids body)
         (keep (lambda (id&vu) (not (memq (car id&vu) ids)))
           (exp-vinfo body))]
        [fix-exp (ids lams body)
         (keep (lambda (id&vu) (not (memq (car id&vu) ids)))
           (reduce-right (lambda (exp vi) (append (exp-vinfo exp) vi))
             (exp-vinfo body) lams))]
        [letcc-exp (id body)
         (keep (lambda (id&vu) (not (eq? (car id&vu) id)))
           (exp-vinfo body))]     
        [withcc-exp (cont-exp exp)
         (append (exp-vinfo cont-exp) (exp-vinfo exp))]))))

(define var-uses-in-exp  ;id exp => (var-use ...)
  (memoizate-var-attribute
    (lambda (id exp)
      (let loop ([vinfo (exp-vinfo exp)] [uses '()])
        (cond [(null? vinfo) uses]
              [(eq? id (caar vinfo)) 
               (loop (cdr vinfo) (cons (cdar vinfo) uses))]
              [else (loop (cdr vinfo) uses)])))))

(define (var-referenced-in-exp? id exp)
  (pair? (var-uses-in-exp id exp)))
  
(define (var-assigned-in-exp? id exp)
  (ormap var-use->assignment-to? (var-uses-in-exp id exp)))

(define (var-reference-count id exp)
  (length (var-uses-in-exp id exp)))

(define (var-assignment-count id exp)
  (reduce-left (lambda (vu n) (if (var-use->assignment-to? vu) (+ n 1) n))
    0 (var-uses-in-exp id exp)))

(define (var-only-applied-in-exp? id exp)
  (andmap var-use->application-of? (var-uses-in-exp id exp))) 

(define (var-use-unboxed-ctype vu) ; => ctype or #f
  (let ([prt (var-use->primapp-ref-ctype vu)]) 
    (and (string? prt) 
         (not (member prt '("obj" "objptr" "void")))
         prt))) 

(define (var-unboxed-ctype-in-exp id exp) ; => ctype or #f
  (let loop ([vu* (var-uses-in-exp id exp)] [ctype #f])
    (cond [(null? vu*) ctype]
          [(var-use-unboxed-ctype (car vu*)) =>
           (lambda (ct)
             (and (or (not ctype) (string=? ct ctype))
                  (loop (cdr vu*) ct)))]
          [else #f])))
    
(define exp->free-vars ; exp -> {id ...}
  (memoizate-exp-attribute
    (lambda (exp)
      (reduce-left 
        (lambda (id&vu res) 
          (adjoinq (car id&vu) res))
        '() (exp-vinfo exp)))))

(define exp->free-lexvars ; exp -> {id ...}
  (memoizate-exp-attribute
    (lambda (exp)
      (reduce-left 
        (lambda (id&vu res)
          (if (global-id? (car id&vu)) res (adjoinq (car id&vu) res)))
        '() (exp-vinfo exp)))))

(define (exp-ctype exp env)
  (variant-case exp
    [var-exp (id)
     (cond [(assq id env) => cdr] [else #f])]
    [if-exp (test-exp then-exp else-exp)
     (let ([h-ctype (exp-ctype then-exp env)] 
           [e-ctype (exp-ctype else-exp env)])
       (and h-ctype e-ctype (string=? h-ctype e-ctype) h-ctype))]
    [let-exp (ids rands body)
     (exp-ctype body
       (append (map (lambda (id rand) (cons id (exp-ctype rand env))) 
          ids rands) env))]
    [primapp-exp (effect prim rands)
     (prim-ctype prim)]
    [else #f]))