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

Do not optimize-out variables if they are:

Browse source 
- Mutated
- Never referenced (implies operation is performed for side effects)
This commit is contained in:
Justin Ethier 2016-06-07 00:03:57 -04:00
parent 9b548b94c3
commit 2f326c0efc
2 changed files with 116 additions and 89 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -17,8 +17,8 @@
; can write initial analyze, but can't get too far without being able ; can write initial analyze, but can't get too far without being able
; to uniquely ID each lambda ; to uniquely ID each lambda
(define-library (cps-optimizations) ;(define-library (cps-optimizations)
;(define-library (scheme cyclone cps-optimizations) (define-library (scheme cyclone cps-optimizations)
(import (scheme base) (import (scheme base)
(scheme cyclone util) (scheme cyclone util)
(scheme cyclone ast) (scheme cyclone ast)
@ -150,6 +150,11 @@
(fnc var) (fnc var)
(adb:set! sym var))) (adb:set! sym var)))
;; Non-mutating version, returns results of fnc
(define (with-var sym fnc)
(let ((var (adb:get/default sym (adb:make-var))))
(fnc var)))
(define (with-fnc! id callback) (define (with-fnc! id callback)
(let ((fnc (adb:get/default id (adb:make-fnc)))) (let ((fnc (adb:get/default id (adb:make-fnc))))
(callback fnc) (callback fnc)
@ -417,6 +422,10 @@
(else (else
(error "CPS optimize [1] - Unknown expression" exp)))) (error "CPS optimize [1] - Unknown expression" exp))))
;; Inline primtives
;; Uses analysis DB, so must be executed after analysis phase
;;
;; TBD: better to enhance CPS conversion to do this??
(define (contract-prims exp . refs*) (define (contract-prims exp . refs*)
(let ((refs (if (null? refs*) (let ((refs (if (null? refs*)
(make-hash-table) (make-hash-table)
@ -456,6 +465,19 @@
;; TODO: check for more than one arg?? ;; TODO: check for more than one arg??
(equal? (length (cdr exp)) (equal? (length (cdr exp))
(length (ast:lambda-formals->list (car exp)))) (length (ast:lambda-formals->list (car exp))))
;; Double-check parameter can be optimized-out
(every
(lambda (param)
(with-var param (lambda (var)
;(trace:error `(DEBUG ,param ,(adbv:ref-by var)))
(and
;; If param is never referenced, then prim is being
;; called for side effects, possibly on a global
(not (null? (adbv:ref-by var)))
;; Need to keep variable because it is mutated
(not (adbv:reassigned? var))
))))
(ast:lambda-formals->list (car exp)))
(every (every
(lambda (arg) (lambda (arg)
(and (prim-call? arg) (and (prim-call? arg)
@ -540,62 +562,8 @@
(trace:info "---------------- cps analysis db:") (trace:info "---------------- cps analysis db:")
(trace:info (adb:get-db)) (trace:info (adb:get-db))
;ast ;; DEBUGGING!!! ;ast ;; DEBUGGING!!!
;(contract-prims (contract-prims
; (opt:contract ast)) (opt:contract ast))
) )
;; Older code, delete this soon
;;;; TODO: don't think we can assume lambda body is single expr, if we want
;;;; to do optimizations such as inlining
;;(define (cps-optimize-01 exp)
;; exp) ;; Temporarily disabling while this is reworked.
;;; (define (opt-lambda exp)
;;; (let ((body (car (lambda->exp exp)))) ;; Single expr after CPS
;;; ;(trace:error `(DEBUG
;;; ; ,exp
;;; ; ,body
;;; ; ,(if (and (pair? body) (app? body) (lambda? (car body)))
;;; ; (list (app->args body)
;;; ; (lambda->formals exp))
;;; ; #f)))
;;; (cond
;;; ;; Does the function just call its continuation?
;;; ((and (pair? body)
;;; (app? body)
;;; (lambda? (car body))
;;; ;; TODO: need to check body length if we allow >1 expr in a body
;;; ;; TODO: not sure this is good enough for all cases
;;; (equal? (app->args body)
;;; ;(lambda->formals (car body))
;;; (lambda->formals exp)
;;; )
;;; (> (length (lambda->formals exp)) 0)
;;; ;; TODO: don't do it if args are used in the body
;;; ;; this won't work if we have any num other than 1 arg
;;; (not (member
;;; (car (lambda->formals exp))
;;; (free-vars (car body))))
;;; )
;;; (cps-optimize-01 (car body)))
;;; (else
;;; `(lambda ,(lambda->formals exp)
;;; ,(cps-optimize-01 (car (lambda->exp exp)))) ;; Assume single expr in lambda body, since after CPS phase
;;; ))))
;;; (cond
;;; ; Core forms:
;;; ((const? exp) exp)
;;; ((ref? exp) exp)
;;; ((prim? exp) exp)
;;; ((quote? exp) exp)
;;; ((lambda? exp) (opt-lambda exp))
;;; ((set!? exp) `(set!
;;; ,(set!->var exp)
;;; ,(cps-optimize-01 (set!->exp exp))))
;;; ((if? exp) `(if ,(cps-optimize-01 (if->condition exp))
;;; ,(cps-optimize-01 (if->then exp))
;;; ,(cps-optimize-01 (if->else exp))))
;;; ; Application:
;;; ((app? exp) (map (lambda (e) (cps-optimize-01 e)) exp))
;;; (else (error "CPS optimize unknown expression type: " exp))))
)) ))

121
scheme/cyclone/test-cps.scm
View file

@ -98,37 +98,96 @@
; 3)))) ; 3))))
; 0))))) ; 0)))))
;(define code
;'(#((record-marker)
; #((record-marker) #f (id args body))
; #(6
; ()
; ((#((record-marker)
; #((record-marker) #f (id args body))
; #(5
; (r$2)
; ((#((record-marker)
; #((record-marker) #f (id args body))
; #(4
; (x$3 y$2 z$1)
; ((#((record-marker)
; #((record-marker) #f (id args body))
; #(3
; (r$4)
; ((#((record-marker)
; #((record-marker) #f (id args body))
; #(2
; (r$3)
; ((write #((record-marker)
; #((record-marker) #f (id args body))
; #(1 (r$1) ((r$1 %halt))))
; r$3))))
; (cons x$3 r$4)))))
; (cons y$2 z$1)))))
; 1
; 2
; 3))))
; 0)))))
;)
(define code (define code
'(#((record-marker) '((define reg-port
#((record-marker) #f (id args body)) #((record-marker)
#(6 #((record-marker) #f (id args body))
() #(630
((#((record-marker) (k$812 fp$262)
#((record-marker) #f (id args body)) ((#((record-marker)
#(5 #((record-marker) #f (id args body))
(r$2) #(629
((#((record-marker) (r$813)
#((record-marker) #f (id args body)) ((#((record-marker)
#(4 #((record-marker) #f (id args body))
(x$3 y$2 z$1) #(628
((#((record-marker) (r$263)
#((record-marker) #f (id args body)) ((if r$263
#(3 (#((record-marker)
(r$4) #((record-marker) #f (id args body))
((#((record-marker) #(622 () ((k$812 r$263)))))
#((record-marker) #f (id args body)) (#((record-marker)
#(2 #((record-marker) #f (id args body))
(r$3) #(627
((write #((record-marker) ()
#((record-marker) #f (id args body)) ((list #((record-marker)
#(1 (r$1) ((r$1 %halt)))) #((record-marker) #f (id args body))
r$3)))) #(626
(cons x$3 r$4))))) (r$817)
(cons y$2 z$1))))) ((#((record-marker)
1 #((record-marker) #f (id args body))
2 #(625
3)))) (r$814)
0))))) ((#((record-marker)
#((record-marker)
#f
(id args body))
#(624
(r$816)
((#((record-marker)
#((record-marker)
#f
(id args body))
#(623
(r$815)
((k$812 r$263))))
(set! *in-port-table*
r$816)))))
(cons r$263 *in-port-table*)))))
(set! r$263 r$817)))))
fp$262
#f
1
0)))))))))
r$813))))
(assoc fp$262 *in-port-table*)))))))
) )
(pretty-print (pretty-print
(contract-prims code)) (optimize-cps code))
;(contract-prims code))
(write "---------------- cps analysis db:")
(pretty-print (adb:get-db))