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

Contract lambda first in a lambda application

Browse source 
Try to prevent timing issues that occur when the application is contracted first, and arguments can be removed too early.
This commit is contained in:
Justin Ethier 2016-05-23 22:29:48 -04:00
parent 3dc541c99b
commit 58bc782022
1 changed files with 34 additions and 31 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -317,10 +317,11 @@
,(opt:contract (if->else exp)))) ,(opt:contract (if->else exp))))
; Application: ; Application:
((app? exp) ((app? exp)
(let* ((fnc (opt:contract (car exp))))
(cond (cond
((and (ast:lambda? (car exp)) ((and (ast:lambda? fnc)
(list? (ast:lambda-args (car exp))) ;; Avoid optional/extra args (list? (ast:lambda-args fnc)) ;; Avoid optional/extra args
(= (length (ast:lambda-args (car exp))) (= (length (ast:lambda-args fnc))
(length (app->args exp)))) (length (app->args exp))))
(let ((new-params '()) (let ((new-params '())
(new-args '()) (new-args '())
@ -336,21 +337,23 @@
(set! new-args (cons (car args) new-args)) (set! new-args (cons (car args) new-args))
(set! new-params (cons param new-params)))) (set! new-params (cons param new-params))))
(set! args (cdr args)))) (set! args (cdr args))))
(ast:lambda-args (car exp))) (ast:lambda-args fnc))
;(trace:error `(DEBUG contract args ,(app->args exp) ;(trace:e rror `(DEBUG contract args ,(app->args exp)
; new-args ,new-args ; new-args ,new-args
; params ,(ast:lambda-args (car exp)) ; params ,(ast:lambda-args fnc)
; new-params ,new-params)) ; new-params ,new-params))
(map
opt:contract
(cons (cons
(ast:%make-lambda (ast:%make-lambda
(ast:lambda-id (car exp)) (ast:lambda-id fnc)
(reverse new-params) (reverse new-params)
(ast:lambda-body (car exp))) (ast:lambda-body fnc))
(map
opt:contract
(reverse new-args))))) (reverse new-args)))))
(else (else
(map (lambda (e) (opt:contract e)) exp)))) (cons
fnc
(map (lambda (e) (opt:contract e)) (cdr exp)))))))
(else (else
(error "CPS optimize [1] - Unknown expression" exp)))) (error "CPS optimize [1] - Unknown expression" exp))))