;==============================================================================
;		       Copyright (C) 1992 by Marc Feeley -- all rights reserved

; file: "ptree2.scm"

;------------------------------------------------------------------------------
;
; Parse tree manipulation package: (part 2)
; -------------------------------

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

(define (normalize-parse-tree ptree env)

  (define (normalize ptree)
    (let ((tree (assignment-convert (partial-evaluate ptree) env)))
      (lambda-lift! tree)
      tree))

  (if (def? ptree)
    (begin
      (node-children-set! ptree (list (normalize (def-val ptree))))
      ptree)
    (normalize ptree)))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
; Partial evaluation:
; ------------------

; (partial-evaluate ptree) returns a parse-tree equivalent to 'ptree' but
; with constants propagated through the parse-tree.
; Presently, very little folding of primitive operations is done.

(define (partial-evaluate ptree)
  (pe ptree '()))

(define (pe ptree consts)

  (cond ((cst? ptree)
         (new-cst (node-source ptree) (node-decl ptree) (cst-val ptree)))

        ((ref? ptree)
         (let ((var (ref-var ptree)))
           (var-refs-set! var (set-remove (var-refs var) ptree))
           (let ((x (assq var consts)))
             (if x
               (new-cst (node-source ptree) (node-decl ptree) (cdr x))
               (let ((y (global-val var)))
                 (if (and y (cst? y))
                   (new-cst (node-source ptree) (node-decl ptree) (cst-val y))
                   (new-ref (node-source ptree) (node-decl ptree) var)))))))

        ((set? ptree)
         (let ((var (set-var ptree))
               (val (pe (set-val ptree) consts)))
           (var-sets-set! var (set-remove (var-sets var) ptree))
           (new-set (node-source ptree) (node-decl ptree)
             var
             val)))

        ((tst? ptree)
         (let ((pre (pe (tst-pre ptree) consts)))
           (if (cst? pre)
             (let ((val (cst-val pre)))
               (if (false-object? val)
                 (pe (tst-alt ptree) consts)
                 (pe (tst-con ptree) consts)))
             (new-tst (node-source ptree) (node-decl ptree)
               pre
               (pe (tst-con ptree) consts)
               (pe (tst-alt ptree) consts)))))

        ((conj? ptree)
         (let ((pre (pe (conj-pre ptree) consts)))
           (if (cst? pre)
             (let ((val (cst-val pre)))
               (if (false-object? val)
                 pre
                 (pe (conj-alt ptree) consts)))
             (new-conj (node-source ptree) (node-decl ptree)
               pre
               (pe (conj-alt ptree) consts)))))

        ((disj? ptree)
         (let ((pre (pe (disj-pre ptree) consts)))
           (if (cst? pre)
             (let ((val (cst-val pre)))
               (if (false-object? val)
                 (pe (disj-alt ptree) consts)
                 pre))
             (new-disj (node-source ptree) (node-decl ptree)
               pre
               (pe (disj-alt ptree) consts)))))

        ((prc? ptree)
         (new-prc (node-source ptree) (node-decl ptree)
           (prc-name ptree)
           (prc-min ptree)
           (prc-rest ptree)
           (prc-parms ptree)
           (pe (prc-body ptree) consts)))

        ((app? ptree)
         (let ((oper (app-oper ptree))
               (args (app-args ptree)))
           (if (and (prc? oper) ; applying a lambda-expr is like a 'let'
                    (not (prc-rest oper))
                    (= (length (prc-parms oper)) (length args)))
             (pe-let ptree consts)
             (new-call (node-source ptree) (node-decl ptree)
               (pe oper consts)
               (map (lambda (x) (pe x consts)) args)))))

        ((fut? ptree)
         (new-fut (node-source ptree) (node-decl ptree)
           (pe (fut-val ptree) consts)))

        (else
         (compiler-internal-error "pe, unknown parse tree node type"))))

(define (pe-let ptree consts)
  (let* ((proc (app-oper ptree))
         (vals (app-args ptree))
         (vars (prc-parms proc))
         (non-mut-vars (set-keep not-mutable? (list->set vars))))

    (for-each (lambda (var)
                (var-refs-set! var (set-empty))
                (var-sets-set! var (set-empty)))
              vars)

    (let loop ((l vars)
               (v vals)
               (new-vars '())
               (new-vals '())
               (new-consts consts))
      (if (null? l)

        (if (null? new-vars)
          (pe (prc-body proc) new-consts)
          (new-call (node-source ptree) (node-decl ptree)
            (new-prc (node-source proc) (node-decl proc)
              #f
              (length new-vars)
              #f
              (reverse new-vars)
              (pe (prc-body proc) new-consts))
            (reverse new-vals)))

        (let ((var (car l))
              (val (pe (car v) consts)))

          (if (and (set-member? var non-mut-vars) (cst? val))

            (loop (cdr l)
                  (cdr v)
                  new-vars
                  new-vals
                  (cons (cons var (cst-val val)) new-consts))

            (loop (cdr l)
                  (cdr v)
                  (cons var new-vars)
                  (cons val new-vals)
                  new-consts)))))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
; Assignment conversion:
; ---------------------

; (assignment-convert ptree env) returns a parse-tree equivalent to 'ptree' but
; containing no assignments to non-global variables.  In the converted
; parse-tree, 'cells' are used to implement mutable variables and calls to
; the procedures:
;
;   ##MAKE-CELL, ##CELL-REF, ##CELL-SET!
;
; are added to create and access the cells.  'env' is the global environment
; in which 'ptree' is parsed.

(define (assignment-convert ptree env)
  (ac ptree (env-declare env (list SAFE-sym #f)) '()))

(define (ac ptree env mut)

  (cond ((cst? ptree)
         ptree)

        ((ref? ptree)
         (let ((var (ref-var ptree)))
           (if (global? var)
             ptree
             (let ((x (assq var mut)))
               (if x
                 (let ((source (node-source ptree)))
                   (var-refs-set! var (set-remove (var-refs var) ptree))
                   (new-call source (node-decl ptree)
                     (new-ref-extended-bindings source **CELL-REF-sym env)
                     (list (new-ref source (node-decl ptree) (cdr x)))))
                 ptree)))))

        ((set? ptree)
         (let ((var (set-var ptree))
               (source (node-source ptree))
               (val (ac (set-val ptree) env mut)))
           (var-sets-set! var (set-remove (var-sets var) ptree))
           (if (global? var)
             (new-set source (node-decl ptree)
               var
               val)
             (new-call source (node-decl ptree)
               (new-ref-extended-bindings source **CELL-SET!-sym env)
               (list (new-ref source (node-decl ptree) (cdr (assq var mut)))
                     val)))))

        ((tst? ptree)
         (new-tst (node-source ptree) (node-decl ptree)
           (ac (tst-pre ptree) env mut)
           (ac (tst-con ptree) env mut)
           (ac (tst-alt ptree) env mut)))

        ((conj? ptree)
         (new-conj (node-source ptree) (node-decl ptree)
           (ac (conj-pre ptree) env mut)
           (ac (conj-alt ptree) env mut)))

        ((disj? ptree)
         (new-disj (node-source ptree) (node-decl ptree)
           (ac (disj-pre ptree) env mut)
           (ac (disj-alt ptree) env mut)))

        ((prc? ptree)
         (ac-proc ptree env mut))

        ((app? ptree)
         (let ((oper (app-oper ptree))
               (args (app-args ptree)))
           (if (and (prc? oper) ; applying a lambda-expr is like a 'let'
                    (not (prc-rest oper))
                    (= (length (prc-parms oper)) (length args)))
             (ac-let ptree env mut)
             (new-call (node-source ptree) (node-decl ptree)
               (ac oper env mut)
               (map (lambda (x) (ac x env mut)) args)))))

        ((fut? ptree)
         (new-fut (node-source ptree) (node-decl ptree)
           (ac (fut-val ptree) env mut)))

        (else
         (compiler-internal-error "ac, unknown parse tree node type"))))

(define (ac-proc ptree env mut)
  (let* ((mut-parms (ac-mutables (prc-parms ptree)))
         (mut-parms-copies (map var-copy mut-parms))
         (mut (append (pair-up mut-parms mut-parms-copies) mut))
         (new-body (ac (prc-body ptree) env mut)))

    (new-prc (node-source ptree) (node-decl ptree)
      (prc-name ptree)
      (prc-min ptree)
      (prc-rest ptree)
      (prc-parms ptree)
      (if (null? mut-parms)
        new-body
        (new-call (node-source ptree) (node-decl ptree)
          (new-prc (node-source ptree) (node-decl ptree)
            #f
            (length mut-parms-copies)
            #f
            mut-parms-copies
            new-body)
          (map (lambda (var)
                 (new-call (var-source var) (node-decl ptree)
                   (new-ref-extended-bindings (var-source var) **MAKE-CELL-sym env)
                   (list (new-ref (var-source var) (node-decl ptree) var))))
               mut-parms))))))

(define (ac-let ptree env mut)
  (let* ((proc (app-oper ptree))
         (vals (app-args ptree))
         (vars (prc-parms proc))
         (vals-fv (apply set-union (map free-variables vals)))
         (mut-parms (ac-mutables vars))
         (mut-parms-copies (map var-copy mut-parms))
         (mut (append (pair-up mut-parms mut-parms-copies) mut)))
         
    (let loop ((l vars)
               (v vals)
               (new-vars '())
               (new-vals '())
               (new-body (ac (prc-body proc) env mut)))
      (if (null? l)

        (new-let ptree proc new-vars new-vals new-body)

        (let ((var (car l))
              (val (car v)))

          (if (memq var mut-parms)

            (let ((src (node-source val))
                  (decl (node-decl val))
                  (var* (cdr (assq var mut))))

              (if (set-member? var vals-fv)

                (loop (cdr l)
                      (cdr v)
                      (cons var* new-vars)
                      (cons (new-call src decl
                              (new-ref-extended-bindings src **MAKE-CELL-sym env)
                              (list (new-cst src decl undef-object)))
                            new-vals)
                      (new-seq src decl
                        (new-call src decl
                          (new-ref-extended-bindings src **CELL-SET!-sym env)
                          (list (new-ref src decl var*)
                                (ac val env mut)))
                        new-body))

                (loop (cdr l)
                      (cdr v)
                      (cons var* new-vars)
                      (cons (new-call src decl
                              (new-ref-extended-bindings src **MAKE-CELL-sym env)
                              (list (ac val env mut)))
                            new-vals)
                      new-body)))

            (loop (cdr l)
                  (cdr v)
                  (cons var new-vars)
                  (cons (ac val env mut) new-vals)
                  new-body)))))))

(define (ac-mutables l)
  (if (pair? l)
    (let ((var (car l)) (rest (ac-mutables (cdr l))))
      (if (mutable? var)
        (cons var rest)
        rest))
    '()))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
; Lambda-lifting procedure:
; ------------------------

; (lambda-lift! ptree) modifies the parse-tree 'ptree' so that some
; of its procedures (i.e. lambda-expressions) are replaced with
; weaker ones (i.e. lambda-expressions having fewer or no closed variables).
; It is assumed that 'ptree' has been assignment-converted.
; Presently, only named procedures are lambda-lifted.

(define (lambda-lift! ptree)
  (ll! ptree (set-empty) '()))

(define (ll! ptree cst-procs env)

  (define (new-env env vars)
    (define (loop i l)
      (if (pair? l)
        (let ((var (car l)))
          (cons (cons var (cons (length (set->list (var-refs var))) i))
                (loop (+ i 1) (cdr l))))
        env))
    (loop (length env) vars))

  (cond ((or (cst? ptree)
             (ref? ptree)
             (set? ptree)
             (tst? ptree)
             (conj? ptree)
             (disj? ptree)
             (fut? ptree))
         (for-each (lambda (child) (ll! child cst-procs env))
                   (node-children ptree)))

        ((prc? ptree)
         (ll! (prc-body ptree) cst-procs (new-env env (prc-parms ptree))))

        ((app? ptree)
         (let ((oper (app-oper ptree))
               (args (app-args ptree)))
           (if (and (prc? oper) ; applying a lambda-expr is like a 'let'
                    (not (prc-rest oper))
                    (= (length (prc-parms oper)) (length args)))
             (ll!-let ptree cst-procs (new-env env (prc-parms oper)))
             (for-each (lambda (child) (ll! child cst-procs env))
                       (node-children ptree)))))

        (else
         (compiler-internal-error "ll!, unknown parse tree node type"))))

(define (ll!-let ptree cst-procs env)
  (let* ((proc (app-oper ptree))
         (vals (app-args ptree))
         (vars (prc-parms proc))
         (var-val-map (pair-up vars vals)))

    (define (var->val var) (cdr (assq var var-val-map)))

    (define (liftable-proc-vars vars)
      (let loop ((cst-proc-vars
                   (set-keep (lambda (var)
                               (let ((val (var->val var)))
                                 (and (prc? val)
                                      (lambda-lift? (node-decl val))
                                      (set-every? oper-pos? (var-refs var)))))
                             (list->set vars))))
        (let* ((non-cst-proc-vars
                 (set-keep (lambda (var)
                             (let ((val (var->val var)))
                               (and (prc? val)
                                    (not (set-member? var cst-proc-vars)))))
                           (list->set vars)))
               (cst-proc-vars*
                 (set-keep (lambda (var)
                             (let ((val (var->val var)))
                               (set-empty?
                                 (set-intersection (free-variables val)
                                                   non-cst-proc-vars))))
                           cst-proc-vars)))
          (if (set-equal? cst-proc-vars cst-proc-vars*)
            cst-proc-vars
            (loop cst-proc-vars*)))))
        
    (let* ((cst-proc-vars (liftable-proc-vars vars))
           (cst-proc-vars-list (set->list cst-proc-vars))
           (cst-procs* (set-union cst-proc-vars cst-procs))
           (var-tcfv-map
             (map (lambda (var) (cons var (free-variables (var->val var))))
                  cst-proc-vars-list)))

      (define (var->tcfv var) (cdr (assq var var-tcfv-map)))

      (define (order-vars vars)
        (map car
             (sort-list (map (lambda (var) (assq var env)) vars)
                        (lambda (x y)
                          (if (= (cadr x) (cadr y))
                            (< (cddr x) (cddr y))
                            (< (cadr x) (cadr y)))))))

      (define (lifted-vars var)
        (order-vars (set->list (set-difference (var->tcfv var) cst-procs*))))

      (define (lift-app! var)
        (let* ((val (var->val var))
               (vars (lifted-vars var)))

          (define (new-ref* var)
            (new-ref (var-source var) (node-decl val) var))

          (if (not (null? vars))
            (for-each (lambda (oper)
                        (let ((node (node-parent oper)))
                          (node-children-set! node
                            (cons (app-oper node)
                                  (append (map new-ref* vars)
                                          (app-args node))))))
                      (set->list (var-refs var))))))

      (define (lift-prc! var)
        (let* ((val (var->val var))
               (vars (lifted-vars var)))

          (if (not (null? vars))
            (let ((var-copies (map var-copy vars)))
              (prc-parms-set! val (append var-copies (prc-parms val)))
              (for-each (lambda (x) (var-bound-set! x val)) var-copies)
              (node-fv-invalidate! val)
              (prc-min-set! val (+ (prc-min val) (length vars)))
              (ll-rename! val (pair-up vars var-copies))))))

      (let loop1 ((changed? #f))
        (for-each (lambda (var-tcfv)
                    (let loop2 ((l (set->list (cdr var-tcfv))) (fv (cdr var-tcfv)))
                      (if (null? l)
                        (if (not (set-equal? fv (cdr var-tcfv)))
                          (begin
                            (set-cdr! var-tcfv fv)
                            (set! changed? #t)))
                        (let ((x (assq (car l) var-tcfv-map)))
                          (loop2 (cdr l)
                                 (if x (set-union fv (cdr x)) fv))))))
                  var-tcfv-map)

        (if changed?

          (loop1 #f)

          (begin
            (for-each lift-app! cst-proc-vars-list)
            (for-each lift-prc! cst-proc-vars-list)
            (for-each (lambda (node) (ll! node cst-procs* env)) vals)
            (ll! (prc-body proc) cst-procs* env)))))))

(define (ll-rename! ptree var-map)

  (cond ((ref? ptree)
         (let* ((var (ref-var ptree))
                (x (assq var var-map)))
           (if x
             (begin
               (var-refs-set! var (set-remove (var-refs var) ptree))
               (var-refs-set! (cdr x) (set-adjoin (var-refs (cdr x)) ptree))
               (ref-var-set! ptree (cdr x))))))

        ((set? ptree)
         (let* ((var (set-var ptree))
                (x (assq var var-map)))
           (if x
             (begin
               (var-sets-set! var (set-remove (var-sets var) ptree))
               (var-sets-set! (cdr x) (set-adjoin (var-sets (cdr x)) ptree))
               (set-var-set! ptree (cdr x)))))))

  (node-fv-set! ptree #t)

  (for-each (lambda (child) (ll-rename! child var-map))
            (node-children ptree)))

;------------------------------------------------------------------------------
;
; Debugging stuff:

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
; (parse-tree->expression ptree) returns the Scheme expression corresponding to
; the parse tree 'ptree'.

(define (parse-tree->expression ptree)
  (se ptree '() (list 0)))

(define (se ptree env num)

  (cond ((cst? ptree)
         (list QUOTE-sym (cst-val ptree)))

        ((ref? ptree)
         (let ((x (assq (ref-var ptree) env)))
           (if x (cdr x) (var-name (ref-var ptree)))))

        ((set? ptree)
         (list SET!-sym
           (let ((x (assq (set-var ptree) env)))
             (if x (cdr x) (var-name (set-var ptree))))
           (se (set-val ptree) env num)))

        ((def? ptree)
         (list DEFINE-sym
           (let ((x (assq (def-var ptree) env)))
             (if x (cdr x) (var-name (def-var ptree))))
           (se (def-val ptree) env num)))

        ((tst? ptree)
         (list IF-sym (se (tst-pre ptree) env num)
                      (se (tst-con ptree) env num)
                      (se (tst-alt ptree) env num)))

        ((conj? ptree)
         (list AND-sym (se (conj-pre ptree) env num)
                       (se (conj-alt ptree) env num)))

        ((disj? ptree)
         (list OR-sym (se (disj-pre ptree) env num)
                      (se (disj-alt ptree) env num)))

        ((prc? ptree)
         (let ((new-env (se-rename (prc-parms ptree) env num)))
           (list LAMBDA-sym
             (se-parameters (prc-parms ptree)
                            (prc-rest ptree)
                            (prc-min ptree)
                            new-env)
             (se (prc-body ptree) new-env num))))

        ((app? ptree)
         (let ((oper (app-oper ptree))
               (args (app-args ptree)))
           (if (and (prc? oper) ; applying a lambda-expr is like a 'let'
                    (not (prc-rest oper))
                    (= (length (prc-parms oper)) (length args)))
             (let ((new-env (se-rename (prc-parms oper) env num)))
               (list
                 (if (set-empty?
                       (set-intersection
                         (list->set (prc-parms oper))
                         (apply set-union (map free-variables args))))
                   LET-sym
                   LETREC-sym)
                 (se-bindings (prc-parms oper) args new-env num)
                 (se (prc-body oper) new-env num)))
             (map (lambda (x) (se x env num)) (cons oper args)))))

        ((fut? ptree)
         (list FUTURE-sym (se (fut-val ptree) env num)))

        (else
         (compiler-internal-error "se, unknown parse tree node type"))))

(define (se-parameters parms rest min env)
  (define (se-parms parms rest n env)
    (cond ((null? parms)
           '())
          ((and rest (null? (cdr parms)))
           (cdr (assq (car parms) env)))
          (else
           (let ((parm (cdr (assq (car parms) env))))
             (cons (if (> n 0) parm (list parm))
                   (se-parms (cdr parms) rest (- n 1) env))))))
  (se-parms parms rest min env))

(define (se-bindings vars vals env num)
  (if (null? vars)
    '()
    (cons (list (cdr (assq (car vars) env)) (se (car vals) env num))
          (se-bindings (cdr vars) (cdr vals) env num))))

(define (se-rename vars env num)
  (define (rename vars)
    (if (null? vars)
      env
      (cons (cons (car vars)
                  (string->canonical-symbol
                    (string-append (symbol->string (var-name (car vars)))
                                   "#"
                                   (number->string (car num)))))
            (rename (cdr vars)))))
  (set-car! num (+ (car num) 1))
  (rename vars))

;==============================================================================