ikarus/src/ikarus.compiler.ss

(library (ikarus compiler)
  (export compile-core-expr-to-port 
          assembler-output
          current-primitive-locations eval-core)
  (import 
    (rnrs hashtables)
    (ikarus system $fx)
    (ikarus system $pairs)
    (only (ikarus system $codes) $code->closure)
    (only (ikarus system $records) $record-ref $record/rtd?)
    (except (ikarus)
        compile-core-expr-to-port assembler-output
        current-primitive-locations eval-core)
    (ikarus intel-assembler)
    ;(ikarus fasl write)
    )


(define-syntax record-case
  (lambda (x)
    (define (enumerate fld* i)
      (syntax-case fld* ()
        [() #'()]
        [(x . x*) 
         (with-syntax ([i i] [i* (enumerate #'x* (fx+ i 1))])
           #'(i . i*))]))
    (define (generate-body ctxt cls*)
      (syntax-case cls* (else)
        [() (with-syntax ([x x]) #'(error #f "unmatched ~s in ~s" v 'x))]
        [([else b b* ...])  #'(begin b b* ...)]
        [([(rec-name rec-field* ...) b b* ...] . rest) (identifier? #'rec-name)
         (with-syntax ([altern (generate-body ctxt #'rest)]
                       [(id* ...) (enumerate #'(rec-field* ...) 0)]
                       [rtd #'(type-descriptor rec-name)])
          #'(if ($record/rtd? v rtd)
                (let ([rec-field* ($record-ref v id*)] ...)
                  b b* ...)
                altern))]))
    (syntax-case x ()
      [(_ expr cls* ...)
       (with-syntax ([body (generate-body #'_ #'(cls* ...))])
         #'(let ([v expr]) body))])))

(include "set-operations.ss")

  
(define-record constant (value))
(define-record code-loc (label))
(define-record foreign-label (label))
(define-record var 
   (name assigned referenced 
         reg-conf frm-conf var-conf reg-move frm-move var-move
         loc index))
(define-record cp-var (idx))
(define-record frame-var (idx))
(define-record new-frame (base-idx size body))
(define-record save-cp (loc))
(define-record eval-cp (check body))
(define-record return (value))
(define-record call-cp
  (call-convention label save-cp? rp-convention base-idx arg-count live-mask))
(define-record tailcall-cp (convention label arg-count))
(define-record primcall (op arg*))
(define-record primref (name))
(define-record conditional (test conseq altern))
(define-record interrupt-call (test handler))
(define-record bind (lhs* rhs* body))
(define-record recbind (lhs* rhs* body))
(define-record rec*bind (lhs* rhs* body))
(define-record fix (lhs* rhs* body))

(define-record seq (e0 e1))
(define-record case-info (label args proper))
(define-record clambda-case (info body))
(define-record clambda (label cases free name))
(define-record closure (code free*))
(define-record funcall (op rand*))
(define-record jmpcall (label op rand*))
(define-record forcall (op rand*))
(define-record codes (list body))
(define-record assign (lhs rhs))
(define-record mvcall (producer consumer))



(define-record shortcut (body handler))

(define-record fvar (idx))
(define-record object (val))
(define-record locals (vars body))
(define-record nframe (vars live body))
(define-record nfv (conf loc var-conf frm-conf nfv-conf))
(define-record ntcall (target value args mask size))
(define-record asm-instr (op dst src))
(define-record disp (s0 s1))

(define mkfvar
  (let ([cache '()])
    (lambda (i)
      (cond
        [(fixnum? i)
         (cond
           [(assv i cache) => cdr]
           [else
            (let ([fv (make-fvar i)])
              (set! cache (cons (cons i fv) cache))
              fv)])]
        [else (error 'mkfvar "~s is not a fixnum" i)]))))

(define (unique-var x)
  (make-var (gensym x) #f #f #f #f #f #f #f #f #f #f))

(define (recordize x)
  (define *cookie* (gensym))
  (define (gen-fml* fml*)
    (cond
      [(pair? fml*)
       (let ([v (unique-var (car fml*))])
         (putprop (car fml*) *cookie* v)
         (cons v (gen-fml* (cdr fml*))))]
      [(symbol? fml*)
       (let ([v (unique-var fml*)])
         (putprop fml* *cookie* v)
         v)]
      [else '()]))
  (define (ungen-fml* fml*)
    (cond
      [(pair? fml*)
       (remprop (car fml*) *cookie*)
       (ungen-fml* (cdr fml*))]
      [(symbol? fml*)
       (remprop fml* *cookie*)]))
  (define (properize fml*)
    (cond
      [(pair? fml*)
       (cons (car fml*) (properize (cdr fml*)))]
      [(null? fml*) '()]
      [else (list fml*)]))
  (define (quoted-sym x)
    (if (and (list? x)
             (fx= (length x) 2)
             (eq? 'quote (car x))
             (symbol? (cadr x)))
        (cadr x)
        (error 'quoted-sym "not a quoted symbol ~s" x)))
  (define (quoted-string x)
    (if (and (list? x)
             (fx= (length x) 2)
             (eq? 'quote (car x))
             (string? (cadr x)))
        (cadr x)
        (error 'quoted-string "not a quoted string ~s" x)))
  (define (Var x)
    (or (getprop x *cookie*) 
        (error 'recordize "unbound ~s" x)))
  (define (lexical x) 
    (getprop x *cookie*))
  (define (E x ctxt)
    (cond
      [(pair? x)
       (case (car x)
         [(quote) (make-constant (cadr x))]
         [(if) 
          (make-conditional 
            (E (cadr x) #f)
            (E (caddr x) ctxt)
            (E (cadddr x) ctxt))]
         [(set!)
          (let ([lhs (cadr x)] [rhs (caddr x)])
            (cond
              [(lexical lhs) => 
               (lambda (var) 
                 (make-assign var (E rhs lhs)))]
              [else
               (make-funcall (make-primref '$init-symbol-value!)
                 (list (make-constant lhs)
                       (E rhs lhs)))]))]
         [(begin)
          (let f ([a (cadr x)] [d (cddr x)])
            (cond
              [(null? d) (E a ctxt)]
              [else
               (make-seq (E a #f) (f (car d) (cdr d)))]))]
         [(letrec)
          (let ([bind* (cadr x)] [body (caddr x)])
            (let ([lhs* (map car bind*)]
                  [rhs* (map cadr bind*)])
              (let ([nlhs* (gen-fml* lhs*)])
                (let ([expr (make-recbind nlhs* (map E rhs* lhs*) (E body ctxt))])
                  (ungen-fml* lhs*)
                  expr))))]
         [(letrec*)
          (let ([bind* (cadr x)] [body (caddr x)])
            (let ([lhs* (map car bind*)]
                  [rhs* (map cadr bind*)])
              (let ([nlhs* (gen-fml* lhs*)])
                (let ([expr (make-rec*bind nlhs* (map E rhs* lhs*) (E body ctxt))])
                  (ungen-fml* lhs*)
                  expr))))]
         [(case-lambda)
          (let ([cls*
                 (map
                   (lambda (cls)
                     (let ([fml* (car cls)] [body (cadr cls)])
                       (let ([nfml* (gen-fml* fml*)])
                         (let ([body (E body #f)])
                           (ungen-fml* fml*)
                           (make-clambda-case 
                             (make-case-info
                               (gensym)
                               (properize nfml*) 
                               (list? fml*)) 
                             body)))))
                   (cdr x))])
            (make-clambda (gensym) cls* #f ctxt))]
         [(foreign-call)
          (let ([name (quoted-string (cadr x))] [arg* (cddr x)])
            (make-forcall name (map (lambda (x) (E x #f)) arg*)))]
         [(primitive)
          (let ([var (cadr x)])
            (make-primref var))]
         [else
           ;;; should annotate expanded let.
          (make-funcall 
            (E (car x) #f) 
            (map (lambda (x) (E x #f)) (cdr x)))])]
      [(symbol? x)
       (or (lexical x) 
           (make-funcall 
             (make-primref 'top-level-value) 
             (list (make-constant x))))]
      [else (error 'recordize "invalid expression ~s" x)]))
  (E x #f))

(define (unparse x)
  (define (E-args proper x)
    (if proper 
        (map E x)
        (let f ([a (car x)] [d (cdr x)])
          (cond
            [(null? d) (E a)]
            [else (cons (E a) (f (car d) (cdr d)))]))))
  (define (E x)
    (record-case x
      [(constant c) `(quote ,c)]
      [(code-loc x) `(code-loc ,x)]
      [(var x) (string->symbol (format "v:~a" x))]
      [(primref x) x]
      [(conditional test conseq altern) 
       `(if ,(E test) ,(E conseq) ,(E altern))]
      [(interrupt-call e0 e1)
       `(interrupt-call ,(E e0) ,(E e1))]
      [(primcall op arg*) `(,op . ,(map E arg*))]
      [(bind lhs* rhs* body) 
       `(let ,(map (lambda (lhs rhs) (list (E lhs) (E rhs))) lhs* rhs*)
          ,(E body))]
      [(recbind lhs* rhs* body) 
       `(letrec ,(map (lambda (lhs rhs) (list (E lhs) (E rhs))) lhs* rhs*)
          ,(E body))]
      [(rec*bind lhs* rhs* body) 
       `(letrec* ,(map (lambda (lhs rhs) (list (E lhs) (E rhs))) lhs* rhs*)
          ,(E body))]
      [(fix lhs* rhs* body) 
       `(fix ,(map (lambda (lhs rhs) (list (E lhs) (E rhs))) lhs* rhs*)
          ,(E body))]
      [(seq e0 e1) 
       (let ()
         (define (f x ac)
           (record-case x
             [(seq e0 e1) (f e0 (f e1 ac))]
             [else (cons (E x) ac)]))
         (cons 'begin (f e0 (f e1 '()))))]
      [(clambda-case info body)
       `(,(E-args (case-info-proper info)
                               (case-info-args info))
            ,(E body))]
      [(clambda g cls* free)
       `(,g (case-lambda . ,(map E cls*)))]
      [(clambda label clauses free)
       `(code ,label . ,(map E clauses))]
      [(closure code free*)
       `(closure ,(E code) ,(map E free*))]
      [(codes list body)
       `(codes ,(map E list)
          ,(E body))]
      [(funcall rator rand*) `(funcall ,(E rator) . ,(map E rand*))]
      [(jmpcall label rator rand*)
       `(jmpcall ,label ,(E rator) . ,(map E rand*))]
      [(forcall rator rand*) `(foreign-call ,rator . ,(map E rand*))]
      [(assign lhs rhs) `(set! ,(E lhs) ,(E rhs))]
      [(return x) `(return ,(E x))]
      [(new-frame base-idx size body)
       `(new-frame [base: ,base-idx]
                   [size: ,size]
          ,(E body))]
      [(frame-var idx) 
       (string->symbol (format "fv.~a" idx))]
      [(cp-var idx) 
       (string->symbol (format "cp.~a" idx))]
      [(save-cp expr)
       `(save-cp ,(E expr))]
      [(eval-cp check body)
       `(eval-cp ,check ,(E body))]
      [(call-cp call-convention label save-cp? rp-convention base-idx arg-count live-mask)
       `(call-cp [conv: ,call-convention]
                 [label: ,label]
                 [rpconv: ,(if (symbol? rp-convention)
                               rp-convention
                               (E rp-convention))]
                 [base-idx: ,base-idx]
                 [arg-count: ,arg-count]
                 [live-mask: ,live-mask])]
      [(tailcall-cp convention label arg-count)
       `(tailcall-cp ,convention ,label ,arg-count)]
      [(foreign-label x) `(foreign-label ,x)]
      [(mvcall prod cons) `(mvcall ,(E prod) ,(E cons))]
      [(fvar idx) (string->symbol (format "fv.~a" idx))]
      [(nfv idx) 'nfv]
      [(locals vars body) `(locals ,(map E vars) ,(E body))]
      [(asm-instr op d s)
       `(asm ,op ,(E d) ,(E s))]
      [(disp s0 s1)
       `(disp ,(E s0) ,(E s1))]
      [(nframe vars live body) `(nframe ;[vars: ,(map E vars)]
                                        ;[live: ,(map E live)]
                                  ,(E body))]
      [(shortcut body handler)
       `(shortcut ,(E body) ,(E handler))]
      [(ntcall target valuw args mask size)
       `(ntcall ,target ,size)]
      [else
       (if (symbol? x) 
           x
           "#<unknown>")]))
  (E x))

(define open-mvcalls (make-parameter #t))

(define (optimize-direct-calls x)
  (define who 'optimize-direct-calls)
  (define (make-conses ls)
    (cond
      [(null? ls) (make-constant '())]
      [else 
       (make-funcall (make-primref 'cons) 
         (list (car ls) (make-conses (cdr ls))))]))      
  (define (properize lhs* rhs*)
    (cond
      [(null? lhs*) (error who "improper improper")]
      [(null? (cdr lhs*)) 
       (list (make-conses rhs*))]
      [else (cons (car rhs*) (properize (cdr lhs*) (cdr rhs*)))]))
  (define (inline-case cls rand*)
    (record-case cls
      [(clambda-case info body)
       (record-case info
         [(case-info label fml* proper)
          (if proper
              (and (fx= (length fml*) (length rand*))
                   (make-bind fml* rand* body))
              (and (fx<= (length fml*) (length rand*))
                   (make-bind fml* (properize fml* rand*) body)))])]))
  (define (try-inline cls* rand* default)
    (cond
      [(null? cls*) default]
      [(inline-case (car cls*) rand*)]
      [else (try-inline (cdr cls*) rand* default)]))
  (define (inline rator rand*)
    (define (valid-mv-consumer? x)
      (record-case x
        [(clambda L cases F)
         (and (fx= (length cases) 1)
              (record-case (car cases)
                [(clambda-case info body)
                 (record-case info
                   [(case-info L args proper) proper])]))]
        [else #f]))
    (define (single-value-consumer? x)
      (record-case x
        [(clambda L cases F)
         (and (fx= (length cases) 1)
              (record-case (car cases)
                [(clambda-case info body)
                 (record-case info
                   [(case-info L args proper)
                    (and proper (fx= (length args) 1))])]))]
        [else #f])) 
    (define (valid-mv-producer? x)
      (record-case x
        [(funcall) #t]
        [(conditional) #f]
        [(bind lhs* rhs* body) (valid-mv-producer? body)]
        [else #f] ;; FIXME BUG
       ; [else (error 'valid-mv-producer? "unhandles ~s"
       ;              (unparse x))]
        ))
    (record-case rator
      [(clambda g cls*)
       (try-inline cls* rand*
          (make-funcall rator rand*))]
      [(primref op)
       (case op
         ;;; FIXME HERE
         [(call-with-values)
          (cond
            [(and (open-mvcalls) (fx= (length rand*) 2))
             (let ([producer (inline (car rand*) '())] 
                   [consumer (cadr rand*)])
               (cond
                 [(single-value-consumer? consumer)
                  (inline consumer (list producer))]
                 [(and (valid-mv-consumer? consumer)
                       (valid-mv-producer? producer))
                  (make-mvcall producer consumer)]
                 [else 
                  (make-funcall rator rand*)]))]
            [else
             (make-funcall rator rand*)])]
         [else
          (make-funcall rator rand*)])]
      [else (make-funcall rator rand*)]))
  (define (Expr x)
    (record-case x
      [(constant) x]
      [(var) x]
      [(primref) x]
      [(bind lhs* rhs* body)
       (make-bind lhs* (map Expr rhs*) (Expr body))]
      [(recbind lhs* rhs* body)
       (make-recbind lhs* (map Expr rhs*) (Expr body))]
      [(rec*bind lhs* rhs* body)
       (make-rec*bind lhs* (map Expr rhs*) (Expr body))]
      [(conditional test conseq altern)
       (make-conditional 
         (Expr test)
         (Expr conseq)
         (Expr altern))]
      [(seq e0 e1) 
       (make-seq (Expr e0) (Expr e1))]
      [(clambda g cls* free name)
       (make-clambda g
         (map (lambda (x)
                (record-case x
                  [(clambda-case info body)
                   (make-clambda-case info (Expr body))]))
              cls*)
         free name)]
      [(funcall rator rand*)
       (inline (Expr rator) (map Expr rand*))]
      [(forcall rator rand*) 
       (make-forcall rator (map Expr rand*))]
      [(assign lhs rhs)
       (make-assign lhs (Expr rhs))]
      [else (error who "invalid expression ~s" (unparse x))]))
  (Expr x))


(define simple-primitives 
  ;;; primitives that are side-effect-free
  ;;; FIXME: surely something must go here, no?
  '())

(define (optimize-letrec x)
  (define who 'optimize-letrec)
  (define (extend-hash lhs* h ref)
    (for-each (lambda (lhs) (hashtable-set! h lhs #t)) lhs*)
    (lambda (x)
      (unless (hashtable-ref h x #f)
        (hashtable-set! h x #t)
        (ref x))))
  (define (E* x* ref comp)
    (cond
      [(null? x*) '()]
      [else
       (cons (E (car x*) ref comp)
             (E* (cdr x*) ref comp))]))  
  (define (do-rhs*-old i lhs* rhs* ref comp vref vcomp)
    (cond
      [(null? rhs*) '()]
      [else
       (let ([h (make-hashtable)])
         (let ([ref
                (lambda (x)
                  (unless (hashtable-ref h x #f)
                    (hashtable-set! h x #t)
                    (ref x)
                    (when (memq x lhs*)
                      (vector-set! vref i #t))))]
               [comp
                (lambda ()
                  (vector-set! vcomp i #t)
                  (comp))])
           (cons (E (car rhs*) ref comp)
                 (do-rhs* (fxadd1 i) lhs* (cdr rhs*) ref comp vref vcomp))))])) 
  (define (do-rhs* i lhs* rhs* ref comp vref vcomp)
    (cond
      [(null? rhs*) '()]
      [else
       (let ([h (make-hashtable)]
             [rest (do-rhs* (fxadd1 i) lhs* (cdr rhs*) ref comp vref vcomp)])
         (let ([ref
                (lambda (x)
                  (unless (hashtable-ref h x #f)
                    (hashtable-set! h x #t)
                    (ref x)
                    (when (memq x lhs*)
                      (vector-set! vref i #t))))]
               [comp
                (lambda ()
                  (vector-set! vcomp i #t)
                  (comp))])
           (cons (E (car rhs*) ref comp) rest)))]))
  (define (partition-rhs* i lhs* rhs* vref vcomp)
    (cond
      [(null? lhs*) (values '() '() '() '() '() '())]
      [else
       (let-values 
         ([(slhs* srhs* llhs* lrhs* clhs* crhs*)
           (partition-rhs* (fxadd1 i) (cdr lhs*) (cdr rhs*) vref vcomp)]
          [(lhs rhs) (values (car lhs*) (car rhs*))])
         (cond
           [(var-assigned lhs) 
            (values slhs* srhs* llhs* lrhs* (cons lhs clhs*) (cons rhs crhs*))]
           [(clambda? rhs)
            (values slhs* srhs* (cons lhs llhs*) (cons rhs lrhs*) clhs* crhs*)]
           [(or (vector-ref vref i) (vector-ref vcomp i))
            (values slhs* srhs* llhs* lrhs* (cons lhs clhs*) (cons rhs crhs*))]
           [else
            (values (cons lhs slhs*) (cons rhs srhs*) llhs* lrhs* clhs* crhs*)]
           ))]))
  (define (do-recbind lhs* rhs* body ref comp letrec?)
    (let ([h (make-hashtable)]
          [vref (make-vector (length lhs*) #f)]
          [vcomp (make-vector (length lhs*) #f)])
      (let* ([ref (extend-hash lhs* h ref)]
             [body (E body ref comp)])
        (let ([rhs* (do-rhs* 0 lhs* rhs* ref comp vref vcomp)])
          (let-values ([(slhs* srhs* llhs* lrhs* clhs* crhs*)
                        (partition-rhs* 0 lhs* rhs* vref vcomp)])
           (let ([v* (map (lambda (x) (make-constant (void))) clhs*)])
             ;(let ([ls 
             ;       (let f ([ls clhs*])
             ;         (cond
             ;           [(null? ls) '()]
             ;           [(var-assigned (car ls)) (f (cdr ls))]
             ;           [else (cons (var-name (car ls)) (f (cdr ls)))]))])
             ;  (unless (null? ls) (printf "complex: ~s\n" ls)))
             (make-bind slhs* srhs*
               (make-bind clhs* v*
                 (make-fix llhs* lrhs*
                   (if letrec?
                       (let ([t* (map (lambda (x) (unique-var 'tmp)) clhs*)])
                         (make-bind t* crhs*
                           (build-assign* clhs* t* body)))
                       (build-assign* clhs* crhs* body)))))))))))
  (define (build-assign* lhs* rhs* body)
    (cond
      [(null? lhs*) body]
      [else
       (make-seq
         (make-assign (car lhs*) (car rhs*))
         (build-assign* (cdr lhs*) (cdr rhs*) body))]))
  (define (E x ref comp)
    (record-case x
      [(constant) x]
      [(var) (ref x) x]
      [(assign lhs rhs)
       (set-var-assigned! lhs #t)
       (ref lhs)
       (make-assign lhs (E rhs ref comp))]
      [(primref) x]
      [(bind lhs* rhs* body)
       (let ([rhs* (E* rhs* ref comp)])
         (let ([h (make-hashtable)])
           (let ([body (E body (extend-hash lhs* h ref) comp)])
             (make-bind lhs* rhs* body))))]
      [(recbind lhs* rhs* body)
       (if (null? lhs*)
           (E body ref comp)
           (do-recbind lhs* rhs* body ref comp #t))]
      [(rec*bind lhs* rhs* body)
       (if (null? lhs*)
           (E body ref comp)
           (do-recbind lhs* rhs* body ref comp #f))] 
      [(conditional e0 e1 e2)
       (make-conditional (E e0 ref comp) (E e1 ref comp) (E e2 ref comp))]
      [(seq e0 e1) (make-seq (E e0 ref comp) (E e1 ref comp))]
      [(clambda g cls* free name)
       (make-clambda g
         (map (lambda (x)
                (record-case x
                  [(clambda-case info body)
                   (let ([h (make-hashtable)])
                     (let ([body (E body (extend-hash (case-info-args info) h ref) void)])
                       (make-clambda-case info body)))]))
              cls*)
         free name)]
      [(funcall rator rand*)
       (let ([rator (E rator ref comp)] [rand* (E* rand* ref comp)])
         (record-case rator
           [(primref op)
            (unless (memq op simple-primitives)
              (comp))]
           [else
            (comp)])
         (make-funcall rator rand*))]
      [(mvcall p c)
       (let ([p (E p ref comp)] [c (E c ref comp)])
         (comp)
         (make-mvcall p c))]
      [(forcall rator rand*) 
       (make-forcall rator (E* rand* ref comp))]
      [else (error who "invalid expression ~s" (unparse x))]))
  (E x (lambda (x) (error who "free var ~s found" x))
       void))


(define (uncover-assigned/referenced x)
  (define who 'uncover-assigned/referenced)
  (define (Expr* x*)
    (for-each Expr x*))
  (define (init-var x)
    (set-var-assigned! x #f)
    (set-var-referenced! x #f))
  (define (Expr x)
    (record-case x
      [(constant) (void)]
      [(var) (set-var-referenced! x #t)]
      [(primref) (void)]
      [(bind lhs* rhs* body)
       (for-each init-var lhs*)
       (begin (Expr body) (Expr* rhs*))]
      [(fix lhs* rhs* body)
       (for-each init-var lhs*)
       (Expr* rhs*)
       (Expr body)
       (when (ormap var-assigned lhs*)
         (error who "a fix lhs is assigned"))]
      [(conditional test conseq altern)
       (begin (Expr test) (Expr conseq) (Expr altern))]
      [(seq e0 e1) (begin (Expr e0) (Expr e1))]
      [(clambda g cls*)
       (for-each
         (lambda (cls)
           (record-case cls
             [(clambda-case info body)
              (for-each init-var (case-info-args info))
              (Expr body)]))
         cls*)]
      [(primcall rator rand*) (Expr* rand*)]
      [(funcall rator rand*)
       (begin (Expr rator) (Expr* rand*))]
      [(mvcall p c) (begin (Expr p) (Expr c))]
      [(forcall rator rand*) (Expr* rand*)]
      [(assign lhs rhs)
       (set-var-assigned! lhs #t)
       (Expr rhs)]
      [else (error who "invalid expression ~s" (unparse x))]))
  (Expr x)
  x)


#|FIXME:missing-optimizations
  111 cadr
  464 $record/rtd?
  404 memq
  249 map
  114 not
  451 car
  224 syntax-error
  248 $syntax-dispatch
  237 pair?
  125 length
  165 $cdr
  137 $car
  805 $record-ref
  181 fixnum?
  328 null?
  136 fx-
  207 eq?
  153 call-with-values
  165 values
  336 apply
  384 cdr
  898 cons
  747 error
  555 void
  645 list
|#


;;; FIXME URGENT: should handle (+ x k), (- x k) where k is a fixnum
;;;               also fx+, fx-
(module (optimize-primcall)
  (define (optimize-primcall ctxt op rand*)
    (cond
      [(getprop op *cookie*) =>
       (lambda (proc)
         (proc ctxt op rand* 
               (lambda () 
                 (make-funcall (make-primref op) rand*))))]
      [else
       (make-funcall (make-primref op) rand*)]))
  (define (constant-value x k) 
    (record-case x 
      [(constant t) (k t)] ; known
      [(bind lhs* rhs* body) (constant-value body k)]
      [(fix lhs* rhs* body) (constant-value body k)]
      [(seq e0 e1) (constant-value e1 k)]
      [else #f]))
  (define (mk-seq e0 e1)  ;;; keep e1 seq-free.
    (cond
      [(and (primcall? e0) (eq? (primcall-op e0) 'void)) e1]
      [(seq? e1)
       (make-seq (make-seq e0 (seq-e0 e1)) (seq-e1 e1))]
      [else
       (make-seq e0 e1)]))
  (define (equable? x)
    (if (number? x) (fixnum? x) #t))
  (define *cookie* (gensym "optimizer-cookie"))
  (define-syntax set-cases
    (syntax-rules ()
      [(_ ctxt op rand* giveup 
          [(op** ...) b* b** ...] ...)
       (begin
         (let ([p (lambda (ctxt op rand* giveup) b* b** ...)])
           (putprop 'op** *cookie* p) ...
           (void)) ...)]))
  (set-cases ctxt op rand* giveup
    [(eq?)
     (or (and (fx= (length rand*) 2)
              (let ([a0 (car rand*)] [a1 (cadr rand*)])
                (or
                  (constant-value a0
                    (lambda (x0)
                      (constant-value a1
                        (lambda (x1)
                          (mk-seq (mk-seq a0 a1)
                            (make-constant (eq? x0 x1)))))
                  (and (eq? ctxt 'e)
                       (mk-seq a0 a1)))))))
         (giveup))] 
    [(eqv?)
     (or (and (fx= (length rand*) 2)
              (let ([a0 (car rand*)] [a1 (cadr rand*)])
                (or
                  (constant-value a0
                    (lambda (x0)
                      (or (constant-value a1
                            (lambda (x1)
                              (mk-seq (mk-seq a0 a1)
                                (make-constant (eqv? x0 x1)))))
                          (and (equable? x0)
                               (optimize-primcall ctxt 'eq? rand*)))))
                  (constant-value a1
                    (lambda (x1)
                      (and (equable? x1)
                           (optimize-primcall ctxt 'eq? rand*))))
                  (and (eq? ctxt 'e)
                       (mk-seq a0 a1)))))
         (giveup))]
    [(memv)
     (or (and (fx= (length rand*) 2)
              (let ([a0 (car rand*)] [a1 (cadr rand*)])
                (constant-value a1
                  (lambda (ls)
                    (cond
                      [(not (list? ls)) #f]
                      [(eq? ctxt 'e) (mk-seq a0 a1)]
                      [(constant-value a0
                         (lambda (x)
                           (mk-seq (mk-seq a0 a1)
                             (case ctxt
                               [(v) (make-constant (memv x ls))]
                               [else (make-constant
                                       (if (memv x ls) #t #f))]))))]
                      [(andmap equable? ls)
                       (optimize-primcall ctxt 'memq rand*)]
                      [(fx= (length ls) 1)
                       (mk-seq a1
                         (optimize-primcall ctxt 'eqv?
                            (list a0 (make-constant (car ls)))))]
                      [else #f])))))
         (giveup))]
    [(memq) 
     (or (and (fx= (length rand*) 2)
              (let ([a0 (car rand*)] [a1 (cadr rand*)])
                (constant-value a1
                  (lambda (ls)
                    (cond
                      [(not (list? ls)) #f]
                      [(eq? ctxt 'e) (make-seq a0 a1)]
                      [(constant-value a0
                         (lambda (x)
                           (mk-seq (mk-seq a0 a1)
                             (case ctxt
                               [(v) (make-constant (memq x ls))]
                               [else (make-constant
                                       (if (memq x ls) #t #f))]))))]