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

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

@ -317,40 +317,43 @@
,(opt:contract (if->else exp))))
; Application:
((app? exp)
(cond
((and (ast:lambda? (car exp))
(list? (ast:lambda-args (car exp))) ;; Avoid optional/extra args
(= (length (ast:lambda-args (car exp)))
(length (app->args exp))))
(let ((new-params '())
(new-args '())
(args (cdr exp)))
(for-each
(lambda (param)
(let ((var (adb:get/default param #f)))
(cond
((and var (adbv:const? var))
#f)
(else
;; Collect the params/args not optimized-out
(set! new-args (cons (car args) new-args))
(set! new-params (cons param new-params))))
(set! args (cdr args))))
(ast:lambda-args (car exp)))
;(trace:error `(DEBUG contract args ,(app->args exp)
; new-args ,new-args
; params ,(ast:lambda-args (car exp))
; new-params ,new-params))
(map
opt:contract
(let* ((fnc (opt:contract (car exp))))
(cond
((and (ast:lambda? fnc)
(list? (ast:lambda-args fnc)) ;; Avoid optional/extra args
(= (length (ast:lambda-args fnc))
(length (app->args exp))))
(let ((new-params '())
(new-args '())
(args (cdr exp)))
(for-each
(lambda (param)
(let ((var (adb:get/default param #f)))
(cond
((and var (adbv:const? var))
#f)
(else
;; Collect the params/args not optimized-out
(set! new-args (cons (car args) new-args))
(set! new-params (cons param new-params))))
(set! args (cdr args))))
(ast:lambda-args fnc))
;(trace:e rror `(DEBUG contract args ,(app->args exp)
; new-args ,new-args
; params ,(ast:lambda-args fnc)
; new-params ,new-params))
(cons
(ast:%make-lambda
(ast:lambda-id (car exp))
(ast:lambda-id fnc)
(reverse new-params)
(ast:lambda-body (car exp)))
(reverse new-args)))))
(else
(map (lambda (e) (opt:contract e)) exp))))
(ast:lambda-body fnc))
(map
opt:contract
(reverse new-args)))))
(else
(cons
fnc
(map (lambda (e) (opt:contract e)) (cdr exp)))))))
(else
(error "CPS optimize [1] - Unknown expression" exp))))