mirror of
https://github.com/justinethier/cyclone.git
synced 2025-07-04 03:36:34 +02:00
Relocate wrap-mutables
This commit is contained in:
Justin Ethier
parent
b6732b988a
commit
82dd4cb5c3
2 changed files with 213 additions and 209 deletions
|
|
@ -110,6 +110,12 @@
|
|||
adbf:set-vars-mutated-by-set!
|
||||
with-fnc
|
||||
with-fnc!
|
||||
;; Wrap mutables
|
||||
clear-mutables
|
||||
mark-mutable
|
||||
is-mutable?
|
||||
analyze-mutable-variables
|
||||
wrap-mutables
|
||||
)
|
||||
(include "cps-opt-local-var-redux.scm")
|
||||
(include "cps-opt-analyze-call-graph.scm")
|
||||
|
|
@ -2453,4 +2459,211 @@
|
|||
(close-port p)
|
||||
result)))
|
||||
|
||||
;; Mutable variable analysis and elimination.
|
||||
|
||||
;; Mutables variables analysis and elimination happens
|
||||
;; on a desugared Intermediate Language (1).
|
||||
|
||||
;; Mutable variable analysis turns mutable variables
|
||||
;; into heap-allocated cells:
|
||||
|
||||
;; For any mutable variable mvar:
|
||||
|
||||
;; (lambda (... mvar ...) body)
|
||||
;; =>
|
||||
;; (lambda (... $v ...)
|
||||
;; (let ((mvar (cell $v)))
|
||||
;; body))
|
||||
|
||||
;; (set! mvar value) => (set-cell! mvar value)
|
||||
|
||||
;; mvar => (cell-get mvar)
|
||||
|
||||
; mutable-variables : list[symbol]
|
||||
(define mutable-variables '())
|
||||
|
||||
(define (clear-mutables)
|
||||
(set! mutable-variables '()))
|
||||
|
||||
; mark-mutable : symbol -> void
|
||||
(define (mark-mutable symbol)
|
||||
(set! mutable-variables (cons symbol mutable-variables)))
|
||||
|
||||
; is-mutable? : symbol -> boolean
|
||||
(define (is-mutable? symbol)
|
||||
(define (is-in? S)
|
||||
(if (not (pair? S))
|
||||
#f
|
||||
(if (eq? (car S) symbol)
|
||||
#t
|
||||
(is-in? (cdr S)))))
|
||||
(is-in? mutable-variables))
|
||||
|
||||
(define mutated-loop-vars '())
|
||||
(define (mark-mutated-loop-var sym)
|
||||
(set! mutated-loop-vars (cons sym mutated-loop-vars)))
|
||||
(define (mutated-loop-var? sym)
|
||||
(member sym mutated-loop-var))
|
||||
|
||||
; analyze-mutable-variables : exp -> void
|
||||
(define (analyze-mutable-variables exp)
|
||||
(cond
|
||||
; Core forms:
|
||||
((ast:lambda? exp)
|
||||
(map analyze-mutable-variables (ast:lambda-body exp))
|
||||
(void))
|
||||
((const? exp) (void))
|
||||
((prim? exp) (void))
|
||||
((ref? exp) (void))
|
||||
((quote? exp) (void))
|
||||
((lambda? exp)
|
||||
(map analyze-mutable-variables (lambda->exp exp))
|
||||
(void))
|
||||
((set!? exp)
|
||||
(mark-mutable (set!->var exp))
|
||||
(analyze-mutable-variables (set!->exp exp)))
|
||||
((if? exp)
|
||||
(analyze-mutable-variables (if->condition exp))
|
||||
(analyze-mutable-variables (if->then exp))
|
||||
(analyze-mutable-variables (if->else exp)))
|
||||
; Application:
|
||||
((app? exp)
|
||||
(map analyze-mutable-variables exp)
|
||||
;; Check if the application is a sentinel indicating the
|
||||
;; var may be used for a recursive loop.
|
||||
;(when (and (= 2 (length exp))
|
||||
; (ast:lambda? (car exp))
|
||||
; (not (cadr exp)))
|
||||
; ;; Candidate, see if the var is set to a lambda
|
||||
; (with-var
|
||||
;)
|
||||
(void))
|
||||
(else
|
||||
(error "unknown expression type: " exp))))
|
||||
|
||||
|
||||
; wrap-mutables : exp -> exp
|
||||
(define (wrap-mutables exp globals)
|
||||
|
||||
(define (wrap-mutable-formals id formals body-exp has-cont)
|
||||
(if (not (pair? formals))
|
||||
body-exp
|
||||
;(list body-exp)
|
||||
(if (is-mutable? (car formals))
|
||||
(list
|
||||
(list ;(ast:%make-lambda
|
||||
; id
|
||||
(ast:make-lambda
|
||||
(list (car formals))
|
||||
(wrap-mutable-formals id (cdr formals) body-exp has-cont)
|
||||
has-cont)
|
||||
`(cell ,(car formals))))
|
||||
(wrap-mutable-formals id (cdr formals) body-exp has-cont))))
|
||||
|
||||
(cond
|
||||
; Core forms:
|
||||
((ast:lambda? exp)
|
||||
(ast:%make-lambda
|
||||
(ast:lambda-id exp)
|
||||
(ast:lambda-args exp)
|
||||
(wrap-mutable-formals
|
||||
(ast:lambda-id exp)
|
||||
(ast:lambda-formals->list exp)
|
||||
(list (wrap-mutables (car (ast:lambda-body exp)) globals))
|
||||
(ast:lambda-has-cont exp))
|
||||
(ast:lambda-has-cont exp)
|
||||
)) ;; Assume single expr in lambda body, since after CPS phase
|
||||
((const? exp) exp)
|
||||
((ref? exp) (if (and (not (member exp globals))
|
||||
(is-mutable? exp))
|
||||
`(cell-get ,exp)
|
||||
exp))
|
||||
((prim? exp) exp)
|
||||
((quote? exp) exp)
|
||||
((lambda? exp) (error `(Unexpected lambda in wrap-mutables ,exp)))
|
||||
((set!? exp) `(,(if (member (set!->var exp) globals)
|
||||
'set-global!
|
||||
'set-cell!)
|
||||
,(set!->var exp)
|
||||
,(wrap-mutables (set!->exp exp) globals)))
|
||||
((if? exp) `(if ,(wrap-mutables (if->condition exp) globals)
|
||||
,(wrap-mutables (if->then exp) globals)
|
||||
,(wrap-mutables (if->else exp) globals)))
|
||||
|
||||
; Application:
|
||||
((app? exp)
|
||||
;; Easy place to clean up nested Cyc-seq expressions
|
||||
(when (tagged-list? 'Cyc-seq exp)
|
||||
(set! exp (flatten-sequence exp)))
|
||||
(let ((result (map (lambda (e) (wrap-mutables e globals)) exp)))
|
||||
;; This code can eliminate a lambda definition. But typically
|
||||
;; the code that would have such a definition has a recursive
|
||||
;; inner loop, so there is not much savings to eliminating the
|
||||
;; single outer lambda:
|
||||
;;
|
||||
;;(cond
|
||||
;; ((and (lambda? (car result))
|
||||
;; (equal? (cdr result) '(#f))
|
||||
;; (app? (car (lambda->exp (car result))))
|
||||
;; (lambda? (car (car (lambda->exp (car result))))))
|
||||
;; (let* ((inner-lambda (car (car (lambda->exp (car result)))))
|
||||
;; (inner-formals (lambda-formals->list inner-lambda))
|
||||
;; (inner-args (cdr (car (lambda->exp (car result)))))
|
||||
;; (outer-formals (lambda-formals->list (car result)))
|
||||
;; (opt? (and (pair? outer-formals)
|
||||
;; (is-mutable? (car outer-formals))
|
||||
;; (equal? outer-formals inner-formals)
|
||||
;; (equal? inner-args `((cell ,(car inner-formals))))
|
||||
;; )))
|
||||
;; (trace:error `(DEBUG ,opt? ,outer-formals ,inner-formals ,inner-args))
|
||||
;; ;result
|
||||
;; (if opt?
|
||||
;; `(,inner-lambda (cell #f))
|
||||
;; result)
|
||||
;; ))
|
||||
;; (else result))))
|
||||
result))
|
||||
(else (error "unknown expression type: " exp))))
|
||||
|
||||
;; Flatten a list containing subcalls of a given symbol.
|
||||
;; For example, the expression:
|
||||
;;
|
||||
;; '(Cyc-seq
|
||||
;; (set! b '(#f . #f))
|
||||
;; (Cyc-seq
|
||||
;; (set-car! a 1)
|
||||
;; (Cyc-seq
|
||||
;; (set-cdr! a '(2))
|
||||
;; ((fnc a1 a2 a3)))))
|
||||
;;
|
||||
;; becomes:
|
||||
;;
|
||||
;; '(Cyc-seq
|
||||
;; (set! b '(#f . #f))
|
||||
;; (set-car! a 1)
|
||||
;; (set-cdr! a '(2))
|
||||
;; ((fnc a1 a2 a3)))
|
||||
;;
|
||||
(define (flatten-sequence sexp)
|
||||
(define (flat sexp acc)
|
||||
(cond
|
||||
((not (pair? sexp)) ;; Stop at end of sexp
|
||||
acc)
|
||||
((and (tagged-list? 'Cyc-seq (car sexp))) ;; Flatten nexted sequences
|
||||
(flat (cdar sexp) acc))
|
||||
((and (ref? (car sexp)) ;; Remove unused identifiers
|
||||
(not (equal? 'Cyc-seq (car sexp))))
|
||||
(flat (cdr sexp) acc))
|
||||
(else ;;(pair? sexp)
|
||||
(flat (cdr sexp) (cons (car sexp) acc))))
|
||||
)
|
||||
(reverse
|
||||
(flat sexp '())))
|
||||
|
||||
(cond-expand
|
||||
(cyclone
|
||||
; void : -> void
|
||||
(define (void) (if #f #t)))
|
||||
(else #f))
|
||||
|
||||
))
|
||||
|
|
|
|||
|
|
@ -88,11 +88,6 @@
|
|||
global-vars
|
||||
filter-unused-variables
|
||||
free-vars
|
||||
clear-mutables
|
||||
mark-mutable
|
||||
is-mutable?
|
||||
analyze-mutable-variables
|
||||
wrap-mutables
|
||||
alpha-convert
|
||||
cps-convert
|
||||
prim-convert
|
||||
|
|
@ -737,210 +732,6 @@ if (acc) {
|
|||
|
||||
|
||||
|
||||
|
||||
|
||||
;; Mutable variable analysis and elimination.
|
||||
|
||||
;; Mutables variables analysis and elimination happens
|
||||
;; on a desugared Intermediate Language (1).
|
||||
|
||||
;; Mutable variable analysis turns mutable variables
|
||||
;; into heap-allocated cells:
|
||||
|
||||
;; For any mutable variable mvar:
|
||||
|
||||
;; (lambda (... mvar ...) body)
|
||||
;; =>
|
||||
;; (lambda (... $v ...)
|
||||
;; (let ((mvar (cell $v)))
|
||||
;; body))
|
||||
|
||||
;; (set! mvar value) => (set-cell! mvar value)
|
||||
|
||||
;; mvar => (cell-get mvar)
|
||||
|
||||
; mutable-variables : list[symbol]
|
||||
(define mutable-variables '())
|
||||
|
||||
(define (clear-mutables)
|
||||
(set! mutable-variables '()))
|
||||
|
||||
; mark-mutable : symbol -> void
|
||||
(define (mark-mutable symbol)
|
||||
(set! mutable-variables (cons symbol mutable-variables)))
|
||||
|
||||
; is-mutable? : symbol -> boolean
|
||||
(define (is-mutable? symbol)
|
||||
(define (is-in? S)
|
||||
(if (not (pair? S))
|
||||
#f
|
||||
(if (eq? (car S) symbol)
|
||||
#t
|
||||
(is-in? (cdr S)))))
|
||||
(is-in? mutable-variables))
|
||||
|
||||
(define mutated-loop-vars '())
|
||||
(define (mark-mutated-loop-var sym)
|
||||
(set! mutated-loop-vars (cons sym mutated-loop-vars)))
|
||||
(define (mutated-loop-var? sym)
|
||||
(member sym mutated-loop-var))
|
||||
|
||||
; analyze-mutable-variables : exp -> void
|
||||
(define (analyze-mutable-variables exp)
|
||||
(cond
|
||||
; Core forms:
|
||||
((ast:lambda? exp)
|
||||
(map analyze-mutable-variables (ast:lambda-body exp))
|
||||
(void))
|
||||
((const? exp) (void))
|
||||
((prim? exp) (void))
|
||||
((ref? exp) (void))
|
||||
((quote? exp) (void))
|
||||
((lambda? exp)
|
||||
(map analyze-mutable-variables (lambda->exp exp))
|
||||
(void))
|
||||
((set!? exp)
|
||||
(mark-mutable (set!->var exp))
|
||||
(analyze-mutable-variables (set!->exp exp)))
|
||||
((if? exp)
|
||||
(analyze-mutable-variables (if->condition exp))
|
||||
(analyze-mutable-variables (if->then exp))
|
||||
(analyze-mutable-variables (if->else exp)))
|
||||
; Application:
|
||||
((app? exp)
|
||||
(map analyze-mutable-variables exp)
|
||||
;; Check if the application is a sentinel indicating the
|
||||
;; var may be used for a recursive loop.
|
||||
;(when (and (= 2 (length exp))
|
||||
; (ast:lambda? (car exp))
|
||||
; (not (cadr exp)))
|
||||
; ;; Candidate, see if the var is set to a lambda
|
||||
; (with-var
|
||||
;)
|
||||
(void))
|
||||
(else
|
||||
(error "unknown expression type: " exp))))
|
||||
|
||||
|
||||
; wrap-mutables : exp -> exp
|
||||
(define (wrap-mutables exp globals)
|
||||
|
||||
(define (wrap-mutable-formals id formals body-exp has-cont)
|
||||
(if (not (pair? formals))
|
||||
body-exp
|
||||
;(list body-exp)
|
||||
(if (is-mutable? (car formals))
|
||||
(list
|
||||
(list ;(ast:%make-lambda
|
||||
; id
|
||||
(ast:make-lambda
|
||||
(list (car formals))
|
||||
(wrap-mutable-formals id (cdr formals) body-exp has-cont)
|
||||
has-cont)
|
||||
`(cell ,(car formals))))
|
||||
(wrap-mutable-formals id (cdr formals) body-exp has-cont))))
|
||||
|
||||
(cond
|
||||
; Core forms:
|
||||
((ast:lambda? exp)
|
||||
(ast:%make-lambda
|
||||
(ast:lambda-id exp)
|
||||
(ast:lambda-args exp)
|
||||
(wrap-mutable-formals
|
||||
(ast:lambda-id exp)
|
||||
(ast:lambda-formals->list exp)
|
||||
(list (wrap-mutables (car (ast:lambda-body exp)) globals))
|
||||
(ast:lambda-has-cont exp))
|
||||
(ast:lambda-has-cont exp)
|
||||
)) ;; Assume single expr in lambda body, since after CPS phase
|
||||
((const? exp) exp)
|
||||
((ref? exp) (if (and (not (member exp globals))
|
||||
(is-mutable? exp))
|
||||
`(cell-get ,exp)
|
||||
exp))
|
||||
((prim? exp) exp)
|
||||
((quote? exp) exp)
|
||||
((lambda? exp) (error `(Unexpected lambda in wrap-mutables ,exp)))
|
||||
((set!? exp) `(,(if (member (set!->var exp) globals)
|
||||
'set-global!
|
||||
'set-cell!)
|
||||
,(set!->var exp)
|
||||
,(wrap-mutables (set!->exp exp) globals)))
|
||||
((if? exp) `(if ,(wrap-mutables (if->condition exp) globals)
|
||||
,(wrap-mutables (if->then exp) globals)
|
||||
,(wrap-mutables (if->else exp) globals)))
|
||||
|
||||
; Application:
|
||||
((app? exp)
|
||||
;; Easy place to clean up nested Cyc-seq expressions
|
||||
(when (tagged-list? 'Cyc-seq exp)
|
||||
(set! exp (flatten-sequence exp)))
|
||||
(let ((result (map (lambda (e) (wrap-mutables e globals)) exp)))
|
||||
;; This code can eliminate a lambda definition. But typically
|
||||
;; the code that would have such a definition has a recursive
|
||||
;; inner loop, so there is not much savings to eliminating the
|
||||
;; single outer lambda:
|
||||
;;
|
||||
;;(cond
|
||||
;; ((and (lambda? (car result))
|
||||
;; (equal? (cdr result) '(#f))
|
||||
;; (app? (car (lambda->exp (car result))))
|
||||
;; (lambda? (car (car (lambda->exp (car result))))))
|
||||
;; (let* ((inner-lambda (car (car (lambda->exp (car result)))))
|
||||
;; (inner-formals (lambda-formals->list inner-lambda))
|
||||
;; (inner-args (cdr (car (lambda->exp (car result)))))
|
||||
;; (outer-formals (lambda-formals->list (car result)))
|
||||
;; (opt? (and (pair? outer-formals)
|
||||
;; (is-mutable? (car outer-formals))
|
||||
;; (equal? outer-formals inner-formals)
|
||||
;; (equal? inner-args `((cell ,(car inner-formals))))
|
||||
;; )))
|
||||
;; (trace:error `(DEBUG ,opt? ,outer-formals ,inner-formals ,inner-args))
|
||||
;; ;result
|
||||
;; (if opt?
|
||||
;; `(,inner-lambda (cell #f))
|
||||
;; result)
|
||||
;; ))
|
||||
;; (else result))))
|
||||
result))
|
||||
(else (error "unknown expression type: " exp))))
|
||||
|
||||
;; Flatten a list containing subcalls of a given symbol.
|
||||
;; For example, the expression:
|
||||
;;
|
||||
;; '(Cyc-seq
|
||||
;; (set! b '(#f . #f))
|
||||
;; (Cyc-seq
|
||||
;; (set-car! a 1)
|
||||
;; (Cyc-seq
|
||||
;; (set-cdr! a '(2))
|
||||
;; ((fnc a1 a2 a3)))))
|
||||
;;
|
||||
;; becomes:
|
||||
;;
|
||||
;; '(Cyc-seq
|
||||
;; (set! b '(#f . #f))
|
||||
;; (set-car! a 1)
|
||||
;; (set-cdr! a '(2))
|
||||
;; ((fnc a1 a2 a3)))
|
||||
;;
|
||||
(define (flatten-sequence sexp)
|
||||
(define (flat sexp acc)
|
||||
(cond
|
||||
((not (pair? sexp)) ;; Stop at end of sexp
|
||||
acc)
|
||||
((and (tagged-list? 'Cyc-seq (car sexp))) ;; Flatten nexted sequences
|
||||
(flat (cdar sexp) acc))
|
||||
((and (ref? (car sexp)) ;; Remove unused identifiers
|
||||
(not (equal? 'Cyc-seq (car sexp))))
|
||||
(flat (cdr sexp) acc))
|
||||
(else ;;(pair? sexp)
|
||||
(flat (cdr sexp) (cons (car sexp) acc))))
|
||||
)
|
||||
(reverse
|
||||
(flat sexp '())))
|
||||
|
||||
|
||||
;; Alpha conversion
|
||||
;; (aka alpha renaming)
|
||||
;;
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue