diff --git a/cyclone.scm b/cyclone.scm index 697ccbbf..13e270cb 100644 --- a/cyclone.scm +++ b/cyclone.scm @@ -304,7 +304,7 @@ (lambda (e) (when (and (define? e) (not (equal? (define->var e) lib-init-fnc)) - (inlinable-top-level-function? e)) + (inlinable-top-level-lambda? e)) (set! inlinable-scheme-fncs (cons (define->var e) inlinable-scheme-fncs)) ;; TESTING, will not work yet @@ -314,7 +314,7 @@ ;; END )) input-program)) - (trace:info "---------------- results of inlinable-top-level-function analysis: ") + (trace:info "---------------- results of inlinable-top-level-lambda analysis: ") (trace:info inlinable-scheme-fncs) (let ((cps (map diff --git a/scheme/cyclone/cps-optimizations.sld b/scheme/cyclone/cps-optimizations.sld index 18f48c97..fafb6323 100644 --- a/scheme/cyclone/cps-optimizations.sld +++ b/scheme/cyclone/cps-optimizations.sld @@ -16,6 +16,7 @@ (scheme cyclone transforms) (srfi 69)) (export + inlinable-top-level-lambda? optimize-cps analyze-cps opt:contract @@ -157,6 +158,94 @@ (callback fnc) (adb:set! id fnc))) +;; Determine if the given top-level function can be freed from CPS, due +;; to it only containing calls to code that itself can be inlined. +(define (inlinable-top-level-lambda? expr) + ;; TODO: consolidate with same function in cps-optimizations module + (define (prim-creates-mutable-obj? prim) + (member + prim + '( + apply ;; ?? + cons + make-vector + make-bytevector + bytevector + bytevector-append + bytevector-copy + string->utf8 + number->string + symbol->string + list->string + utf8->string + read-line + string-append + string + substring + Cyc-installation-dir + Cyc-compilation-environment + Cyc-bytevector-copy + Cyc-utf8->string + Cyc-string->utf8 + list->vector + ))) + (define (scan expr fail) + (cond + ((string? expr) (fail)) + ((bytevector? expr) (fail)) + ((const? expr) #t) ;; Good enough? what about large vectors or anything requiring alloca (strings, bytevectors, what else?) + ((ref? expr) #t) + ((if? expr) + (scan (if->condition expr) fail) + (scan (if->then expr) fail) + (scan (if->else expr) fail)) + ((app? expr) + (let ((fnc (car expr))) + ;; If function needs CPS, fail right away + (if (or (not (prim? fnc)) ;; Eventually need to handle user functions, too + (prim:cont? fnc) ;; Needs CPS + (prim:mutates? fnc) ;; This is too conservative, but basically + ;; there are restrictions about optimizing + ;; args to a mutator, so reject them for now + (prim-creates-mutable-obj? fnc) ;; Again, probably more conservative + ;; than necessary + ) + (fail)) + ;; Otherwise, check for valid args + (for-each + (lambda (e) + (scan e fail)) + (cdr expr)))) + ;; prim-app - OK only if prim does not require CPS. + ;; still need to check all its args + ;; app - same as prim, only OK if function does not require CPS. + ;; probably safe to return #t if calling self, since if no + ;; CPS it will be rejected anyway + ;; NOTE: would not be able to detect all functions in this module immediately. + ;; would probably have to find some, then run this function successively to find others. + ;; + ;; Reject everything else - define, set, lambda + (else (fail)))) + (cond + ((and (define? expr) + (lambda? (car (define->exp expr))) + (equal? 'args:fixed (lambda-formals-type (car (define->exp expr))))) + (call/cc + (lambda (k) + (let* ((define-body (car (define->exp expr))) + (lambda-body (lambda->exp define-body))) + (cond + ((> (length lambda-body) 1) + (k #f)) ;; Fail with more than one expression in lambda body, + ;; because CPS is required to compile that. + (else + (scan + (car lambda-body) + (lambda () (k #f))) ;; Fail with #f + (k #t))))))) ;; Scanned fine, return #t + (else #f))) + + ;; TODO: check app for const/const-value, also (for now) reset them ;; if the variable is modified via set/define (define (analyze exp lid)