diff --git a/CHANGELOG.md b/CHANGELOG.md index 240c105c..5c80f11b 100644 --- a/CHANGELOG.md +++ b/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 diff --git a/array1-test.scm b/array1-test.scm new file mode 100644 index 00000000..a1519458 --- /dev/null +++ b/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)) diff --git a/cyclone.scm b/cyclone.scm index 22668807..e51a7d76 100644 --- a/cyclone.scm +++ b/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 input-program)) + (trace:info "---------------- after cps optimizations (1):") + (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? diff --git a/examples/Makefile b/examples/Makefile index 280f2cd2..8e665bb1 100644 --- a/examples/Makefile +++ b/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 + diff --git a/gc.c b/gc.c index a77b2482..d6d5a91b 100644 --- a/gc.c +++ b/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) { - return gc_heap_align(sizeof(string_type) + string_len(obj) + 1); - } - if (t == integer_tag) - return gc_heap_align(sizeof(integer_type)); + if (t == macro_tag) + return gc_heap_align(sizeof(macro_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); diff --git a/include/cyclone/types.h b/include/cyclone/types.h index 9f0f02a0..fafc703f 100644 --- a/include/cyclone/types.h +++ b/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; \ + } \ +} + /**@}*/ /**@}*/ diff --git a/scheme/base.sld b/scheme/base.sld index 10358a46..c6839bb1 100644 --- a/scheme/base.sld +++ b/scheme/base.sld @@ -207,6 +207,23 @@ ; letrec-syntax ;;;; ) + (inline + exact-integer? + square + quotient + numerator + denominator + truncate + negative? + positive? + zero? + not + string>=? + string>? + string<=? + stringsymbol 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 diff --git a/scheme/complex.sld b/scheme/complex.sld index 16d55bf7..0c7208d2 100644 --- a/scheme/complex.sld +++ b/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) diff --git a/scheme/cyclone/ast.sld b/scheme/cyclone/ast.sld index b1989d95..1c9cf628 100644 --- a/scheme/cyclone/ast.sld +++ b/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 - (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!)) - (define (ast:make-lambda args body) - (set! *lambda-id* (+ 1 *lambda-id*)) - (ast:%make-lambda *lambda-id* args body)) + (body ast:lambda-body ast:set-lambda-body!) + (has-cont ast:lambda-has-cont ast:set-lambda-has-cont!) + ) + (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))) )) diff --git a/scheme/cyclone/cgen.sld b/scheme/cyclone/cgen.sld index e7d533b1..37d4cb69 100644 --- a/scheme/cyclone/cgen.sld +++ b/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))) - (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) - ");")))) + (cargs (c-compile-args (cdr args) append-preamble " " this-cont trace cps?))) + (cond + ((not cps?) + (c-code + (string-append + (c:allocs->str (c:allocs cfun) "\n") + (c:allocs->str (c:allocs cargs) "\n") + "return_copy(ptr," + (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) - (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) - ");")))) + (cond + ((not cps?) + (c-code + (string-append + (c:allocs->str (c:allocs cfun) "\n") + (c:allocs->str (c:allocs cargs) "\n") + "return_copy(ptr," + (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) - (set! *global-inlines* (cons var-sym *global-inlines*))) +(define (add-global-inline orig-sym inline-sym) + (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) - (cdr (assv id lambdas))) +;(define (get-lambda id) +; (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 - "closure _,")) ;; due to missing refs, with ignored closure? + arg-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 - "(void *data, int argc, " + (string-append "static " return-type " " name + "(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))) - (pair-sym (mangle (gensym 'pair)))) - (emits* - " make_cvar(" cvar-sym - ", (object *)&" (cgen:mangle-global g) ");") + (let ((pair-sym (mangle (gensym 'pair)))) (emits* - "make_pair(" pair-sym ", find_or_add_symbol(\"" (symbol->string g) - "\"), &" cvar-sym ");\n") + "make_pair(" pair-sym ", find_or_add_symbol(\"" (symbol->string (car g)) + "\"), find_or_add_symbol(\"" (symbol->string (cdr g)) "\"));\n") (set! pairs (cons pair-sym pairs)))) *global-inlines*) ;; Link the pairs diff --git a/scheme/cyclone/cps-optimizations.sld b/scheme/cyclone/cps-optimizations.sld index 18f48c97..8c9fb409 100644 --- a/scheme/cyclone/cps-optimizations.sld +++ b/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 - (%adb:make-var global defined-by const const-value ref-by - reassigned assigned-value app-fnc-count app-arg-count - inlinable mutated-indirectly) + (%adb:make-var + global defined-by + 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 - (%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 diff --git a/scheme/cyclone/libraries.sld b/scheme/cyclone/libraries.sld index dddc77c4..9330e7e2 100644 --- a/scheme/cyclone/libraries.sld +++ b/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. diff --git a/scheme/cyclone/macros.sld b/scheme/cyclone/macros.sld index dc2d391f..1696248e 100644 --- a/scheme/cyclone/macros.sld +++ b/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* '()) diff --git a/scheme/cyclone/transforms.sld b/scheme/cyclone/transforms.sld index 29fdf5f5..26fe492d 100644 --- a/scheme/cyclone/transforms.sld +++ b/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 diff --git a/scheme/cyclone/util.sld b/scheme/cyclone/util.sld index 8f292f43..b89d5a2b 100644 --- a/scheme/cyclone/util.sld +++ b/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) diff --git a/scheme/eval.sld b/scheme/eval.sld index 5ed800b4..f3d0814e 100644 --- a/scheme/eval.sld +++ b/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)" diff --git a/scheme/inexact.sld b/scheme/inexact.sld index fca6a93d..11db3320 100644 --- a/scheme/inexact.sld +++ b/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 - "(void *data, int argc, closure _, object k, object z)" - " return_inexact_double_op(data, k, log, z);" - "(void *data, object ptr, object z)" - " return_inexact_double_op_no_cps(data, ptr, log, z);" - ) - (define-c sin - "(void *data, int argc, closure _, object k, object z)" - " return_inexact_double_op(data, k, sin, z);" - "(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);") + (define-inexact-op c-log "log") + (define-inexact-op exp "exp") + (define-inexact-op sqrt "sqrt") + (define-inexact-op sin "sin") + (define-inexact-op cos "cos") + (define-inexact-op tan "tan") + (define-inexact-op asin "asin") + (define-inexact-op acos "acos") + (define-inexact-op atan "atan") )) diff --git a/scheme/read.sld b/scheme/read.sld index 8dbb9282..38b7f38e 100644 --- a/scheme/read.sld +++ b/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 diff --git a/srfi/1.sld b/srfi/1.sld index bc80890e..9bd245b5 100644 --- a/srfi/1.sld +++ b/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) ) diff --git a/srfi/106.sld b/srfi/106.sld index 3a9315d0..e2b3ebda 100644 --- a/srfi/106.sld +++ b/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)) diff --git a/srfi/128.sld b/srfi/128.sld index 8c947d06..9476378b 100644 --- a/srfi/128.sld +++ b/srfi/128.sld @@ -2,6 +2,8 @@ (import (scheme base)) (import (scheme case-lambda)) (import (scheme char) (scheme complex) (scheme inexact)) + (inline + booleanheap Cyc-minor-gc ) + (inline + thread-specific + thread-name + ) (begin ;; Threading (define (thread? obj)