Merge branch 'inline7-dev'

CHANGELOG.md

@@ -2,6 +2,14 @@
 
 ## 0.5.1 - TBD
 
+Features
+
+- Allow `define-c` function definitions to optionally provide an additional non-CPS form of the function. This form is typically more efficient and will be used by compiled code whenever possible.
+
+- Improved the compiler's CPS optimization phase to eliminate certain unnecessary function calls. This leads to a performance increase of about 5% when running ecraven's R7RS benchmark suite.
+
+Bug Fixes
+
 - Prevent potential memory corruption when working with large vectors that cannot be allocated on the stack.
 
 ## 0.5 - April 14, 2017

array1-test.scm

@@ -0,0 +1,12 @@
+;;; A temporary test file, can inlining be done more efficiently here?
+;; if this inline can be done, try with full-up array1
+
+(import (scheme base) (scheme read) (scheme write) (scheme time))
+
+(define (create-x n)
+  (define result (make-vector n))
+  (do ((i 0 (+ i 1)))
+      ((>= i n) result) ;; TODO: check generated code, can this >= be inlined???
+    (vector-set! result i i)))
+
+(write (create-x 10))

cyclone.scm

@@ -36,6 +36,7 @@
       (define module-globals '()) ;; Globals defined by this module
       (define program? #t) ;; Are we building a program or a library?
       (define imports '())
+      (define inlines '())
       (define imported-vars '())
       (define lib-name '())
       (define lib-exports '())
@@ -55,6 +56,7 @@
            (set! program? #f)
            (set! lib-name (lib:name (car input-program)))
            (set! c-headers (lib:include-c-headers (car input-program)))
+           (set! inlines (lib:inlines (car input-program)))
            (set! lib-exports
              (cons
                (lib:name->symbol lib-name)
@@ -89,6 +91,17 @@
             (set! imports (car reduction))
             (set! input-program (cdr reduction)))
 
+          ;;  Handle inline list, if present`
+          (let ((lis (lib:inlines `(dummy dummy ,@input-program))))
+            (cond
+              ((not (null? lis))
+               (set! inlines lis)
+               (set! input-program 
+                     (filter 
+                       (lambda (expr)
+                         (not (tagged-list? 'inline expr)))
+                       input-program)))))
+
           ;; Handle any C headers
           (let ((headers (lib:include-c-headers `(dummy dummy ,@input-program))))
             (cond
@@ -101,6 +114,9 @@
                        input-program)))))
         ))
 
+      (trace:info "inline candidates:")
+      (trace:info inlines)
+
       ;; Process library imports
       (trace:info "imports:")
       (trace:info imports)
@@ -216,6 +232,79 @@
       (trace:info "---------------- after alpha conversion:")
       (trace:info input-program) ;pretty-print
 
+;; EXPERIMENTAL CODE
+;; TODO: extend this initially by, for each import, invoking that module's inlinable_lambdas function
+;;       behind an exception handler (in case the compiler does not have that module loaded).
+;;
+;;       Longer term, need to test if module is loaded (maybe do that in combo with exception handler above)
+;;       and if not loaded, eval/import it and try again.
+;;
+;; assumes (scheme base) is available to compiler AND at runtime in the compiled module/program
+;; TODO: probably not good enough since inlines are not in export list
+;;
+;; TODO: later on, in cgen, only add inlinables that correspond to exported functions
+
+(for-each
+  (lambda (import)
+    (with-handler
+      (lambda (err)
+        #f)
+      (let* ((lib-name-str (lib:name->string (lib:list->import-set import)))
+             (inlinable-lambdas-fnc 
+              (string->symbol
+                (string-append "c_" lib-name-str "_inlinable_lambdas"))))
+      (cond
+        ((imported? import)
+         (let ((lib-name (lib:import->library-name 
+                           (lib:list->import-set import)))
+               (vars/inlines
+                 (filter
+                  (lambda (v/i)
+                    ;; Try to avoid name conflicts by not loading inlines
+                    ;; that conflict with identifiers in this module.
+                    ;; More of a band-aid than a true solution, though.
+                    (not (member (car v/i) module-globals)))
+                  (eval `( ,inlinable-lambdas-fnc )))))
+           (trace:info `(DEBUG ,import ,vars/inlines ,module-globals))
+           ;; Register inlines as user-defined primitives
+           (for-each
+             (lambda (v/i)
+               (let ((var (car v/i)) (inline (cdr v/i)))
+                 (prim:add-udf! var inline)))
+             vars/inlines)
+           ;; Keep track of inline version of functions along with other imports
+           (set! imported-vars 
+             (append
+               imported-vars
+               (map
+                 (lambda (v/i)
+                   (cons (cdr v/i) lib-name))
+                 vars/inlines)))))
+        (else
+          ;; TODO: try loading if not loaded (but need ex handler in case anything bad happens) #t ;(eval `(import ,import))
+          ;;(%import import)
+          ;; if this work is done, would need to consolidate inline reg code above
+          #f)))))
+  imports)
+
+;(for-each
+;  (lambda (psyms)
+;    (let ((var (car psyms)) (inline (cdr psyms)))
+;      (prim:add-udf! var inline)))
+;  (eval '(c_schemebase_inlinable_lambdas)))
+;  ;(assoc 'quotient (c_schemebase_inlinable_lambdas))
+;  ;    (set! globals (append (lib:idb:ids imported-vars) module-globals))
+;
+;  ;; total hack to update export list
+;  (set! imported-vars 
+;    (append
+;      imported-vars
+;      (map
+;        (lambda (psyms)
+;          (list (cdr psyms) 'scheme 'base))
+;        (eval '(c_schemebase_inlinable_lambdas)))))
+;; END
+
       ;; Convert some function calls to primitives, if possible
       (set! input-program 
         (map
@@ -224,6 +313,33 @@
           input-program))
       (trace:info "---------------- after func->primitive conversion:")
       (trace:info input-program) ;pretty-print
+
+      ;; Identify native Scheme functions (from module being compiled) that can be inlined
+      ;;
+      ;; NOTE: There is a chicken-and-egg problem here that prevents this from 
+      ;; automatically working 100%. Basically we need to know whether the inline logic will
+      ;; work for a given candidate. The problem is, the only way to do that is to run the
+      ;; code through CPS and by then we would have to go back and repeat many phases if a
+      ;; candidate fails the inline tests. At least for now, an alternative is to require 
+      ;; user code to specify (via inline) what functions the compiler should try inlining.
+      ;; There is a small chance one of those inlines can pass these tests and still fail
+      ;; the subsequent inline checks though, which causes an error in the C compiler.
+      (define inlinable-scheme-fncs '())
+      (let ((lib-init-fnc (lib:name->symbol lib-name))) ;; safe to ignore for programs
+        (for-each
+          (lambda (e)
+            (when (and (define? e)
+                       (member (define->var e) inlines) ;; Primary check, did use request inline
+                       (not (equal? (define->var e) lib-init-fnc))
+                       (inlinable-top-level-lambda? e)) ;; Failsafe, reject if basic checks fail
+              (set! inlinable-scheme-fncs
+                (cons (define->var e) inlinable-scheme-fncs))
+              (set! module-globals
+                (cons (define-c->inline-var e) module-globals))
+              (prim:add-udf! (define->var e) (define-c->inline-var e))))
+          input-program)
+        (trace:info "---------------- results of inlinable-top-level-lambda analysis: ")
+        (trace:info inlinable-scheme-fncs))
     
       (let ((cps (map 
                    (lambda (expr)
@@ -274,8 +390,15 @@
       (when (> *optimization-level* 0)
         (set! input-program
           (optimize-cps input-program))
-        (trace:info "---------------- after cps optimizations:")
+        (trace:info "---------------- after cps optimizations (1):")
-        (trace:info input-program))
+        (trace:info input-program)
+
+        (set! input-program
+          (optimize-cps input-program))
+        (trace:info "---------------- after cps optimizations (2):")
+        (trace:info input-program)
+        
+      )
     
       (set! input-program
         (map
@@ -313,6 +436,9 @@
       (trace:info "---------------- C headers: ")
       (trace:info c-headers)
 
+      (trace:info "---------------- module globals: ")
+      (trace:info module-globals)
+
       (trace:info "---------------- C code:")
       (mta:code-gen input-program 
                     program? 

examples/Makefile

@@ -48,3 +48,5 @@ clean:
 	cd threading ; rm -rf *.o *.c *.meta
 	cd game-of-life ; make clean
 	cd hello-library ; make clean
+	cd networking ; rm -rf client.c server.c
+

gc.c

@@ -775,17 +775,20 @@ size_t gc_allocated_bytes(object obj, gc_free_list * q, gc_free_list * r)
   t = type_of(obj);
   if (t == pair_tag)
     return gc_heap_align(sizeof(pair_type));
-  if (t == macro_tag)
-    return gc_heap_align(sizeof(macro_type));
-  if (t == closure0_tag)
-    return gc_heap_align(sizeof(closure0_type));
-  if (t == closure1_tag)
-    return gc_heap_align(sizeof(closure1_type));
   if (t == closureN_tag) {
     return gc_heap_align(sizeof(closureN_type) +
                          sizeof(object) * 
                          ((closureN_type *) obj)->num_elements);
   }
+  if (t == double_tag)
+    return gc_heap_align(sizeof(double_type));
+  if (t == closure0_tag)
+    return gc_heap_align(sizeof(closure0_type));
+  if (t == closure1_tag)
+    return gc_heap_align(sizeof(closure1_type));
+  if (t == string_tag) {
+    return gc_heap_align(sizeof(string_type) + string_len(obj) + 1);
+  }
   if (t == vector_tag) {
     return gc_heap_align(sizeof(vector_type) +
                          sizeof(object) * ((vector_type *) obj)->num_elements);
@@ -794,15 +797,10 @@ size_t gc_allocated_bytes(object obj, gc_free_list * q, gc_free_list * r)
     return gc_heap_align(sizeof(bytevector_type) +
                          sizeof(char) * ((bytevector) obj)->len);
   }
-  if (t == string_tag) {
+  if (t == macro_tag)
-    return gc_heap_align(sizeof(string_type) + string_len(obj) + 1);
+    return gc_heap_align(sizeof(macro_type));
-  }
-  if (t == integer_tag)
-    return gc_heap_align(sizeof(integer_type));
   if (t == bignum_tag)
     return gc_heap_align(sizeof(bignum_type));
-  if (t == double_tag)
-    return gc_heap_align(sizeof(double_type));
   if (t == port_tag)
     return gc_heap_align(sizeof(port_type));
   if (t == cvar_tag)
@@ -813,6 +811,8 @@ size_t gc_allocated_bytes(object obj, gc_free_list * q, gc_free_list * r)
     return gc_heap_align(sizeof(mutex_type));
   if (t == cond_var_tag)
     return gc_heap_align(sizeof(cond_var_type));
+  if (t == integer_tag)
+    return gc_heap_align(sizeof(integer_type));
 
   fprintf(stderr, "gc_allocated_bytes: unexpected object %p of type %d\n", obj,
           t);

include/cyclone/types.h

@@ -1040,6 +1040,23 @@ typedef union {
   bignum_type bignum_t;
 } common_type;
 
+#define return_copy(ptr, obj) \
+{ \
+  tag_type t; \
+  if (!is_object_type(obj)) \
+    return obj; \
+  t = type_of(obj); \
+  if (t == double_tag) { \
+    ((common_type *)ptr)->double_t.hdr.mark = gc_color_red; \
+    ((common_type *)ptr)->double_t.hdr.grayed = 0; \
+    ((common_type *)ptr)->double_t.tag = double_tag; \
+    ((common_type *)ptr)->double_t.value = double_value(obj); \
+    return ptr; \
+  } else { \
+    return obj; \
+  } \
+}
+
 /**@}*/
 /**@}*/
 

scheme/base.sld

@@ -207,6 +207,23 @@
 ;    letrec-syntax
 ;;;;
   )
+  (inline
+    exact-integer?
+    square
+    quotient
+    numerator
+    denominator
+    truncate
+    negative?
+    positive?
+    zero?
+    not
+    string>=?
+    string>?
+    string<=?
+    string<?
+    string=?
+  )
   (begin
     ;; Features implemented by this Scheme
     (define (features) 
@@ -1065,11 +1082,14 @@
 
   (define-c floor
     "(void *data, int argc, closure _, object k, object z)"
-    " return_exact_double_op(data, k, floor, z); ")
+    " return_exact_double_op(data, k, floor, z); "
+    "(void *data, object ptr, object z)"
+    " return_exact_double_op_no_cps(data, ptr, floor, z);")
   (define-c ceiling
     "(void *data, int argc, closure _, object k, object z)"
-    " return_exact_double_op(data, k, ceil, z); ")
+    " return_exact_double_op(data, k, ceil, z); "
-  ;TODO: working on define-c:inline macro to make it less verbose to do this
+    "(void *data, object ptr, object z)"
+    " return_exact_double_op_no_cps(data, ptr, ceil, z);")
   (define-c truncate
     "(void *data, int argc, closure _, object k, object z)"
     " return_exact_double_op(data, k, (int), z); "
@@ -1077,11 +1097,15 @@
     " return_exact_double_op_no_cps(data, ptr, (int), z);")
   (define-c round
     "(void *data, int argc, closure _, object k, object z)"
-    " return_exact_double_op(data, k, round, z); ")
+    " return_exact_double_op(data, k, round, z); "
+    "(void *data, object ptr, object z)"
+    " return_exact_double_op_no_cps(data, ptr, round, z);")
   (define exact truncate)
   (define-c inexact
     "(void *data, int argc, closure _, object k, object z)"
-    " return_inexact_double_op(data, k, (double), z); ")
+    " return_inexact_double_op(data, k, (double), z); "
+    "(void *data, object ptr, object z)"
+    " return_inexact_double_op_no_cps(data, ptr, (double), z);")
   (define-c abs
     "(void *data, int argc, closure _, object k, object num)"
     " Cyc_check_num(data, num);
@@ -1130,7 +1154,9 @@
       (values s r)))
   (define-c sqrt
     "(void *data, int argc, closure _, object k, object z)"
-    " return_inexact_double_op(data, k, sqrt, z);")
+    " return_inexact_double_op(data, k, sqrt, z);"
+    "(void *data, object ptr, object z)"
+    " return_inexact_double_op_no_cps(data, ptr, sqrt, z);")
   (define (exact-integer? num)
     (and (exact? num) (integer? num)))
   (define-c exact?
@@ -1139,7 +1165,13 @@
       if (obj_is_int(num) || type_of(num) == integer_tag 
                           || type_of(num) == bignum_tag)
         return_closcall1(data, k, boolean_t);
-      return_closcall1(data, k, boolean_f); ")
+      return_closcall1(data, k, boolean_f); "
+    "(void *data, object ptr, object num)"
+    " Cyc_check_num(data, num);
+      if (obj_is_int(num) || type_of(num) == integer_tag 
+                          || type_of(num) == bignum_tag)
+        return boolean_t;
+      return boolean_f;")
   (define (inexact? num) (not (exact? num)))
   (define complex? number?) 
   (define rational? number?)
@@ -1203,7 +1235,9 @@
     " Cyc_expt(data, k, z1, z2); ")
   (define-c eof-object
     "(void *data, int argc, closure _, object k)"
-    " return_closcall1(data, k, Cyc_EOF); ")
+    " return_closcall1(data, k, Cyc_EOF); "
+    "(void *data, object ptr)"
+    " return Cyc_EOF;")
   (define-c input-port?
     "(void *data, int argc, closure _, object k, object port)"
     " port_type *p = (port_type *)port;
@@ -1261,7 +1295,7 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; syntax-rules
 (define identifier? symbol?)
-(define (identifier->symbol obj) obj)
+;(define (identifier->symbol obj) obj)
 (define (find-tail pred ls)
   (and (pair? ls) (if (pred (car ls)) ls (find-tail pred (cdr ls)))))
 
@@ -1363,7 +1397,8 @@
                                          (next-symbol
                                           (string-append
                                            (symbol->string
-                                            (identifier->symbol (car x)))
+                                            (car x))
+                                            ;(identifier->symbol (car x)))
                                            "-ls")))
                                        new-vars))
                          (once

scheme/complex.sld

@@ -15,6 +15,9 @@
     make-rectangular 
     real-part
   )
+  (inline
+    real-part
+    imag-part)
   (import (scheme base))
   (begin
     (define (real-part x) x)

scheme/cyclone/ast.sld

@@ -21,16 +21,21 @@
      ast:set-lambda-args!
      ast:lambda-body 
      ast:set-lambda-body!
+     ast:lambda-has-cont 
+     ast:set-lambda-has-cont!
   )
   (begin
     (define *lambda-id* 0)
     (define-record-type <lambda-ast>
-     (ast:%make-lambda id args body)
+     (ast:%make-lambda id args body has-cont)
      ast:lambda?
      (id ast:lambda-id)
      (args ast:lambda-args ast:set-lambda-args!)
-     (body ast:lambda-body ast:set-lambda-body!))
+     (body ast:lambda-body ast:set-lambda-body!)
-    (define (ast:make-lambda args body)
+     (has-cont ast:lambda-has-cont ast:set-lambda-has-cont!)
-      (set! *lambda-id* (+ 1 *lambda-id*))
+    )
-      (ast:%make-lambda *lambda-id* args body))
+    (define (ast:make-lambda args body . opts)
+      (let ((has-cont (if (pair? opts) (car opts) #f)))
+        (set! *lambda-id* (+ 1 *lambda-id*))
+        (ast:%make-lambda *lambda-id* args body has-cont)))
 ))

scheme/cyclone/cgen.sld

@@ -28,6 +28,13 @@
     emit-newline
     string-join
   )
+  (inline
+    global-not-lambda?
+    global-lambda?
+    c:num-args
+    c:allocs
+    st:->var
+  )
   (begin
 
 (define (emit line)
@@ -286,7 +293,7 @@
   (let* ((preamble "")
          (append-preamble (lambda (s)
                             (set! preamble (string-append preamble "  " s "\n"))))
-         (body (c-compile-exp exp append-preamble "cont" (list src-file))))
+         (body (c-compile-exp exp append-preamble "cont" (list src-file) #t)))
     ;(write `(DEBUG ,body))
     (string-append 
      preamble 
@@ -305,7 +312,13 @@
 ;; trace - trace information. presently a pair containing:
 ;;         * source file
 ;;         * function name (or NULL if none)
-(define (c-compile-exp exp append-preamble cont trace)
+;; cps? - Determine whether to compile using continuation passing style.
+;;        Normally this is always enabled, but sometimes a function has a
+;;        version that can be inlined (as an optimization), so this will 
+;;        be set to false to change the type of compilation.
+;;        NOTE: this field is not passed everywhere because a lot of forms
+;;              require CPS, so this flag is not applicable to them.
+(define (c-compile-exp exp append-preamble cont trace cps?)
   (cond
     ; Core forms:
     ((const? exp)       (c-compile-const exp))
@@ -314,11 +327,11 @@
      (c-code (string-append "primitive_" (mangle exp))))
     ((ref?   exp)       (c-compile-ref exp))
     ((quote? exp)       (c-compile-quote exp))
-    ((if? exp)          (c-compile-if exp append-preamble cont trace))
+    ((if? exp)          (c-compile-if exp append-preamble cont trace cps?))
 
     ; IR (2):
     ((tagged-list? '%closure exp)
-     (c-compile-closure exp append-preamble cont trace))
+     (c-compile-closure exp append-preamble cont trace cps?))
     ; Global definition
     ((define? exp)
      (c-compile-global exp append-preamble cont trace))
@@ -328,10 +341,10 @@
     ((tagged-list? 'lambda exp)
      (c-compile-exp
       `(%closure ,exp)
-       append-preamble cont trace))
+       append-preamble cont trace cps?))
     
     ; Application:      
-    ((app? exp)         (c-compile-app exp append-preamble cont trace))
+    ((app? exp)         (c-compile-app exp append-preamble cont trace cps?))
     (else               (error "unknown exp in c-compile-exp: " exp))))
 
 (define (c-compile-quote qexp)
@@ -654,7 +667,7 @@
       (mangle exp))))
 
 ; c-compile-args : list[exp] (string -> void) -> string
-(define (c-compile-args args append-preamble prefix cont trace)
+(define (c-compile-args args append-preamble prefix cont trace cps?)
   (letrec ((num-args 0)
          (_c-compile-args 
           (lambda (args append-preamble prefix cont)
@@ -667,7 +680,7 @@
               (c:append/prefix
                 prefix 
                 (c-compile-exp (car args) 
-                  append-preamble cont trace)
+                  append-preamble cont trace cps?)
                 (_c-compile-args (cdr args) 
                   append-preamble ", " cont)))))))
   (c:tuple/args
@@ -676,14 +689,14 @@
     num-args)))
 
 ;; c-compile-app : app-exp (string -> void) -> string
-(define (c-compile-app exp append-preamble cont trace)
+(define (c-compile-app exp append-preamble cont trace cps?)
   ;(trace:debug `(c-compile-app: ,exp))
   (let (($tmp (mangle (gensym 'tmp))))
     (let* ((args     (app->args exp))
            (fun      (app->fun exp)))
       (cond
         ((lambda? fun)
-         (let* ((lid (allocate-lambda (c-compile-lambda fun trace))) ;; TODO: pass in free vars? may be needed to track closures
+         (let* ((lid (allocate-lambda (c-compile-lambda fun trace #t))) ;; TODO: pass in free vars? may be needed to track closures
                                                                ;; properly, wait until this comes up in an example
                 (this-cont (string-append "__lambda_" (number->string lid)))
                 (cgen 
@@ -692,7 +705,8 @@
                      append-preamble 
                      ""
                      this-cont
-                     trace))
+                     trace
+                     cps?))
                 (num-cargs (c:num-args cgen)))
            (set-c-call-arity! num-cargs)
            (c-code
@@ -707,7 +721,7 @@
          (let* ((c-fun 
                  (c-compile-prim fun cont))
                 (c-args
-                 (c-compile-args args append-preamble "" "" trace))
+                 (c-compile-args args append-preamble "" "" trace cps?))
                 (num-args (length args))
                 (num-args-str
                   (string-append 
@@ -727,7 +741,9 @@
                     (if (prim/c-var-assign fun)
                       ;; Add a comma if there were any args to the func added by comp-prim
                       (if (or (str-ending? (car (c:allocs c-fun)) "(") 
-                              (prim:cont/no-args? fun))
+                              (prim:cont/no-args? fun)
+                              (and (prim:udf? fun)
+                                   (zero? num-args)))
                         "" 
                         ",")
                       ",")
@@ -755,47 +771,67 @@
 
         ;; TODO: may not be good enough, closure app could be from an element
         ((tagged-list? '%closure-ref fun)
-         (let* ((cfun (c-compile-args (list (car args)) append-preamble "  " cont trace))
+         (let* ((cfun (c-compile-args (list (car args)) append-preamble "  " cont trace cps?))
                 (this-cont (c:body cfun))
-                (cargs (c-compile-args (cdr args) append-preamble "  " this-cont trace)))
+                (cargs (c-compile-args (cdr args) append-preamble "  " this-cont trace cps?)))
-           (set-c-call-arity! (c:num-args cargs))
+           (cond
-           (c-code 
+             ((not cps?)
-             (string-append
+              (c-code 
-               (c:allocs->str (c:allocs cfun) "\n")
+                (string-append
-               (c:allocs->str (c:allocs cargs) "\n")
+                  (c:allocs->str (c:allocs cfun) "\n")
-               "return_closcall" (number->string (c:num-args cargs))
+                  (c:allocs->str (c:allocs cargs) "\n")
-               "(data,"
+                  "return_copy(ptr,"
-               this-cont
+                  (c:body cargs)
-               (if (> (c:num-args cargs) 0) "," "")
+                  ");")))
-               (c:body cargs)
+             (else
-               ");"))))
+              (set-c-call-arity! (c:num-args cargs))
+              (c-code 
+                (string-append
+                  (c:allocs->str (c:allocs cfun) "\n")
+                  (c:allocs->str (c:allocs cargs) "\n")
+                  "return_closcall" (number->string (c:num-args cargs))
+                  "(data,"
+                  this-cont
+                  (if (> (c:num-args cargs) 0) "," "")
+                  (c:body cargs)
+                  ");"))))))
 
         ((tagged-list? '%closure fun)
          (let* ((cfun (c-compile-closure 
-                        fun append-preamble cont trace))
+                        fun append-preamble cont trace cps?))
                 (this-cont (string-append "(closure)" (c:body cfun)))
                 (cargs (c-compile-args
-                         args append-preamble "  " this-cont trace))
+                         args append-preamble "  " this-cont trace cps?))
                 (num-cargs (c:num-args cargs)))
-           (set-c-call-arity! num-cargs)
+           (cond
-           (c-code
+             ((not cps?)
-             (string-append
+              (c-code
-                (c:allocs->str (c:allocs cfun) "\n")
+                (string-append
-                (c:allocs->str (c:allocs cargs) "\n")
+                   (c:allocs->str (c:allocs cfun) "\n")
-                "return_closcall" (number->string num-cargs)
+                   (c:allocs->str (c:allocs cargs) "\n")
-                "(data,"
+                   "return_copy(ptr,"
-                this-cont
+                   (c:body cargs)
-                (if (> num-cargs 0) "," "")
+                   ");")))
-                (c:body cargs)
+             (else ;; CPS, IE normal behavior
-                ");"))))
+               (set-c-call-arity! num-cargs)
+               (c-code
+                 (string-append
+                    (c:allocs->str (c:allocs cfun) "\n")
+                    (c:allocs->str (c:allocs cargs) "\n")
+                    "return_closcall" (number->string num-cargs)
+                    "(data,"
+                    this-cont
+                    (if (> num-cargs 0) "," "")
+                    (c:body cargs)
+                    ");"))))))
 
         (else
          (error `(Unsupported function application ,exp)))))))
 
 ; c-compile-if : if-exp -> string
-(define (c-compile-if exp append-preamble cont trace)
+(define (c-compile-if exp append-preamble cont trace cps?)
   (let* ((compile (lambda (exp)
-                    (c-compile-exp exp append-preamble cont trace)))
+                    (c-compile-exp exp append-preamble cont trace cps?)))
          (test (compile (if->condition exp)))
          (then (compile (if->then exp)))
          (els (compile (if->else exp))))
@@ -811,8 +847,17 @@
 
 ;; Global inlinable functions
 (define *global-inlines* '())
-(define (add-global-inline var-sym)
+(define (add-global-inline orig-sym inline-sym)
-  (set! *global-inlines* (cons var-sym *global-inlines*)))
+  (set! *global-inlines* (cons (cons orig-sym inline-sym) *global-inlines*)))
+
+;; Add a global inlinable function that is written in Scheme.
+;; This is more challenging than define-c forms since the 
+;; code must be compiled again to work without CPS.
+;(define *global-inline-scms* '())
+;(define (add-global-inline-scm-lambda var-sym code)
+;  (add-global-inline var-sym )
+;  (set! *global-inline-scms* 
+;        (cons (list var-sym code) *global-inline-scms*)))
 
 ;; Global compilation
 (define *globals* '())
@@ -832,12 +877,34 @@
      (lambda? body) 
      (c-compile-exp 
       body append-preamble cont
-      (st:add-function! trace var)))
+      (st:add-function! trace var) #t))
+
+   ;; Add inline global definition also, if applicable
+;   (trace:error `(JAE DEBUG ,var 
+;           ,(lambda? body) 
+;           ,(define-c->inline-var exp)
+;           ,(prim:udf? (define-c->inline-var exp))
+;           ))
+   (when (and (lambda? body)
+              (prim:udf? (define-c->inline-var exp)))
+       (add-global-inline 
+         var
+         (define-c->inline-var exp))
+       (add-global 
+         (define-c->inline-var exp)
+         #t ;; always a lambda
+         (c-compile-exp 
+          body append-preamble cont
+          (st:add-function! trace var)
+          #f ;; inline, so disable CPS on this pass
+         )
+        ))
+
    (c-code/vars "" (list ""))))
 
-(define (c-compile-raw-global-lambda exp append-preamble cont trace . inline?)
+(define (c-compile-raw-global-lambda exp append-preamble cont trace . cps?)
    (let* ((precompiled-sym
-            (if (equal? inline? '(#t))
+            (if (equal? cps? '(#f))
                 'precompiled-inline-lambda
                 'precompiled-lambda))
           (lambda-data
@@ -865,13 +932,13 @@
        (let ((fnc-sym 
                (define-c->inline-var exp)))
           ;(trace:error `(JAE define-c inline detected ,fnc-sym))
-         (add-global-inline fnc-sym)
+         (add-global-inline (define->var exp) fnc-sym)
          (c-compile-raw-global-lambda 
            `(define-c ,fnc-sym ,@(cddddr exp))
            append-preamble 
            cont 
            trace
-           #t)))) ;; Inline this one
+           #f)))) ;; Inline this one; CPS will not be used
      ;; Add this define-c
      (add-global 
        (define->var exp)
@@ -903,7 +970,7 @@
 ;; once given a C name, produce a C function
 ;; definition with that name.
 
-;; These procedures are stored up an eventually 
+;; These procedures are stored up and eventually 
 ;; emitted.
 
 ; type lambda-id = natural
@@ -913,17 +980,20 @@
 
 ; lambdas : alist[lambda-id,string -> string]
 (define lambdas '())
+(define inline-lambdas '())
 
 ; allocate-lambda : (string -> string) -> lambda-id
-(define (allocate-lambda lam)
+(define (allocate-lambda lam . cps?)
   (let ((id num-lambdas))
     (set! num-lambdas (+ 1 num-lambdas))
     (set! lambdas (cons (list id lam) lambdas))
+    (if (equal? cps? '(#f))
+        (set! inline-lambdas (cons id inline-lambdas)))
     id))
 
 ; get-lambda : lambda-id -> (symbol -> string)
-(define (get-lambda id)
+;(define (get-lambda id)
-  (cdr (assv id lambdas)))
+;  (cdr (assv id lambdas)))
 
 (define (lambda->env exp)
     (let ((formals (lambda-formals->list exp)))
@@ -993,7 +1063,7 @@
 ;;    the closure. The closure conversion phase tags each access
 ;;    to one with the corresponding index so `lambda` can use them.
 ;;
-(define (c-compile-closure exp append-preamble cont trace)
+(define (c-compile-closure exp append-preamble cont trace cps?)
   (let* ((lam (closure->lam exp))
          (free-vars
            (map
@@ -1006,7 +1076,7 @@
                     (mangle free-var)))
              (closure->fv exp))) ; Note these are not necessarily symbols, but in cc form
          (cv-name (mangle (gensym 'c)))
-         (lid (allocate-lambda (c-compile-lambda lam trace)))
+         (lid (allocate-lambda (c-compile-lambda lam trace cps?) cps?))
          (macro? (assoc (st:->var trace) (get-macros)))
          (call/cc? (and (equal? (car trace) "scheme/base.sld")
                         (equal? (st:->var trace) 'call/cc)))
@@ -1084,18 +1154,28 @@
         ""))))))
 
 ; c-compile-lambda : lamda-exp (string -> void) -> (string -> string)
-(define (c-compile-lambda exp trace)
+(define (c-compile-lambda exp trace cps?)
   (let* ((preamble "")
          (append-preamble (lambda (s)
                             (set! preamble (string-append preamble "  " s "\n")))))
     (let* ((formals (c-compile-formals 
-                      (lambda->formals exp)
+                      (if (not cps?)
+                          ;; Ignore continuation (k) arg for non-CPS funcs
+                          (cdr (lambda->formals exp))
+                          (lambda->formals exp))
                       (lambda-formals-type exp)))
            (tmp-ident (if (> (length (lambda-formals->list exp)) 0) 
                           (mangle (if (pair? (lambda->formals exp))
                                       (car (lambda->formals exp))
                                       (lambda->formals exp)))
                           ""))
+           (return-type
+            (if cps? "void" "object"))
+           (arg-argc (if cps? "int argc, " ""))
+           (arg-closure
+            (if cps?
+                "closure _"
+                "object ptr"))
            (has-closure? 
              (and
                (> (string-length tmp-ident) 3)
@@ -1105,19 +1185,20 @@
                 (if has-closure? 
                     "" 
                     (if (equal? "" formals) 
-                        "closure _"    ;; TODO: seems wrong, will GC be too aggressive 
+                        arg-closure
-                        "closure _,")) ;; due to missing refs, with ignored closure?
+                        (string-append arg-closure ",")))
                 formals))
            (env-closure (lambda->env exp))
            (body    (c-compile-exp     
                         (car (lambda->exp exp)) ;; car ==> assume single expr in lambda body after CPS
                         append-preamble
                         (mangle env-closure)
-                        trace)))
+                        trace 
+                        cps?)))
      (cons 
       (lambda (name)
-        (string-append "static void " name 
+        (string-append "static " return-type " " name 
-                       "(void *data, int argc, " 
+                       "(void *data, " arg-argc
                         formals*
                        ") {\n"
                        preamble
@@ -1293,6 +1374,12 @@
            (number->string (car l))
            (cadadr l)
            " ;"))
+        ((member (car l) inline-lambdas)
+         (emit*
+           "static object __lambda_" 
+           (number->string (car l)) "(void *data, "
+           (cdadr l)
+           ") ;"))
         (else
          (emit*
            "static void __lambda_" 
@@ -1325,6 +1412,8 @@
            (car (cddadr l))
            " }"
          ))
+       ((member (car l) inline-lambdas)
+        (emit ((caadr l) (string-append "__lambda_" (number->string (car l))))))
        (else
          (emit ((caadr l) (string-append "__lambda_" (number->string (car l))))))))
      lambdas)
@@ -1337,14 +1426,10 @@
               (head-pair #f))
           (for-each
             (lambda (g)
-              (let ((cvar-sym (mangle (gensym 'cvar)))
+              (let ((pair-sym (mangle (gensym 'pair))))
-                    (pair-sym (mangle (gensym 'pair))))
-               (emits* 
-                   "  make_cvar(" cvar-sym 
-                   ", (object *)&" (cgen:mangle-global g) ");")
                (emits*
-                   "make_pair(" pair-sym ", find_or_add_symbol(\"" (symbol->string g)
+                   "make_pair(" pair-sym ", find_or_add_symbol(\"" (symbol->string (car g))
-                   "\"), &" cvar-sym ");\n")
+                   "\"), find_or_add_symbol(\"" (symbol->string (cdr g)) "\"));\n")
                (set! pairs (cons pair-sym pairs))))
             *global-inlines*)
             ;; Link the pairs

scheme/cyclone/cps-optimizations.sld

@@ -16,8 +16,10 @@
           (scheme cyclone transforms)
           (srfi 69))
   (export
+      inlinable-top-level-lambda?
       optimize-cps 
       analyze-cps
+      ;analyze-lambda-side-effects
       opt:contract
       opt:inline-prims
       adb:clear!
@@ -51,6 +53,7 @@
       adb:function?
       adbf:simple adbf:set-simple!
       adbf:unused-params adbf:set-unused-params!
+      adbf:side-effects adbf:set-side-effects!
   )
   (begin
     (define *adb* (make-hash-table))
@@ -61,12 +64,18 @@
     (define (adb:get/default key default) (hash-table-ref/default *adb* key default))
     (define (adb:set! key val) (hash-table-set! *adb* key val))
     (define-record-type <analysis-db-variable>
-      (%adb:make-var global defined-by const const-value  ref-by
+      (%adb:make-var 
-                     reassigned assigned-value app-fnc-count app-arg-count
+        global defined-by 
-                     inlinable mutated-indirectly)
+        defines-lambda-id
+        const const-value  ref-by
+        reassigned assigned-value 
+        app-fnc-count app-arg-count
+        inlinable mutated-indirectly
+        cont)
       adb:variable?
       (global adbv:global? adbv:set-global!)
       (defined-by adbv:defined-by adbv:set-defined-by!)
+      (defines-lambda-id adbv:defines-lambda-id adbv:set-defines-lambda-id!)
       (const adbv:const? adbv:set-const!)
       (const-value adbv:const-value adbv:set-const-value!)
       (ref-by adbv:ref-by adbv:set-ref-by!)
@@ -83,6 +92,7 @@
       (inlinable adbv:inlinable adbv:set-inlinable!)
       ;; Is the variable mutated indirectly? (EG: set-car! of a cdr)
       (mutated-indirectly adbv:mutated-indirectly? adbv:set-mutated-indirectly!)
+      (cont adbv:cont? adbv:set-cont!)
     )
 
     (define (adbv-set-assigned-value-helper! sym var value)
@@ -111,18 +121,19 @@
     )
 
     (define (adb:make-var)
-      (%adb:make-var '? '? #f #f '() #f #f 0 0 #t #f))
+      (%adb:make-var '? '? #f #f #f '() #f #f 0 0 #t #f #f))
 
     (define-record-type <analysis-db-function>
-      (%adb:make-fnc simple unused-params assigned-to-var)
+      (%adb:make-fnc simple unused-params assigned-to-var side-effects)
       adb:function?
       (simple adbf:simple adbf:set-simple!)
       (unused-params adbf:unused-params adbf:set-unused-params!)
       (assigned-to-var adbf:assigned-to-var adbf:set-assigned-to-var!)
+      (side-effects adbf:side-effects adbf:set-side-effects!)
       ;; TODO: top-level-define ?
     )
     (define (adb:make-fnc)
-      (%adb:make-fnc '? '? '()))
+      (%adb:make-fnc '? '? '() #f))
 
     ;; A constant value that cannot be mutated
     ;; A variable only ever assigned to one of these could have all
@@ -157,6 +168,197 @@
         (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))
+               (fv (filter 
+                     (lambda (v)
+                       (not (prim? v)))
+                     (free-vars expr)))
+              )
+;(trace:error `(JAE DEBUG ,(define->var expr) ,fv))
+          (cond
+            ((> (length lambda-body) 1)
+             (k #f)) ;; Fail with more than one expression in lambda body,
+                     ;; because CPS is required to compile that.
+            ((> (length fv) 1) ;; Reject any free variables to attempt to prevent
+             (k #f))           ;; cases where there is a variable that may be
+                               ;; mutated outside the scope of this function.
+            (else
+              (scan
+                (car lambda-body)
+                (lambda () (k #f))) ;; Fail with #f
+              (k #t))))))) ;; Scanned fine, return #t
+    (else #f)))
+
+    (define (analyze-find-lambdas exp lid)
+      (cond
+        ((ast:lambda? exp)
+         (let* ((id (ast:lambda-id exp))
+                (fnc (adb:get/default id (adb:make-fnc))))
+           (adb:set! id fnc)
+           ;; Flag continuation variable, if present
+           (if (ast:lambda-has-cont exp)
+               (let ((k (car (ast:lambda-args exp))))
+                 (with-var! k (lambda (var)
+                   (adbv:set-cont! var #t)))))
+           (for-each
+             (lambda (expr)
+               (analyze-find-lambdas expr id))
+             (ast:lambda-body exp))))
+        ((const? exp) #f)
+        ((quote? exp) #f)
+        ((ref? exp) #f)
+        ((define? exp)
+         (let ((val (define->exp exp)))
+           (if (ast:lambda? (car val))
+               (with-var! (define->var exp) (lambda (var)
+                 (adbv:set-defines-lambda-id! 
+                   var (ast:lambda-id (car val)))))))
+         (analyze-find-lambdas (define->exp exp) lid))
+        ((set!? exp)
+         (analyze-find-lambdas (set!->exp exp) lid))
+        ((if? exp)
+         (analyze-find-lambdas (if->condition exp) lid)
+         (analyze-find-lambdas (if->then exp) lid)
+         (analyze-find-lambdas (if->else exp) lid))
+        ((app? exp)
+         (for-each
+           (lambda (e)
+             (analyze-find-lambdas e lid))
+           exp))
+        (else
+          #f)))
+
+    ;; Mark each lambda that has side effects.
+    ;; For nested lambdas, if a child has side effects also mark the parent
+    (define (analyze-lambda-side-effects exp lid)
+      (cond
+        ((ast:lambda? exp)
+         (let* ((id (ast:lambda-id exp))
+                (fnc (adb:get/default id (adb:make-fnc))))
+           (adb:set! id fnc)
+           (for-each
+             (lambda (expr)
+               (analyze-lambda-side-effects expr id))
+             (ast:lambda-body exp))
+           ;; If id has side effects, mark parent lid, too
+           (if (and (> lid -1)
+                    (adbf:side-effects fnc))
+               (with-fnc! lid (lambda (f)
+                 (adbf:set-side-effects! f #t))))))
+        ((const? exp) #f)
+        ((quote? exp) #f)
+        ((ref? exp) #f)
+        ((define? exp)
+         (analyze-lambda-side-effects (define->exp exp) lid))
+        ((set!? exp)
+         (with-fnc! lid (lambda (fnc)
+           (adbf:set-side-effects! fnc #t)))
+         (analyze-lambda-side-effects (set!->exp exp) lid))
+        ((if? exp)
+         (analyze-lambda-side-effects (if->condition exp) lid)
+         (analyze-lambda-side-effects (if->then exp) lid)
+         (analyze-lambda-side-effects (if->else exp) lid))
+        ((app? exp)
+         (let ((pure-ref #t))
+           ;; Check if ref is pure. Note this may give wrong results
+           ;; if ref's lambda has not been scanned yet. One solution is
+           ;; to make 2 top-level passes of analyze-lambda-side-effects.
+           (if (ref? (car exp))
+               (with-var (car exp) (lambda (var)
+                 (if (adbv:defines-lambda-id var)
+                     (with-fnc! (adbv:defines-lambda-id var) (lambda (fnc)
+                       (if (adbf:side-effects fnc)
+                           (set! pure-ref #f))))))))
+
+         ;; This lambda has side effects if it calls a mutating prim or
+         ;; a function not explicitly marked as having no side effects.
+         (if (or (prim:mutates? (car exp))
+                 (and (ref? (car exp))
+                      (not pure-ref)))
+             (with-fnc! lid (lambda (fnc)
+               (adbf:set-side-effects! fnc #t))))
+         (for-each
+           (lambda (e)
+             (analyze-lambda-side-effects e lid))
+           exp)))
+        (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)
@@ -403,7 +605,8 @@
                (ast:%make-lambda
                  (ast:lambda-id exp)
                  (ast:lambda-args exp)
-                 (opt:contract (ast:lambda-body exp))))))
+                 (opt:contract (ast:lambda-body exp))
+                 (ast:lambda-has-cont exp)))))
         ((const? exp) exp)
         ((ref? exp) 
          (let ((var (adb:get/default exp #f)))
@@ -457,7 +660,8 @@
                  (ast:%make-lambda
                    (ast:lambda-id fnc)
                    (reverse new-params)
-                   (ast:lambda-body fnc))
+                   (ast:lambda-body fnc) 
+                   (ast:lambda-has-cont fnc))
                  (map 
                    opt:contract
                      (reverse new-args)))))
@@ -488,7 +692,8 @@
            (ast:%make-lambda
             (ast:lambda-id exp)
             (ast:lambda-args exp)
-            (map (lambda (b) (opt:inline-prims b refs)) (ast:lambda-body exp))))
+            (map (lambda (b) (opt:inline-prims b refs)) (ast:lambda-body exp))
+            (ast:lambda-has-cont exp)))
           ((const? exp) exp)
           ((quote? exp) exp)
           ((define? exp)
@@ -729,6 +934,7 @@
               (if (not (adbv:inlinable var))
                   (set! fast-inline #f)))))
           ivars)
+;(trace:error `(DEBUG inline-prim-call ,exp ,ivars ,args ,cannot-inline ,fast-inline))
       (cond
         (cannot-inline #f)
         (else
@@ -817,6 +1023,7 @@
            ;; If the code gets this far, assume we came from a place
            ;; that does not allow the var to be inlined. We need to
            ;; explicitly white-list variables that can be inlined.
+; (trace:error `(DEBUG not inlinable ,exp ,args))
            (with-var exp (lambda (var)
              (adbv:set-inlinable! var #f)))))
         ((ast:lambda? exp)
@@ -860,9 +1067,42 @@
                   (analyze:find-inlinable-vars e args)))
             (cdr exp)))
             ;(reverse (cdr exp))))
+          ;; If primitive mutates its args, ignore ivar if it is not mutated
+          ((and (prim? (car exp))
+                (prim:mutates? (car exp))
+                (> (length exp) 1))
+           (analyze:find-inlinable-vars (cadr exp) args)
+           ;; First param is always mutated
+           (for-each
+            (lambda (e)
+              (if (not (ref? e))
+                  (analyze:find-inlinable-vars e args)))
+            (cddr exp)))
           ((and (not (prim? (car exp)))
                 (ref? (car exp)))
+           (define pure-fnc #f)
+           (define calling-cont #f)
            (define ref-formals '())
+           ;; Does ref refer to a pure function (no side effects)?
+           (let ((var (adb:get/default (car exp) #f)))
+            (if var
+                (let ((lid (adbv:defines-lambda-id var))
+                      (assigned-val (adbv:assigned-value var)))
+                  (cond
+                   (lid
+                    (with-fnc! lid (lambda (fnc)
+                      (if (not (adbf:side-effects fnc))
+                          (set! pure-fnc #t)))))
+                   ((ast:lambda? assigned-val)
+                    (with-fnc! (ast:lambda-id assigned-val) (lambda (fnc)
+                      (if (not (adbf:side-effects fnc))
+                          (set! pure-fnc #t)))))
+                   ;; Experimental - if a cont, execution will leave fnc anyway,
+                   ;; so inlines there should be safe
+                   ((adbv:cont? var)
+                    (set! calling-cont #t))
+                   ))))
+           ;;
            (with-var (car exp) (lambda (var)
              (let ((val (adbv:assigned-value var)))
               (cond
@@ -875,6 +1115,15 @@
            ))))
 ;(trace:error `(DEBUG ref app ,(car exp) ,(cdr exp) ,ref-formals))
            (cond
+            ((or pure-fnc calling-cont)
+              (for-each
+                (lambda (e)
+                  ;; Skip refs since fnc is pure and cannot change them
+                  (if (not (ref? e))
+                      (analyze:find-inlinable-vars e args)))
+                exp))
+            ;; TODO: how do you know if it is the same function, or just
+            ;; another function with the same formals?
             ((= (length ref-formals) (length (cdr exp)))
              (analyze:find-inlinable-vars (car exp) args)
              (for-each
@@ -901,6 +1150,9 @@
           (error `(Unexpected expression passed to find inlinable vars ,exp)))))
 
     (define (analyze-cps exp)
+      (analyze-find-lambdas exp -1)
+      (analyze-lambda-side-effects exp -1)
+      (analyze-lambda-side-effects exp -1) ;; 2nd pass guarantees lambda purity
       (analyze exp -1) ;; Top-level is lambda ID -1
       (analyze2 exp) ;; Second pass
       (analyze:find-inlinable-vars exp '()) ;; Identify variables safe to inline

scheme/cyclone/libraries.sld

@@ -35,6 +35,7 @@
     lib:cond-expand-decls
     lib:includes
     lib:include-c-headers
+    lib:inlines
     lib:import-set:library-name?
     lib:import-set->import-set
     lib:import->library-name
@@ -60,6 +61,10 @@
     lib:idb:entry->library-name
     lib:idb:entry->library-id
   )
+  (inline
+    lib:idb:entry->library-name
+    lib:import-set->import-set
+  )
   (begin
 
 (define (library? ast)
@@ -188,6 +193,17 @@
         (tagged-list? 'include-c-header code))
       (cddr ast))))
 
+(define (lib:inlines ast)
+  (apply 
+    append
+    (map
+      (lambda (inc-lst)
+        (cdr inc-lst))
+      (filter
+        (lambda (code)
+          (tagged-list? 'inline code))
+        (cddr ast)))))
+
 ;; TODO: include-ci, cond-expand
 
 ;TODO: maybe just want a function that will take a define-library expression and expand any top-level cond-expand expressions.

scheme/cyclone/macros.sld

@@ -22,6 +22,8 @@
     macro:get-env
     macro:get-defined-macros
   )
+  (inline
+    macro:macro?)
   (begin
     ;; top-level macro environment
     (define *macro:env* '())

scheme/cyclone/transforms.sld

@@ -105,7 +105,27 @@
     pos-in-list 
     closure-convert 
     prim-convert
-    inlinable-top-level-function?
+  )
+  (inline
+    cell-get->cell
+    cell->value
+    set-cell!->value
+    set-cell!->cell
+    env-get->env
+    env-get->field
+    env-get->id
+    env-make->id
+    closure->fv
+    closure->env
+    closure->lam
+    begin->exps
+    app->args
+    app->fun
+    letrec->exp
+    letrec->bindings
+    let->exp
+    let->bindings
+    void
   )
   (begin
 
@@ -163,17 +183,6 @@
 
 ;; Utilities.
 
-(cond-expand
-  (cyclone
-    ; member : symbol sorted-set[symbol] -> boolean
-    (define (member sym S)
-      (if (not (pair? S))
-          #f
-          (if (eq? sym (car S))
-              #t
-              (member sym (cdr S))))))
-  (else #f))
-
 (cond-expand
   (cyclone
     ; void : -> void
@@ -1231,54 +1240,6 @@
         ast)))
   (conv expr))
 
-;; 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-function? expr)
-   (define this-fnc-sym (define->var expr))
-   (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
-              )
-              (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)
-        (scan
-          (car (lambda->exp
-                 (car (define->exp expr))))
-          (lambda () (k #f))) ;; Fail with #f
-        (k #t)))) ;; Scanned fine, return #t
-    (else #f)))
 ;;
 ;; Helpers to syntax check primitive calls
 ;;
@@ -1328,7 +1289,8 @@
                  (let ((k (gensym 'k)))
                     (list (ast:make-lambda
                            (list k)
-                           (list (xform k)))
+                           (list (xform k))
+                           #t)
                           cont-ast)))))
 
           ((prim-call? ast)
@@ -1355,7 +1317,8 @@
                          (if (equal? ltype 'args:varargs)
                              'args:fixed-with-varargs ;; OK? promote due to k
                              ltype))
-                      (list (cps-seq (cddr ast) k))))))
+                      (list (cps-seq (cddr ast) k)) 
+                      #t))))
 
           ((app? ast)
            ;; Syntax check the function

scheme/cyclone/util.sld

@@ -83,6 +83,23 @@
     string-replace-all
     take
     filter)
+  (inline
+    env:frame-values
+    env:frame-variables
+    env:first-frame
+    env:enclosing-environment
+    lambda->exp
+    lambda->formals
+    define->exp
+    set!->exp
+    set!->var
+    ref?
+    app?
+    if->else
+    if->then
+    if->condition
+    tagged-list?
+  )
   (begin
 
 (define (tagged-list? tag exp)

scheme/eval.sld

@@ -23,6 +23,25 @@
     setup-environment ; non-standard
     ;; Dynamic import
     %import
+    imported?
+  )
+  (inline
+    primitive-implementation
+    procedure-environment
+    procedure-body
+    procedure-parameters
+    operands
+    operator
+    application?
+    if-alternative
+    if-consequent
+    if-predicate
+    lambda-body
+    lambda-parameters
+    definition-variable
+    assignment-value
+    assignment-variable
+    variable?
   )
   (begin
 
@@ -624,6 +643,10 @@
     (set! *global-environment* (setup-environment *initial-environment*))
     #t))
 
+;; Is the given library loaded?
+(define (imported? lis)
+  (c:lib-loaded? (lib:name->unique-string (lib:list->import-set lis))))
+
 ;; Wrapper around the actual shared object import function
 (define-c c:import-shared-obj
   "(void *data, int argc, closure _, object k, object fn, object entry_fnc)"

scheme/inexact.sld

@@ -7,6 +7,7 @@
 ;;;; This module contains the inexact library from r7rs.
 ;;;;
 (define-library (scheme inexact)
+  (import (scheme base))
   (export 
     acos 
     asin
@@ -22,6 +23,19 @@
     tan
   )
   (begin
+    (define-syntax define-inexact-op
+      (er-macro-transformer
+        (lambda (expr rename compare)
+          (let* ((fnc (cadr expr))
+                 (op (caddr expr)))
+           `(define-c ,fnc
+              "(void *data, int argc, closure _, object k, object z)"
+              ,(string-append
+                " return_inexact_double_op(data, k, " op ", z);")
+              "(void *data, object ptr, object z)"
+              ,(string-append
+                " return_inexact_double_op_no_cps(data, ptr, " op ", z);"))))))
+
     (define-c nan?
       "(void *data, int argc, closure _, object k, object z)"
       " Cyc_check_num(data, z);
@@ -46,41 +60,18 @@
         return_closcall1(data, k, boolean_t);")
     (define (finite? z)
       (if (infinite? z) #f #t))
-    (define-c acos
-      "(void *data, int argc, closure _, object k, object z)"
-      " return_inexact_double_op(data, k, acos, z);")
-    (define-c asin
-      "(void *data, int argc, closure _, object k, object z)"
-      " return_inexact_double_op(data, k, asin, z);")
-    (define-c atan
-      "(void *data, int argc, closure _, object k, object z)"
-      " return_inexact_double_op(data, k, atan, z);")
-    (define-c cos
-      "(void *data, int argc, closure _, object k, object z)"
-      " return_inexact_double_op(data, k, cos, z);")
-    (define-c exp
-      "(void *data, int argc, closure _, object k, object z)"
-      " return_inexact_double_op(data, k, exp, z);")
     (define (log z1 . z2)
       (if (null? z2)
           (c-log z1)
           (let ((z2* (car z2)))
             (/ (c-log z1) (c-log z2*)))))
-    (define-c c-log
+    (define-inexact-op c-log "log")
-      "(void *data, int argc, closure _, object k, object z)"
+    (define-inexact-op exp "exp")
-      " return_inexact_double_op(data, k, log, z);"
+    (define-inexact-op sqrt "sqrt")
-      "(void *data, object ptr, object z)"
+    (define-inexact-op sin "sin")
-      " return_inexact_double_op_no_cps(data, ptr, log, z);"
+    (define-inexact-op cos "cos")
-      )
+    (define-inexact-op tan "tan")
-    (define-c sin
+    (define-inexact-op asin "asin")
-      "(void *data, int argc, closure _, object k, object z)"
+    (define-inexact-op acos "acos")
-      " return_inexact_double_op(data, k, sin, z);"
+    (define-inexact-op atan "atan")
-      "(void *data, object ptr, object z)"
-      " return_inexact_double_op_no_cps(data, ptr, sin, z);")
-    (define-c sqrt
-      "(void *data, int argc, closure _, object k, object z)"
-      " return_inexact_double_op(data, k, sqrt, z);")
-    (define-c tan
-      "(void *data, int argc, closure _, object k, object z)"
-      " return_inexact_double_op(data, k, tan, z);")
 ))

scheme/read.sld

@@ -16,6 +16,11 @@
     include
     include-ci
   )
+  (inline
+    in-port:get-cnum
+    in-port:get-lnum
+    in-port:get-buf
+  )
   (begin
 
 (define-syntax include

srfi/1.sld

@@ -42,6 +42,15 @@
     lset-union  lset-intersection  lset-difference  lset-xor  lset-diff+intersection
     lset-union! lset-intersection! lset-difference! lset-xor! lset-diff+intersection!
   )
+  (inline
+    tenth
+    ninth
+    eighth
+    seventh
+    sixth
+    fifth
+    not-pair?
+  )
   (include "1.scm")
   (begin)
 )

srfi/106.sld

@@ -36,6 +36,8 @@
       *msg-peek* *msg-oob* *msg-waitall*
       *shut-rd* *shut-wr* *shut-rdwr*
   )
+  (inline
+    socket->fd)
   (begin
     (define *socket-object-type* '%socket-object-type%)
     (define (socket->fd obj) (cdr obj))

srfi/128.sld

@@ -2,6 +2,8 @@
   (import (scheme base))
   (import (scheme case-lambda))
   (import (scheme char) (scheme complex) (scheme inexact))
+  (inline
+    boolean<?)
   (export comparator? comparator-ordered? comparator-hashable?)
   (export make-comparator
           make-pair-comparator make-list-comparator make-vector-comparator

srfi/133.sld

@@ -1,6 +1,11 @@
 (define-library (srfi 133) ;vectors)
   (import (scheme base))
   (import (scheme cxr))
+  (inline
+    unspecified-value
+    between?
+    nonneg-int?
+  )
   ;; Constructors 
   (export vector-unfold vector-unfold-right vector-reverse-copy 
           vector-concatenate vector-append-subvectors)

srfi/18.sld

@@ -49,6 +49,10 @@
     ->heap
     Cyc-minor-gc
   )
+  (inline
+    thread-specific
+    thread-name
+  )
   (begin
     ;; Threading
     (define (thread? obj)