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

Merge branch 'inline7-dev'

Browse source
This commit is contained in:
Justin Ethier 2017-05-09 13:00:21 +00:00
commit e6eeeb958e
23 changed files with 785 additions and 201 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
CHANGELOG.md
View file

@ -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

12
array1-test.scm Normal file
View file

@ -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))

130
cyclone.scm
View file

@ -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?

2
examples/Makefile
View file

@ -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

26
gc.c
View file

@ -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);

17
include/cyclone/types.h
View file

@ -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; \
} \
}
/**@}*/
/**@}*/

55
scheme/base.sld
View file

@ -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); ")
;TODO: working on define-c:inline macro to make it less verbose to do this
" return_exact_double_op(data, k, ceil, z); "
"(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

3
scheme/complex.sld
View file

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

15
scheme/cyclone/ast.sld
View file

@ -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!))
(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)))
))

221
scheme/cyclone/cgen.sld
View file

@ -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

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

@ -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
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 <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

16
scheme/cyclone/libraries.sld
View file

@ -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.

2
scheme/cyclone/macros.sld
View file

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

87
scheme/cyclone/transforms.sld
View file

@ -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

17
scheme/cyclone/util.sld
View file

@ -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)

23
scheme/eval.sld
View file

@ -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)"

55
scheme/inexact.sld
View file

@ -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")
))

5
scheme/read.sld
View file

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

9
srfi/1.sld
View file

@ -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)
)

2
srfi/106.sld
View file

@ -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))

2
srfi/128.sld
View file

@ -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

5
srfi/133.sld
View file

@ -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)

4
srfi/18.sld
View file

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