|
2641 | 2641 | (define (free-vars e)
|
2642 | 2642 | (table.keys (free-vars- e (table))))
|
2643 | 2643 |
|
2644 |
| -(define (analyze-vars-lambda e env captvars sp new-sp) |
| 2644 | +(define (analyze-vars-lambda e env captvars sp new-sp glob-assign) |
2645 | 2645 | (let* ((args (lam:args e))
|
| 2646 | + (glob-assign (if (null? args) (table) glob-assign)) |
2646 | 2647 | (locl (caddr e))
|
2647 | 2648 | (allv (nconc (map arg-name args) locl))
|
2648 | 2649 | (fv (let* ((fv (diff (free-vars (lam:body e)) allv))
|
|
2674 | 2675 | (and (not (memq (vinfo:name v) allv))
|
2675 | 2676 | (not (memq (vinfo:name v) glo))))
|
2676 | 2677 | env))
|
2677 |
| - cv (delete-duplicates (append new-sp sp))) |
| 2678 | + cv |
| 2679 | + (delete-duplicates (append new-sp sp)) |
| 2680 | + glob-assign) |
| 2681 | + ;; if we collected any assignments to globals |
| 2682 | + ;; annotate them now at the toplevel |
| 2683 | + (if (null? args) |
| 2684 | + (let ((glob-decl (map (lambda (e) `(global ,e)) (table.keys glob-assign)))) |
| 2685 | + (set-car! (cdddr e) (insert-after-meta (lam:body e) glob-decl)))) |
2678 | 2686 | ;; mark all the vars we capture as captured
|
2679 | 2687 | (for-each (lambda (v) (vinfo:set-capt! v #t))
|
2680 | 2688 | cv)
|
|
2689 | 2697 | ;; in-place to
|
2690 | 2698 | ;; (var-info-lst captured-var-infos ssavalues static_params)
|
2691 | 2699 | ;; where var-info-lst is a list of var-info records
|
2692 |
| -(define (analyze-vars e env captvars sp) |
| 2700 | +(define (analyze-vars e env captvars sp glob-assign) |
2693 | 2701 | (if (or (atom? e) (quoted? e))
|
2694 | 2702 | e
|
2695 | 2703 | (case (car e)
|
2696 | 2704 | ((local-def) ;; a local that we know has an assignment that dominates all usages
|
2697 | 2705 | (let ((vi (var-info-for (cadr e) env)))
|
2698 | 2706 | (vinfo:set-never-undef! vi #t)))
|
2699 | 2707 | ((=)
|
2700 |
| - (let ((vi (var-info-for (cadr e) env))) |
2701 |
| - (if vi |
2702 |
| - (begin (if (vinfo:asgn vi) |
2703 |
| - (vinfo:set-sa! vi #f) |
2704 |
| - (vinfo:set-sa! vi #t)) |
2705 |
| - (vinfo:set-asgn! vi #t)))) |
2706 |
| - (analyze-vars (caddr e) env captvars sp)) |
| 2708 | + (if (not (ssavalue? (cadr e))) |
| 2709 | + (let ((vi (and (symbol? (cadr e)) (var-info-for (cadr e) env)))) |
| 2710 | + (if vi ; if local or captured |
| 2711 | + (begin (if (vinfo:asgn vi) |
| 2712 | + (vinfo:set-sa! vi #f) |
| 2713 | + (vinfo:set-sa! vi #t)) |
| 2714 | + (vinfo:set-asgn! vi #t)) |
| 2715 | + (if (and (pair? (cadr e)) (eq? (caadr e) 'outerref)) |
| 2716 | + (if (not (memq (cadadr e) sp)) ; if not a sparam |
| 2717 | + (put! glob-assign (cadadr e) #t)) ; it's a global |
| 2718 | + (put! glob-assign (cadr e) #t))))) ; symbol or global ref |
| 2719 | + (analyze-vars (caddr e) env captvars sp glob-assign)) |
2707 | 2720 | ((call)
|
2708 | 2721 | (let ((vi (var-info-for (cadr e) env)))
|
2709 | 2722 | (if vi
|
2710 | 2723 | (vinfo:set-called! vi #t))
|
2711 |
| - (for-each (lambda (x) (analyze-vars x env captvars sp)) |
| 2724 | + (for-each (lambda (x) (analyze-vars x env captvars sp glob-assign)) |
2712 | 2725 | (cdr e))))
|
2713 | 2726 | ((decl)
|
2714 | 2727 | ;; handle var::T declaration by storing the type in the var-info
|
|
2723 | 2736 | "\" declared in inner scope")))
|
2724 | 2737 | (vinfo:set-type! vi (caddr e))))))
|
2725 | 2738 | ((lambda)
|
2726 |
| - (analyze-vars-lambda e env captvars sp '())) |
| 2739 | + (analyze-vars-lambda e env captvars sp '() glob-assign)) |
2727 | 2740 | ((with-static-parameters)
|
2728 | 2741 | ;; (with-static-parameters func_expr sp_1 sp_2 ...)
|
2729 | 2742 | (assert (eq? (car (cadr e)) 'lambda))
|
2730 | 2743 | (analyze-vars-lambda (cadr e) env captvars sp
|
2731 |
| - (cddr e))) |
| 2744 | + (cddr e) |
| 2745 | + glob-assign)) |
2732 | 2746 | ((method)
|
2733 | 2747 | (if (length= e 2)
|
2734 | 2748 | (let ((vi (var-info-for (method-expr-name e) env)))
|
|
2738 | 2752 | (vinfo:set-sa! vi #t))
|
2739 | 2753 | (vinfo:set-asgn! vi #t)))
|
2740 | 2754 | e)
|
2741 |
| - (begin (analyze-vars (caddr e) env captvars sp) |
| 2755 | + (begin (analyze-vars (caddr e) env captvars sp glob-assign) |
2742 | 2756 | (assert (eq? (car (cadddr e)) 'lambda))
|
2743 | 2757 | (analyze-vars-lambda (cadddr e) env captvars sp
|
2744 |
| - (method-expr-static-parameters e))))) |
| 2758 | + (method-expr-static-parameters e) |
| 2759 | + glob-assign)))) |
2745 | 2760 | ((module toplevel) e)
|
2746 |
| - (else (for-each (lambda (x) (analyze-vars x env captvars sp)) |
| 2761 | + (else (for-each (lambda (x) (analyze-vars x env captvars sp glob-assign)) |
2747 | 2762 | (cdr e))))))
|
2748 | 2763 |
|
2749 |
| -(define (analyze-variables! e) (analyze-vars e '() '() '()) e) |
| 2764 | +(define (analyze-variables! e) |
| 2765 | + (let ((glob-assign (table))) |
| 2766 | + (analyze-vars e '() '() '() glob-assign) |
| 2767 | + ;; if we collected any assignments to globals |
| 2768 | + ;; annotate them now at the toplevel |
| 2769 | + (let ((glob-decl (map (lambda (e) `(global ,e)) (table.keys glob-assign)))) |
| 2770 | + (if (null? glob-decl) |
| 2771 | + e |
| 2772 | + (insert-after-meta |
| 2773 | + (if (and (pair? e) (eq? (car e) 'block)) |
| 2774 | + e |
| 2775 | + `(block ,e)) |
| 2776 | + glob-decl))))) |
2750 | 2777 |
|
2751 | 2778 | ;; pass 4: closure conversion
|
2752 | 2779 |
|
@@ -2841,35 +2868,45 @@ f(x) = yt(x)
|
2841 | 2868 | ;; when doing this, the original value needs to be preserved, to
|
2842 | 2869 | ;; ensure the expression `a=b` always returns exactly `b`.
|
2843 | 2870 | (define (convert-assignment var rhs0 fname lam interp)
|
2844 |
| - (let* ((vi (assq var (car (lam:vinfo lam)))) |
2845 |
| - (cv (assq var (cadr (lam:vinfo lam)))) |
2846 |
| - (vt (or (and vi (vinfo:type vi)) |
2847 |
| - (and cv (vinfo:type cv)) |
2848 |
| - '(core Any))) |
2849 |
| - (closed (and cv (vinfo:asgn cv) (vinfo:capt cv))) |
2850 |
| - (capt (and vi (vinfo:asgn vi) (vinfo:capt vi)))) |
2851 |
| - (if (and (not closed) (not capt) (equal? vt '(core Any))) |
2852 |
| - `(= ,var ,rhs0) |
2853 |
| - (let* ((rhs1 (if (or (ssavalue? rhs0) (simple-atom? rhs0) |
2854 |
| - (equal? rhs0 '(the_exception))) |
2855 |
| - rhs0 |
2856 |
| - (make-ssavalue))) |
2857 |
| - (rhs (if (equal? vt '(core Any)) |
2858 |
| - rhs1 |
2859 |
| - (convert-for-type-decl rhs1 (cl-convert vt fname lam #f #f interp)))) |
2860 |
| - (ex (cond (closed `(call (core setfield!) |
2861 |
| - ,(if interp |
2862 |
| - `($ ,var) |
2863 |
| - `(call (core getfield) ,fname (inert ,var))) |
2864 |
| - (inert contents) |
2865 |
| - ,rhs)) |
2866 |
| - (capt `(call (core setfield!) ,var (inert contents) ,rhs)) |
2867 |
| - (else `(= ,var ,rhs))))) |
2868 |
| - (if (eq? rhs1 rhs0) |
2869 |
| - `(block ,ex ,rhs0) |
2870 |
| - `(block (= ,rhs1 ,rhs0) |
2871 |
| - ,ex |
2872 |
| - ,rhs1)))))) |
| 2871 | + (cond |
| 2872 | + ((symbol? var) |
| 2873 | + (let* ((vi (assq var (car (lam:vinfo lam)))) |
| 2874 | + (cv (assq var (cadr (lam:vinfo lam)))) |
| 2875 | + (vt (or (and vi (vinfo:type vi)) |
| 2876 | + (and cv (vinfo:type cv)) |
| 2877 | + '(core Any))) |
| 2878 | + (closed (and cv (vinfo:asgn cv) (vinfo:capt cv))) |
| 2879 | + (capt (and vi (vinfo:asgn vi) (vinfo:capt vi)))) |
| 2880 | + (if (and (not closed) (not capt) (equal? vt '(core Any))) |
| 2881 | + `(= ,var ,rhs0) |
| 2882 | + (let* ((rhs1 (if (or (ssavalue? rhs0) (simple-atom? rhs0) |
| 2883 | + (equal? rhs0 '(the_exception))) |
| 2884 | + rhs0 |
| 2885 | + (make-ssavalue))) |
| 2886 | + (rhs (if (equal? vt '(core Any)) |
| 2887 | + rhs1 |
| 2888 | + (convert-for-type-decl rhs1 (cl-convert vt fname lam #f #f interp)))) |
| 2889 | + (ex (cond (closed `(call (core setfield!) |
| 2890 | + ,(if interp |
| 2891 | + `($ ,var) |
| 2892 | + `(call (core getfield) ,fname (inert ,var))) |
| 2893 | + (inert contents) |
| 2894 | + ,rhs)) |
| 2895 | + (capt `(call (core setfield!) ,var (inert contents) ,rhs)) |
| 2896 | + (else `(= ,var ,rhs))))) |
| 2897 | + (if (eq? rhs1 rhs0) |
| 2898 | + `(block ,ex ,rhs0) |
| 2899 | + `(block (= ,rhs1 ,rhs0) |
| 2900 | + ,ex |
| 2901 | + ,rhs1)))))) |
| 2902 | + ((and (pair? var) (or (eq? (car var) 'outerref) |
| 2903 | + (eq? (car var) 'globalref))) |
| 2904 | + |
| 2905 | + `(= ,var ,rhs0)) |
| 2906 | + ((ssavalue? var) |
| 2907 | + `(= ,var ,rhs0)) |
| 2908 | + (else |
| 2909 | + (error (string "invalid assignment location \"" (deparse var) "\""))))) |
2873 | 2910 |
|
2874 | 2911 | ;; replace leading (function) argument type with `typ`
|
2875 | 2912 | (define (fix-function-arg-type te typ iskw namemap type-sp)
|
@@ -3056,9 +3093,7 @@ f(x) = yt(x)
|
3056 | 3093 | ((=)
|
3057 | 3094 | (let ((var (cadr e))
|
3058 | 3095 | (rhs (cl-convert (caddr e) fname lam namemap toplevel interp)))
|
3059 |
| - (if (ssavalue? var) |
3060 |
| - `(= ,var ,rhs) |
3061 |
| - (convert-assignment var rhs fname lam interp)))) |
| 3096 | + (convert-assignment var rhs fname lam interp))) |
3062 | 3097 | ((local-def) ;; make new Box for local declaration of defined variable
|
3063 | 3098 | (let ((vi (assq (cadr e) (car (lam:vinfo lam)))))
|
3064 | 3099 | (if (and vi (vinfo:asgn vi) (vinfo:capt vi))
|
@@ -3100,10 +3135,10 @@ f(x) = yt(x)
|
3100 | 3135 | (lam2 (if short #f (cadddr e)))
|
3101 | 3136 | (vis (if short '(() () ()) (lam:vinfo lam2)))
|
3102 | 3137 | (cvs (map car (cadr vis)))
|
3103 |
| - (local? (lambda (s) (and (symbol? s) |
| 3138 | + (local? (lambda (s) (and lam (symbol? s) |
3104 | 3139 | (or (assq s (car (lam:vinfo lam)))
|
3105 | 3140 | (assq s (cadr (lam:vinfo lam)))))))
|
3106 |
| - (local (and lam (local? name))) |
| 3141 | + (local (local? name)) |
3107 | 3142 | (sig (and (not short) (caddr e)))
|
3108 | 3143 | (sp-inits (if (or short (not (eq? (car sig) 'block)))
|
3109 | 3144 | '()
|
@@ -3180,7 +3215,7 @@ f(x) = yt(x)
|
3180 | 3215 | (and (symbol? s)
|
3181 | 3216 | (not (eq? name s))
|
3182 | 3217 | (not (memq s capt-sp))
|
3183 |
| - (or ;(local? s) ; TODO: make this work for local variables too? |
| 3218 | + (or ;(local? s) ; TODO: error for local variables |
3184 | 3219 | (memq s (lam:sp lam)))))))
|
3185 | 3220 | (caddr methdef)
|
3186 | 3221 | (lambda (e) (cadr e)))))
|
@@ -3306,7 +3341,8 @@ f(x) = yt(x)
|
3306 | 3341 | ;; numbered slots (or be simple immediate values), and then those will be the
|
3307 | 3342 | ;; only possible returned values.
|
3308 | 3343 | (define (compile-body e vi lam)
|
3309 |
| - (let ((code '()) |
| 3344 | + (let ((code '()) ;; statements (emitted in reverse order) |
| 3345 | + (glob-decl '()) ;; global decls will be collected in the prelude to code so they execute first |
3310 | 3346 | (filename 'none)
|
3311 | 3347 | (first-line #t)
|
3312 | 3348 | (current-loc #f)
|
@@ -3614,6 +3650,7 @@ f(x) = yt(x)
|
3614 | 3650 | (if (var-info-for vname vi)
|
3615 | 3651 | ;; issue #7264
|
3616 | 3652 | (error (string "`global " vname "`: " vname " is local variable in the enclosing scope"))
|
| 3653 | + (if (null? (lam:args lam)) (set! glob-decl (cons e glob-decl))) ;; keep global decl in thunks |
3617 | 3654 | #f)))
|
3618 | 3655 | ((local-def) #f)
|
3619 | 3656 | ((local) #f)
|
@@ -3699,13 +3736,13 @@ f(x) = yt(x)
|
3699 | 3736 | (body (cons 'body (filter (lambda (e)
|
3700 | 3737 | (not (and (pair? e) (eq? (car e) 'newvar)
|
3701 | 3738 | (has? di (cadr e)))))
|
3702 |
| - stmts)))) |
3703 |
| - (if arg-map |
3704 |
| - (insert-after-meta |
3705 |
| - body |
3706 |
| - (table.foldl (lambda (k v lst) (cons `(= ,v ,k) lst)) |
3707 |
| - '() arg-map)) |
3708 |
| - body)))) |
| 3739 | + stmts))) |
| 3740 | + (prelude (if arg-map |
| 3741 | + (append! glob-decl |
| 3742 | + (table.foldl (lambda (k v lst) (cons `(= ,v ,k) lst)) |
| 3743 | + '() arg-map)) |
| 3744 | + glob-decl))) |
| 3745 | + (insert-after-meta body prelude)))) |
3709 | 3746 |
|
3710 | 3747 | ;; find newvar nodes that are unnecessary because (1) the variable is not
|
3711 | 3748 | ;; captured, and (2) the variable is assigned before any branches.
|
|
0 commit comments