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

Relocate closure conversion

Browse source
This commit is contained in:
Justin Ethier 2017-07-07 13:03:30 +00:00
parent 148edd15a7
commit 2fd88a15e6
2 changed files with 97 additions and 97 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -16,6 +16,8 @@
(scheme cyclone transforms) (scheme cyclone transforms)
(srfi 69)) (srfi 69))
(export (export
closure-convert
pos-in-list
inlinable-top-level-lambda? inlinable-top-level-lambda?
optimize-cps optimize-cps
analyze-cps analyze-cps
@ -1405,4 +1407,99 @@
(opt:contract ast))) (opt:contract ast)))
) )
;; Closure-conversion.
;;
;; Closure conversion eliminates all of the free variables from every
;; lambda term.
;;
;; The code below is based on a fusion of a port of the 90-min-scc code by
;; Marc Feeley and the closure conversion code in Matt Might's scheme->c
;; compiler.
(define (pos-in-list x lst)
(let loop ((lst lst) (i 0))
(cond ((not (pair? lst)) #f)
((eq? (car lst) x) i)
(else
(loop (cdr lst) (+ i 1))))))
(define (closure-convert exp globals)
(define (convert exp self-var free-var-lst)
(define (cc exp)
(cond
((const? exp) exp)
((quote? exp) exp)
((ref? exp)
(let ((i (pos-in-list exp free-var-lst)))
(if i
`(%closure-ref
,self-var
,(+ i 1))
exp)))
((or
(tagged-list? '%closure-ref exp)
(tagged-list? '%closure exp)
(prim-call? exp))
`(,(car exp)
,@(map cc (cdr exp)))) ;; TODO: need to splice?
((set!? exp) `(set! ,(set!->var exp)
,(cc (set!->exp exp))))
((lambda? exp)
(let* ((new-self-var (gensym 'self))
(body (lambda->exp exp))
(new-free-vars
(difference
(difference (free-vars body) (lambda-formals->list exp))
globals)))
`(%closure
(lambda
,(list->lambda-formals
(cons new-self-var (lambda-formals->list exp))
(lambda-formals-type exp))
,(convert (car body) new-self-var new-free-vars)) ;; TODO: should this be a map??? was a list in 90-min-scc.
,@(map (lambda (v) ;; TODO: splice here?
(cc v))
new-free-vars))))
((if? exp) `(if ,@(map cc (cdr exp))))
((cell? exp) `(cell ,(cc (cell->value exp))))
((cell-get? exp) `(cell-get ,(cc (cell-get->cell exp))))
((set-cell!? exp) `(set-cell! ,(cc (set-cell!->cell exp))
,(cc (set-cell!->value exp))))
((app? exp)
(let ((fn (car exp))
(args (map cc (cdr exp))))
(if (lambda? fn)
(let* ((body (lambda->exp fn))
(new-free-vars
(difference
(difference (free-vars body) (lambda-formals->list fn))
globals))
(new-free-vars? (> (length new-free-vars) 0)))
(if new-free-vars?
; Free vars, create a closure for them
(let* ((new-self-var (gensym 'self)))
`((%closure
(lambda
,(list->lambda-formals
(cons new-self-var (lambda-formals->list fn))
(lambda-formals-type fn))
,(convert (car body) new-self-var new-free-vars))
,@(map (lambda (v) (cc v))
new-free-vars))
,@args))
; No free vars, just create simple lambda
`((lambda ,(lambda->formals fn)
,@(map cc body))
,@args)))
(let ((f (cc fn)))
`((%closure-ref ,f 0)
,f
,@args)))))
(else
(error "unhandled exp: " exp))))
(cc exp))
`(lambda ()
,(convert exp #f '())))
)) ))

97
scheme/cyclone/transforms.sld
View file

@ -102,8 +102,6 @@
wrap-mutables wrap-mutables
alpha-convert alpha-convert
cps-convert cps-convert
pos-in-list
closure-convert
prim-convert prim-convert
) )
(inline (inline
@ -1453,101 +1451,6 @@
(cps ast '%halt))))) (cps ast '%halt)))))
ast-cps)) ast-cps))
;; Closure-conversion.
;;
;; Closure conversion eliminates all of the free variables from every
;; lambda term.
;;
;; The code below is based on a fusion of a port of the 90-min-scc code by
;; Marc Feeley and the closure conversion code in Matt Might's scheme->c
;; compiler.
(define (pos-in-list x lst)
(let loop ((lst lst) (i 0))
(cond ((not (pair? lst)) #f)
((eq? (car lst) x) i)
(else
(loop (cdr lst) (+ i 1))))))
(define (closure-convert exp globals)
(define (convert exp self-var free-var-lst)
(define (cc exp)
(cond
((const? exp) exp)
((quote? exp) exp)
((ref? exp)
(let ((i (pos-in-list exp free-var-lst)))
(if i
`(%closure-ref
,self-var
,(+ i 1))
exp)))
((or
(tagged-list? '%closure-ref exp)
(tagged-list? '%closure exp)
(prim-call? exp))
`(,(car exp)
,@(map cc (cdr exp)))) ;; TODO: need to splice?
((set!? exp) `(set! ,(set!->var exp)
,(cc (set!->exp exp))))
((lambda? exp)
(let* ((new-self-var (gensym 'self))
(body (lambda->exp exp))
(new-free-vars
(difference
(difference (free-vars body) (lambda-formals->list exp))
globals)))
`(%closure
(lambda
,(list->lambda-formals
(cons new-self-var (lambda-formals->list exp))
(lambda-formals-type exp))
,(convert (car body) new-self-var new-free-vars)) ;; TODO: should this be a map??? was a list in 90-min-scc.
,@(map (lambda (v) ;; TODO: splice here?
(cc v))
new-free-vars))))
((if? exp) `(if ,@(map cc (cdr exp))))
((cell? exp) `(cell ,(cc (cell->value exp))))
((cell-get? exp) `(cell-get ,(cc (cell-get->cell exp))))
((set-cell!? exp) `(set-cell! ,(cc (set-cell!->cell exp))
,(cc (set-cell!->value exp))))
((app? exp)
(let ((fn (car exp))
(args (map cc (cdr exp))))
(if (lambda? fn)
(let* ((body (lambda->exp fn))
(new-free-vars
(difference
(difference (free-vars body) (lambda-formals->list fn))
globals))
(new-free-vars? (> (length new-free-vars) 0)))
(if new-free-vars?
; Free vars, create a closure for them
(let* ((new-self-var (gensym 'self)))
`((%closure
(lambda
,(list->lambda-formals
(cons new-self-var (lambda-formals->list fn))
(lambda-formals-type fn))
,(convert (car body) new-self-var new-free-vars))
,@(map (lambda (v) (cc v))
new-free-vars))
,@args))
; No free vars, just create simple lambda
`((lambda ,(lambda->formals fn)
,@(map cc body))
,@args)))
(let ((f (cc fn)))
`((%closure-ref ,f 0)
,f
,@args)))))
(else
(error "unhandled exp: " exp))))
(cc exp))
`(lambda ()
,(convert exp #f '())))
; Suitable definitions for the cell functions: ; Suitable definitions for the cell functions:
;(define (cell value) (lambda (get? new-value) ;(define (cell value) (lambda (get? new-value)
; (if get? value (set! value new-value)))) ; (if get? value (set! value new-value))))