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

WIP - contract-prims

Browse source
This commit is contained in:
Justin Ethier 2016-06-03 23:59:54 -04:00
parent a62387cb03
commit e9ebc2f4e3
1 changed files with 51 additions and 29 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -416,35 +416,57 @@
(else (else
(error "CPS optimize [1] - Unknown expression" exp)))) (error "CPS optimize [1] - Unknown expression" exp))))
(define (contract-prims exp) (define (contract-prims exp . refs*)
(cond (let ((refs (if (null? refs*)
((const? exp) exp) (make-hash-table)
((quote? exp) exp) (car refs*))))
((ref? exp) exp) ;(trace:error `(contract-prims ,exp))
((ast:lambda? exp) (cond
(ast:%make-lambda ((ref? exp)
(ast:lambda-id exp) ;; Replace lambda variables, if necessary
(ast:lambda-args exp) (let ((key (hash-table-ref/default refs exp #f)))
(map contract-prims (ast:lambda-body exp)))) (if key
((define? exp) (contract-prims key refs)
`(define ,(define->var exp) exp)))
,(contract-prims (define->exp exp)))) ((ast:lambda? exp)
((set!? exp) (ast:%make-lambda
`(set! ,(set!->var exp) (ast:lambda-id exp)
,(contract-prims (set!->exp exp)))) (ast:lambda-args exp)
((if? exp) `(if ,(contract-prims (if->condition exp)) (map (lambda (b) (contract-prims b refs)) (ast:lambda-body exp))))
,(contract-prims (if->then exp)) ((const? exp) exp)
,(contract-prims (if->else exp)))) ((quote? exp) exp)
; Application: ((define? exp)
((app? exp) `(define ,(define->var exp)
(cond ,(contract-prims (define->exp exp) refs)))
((and (ast:lambda? (car exp)) ((set!? exp)
(all-prim-calls? (cdr exp))) `(set! ,(set!->var exp)
'TODO) ,(contract-prims (set!->exp exp) refs)))
(else ((if? exp) `(if ,(contract-prims (if->condition exp) refs)
(map contract-prims exp)))) ,(contract-prims (if->then exp) refs)
(else ,(contract-prims (if->else exp) refs)))
(error `(Unexpected expression passed to contract-prims ,exp))))) ; Application:
((app? exp)
;(trace:error `(app? ,exp ,(ast:lambda? (car exp))
; ,(length (cdr exp))
; ,(length (ast:lambda-formals->list (car exp)))
; ,(all-prim-calls? (cdr exp))))
(cond
((and (ast:lambda? (car exp))
;; TODO: check for more than one arg??
(equal? (length (cdr exp))
(length (ast:lambda-formals->list (car exp))))
(all-prim-calls? (cdr exp)))
(let ((args (cdr exp)))
(for-each
(lambda (param)
(hash-table-set! refs param (car args))
(set! args (cdr args)))
(ast:lambda-formals->list (car exp))))
(contract-prims (car (ast:lambda-body (car exp))) refs))
(else
(map (lambda (e) (contract-prims e refs)) exp))))
(else
(error `(Unexpected expression passed to contract-prims ,exp))))))
;; Do all the expressions contain prim calls? ;; Do all the expressions contain prim calls?
;; TODO: check for prim calls accepting no continuation ;; TODO: check for prim calls accepting no continuation