Fcalva/cyclone
1
0
Fork 0
mirror of https://github.com/justinethier/cyclone.git synced 2025-07-14 16:27:35 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Added opt:beta-expand

Browse source
This commit is contained in:
Justin Ethier 2017-05-15 18:50:37 +00:00
parent eee5695c1f
commit 6118325ff4
1 changed files with 60 additions and 59 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

117
scheme/cyclone/cps-optimizations.sld
View file

@ -22,6 +22,7 @@
;analyze-lambda-side-effects ;analyze-lambda-side-effects
opt:contract opt:contract
opt:inline-prims opt:inline-prims
opt:beta-expand
adb:clear! adb:clear!
adb:get adb:get
adb:get/default adb:get/default
@ -631,12 +632,9 @@
,(opt:contract (if->else exp)))))) ,(opt:contract (if->else exp))))))
; Application: ; Application:
((app? exp) ((app? exp)
;; Hack to test this idea ;; Beta expansion of functions only called once, from CWC
;; TODO: was testing this with the fibc program (if (beta-expand/called-once? exp)
;; TODO: real solution is to have a separate beta expansion phase after opt:contract. (set! exp (beta-expand-app exp)))
;; will need to pass over all the code and expand here in the (app?) clause
(if (beta-expand? exp)
(set! exp (beta-expand exp)))
;; END ;; END
(let* ((fnc (opt:contract (car exp)))) (let* ((fnc (opt:contract (car exp))))
@ -1157,20 +1155,25 @@
(else (else
(error `(Unexpected expression passed to find inlinable vars ,exp))))) (error `(Unexpected expression passed to find inlinable vars ,exp)))))
(define (beta-expand/called-once? exp)
(beta-expand/opts? exp #t))
(define (beta-expand? exp) (define (beta-expand? exp)
(beta-expand/opts? exp #f))
(define (beta-expand/opts? exp called-once?)
(cond (cond
((and (app? exp) ((and (app? exp)
(ref? (car exp))) (ref? (car exp)))
(with-var (car exp) (lambda (var) (with-var (car exp) (lambda (var)
;(= 1 (adbv:app-fnc-count var)) ;; TODO: too simplistic
;; TODO: following causes problems on unit-test.scm.
;; Needs to be debugged more...
(let* ((fnc* (adbv:assigned-value var)) (let* ((fnc* (adbv:assigned-value var))
(fnc (if (and (pair? fnc*) (fnc (if (and (pair? fnc*)
(ast:lambda? (car fnc*))) (ast:lambda? (car fnc*)))
(car fnc*) (car fnc*)
fnc*))) fnc*)))
(and (ast:lambda? fnc) (and (ast:lambda? fnc)
(or (not called-once?)
(= 1 (adbv:app-fnc-count var)))
(not (adbv:reassigned? var)) (not (adbv:reassigned? var))
(not (fnc-depth>? (ast:lambda-body fnc) 4)))) (not (fnc-depth>? (ast:lambda-body fnc) 4))))
))) )))
@ -1194,25 +1197,26 @@
(scan exp depth) (scan exp depth)
(return #f)))) (return #f))))
(define (beta-expand exp) ;; Check app and beta expand if possible, else just return given code
(define (beta-expand-app exp)
(let* ((args (cdr exp)) (let* ((args (cdr exp))
(var (adb:get (car exp))) (var (adb:get/default (car exp) #f))
;; Function definition, or #f if none ;; Function definition, or #f if none
(fnc* (adbv:assigned-value var)) (fnc* (if var (adbv:assigned-value var) #f))
(fnc (if (and (pair? fnc*) (fnc (if (and (pair? fnc*)
(ast:lambda? (car fnc*))) (ast:lambda? (car fnc*)))
(car fnc*) (car fnc*)
fnc*)) fnc*))
(formals (if (ast:lambda? fnc) (ast:lambda-args fnc) '())) (formals (if (ast:lambda? fnc) (ast:lambda-args fnc) '()))
;; First formal, or #f if none ;;; First formal, or #f if none
(maybe-cont (if (and (list? formals) (pair? formals)) ;(maybe-cont (if (and (list? formals) (pair? formals))
(car formals) ; (car formals)
#f)) ; #f))
;; function's continuation symbol, or #f if none ;;; function's continuation symbol, or #f if none
(cont (if maybe-cont ;(cont (if maybe-cont
(with-var maybe-cont (lambda (var) ; (with-var maybe-cont (lambda (var)
(if (adbv:cont? var) maybe-cont #f))) ; (if (adbv:cont? var) maybe-cont #f)))
#f)) ; #f))
) )
;(trace:error `(JAE beta expand ,exp ,var ,fnc ,formals ,cont)) ;(trace:error `(JAE beta expand ,exp ,var ,fnc ,formals ,cont))
(cond (cond
@ -1223,12 +1227,12 @@
(list? formals) (list? formals)
(= (length args) (length formals))) (= (length args) (length formals)))
;(trace:error `(JAE DEBUG beta expand ,exp)) ;(trace:error `(JAE DEBUG beta expand ,exp))
(beta-expansion exp fnc) ; exp (beta-expansion-app exp fnc) ; exp
) )
(else exp)))) ;; beta expansion failed (else exp)))) ;; beta expansion failed
;; Replace function call with body of fnc ;; Replace function call with body of fnc
(define (beta-expansion exp fnc) (define (beta-expansion-app exp fnc)
;; Mapping from a formal => actual arg ;; Mapping from a formal => actual arg
(define formals/actuals (define formals/actuals
(map cons (ast:lambda-args fnc) (cdr exp))) (map cons (ast:lambda-args fnc) (cdr exp)))
@ -1252,6 +1256,36 @@
(else exp))) (else exp)))
(scan (car (ast:lambda-body fnc)))) (scan (car (ast:lambda-body fnc))))
;; Full beta expansion phase, make a pass over all of the program's AST
(define (opt:beta-expand exp)
;(write `(DEBUG opt:beta-expand ,exp)) (newline)
(cond
((ast:lambda? exp)
(ast:%make-lambda
(ast:lambda-id exp)
(ast:lambda-args exp)
(opt:beta-expand (ast:lambda-body exp))
(ast:lambda-has-cont exp)))
((quote? exp) exp)
((const? exp) exp)
((ref? exp) exp)
((define? exp)
`(define ,(define->var exp)
,@(opt:beta-expand (define->exp exp))))
((set!? exp)
`(set! ,(set!->var exp)
,(opt:beta-expand (set!->exp exp))))
((if? exp)
`(if ,(opt:beta-expand (if->condition exp))
,(opt:beta-expand (if->then exp))
,(opt:beta-expand (if->else exp))))
((app? exp)
(let ((code (if (beta-expand? exp)
(beta-expand-app exp)
exp)))
(map opt:beta-expand code)))
(else exp)))
(define (analyze-cps exp) (define (analyze-cps exp)
(analyze-find-lambdas exp -1) (analyze-find-lambdas exp -1)
(analyze-lambda-side-effects exp -1) (analyze-lambda-side-effects exp -1)
@ -1259,33 +1293,6 @@
(analyze exp -1) ;; Top-level is lambda ID -1 (analyze exp -1) ;; Top-level is lambda ID -1
(analyze2 exp) ;; Second pass (analyze2 exp) ;; Second pass
(analyze:find-inlinable-vars exp '()) ;; Identify variables safe to inline (analyze:find-inlinable-vars exp '()) ;; Identify variables safe to inline
;; For now, beta expansion finds so few candidates it is not worth optimizing
;; ;; TODO:
;; ;; Find candidates for beta expansion
;; (for-each
;; (lambda (db-entry)
;;;(trace:error `(check for lambda candidate
;; (cond
;; ((number? (car db-entry))
;; ;; TODO: this is just exploratory code, can be more efficient
;; (let ((id (car db-entry))
;; (fnc (cdr db-entry))
;; (app-count 0)
;; (app-arg-count 0)
;; (reassigned-count 0))
;; (for-each
;; (lambda (sym)
;; (with-var! sym (lambda (var)
;; (set! app-count (+ app-count (adbv:app-fnc-count var)))
;; (set! app-arg-count (+ app-arg-count (adbv:app-arg-count var)))
;; (set! reassigned-count (+ reassigned-count (if (adbv:reassigned? var) 1 0)))
;; ))
;; )
;; (adbf:assigned-to-var fnc))
;;(trace:error `(candidate ,id ,app-count ,app-arg-count ,reassigned-count))
;; ))))
;; (hash-table->alist *adb*))
;; ;; END TODO
) )
;; NOTES: ;; NOTES:
@ -1301,20 +1308,14 @@
;; TODO: re-run phases again until program is stable (less than n opts made, more than r rounds performed, etc) ;; TODO: re-run phases again until program is stable (less than n opts made, more than r rounds performed, etc)
;; END notes ;; END notes
;(define (optimize-cps ast)
; (define (loop ast n)
; (if (= n 0)
; (do-optimize-cps ast)
; (loop (do-optimize-cps ast) (- n 1))))
; (loop ast 2))
(define (optimize-cps ast) (define (optimize-cps ast)
(adb:clear!) (adb:clear!)
(analyze-cps ast) (analyze-cps ast)
(trace:info "---------------- cps analysis db:") (trace:info "---------------- cps analysis db:")
(trace:info (adb:get-db)) (trace:info (adb:get-db))
(opt:beta-expand
(opt:inline-prims (opt:inline-prims
(opt:contract ast)) (opt:contract ast)))
) )
)) ))