mirror of
https://github.com/justinethier/cyclone.git
synced 2025-05-23 20:15:05 +02:00
Merge branch 'heap-dev'
This commit is contained in:
Justin Ethier
commit
ef4c950829
47 changed files with 4218 additions and 40661 deletions
10
Makefile
10
Makefile
|
|
@ -110,6 +110,9 @@ bootstrap: icyc
|
|||
cp cyclone.c $(BOOTSTRAP_DIR)/cyclone.c
|
||||
cp Makefile.config $(BOOTSTRAP_DIR)/Makefile.config
|
||||
|
||||
.PHONY: examples
|
||||
examples:
|
||||
cd examples ; make
|
||||
|
||||
.PHONY: test
|
||||
test: $(TESTFILES) $(CYCLONE)
|
||||
|
|
@ -119,10 +122,17 @@ test: $(TESTFILES) $(CYCLONE)
|
|||
tags:
|
||||
ctags -R *
|
||||
|
||||
.PHONY: indent
|
||||
indent:
|
||||
indent -linux -l80 -i2 -nut gc.c
|
||||
indent -linux -l80 -i2 -nut runtime.c
|
||||
indent -linux -l80 -i2 -nut include/cyclone/*.h
|
||||
|
||||
.PHONY: clean
|
||||
clean:
|
||||
rm -rf a.out *.o *.so *.a *.out tags cyclone icyc scheme/*.o scheme/*.c scheme/*.meta srfi/*.c srfi/*.meta srfi/*.o scheme/cyclone/*.o scheme/cyclone/*.c scheme/cyclone/*.meta cyclone.c dispatch.c icyc.c generate-c.c generate-c
|
||||
$(foreach f,$(TESTSCM), rm -rf $(f) $(f).c tests/$(f).c;)
|
||||
cd examples ; make clean
|
||||
|
||||
install-includes:
|
||||
$(MKDIR) $(DESTDIR)$(INCDIR)
|
||||
|
|
|
|||
15
README.md
15
README.md
|
|
@ -53,6 +53,21 @@ Documentation
|
|||
|
||||
- Finally, if you need another resource to start learning the Scheme language you may want to try a classic textbook such as [Structure and Interpretation of Computer Programs](https://mitpress.mit.edu/sicp/full-text/book/book.html).
|
||||
|
||||
Example Programs
|
||||
----------------
|
||||
|
||||
Cyclone provides several example programs, including:
|
||||
|
||||
- [Tail Call Optimization](examples/tail-call-optimization.scm) - A simple example of Scheme tail call optimization; this program runs forever, calling into two mutually recursive functions.
|
||||
|
||||
- [Threading](examples/threading) - Various examples of multi-threaded programs.
|
||||
|
||||
- [Game of Life](examples/game-of-life) - The [Conway's game of life](https://en.wikipedia.org/wiki/Conway%27s_Game_of_Life) example program and libraries from R<sup>7</sup>RS.
|
||||
|
||||
- [Game of Life PNG Image Generator](examples/game-of-life-png) - A modified version of game of life that uses libpng to create an image of each iteration instead of writing it to console. This example also demonstrates basic usage of the C Foreign Function Interface (FFI).
|
||||
|
||||
- Finally, the largest program is the compiler itself. Most of the code is contained in a series of libraries which are used by [`cyclone.scm`](cyclone.scm) and [`icyc.scm`](icyc.scm) to create executables for Cyclone's compiler and interpreter.
|
||||
|
||||
License
|
||||
-------
|
||||
Copyright (C) 2014 [Justin Ethier](http://github.com/justinethier).
|
||||
|
|
|
|||
19
TODO
19
TODO
|
|
@ -1,9 +1,28 @@
|
|||
Initiatives:
|
||||
|
||||
Tier 0:
|
||||
- Library support
|
||||
|
||||
Import sets (importing libraries, section 5.2):
|
||||
supported:
|
||||
- library name
|
||||
not supported (not these are defined recursively, and can be nested):
|
||||
- only
|
||||
- except
|
||||
- rename
|
||||
- prefix
|
||||
|
||||
|
||||
Tier 1:
|
||||
- Performance - most likely need CPS optimization and closure elimination
|
||||
- pass larceny benchmarks (will require some bugfixes):
|
||||
|
||||
TODO: sboyer finishes in a reasonable amount of time now, but the collector's memory growth is
|
||||
not being limited. need to test, but I think disabling the growth code after collection
|
||||
is throwing off the collector's memory ratios and causing each major collection to first
|
||||
'bump' gc_grow_heap. anyway, need to figure this out
|
||||
|
||||
|
||||
benchmarks that do not finish due to
|
||||
missing features:
|
||||
- gcbench.scm - Needed to manually import (srfi 9)
|
||||
|
|
|
|||
73
cyclone.scm
73
cyclone.scm
|
|
@ -20,23 +20,23 @@
|
|||
(scheme cyclone macros)
|
||||
(scheme cyclone libraries))
|
||||
|
||||
(cond-expand
|
||||
(chicken
|
||||
(define (Cyc-installation-dir . opt)
|
||||
(if (equal? '(inc) opt)
|
||||
"/home/justin/Documents/cyclone/include"
|
||||
;; Ignore opt and always assume current dir for chicken, since it is just dev
|
||||
"/home/justin/Documents/cyclone"))
|
||||
(require-extension extras) ;; pretty-print
|
||||
(require-extension chicken-syntax) ;; when
|
||||
(require-extension srfi-1) ;; every
|
||||
(load (string-append (Cyc-installation-dir) "/scheme/cyclone/common.so"))
|
||||
(load (string-append (Cyc-installation-dir) "/scheme/parser.so"))
|
||||
(load (string-append (Cyc-installation-dir) "/scheme/cyclone/util.so"))
|
||||
(load (string-append (Cyc-installation-dir) "/scheme/cyclone/libraries.so"))
|
||||
(load (string-append (Cyc-installation-dir) "/scheme/cyclone/transforms.so"))
|
||||
(load (string-append (Cyc-installation-dir) "/scheme/cyclone/cgen.so")))
|
||||
(else #f))
|
||||
;;(cond-expand
|
||||
;; (chicken
|
||||
;; (define (Cyc-installation-dir . opt)
|
||||
;; (if (equal? '(inc) opt)
|
||||
;; "/home/justin/Documents/cyclone/include"
|
||||
;; ;; Ignore opt and always assume current dir for chicken, since it is just dev
|
||||
;; "/home/justin/Documents/cyclone"))
|
||||
;; (require-extension extras) ;; pretty-print
|
||||
;; (require-extension chicken-syntax) ;; when
|
||||
;; (require-extension srfi-1) ;; every
|
||||
;; (load (string-append (Cyc-installation-dir) "/scheme/cyclone/common.so"))
|
||||
;; (load (string-append (Cyc-installation-dir) "/scheme/parser.so"))
|
||||
;; (load (string-append (Cyc-installation-dir) "/scheme/cyclone/util.so"))
|
||||
;; (load (string-append (Cyc-installation-dir) "/scheme/cyclone/libraries.so"))
|
||||
;; (load (string-append (Cyc-installation-dir) "/scheme/cyclone/transforms.so"))
|
||||
;; (load (string-append (Cyc-installation-dir) "/scheme/cyclone/cgen.so")))
|
||||
;; (else #f))
|
||||
|
||||
;; Code emission.
|
||||
|
||||
|
|
@ -51,6 +51,8 @@
|
|||
(define imported-vars '())
|
||||
(define lib-name '())
|
||||
(define lib-exports '())
|
||||
(define lib-renamed-exports '())
|
||||
(define c-headers '())
|
||||
|
||||
(emit *c-file-header-comment*) ; Guarantee placement at top of C file
|
||||
|
||||
|
|
@ -62,12 +64,23 @@
|
|||
(let ((includes (lib:includes (car input-program))))
|
||||
(set! program? #f)
|
||||
(set! lib-name (lib:name (car input-program)))
|
||||
(set! c-headers (lib:include-c-headers (car input-program)))
|
||||
(set! lib-exports
|
||||
(cons
|
||||
(lib:name->symbol lib-name)
|
||||
(lib:exports (car input-program))))
|
||||
(set! lib-renamed-exports
|
||||
(lib:rename-exports (car input-program)))
|
||||
(set! imports (lib:imports (car input-program)))
|
||||
(set! input-program (lib:body (car input-program)))
|
||||
;; Add any renamed exports to the begin section
|
||||
(set! input-program
|
||||
(append
|
||||
(map
|
||||
(lambda (r)
|
||||
`(define ,(caddr r) ,(cadr r)))
|
||||
lib-renamed-exports)
|
||||
input-program))
|
||||
;; Prepend any included files into the begin section
|
||||
(if (not (null? includes))
|
||||
(for-each
|
||||
|
|
@ -78,10 +91,24 @@
|
|||
include))
|
||||
input-program)))
|
||||
includes))))
|
||||
((tagged-list? 'import (car input-program))
|
||||
(set! imports (cdar input-program))
|
||||
(set! input-program (cdr input-program))
|
||||
;(error (list 'imports (cdar input-program)))
|
||||
(else
|
||||
;; Handle import, if present
|
||||
(cond
|
||||
((tagged-list? 'import (car input-program))
|
||||
(set! imports (cdar input-program))
|
||||
(set! input-program (cdr input-program))
|
||||
;(error (list 'imports (cdar input-program)))
|
||||
))
|
||||
;; Handle any C headers
|
||||
(let ((headers (lib:include-c-headers `(dummy dummy ,@input-program))))
|
||||
(cond
|
||||
((not (null? headers))
|
||||
(set! c-headers headers)
|
||||
(set! input-program
|
||||
(filter
|
||||
(lambda (expr)
|
||||
(not (tagged-list? 'include-c-header expr)))
|
||||
input-program)))))
|
||||
))
|
||||
|
||||
;; Process library imports
|
||||
|
|
@ -251,6 +278,9 @@
|
|||
(trace:error "DEBUG, existing program")
|
||||
(exit 0))
|
||||
|
||||
(trace:info "---------------- C headers: ")
|
||||
(trace:info c-headers)
|
||||
|
||||
(trace:info "---------------- C code:")
|
||||
(mta:code-gen input-program
|
||||
program?
|
||||
|
|
@ -258,6 +288,7 @@
|
|||
lib-exports
|
||||
imported-vars
|
||||
module-globals
|
||||
c-headers
|
||||
lib-deps
|
||||
src-file)
|
||||
(return '())))) ;; No codes to return
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load diff
File diff suppressed because one or more lines are too long
|
|
@ -1,836 +0,0 @@
|
|||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; File: nboyer.sch
|
||||
; Description: The Boyer benchmark
|
||||
; Author: Bob Boyer
|
||||
; Created: 5-Apr-85
|
||||
; Modified: 10-Apr-85 14:52:20 (Bob Shaw)
|
||||
; 22-Jul-87 (Will Clinger)
|
||||
; 2-Jul-88 (Will Clinger -- distinguished #f and the empty list)
|
||||
; 13-Feb-97 (Will Clinger -- fixed bugs in unifier and rules,
|
||||
; rewrote to eliminate property lists, and added
|
||||
; a scaling parameter suggested by Bob Boyer)
|
||||
; 19-Mar-99 (Will Clinger -- cleaned up comments)
|
||||
; 24-Nov-07 (Will Clinger -- converted to R6RS)
|
||||
; Language: Scheme
|
||||
; Status: Public Domain
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;;; NBOYER -- Logic programming benchmark, originally written by Bob Boyer.
|
||||
;;; Fairly CONS intensive.
|
||||
|
||||
; Note: The version of this benchmark that appears in Dick Gabriel's book
|
||||
; contained several bugs that are corrected here. These bugs are discussed
|
||||
; by Henry Baker, "The Boyer Benchmark Meets Linear Logic", ACM SIGPLAN Lisp
|
||||
; Pointers 6(4), October-December 1993, pages 3-10. The fixed bugs are:
|
||||
;
|
||||
; The benchmark now returns a boolean result.
|
||||
; FALSEP and TRUEP use TERM-MEMBER? rather than MEMV (which is called MEMBER
|
||||
; in Common Lisp)
|
||||
; ONE-WAY-UNIFY1 now treats numbers correctly
|
||||
; ONE-WAY-UNIFY1-LST now treats empty lists correctly
|
||||
; Rule 19 has been corrected (this rule was not touched by the original
|
||||
; benchmark, but is used by this version)
|
||||
; Rules 84 and 101 have been corrected (but these rules are never touched
|
||||
; by the benchmark)
|
||||
;
|
||||
; According to Baker, these bug fixes make the benchmark 10-25% slower.
|
||||
; Please do not compare the timings from this benchmark against those of
|
||||
; the original benchmark.
|
||||
;
|
||||
; This version of the benchmark also prints the number of rewrites as a sanity
|
||||
; check, because it is too easy for a buggy version to return the correct
|
||||
; boolean result. The correct number of rewrites is
|
||||
;
|
||||
; n rewrites peak live storage (approximate, in bytes)
|
||||
; 0 95024 520,000
|
||||
; 1 591777 2,085,000
|
||||
; 2 1813975 5,175,000
|
||||
; 3 5375678
|
||||
; 4 16445406
|
||||
; 5 51507739
|
||||
|
||||
; Nboyer is a 2-phase benchmark.
|
||||
; The first phase attaches lemmas to symbols. This phase is not timed,
|
||||
; but it accounts for very little of the runtime anyway.
|
||||
; The second phase creates the test problem, and tests to see
|
||||
; whether it is implied by the lemmas.
|
||||
|
||||
(import (scheme base)
|
||||
(scheme cxr)
|
||||
(scheme read)
|
||||
(scheme write)
|
||||
(scheme time))
|
||||
|
||||
(define (main)
|
||||
(let* ((count (read))
|
||||
(input (read))
|
||||
(output (read))
|
||||
(s2 (number->string count))
|
||||
(s1 (number->string input))
|
||||
(name "nboyer"))
|
||||
(run-r7rs-benchmark
|
||||
(string-append name ":" s1 ":" s2)
|
||||
count
|
||||
(lambda ()
|
||||
(setup-boyer)
|
||||
(test-boyer alist term (hide count input)))
|
||||
(lambda (rewrites)
|
||||
(and (number? rewrites) (= rewrites output))))))
|
||||
|
||||
(define alist
|
||||
(quote ((x f (plus (plus a b)
|
||||
(plus c (zero))))
|
||||
(y f (times (times a b)
|
||||
(plus c d)))
|
||||
(z f (reverse (append (append a b)
|
||||
(nil))))
|
||||
(u equal (plus a b)
|
||||
(difference x y))
|
||||
(w lessp (remainder a b)
|
||||
(member a (length b))))))
|
||||
|
||||
(define term
|
||||
(quote (implies (and (implies x y)
|
||||
(and (implies y z)
|
||||
(and (implies z u)
|
||||
(implies u w))))
|
||||
(implies x w))))
|
||||
|
||||
(define (setup-boyer . args) #t) ; assigned below
|
||||
(define (test-boyer . args) #t) ; assigned below
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;
|
||||
; The first phase.
|
||||
;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
; In the original benchmark, it stored a list of lemmas on the
|
||||
; property lists of symbols.
|
||||
; In the new benchmark, it maintains an association list of
|
||||
; symbols and symbol-records, and stores the list of lemmas
|
||||
; within the symbol-records.
|
||||
|
||||
(let ()
|
||||
|
||||
(define (setup)
|
||||
(add-lemma-lst
|
||||
(quote ((equal (compile form)
|
||||
(reverse (codegen (optimize form)
|
||||
(nil))))
|
||||
(equal (eqp x y)
|
||||
(equal (fix x)
|
||||
(fix y)))
|
||||
(equal (greaterp x y)
|
||||
(lessp y x))
|
||||
(equal (lesseqp x y)
|
||||
(not (lessp y x)))
|
||||
(equal (greatereqp x y)
|
||||
(not (lessp x y)))
|
||||
(equal (boolean x)
|
||||
(or (equal x (t))
|
||||
(equal x (f))))
|
||||
(equal (iff x y)
|
||||
(and (implies x y)
|
||||
(implies y x)))
|
||||
(equal (even1 x)
|
||||
(if (zerop x)
|
||||
(t)
|
||||
(odd (_1- x))))
|
||||
(equal (countps- l pred)
|
||||
(countps-loop l pred (zero)))
|
||||
(equal (fact- i)
|
||||
(fact-loop i 1))
|
||||
(equal (reverse- x)
|
||||
(reverse-loop x (nil)))
|
||||
(equal (divides x y)
|
||||
(zerop (remainder y x)))
|
||||
(equal (assume-true var alist)
|
||||
(cons (cons var (t))
|
||||
alist))
|
||||
(equal (assume-false var alist)
|
||||
(cons (cons var (f))
|
||||
alist))
|
||||
(equal (tautology-checker x)
|
||||
(tautologyp (normalize x)
|
||||
(nil)))
|
||||
(equal (falsify x)
|
||||
(falsify1 (normalize x)
|
||||
(nil)))
|
||||
(equal (prime x)
|
||||
(and (not (zerop x))
|
||||
(not (equal x (add1 (zero))))
|
||||
(prime1 x (_1- x))))
|
||||
(equal (and p q)
|
||||
(if p (if q (t)
|
||||
(f))
|
||||
(f)))
|
||||
(equal (or p q)
|
||||
(if p (t)
|
||||
(if q (t)
|
||||
(f))))
|
||||
(equal (not p)
|
||||
(if p (f)
|
||||
(t)))
|
||||
(equal (implies p q)
|
||||
(if p (if q (t)
|
||||
(f))
|
||||
(t)))
|
||||
(equal (fix x)
|
||||
(if (numberp x)
|
||||
x
|
||||
(zero)))
|
||||
(equal (if (if a b c)
|
||||
d e)
|
||||
(if a (if b d e)
|
||||
(if c d e)))
|
||||
(equal (zerop x)
|
||||
(or (equal x (zero))
|
||||
(not (numberp x))))
|
||||
(equal (plus (plus x y)
|
||||
z)
|
||||
(plus x (plus y z)))
|
||||
(equal (equal (plus a b)
|
||||
(zero))
|
||||
(and (zerop a)
|
||||
(zerop b)))
|
||||
(equal (difference x x)
|
||||
(zero))
|
||||
(equal (equal (plus a b)
|
||||
(plus a c))
|
||||
(equal (fix b)
|
||||
(fix c)))
|
||||
(equal (equal (zero)
|
||||
(difference x y))
|
||||
(not (lessp y x)))
|
||||
(equal (equal x (difference x y))
|
||||
(and (numberp x)
|
||||
(or (equal x (zero))
|
||||
(zerop y))))
|
||||
(equal (meaning (plus-tree (append x y))
|
||||
a)
|
||||
(plus (meaning (plus-tree x)
|
||||
a)
|
||||
(meaning (plus-tree y)
|
||||
a)))
|
||||
(equal (meaning (plus-tree (plus-fringe x))
|
||||
a)
|
||||
(fix (meaning x a)))
|
||||
(equal (append (append x y)
|
||||
z)
|
||||
(append x (append y z)))
|
||||
(equal (reverse (append a b))
|
||||
(append (reverse b)
|
||||
(reverse a)))
|
||||
(equal (times x (plus y z))
|
||||
(plus (times x y)
|
||||
(times x z)))
|
||||
(equal (times (times x y)
|
||||
z)
|
||||
(times x (times y z)))
|
||||
(equal (equal (times x y)
|
||||
(zero))
|
||||
(or (zerop x)
|
||||
(zerop y)))
|
||||
(equal (exec (append x y)
|
||||
pds envrn)
|
||||
(exec y (exec x pds envrn)
|
||||
envrn))
|
||||
(equal (mc-flatten x y)
|
||||
(append (flatten x)
|
||||
y))
|
||||
(equal (member x (append a b))
|
||||
(or (member x a)
|
||||
(member x b)))
|
||||
(equal (member x (reverse y))
|
||||
(member x y))
|
||||
(equal (length (reverse x))
|
||||
(length x))
|
||||
(equal (member a (intersect b c))
|
||||
(and (member a b)
|
||||
(member a c)))
|
||||
(equal (nth (zero)
|
||||
i)
|
||||
(zero))
|
||||
(equal (exp i (plus j k))
|
||||
(times (exp i j)
|
||||
(exp i k)))
|
||||
(equal (exp i (times j k))
|
||||
(exp (exp i j)
|
||||
k))
|
||||
(equal (reverse-loop x y)
|
||||
(append (reverse x)
|
||||
y))
|
||||
(equal (reverse-loop x (nil))
|
||||
(reverse x))
|
||||
(equal (count-list z (sort-lp x y))
|
||||
(plus (count-list z x)
|
||||
(count-list z y)))
|
||||
(equal (equal (append a b)
|
||||
(append a c))
|
||||
(equal b c))
|
||||
(equal (plus (remainder x y)
|
||||
(times y (quotient x y)))
|
||||
(fix x))
|
||||
(equal (power-eval (big-plus1 l i base)
|
||||
base)
|
||||
(plus (power-eval l base)
|
||||
i))
|
||||
(equal (power-eval (big-plus x y i base)
|
||||
base)
|
||||
(plus i (plus (power-eval x base)
|
||||
(power-eval y base))))
|
||||
(equal (remainder y 1)
|
||||
(zero))
|
||||
(equal (lessp (remainder x y)
|
||||
y)
|
||||
(not (zerop y)))
|
||||
(equal (remainder x x)
|
||||
(zero))
|
||||
(equal (lessp (quotient i j)
|
||||
i)
|
||||
(and (not (zerop i))
|
||||
(or (zerop j)
|
||||
(not (equal j 1)))))
|
||||
(equal (lessp (remainder x y)
|
||||
x)
|
||||
(and (not (zerop y))
|
||||
(not (zerop x))
|
||||
(not (lessp x y))))
|
||||
(equal (power-eval (power-rep i base)
|
||||
base)
|
||||
(fix i))
|
||||
(equal (power-eval (big-plus (power-rep i base)
|
||||
(power-rep j base)
|
||||
(zero)
|
||||
base)
|
||||
base)
|
||||
(plus i j))
|
||||
(equal (gcd x y)
|
||||
(gcd y x))
|
||||
(equal (nth (append a b)
|
||||
i)
|
||||
(append (nth a i)
|
||||
(nth b (difference i (length a)))))
|
||||
(equal (difference (plus x y)
|
||||
x)
|
||||
(fix y))
|
||||
(equal (difference (plus y x)
|
||||
x)
|
||||
(fix y))
|
||||
(equal (difference (plus x y)
|
||||
(plus x z))
|
||||
(difference y z))
|
||||
(equal (times x (difference c w))
|
||||
(difference (times c x)
|
||||
(times w x)))
|
||||
(equal (remainder (times x z)
|
||||
z)
|
||||
(zero))
|
||||
(equal (difference (plus b (plus a c))
|
||||
a)
|
||||
(plus b c))
|
||||
(equal (difference (add1 (plus y z))
|
||||
z)
|
||||
(add1 y))
|
||||
(equal (lessp (plus x y)
|
||||
(plus x z))
|
||||
(lessp y z))
|
||||
(equal (lessp (times x z)
|
||||
(times y z))
|
||||
(and (not (zerop z))
|
||||
(lessp x y)))
|
||||
(equal (lessp y (plus x y))
|
||||
(not (zerop x)))
|
||||
(equal (gcd (times x z)
|
||||
(times y z))
|
||||
(times z (gcd x y)))
|
||||
(equal (value (normalize x)
|
||||
a)
|
||||
(value x a))
|
||||
(equal (equal (flatten x)
|
||||
(cons y (nil)))
|
||||
(and (nlistp x)
|
||||
(equal x y)))
|
||||
(equal (listp (gopher x))
|
||||
(listp x))
|
||||
(equal (samefringe x y)
|
||||
(equal (flatten x)
|
||||
(flatten y)))
|
||||
(equal (equal (greatest-factor x y)
|
||||
(zero))
|
||||
(and (or (zerop y)
|
||||
(equal y 1))
|
||||
(equal x (zero))))
|
||||
(equal (equal (greatest-factor x y)
|
||||
1)
|
||||
(equal x 1))
|
||||
(equal (numberp (greatest-factor x y))
|
||||
(not (and (or (zerop y)
|
||||
(equal y 1))
|
||||
(not (numberp x)))))
|
||||
(equal (times-list (append x y))
|
||||
(times (times-list x)
|
||||
(times-list y)))
|
||||
(equal (prime-list (append x y))
|
||||
(and (prime-list x)
|
||||
(prime-list y)))
|
||||
(equal (equal z (times w z))
|
||||
(and (numberp z)
|
||||
(or (equal z (zero))
|
||||
(equal w 1))))
|
||||
(equal (greatereqp x y)
|
||||
(not (lessp x y)))
|
||||
(equal (equal x (times x y))
|
||||
(or (equal x (zero))
|
||||
(and (numberp x)
|
||||
(equal y 1))))
|
||||
(equal (remainder (times y x)
|
||||
y)
|
||||
(zero))
|
||||
(equal (equal (times a b)
|
||||
1)
|
||||
(and (not (equal a (zero)))
|
||||
(not (equal b (zero)))
|
||||
(numberp a)
|
||||
(numberp b)
|
||||
(equal (_1- a)
|
||||
(zero))
|
||||
(equal (_1- b)
|
||||
(zero))))
|
||||
(equal (lessp (length (delete x l))
|
||||
(length l))
|
||||
(member x l))
|
||||
(equal (sort2 (delete x l))
|
||||
(delete x (sort2 l)))
|
||||
(equal (dsort x)
|
||||
(sort2 x))
|
||||
(equal (length (cons x1
|
||||
(cons x2
|
||||
(cons x3 (cons x4
|
||||
(cons x5
|
||||
(cons x6 x7)))))))
|
||||
(plus 6 (length x7)))
|
||||
(equal (difference (add1 (add1 x))
|
||||
2)
|
||||
(fix x))
|
||||
(equal (quotient (plus x (plus x y))
|
||||
2)
|
||||
(plus x (quotient y 2)))
|
||||
(equal (sigma (zero)
|
||||
i)
|
||||
(quotient (times i (add1 i))
|
||||
2))
|
||||
(equal (plus x (add1 y))
|
||||
(if (numberp y)
|
||||
(add1 (plus x y))
|
||||
(add1 x)))
|
||||
(equal (equal (difference x y)
|
||||
(difference z y))
|
||||
(if (lessp x y)
|
||||
(not (lessp y z))
|
||||
(if (lessp z y)
|
||||
(not (lessp y x))
|
||||
(equal (fix x)
|
||||
(fix z)))))
|
||||
(equal (meaning (plus-tree (delete x y))
|
||||
a)
|
||||
(if (member x y)
|
||||
(difference (meaning (plus-tree y)
|
||||
a)
|
||||
(meaning x a))
|
||||
(meaning (plus-tree y)
|
||||
a)))
|
||||
(equal (times x (add1 y))
|
||||
(if (numberp y)
|
||||
(plus x (times x y))
|
||||
(fix x)))
|
||||
(equal (nth (nil)
|
||||
i)
|
||||
(if (zerop i)
|
||||
(nil)
|
||||
(zero)))
|
||||
(equal (last (append a b))
|
||||
(if (listp b)
|
||||
(last b)
|
||||
(if (listp a)
|
||||
(cons (car (last a))
|
||||
b)
|
||||
b)))
|
||||
(equal (equal (lessp x y)
|
||||
z)
|
||||
(if (lessp x y)
|
||||
(equal (t) z)
|
||||
(equal (f) z)))
|
||||
(equal (assignment x (append a b))
|
||||
(if (assignedp x a)
|
||||
(assignment x a)
|
||||
(assignment x b)))
|
||||
(equal (car (gopher x))
|
||||
(if (listp x)
|
||||
(car (flatten x))
|
||||
(zero)))
|
||||
(equal (flatten (cdr (gopher x)))
|
||||
(if (listp x)
|
||||
(cdr (flatten x))
|
||||
(cons (zero)
|
||||
(nil))))
|
||||
(equal (quotient (times y x)
|
||||
y)
|
||||
(if (zerop y)
|
||||
(zero)
|
||||
(fix x)))
|
||||
(equal (get j (set i val mem))
|
||||
(if (eqp j i)
|
||||
val
|
||||
(get j mem)))))))
|
||||
|
||||
(define (add-lemma-lst lst)
|
||||
(cond ((null? lst)
|
||||
#t)
|
||||
(else (add-lemma (car lst))
|
||||
(add-lemma-lst (cdr lst)))))
|
||||
|
||||
(define (add-lemma term)
|
||||
(cond ((and (pair? term)
|
||||
(eq? (car term)
|
||||
(quote equal))
|
||||
(pair? (cadr term)))
|
||||
(put (car (cadr term))
|
||||
(quote lemmas)
|
||||
(cons
|
||||
(translate-term term)
|
||||
(get (car (cadr term)) (quote lemmas)))))
|
||||
(else (error #f "ADD-LEMMA did not like term: " term))))
|
||||
|
||||
; Translates a term by replacing its constructor symbols by symbol-records.
|
||||
|
||||
(define (translate-term term)
|
||||
(cond ((not (pair? term))
|
||||
term)
|
||||
(else (cons (symbol->symbol-record (car term))
|
||||
(translate-args (cdr term))))))
|
||||
|
||||
(define (translate-args lst)
|
||||
(cond ((null? lst)
|
||||
'())
|
||||
(else (cons (translate-term (car lst))
|
||||
(translate-args (cdr lst))))))
|
||||
|
||||
; For debugging only, so the use of MAP does not change
|
||||
; the first-order character of the benchmark.
|
||||
|
||||
(define (untranslate-term term)
|
||||
(cond ((not (pair? term))
|
||||
term)
|
||||
(else (cons (get-name (car term))
|
||||
(map untranslate-term (cdr term))))))
|
||||
|
||||
; A symbol-record is represented as a vector with two fields:
|
||||
; the symbol (for debugging) and
|
||||
; the list of lemmas associated with the symbol.
|
||||
|
||||
(define (put sym property value)
|
||||
(put-lemmas! (symbol->symbol-record sym) value))
|
||||
|
||||
(define (get sym property)
|
||||
(get-lemmas (symbol->symbol-record sym)))
|
||||
|
||||
(define (symbol->symbol-record sym)
|
||||
(let ((x (assq sym *symbol-records-alist*)))
|
||||
(if x
|
||||
(cdr x)
|
||||
(let ((r (make-symbol-record sym)))
|
||||
(set! *symbol-records-alist*
|
||||
(cons (cons sym r)
|
||||
*symbol-records-alist*))
|
||||
r))))
|
||||
|
||||
; Association list of symbols and symbol-records.
|
||||
|
||||
(define *symbol-records-alist* '())
|
||||
|
||||
; A symbol-record is represented as a vector with two fields:
|
||||
; the symbol (for debugging) and
|
||||
; the list of lemmas associated with the symbol.
|
||||
|
||||
(define (make-symbol-record sym)
|
||||
(vector sym '()))
|
||||
|
||||
(define (put-lemmas! symbol-record lemmas)
|
||||
(vector-set! symbol-record 1 lemmas))
|
||||
|
||||
(define (get-lemmas symbol-record)
|
||||
(vector-ref symbol-record 1))
|
||||
|
||||
(define (get-name symbol-record)
|
||||
(vector-ref symbol-record 0))
|
||||
|
||||
(define (symbol-record-equal? r1 r2)
|
||||
(eq? r1 r2))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;
|
||||
; The second phase.
|
||||
;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (test alist term n)
|
||||
(let ((term
|
||||
(apply-subst
|
||||
(translate-alist alist)
|
||||
(translate-term
|
||||
(do ((term term (list 'or term '(f)))
|
||||
(n n (- n 1)))
|
||||
((zero? n) term))))))
|
||||
(tautp term)))
|
||||
|
||||
(define (translate-alist alist)
|
||||
(cond ((null? alist)
|
||||
'())
|
||||
(else (cons (cons (caar alist)
|
||||
(translate-term (cdar alist)))
|
||||
(translate-alist (cdr alist))))))
|
||||
|
||||
(define (apply-subst alist term)
|
||||
(cond ((not (pair? term))
|
||||
(let ((temp-temp (assq term alist)))
|
||||
(if temp-temp
|
||||
(cdr temp-temp)
|
||||
term)))
|
||||
(else (cons (car term)
|
||||
(apply-subst-lst alist (cdr term))))))
|
||||
|
||||
(define (apply-subst-lst alist lst)
|
||||
(cond ((null? lst)
|
||||
'())
|
||||
(else (cons (apply-subst alist (car lst))
|
||||
(apply-subst-lst alist (cdr lst))))))
|
||||
|
||||
(define (tautp x)
|
||||
(tautologyp (rewrite x)
|
||||
'() '()))
|
||||
|
||||
(define (tautologyp x true-lst false-lst)
|
||||
(cond ((truep x true-lst)
|
||||
#t)
|
||||
((falsep x false-lst)
|
||||
#f)
|
||||
((not (pair? x))
|
||||
#f)
|
||||
((eq? (car x) if-constructor)
|
||||
(cond ((truep (cadr x)
|
||||
true-lst)
|
||||
(tautologyp (caddr x)
|
||||
true-lst false-lst))
|
||||
((falsep (cadr x)
|
||||
false-lst)
|
||||
(tautologyp (cadddr x)
|
||||
true-lst false-lst))
|
||||
(else (and (tautologyp (caddr x)
|
||||
(cons (cadr x)
|
||||
true-lst)
|
||||
false-lst)
|
||||
(tautologyp (cadddr x)
|
||||
true-lst
|
||||
(cons (cadr x)
|
||||
false-lst))))))
|
||||
(else #f)))
|
||||
|
||||
(define if-constructor '*) ; becomes (symbol->symbol-record 'if)
|
||||
|
||||
(define rewrite-count 0) ; sanity check
|
||||
|
||||
(define (rewrite term)
|
||||
(set! rewrite-count (+ rewrite-count 1))
|
||||
(cond ((not (pair? term))
|
||||
term)
|
||||
(else (rewrite-with-lemmas (cons (car term)
|
||||
(rewrite-args (cdr term)))
|
||||
(get-lemmas (car term))))))
|
||||
|
||||
(define (rewrite-args lst)
|
||||
(cond ((null? lst)
|
||||
'())
|
||||
(else (cons (rewrite (car lst))
|
||||
(rewrite-args (cdr lst))))))
|
||||
|
||||
(define (rewrite-with-lemmas term lst)
|
||||
(cond ((null? lst)
|
||||
term)
|
||||
((one-way-unify term (cadr (car lst)))
|
||||
(rewrite (apply-subst unify-subst (caddr (car lst)))))
|
||||
(else (rewrite-with-lemmas term (cdr lst)))))
|
||||
|
||||
(define unify-subst '*)
|
||||
|
||||
(define (one-way-unify term1 term2)
|
||||
(begin (set! unify-subst '())
|
||||
(one-way-unify1 term1 term2)))
|
||||
|
||||
(define (one-way-unify1 term1 term2)
|
||||
(cond ((not (pair? term2))
|
||||
(let ((temp-temp (assq term2 unify-subst)))
|
||||
(cond (temp-temp
|
||||
(term-equal? term1 (cdr temp-temp)))
|
||||
((number? term2) ; This bug fix makes
|
||||
(equal? term1 term2)) ; nboyer 10-25% slower!
|
||||
(else
|
||||
(set! unify-subst (cons (cons term2 term1)
|
||||
unify-subst))
|
||||
#t))))
|
||||
((not (pair? term1))
|
||||
#f)
|
||||
((eq? (car term1)
|
||||
(car term2))
|
||||
(one-way-unify1-lst (cdr term1)
|
||||
(cdr term2)))
|
||||
(else #f)))
|
||||
|
||||
(define (one-way-unify1-lst lst1 lst2)
|
||||
(cond ((null? lst1)
|
||||
(null? lst2))
|
||||
((null? lst2)
|
||||
#f)
|
||||
((one-way-unify1 (car lst1)
|
||||
(car lst2))
|
||||
(one-way-unify1-lst (cdr lst1)
|
||||
(cdr lst2)))
|
||||
(else #f)))
|
||||
|
||||
(define (falsep x lst)
|
||||
(or (term-equal? x false-term)
|
||||
(term-member? x lst)))
|
||||
|
||||
(define (truep x lst)
|
||||
(or (term-equal? x true-term)
|
||||
(term-member? x lst)))
|
||||
|
||||
(define false-term '*) ; becomes (translate-term '(f))
|
||||
(define true-term '*) ; becomes (translate-term '(t))
|
||||
|
||||
; The next two procedures were in the original benchmark
|
||||
; but were never used.
|
||||
|
||||
(define (trans-of-implies n)
|
||||
(translate-term
|
||||
(list (quote implies)
|
||||
(trans-of-implies1 n)
|
||||
(list (quote implies)
|
||||
0 n))))
|
||||
|
||||
(define (trans-of-implies1 n)
|
||||
(cond ((equal? n 1)
|
||||
(list (quote implies)
|
||||
0 1))
|
||||
(else (list (quote and)
|
||||
(list (quote implies)
|
||||
(- n 1)
|
||||
n)
|
||||
(trans-of-implies1 (- n 1))))))
|
||||
|
||||
; Translated terms can be circular structures, which can't be
|
||||
; compared using Scheme's equal? and member procedures, so we
|
||||
; use these instead.
|
||||
|
||||
(define (term-equal? x y)
|
||||
(cond ((pair? x)
|
||||
(and (pair? y)
|
||||
(symbol-record-equal? (car x) (car y))
|
||||
(term-args-equal? (cdr x) (cdr y))))
|
||||
(else (equal? x y))))
|
||||
|
||||
(define (term-args-equal? lst1 lst2)
|
||||
(cond ((null? lst1)
|
||||
(null? lst2))
|
||||
((null? lst2)
|
||||
#f)
|
||||
((term-equal? (car lst1) (car lst2))
|
||||
(term-args-equal? (cdr lst1) (cdr lst2)))
|
||||
(else #f)))
|
||||
|
||||
(define (term-member? x lst)
|
||||
(cond ((null? lst)
|
||||
#f)
|
||||
((term-equal? x (car lst))
|
||||
#t)
|
||||
(else (term-member? x (cdr lst)))))
|
||||
|
||||
(set! setup-boyer
|
||||
(lambda ()
|
||||
(set! *symbol-records-alist* '())
|
||||
(set! if-constructor (symbol->symbol-record 'if))
|
||||
(set! false-term (translate-term '(f)))
|
||||
(set! true-term (translate-term '(t)))
|
||||
(setup)))
|
||||
|
||||
(set! test-boyer
|
||||
(lambda (alist term n)
|
||||
(set! rewrite-count 0)
|
||||
(let ((answer (test alist term n)))
|
||||
; (write rewrite-count)
|
||||
; (display " rewrites")
|
||||
; (newline)
|
||||
(if answer
|
||||
rewrite-count
|
||||
#f)))))
|
||||
|
||||
;;; The following code is appended to all benchmarks.
|
||||
|
||||
;;; Given an integer and an object, returns the object
|
||||
;;; without making it too easy for compilers to tell
|
||||
;;; the object will be returned.
|
||||
|
||||
(define (hide r x)
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(values (vector values (lambda (x) x))
|
||||
(if (< r 100) 0 1)))
|
||||
(lambda (v i)
|
||||
((vector-ref v i) x))))
|
||||
|
||||
;;; Given the name of a benchmark,
|
||||
;;; the number of times it should be executed,
|
||||
;;; a thunk that runs the benchmark once,
|
||||
;;; and a unary predicate that is true of the
|
||||
;;; correct results the thunk may return,
|
||||
;;; runs the benchmark for the number of specified iterations.
|
||||
|
||||
(define (run-r7rs-benchmark name count thunk ok?)
|
||||
|
||||
;; Rounds to thousandths.
|
||||
(define (rounded x)
|
||||
(/ (round (* 1000 x)) 1000))
|
||||
|
||||
(display "Running ")
|
||||
(display name)
|
||||
(newline)
|
||||
(flush-output-port)
|
||||
(let* ((j/s (jiffies-per-second))
|
||||
(t0 (current-second))
|
||||
(j0 (current-jiffy)))
|
||||
(let loop ((i 0)
|
||||
(result (if #f #f)))
|
||||
(cond ((< i count)
|
||||
(loop (+ i 1) (thunk)))
|
||||
((ok? result)
|
||||
(let* ((j1 (current-jiffy))
|
||||
(t1 (current-second))
|
||||
(jifs (- j1 j0))
|
||||
(secs (inexact (/ jifs j/s)))
|
||||
(secs2 (rounded (- t1 t0))))
|
||||
(display "Elapsed time: ")
|
||||
(write secs)
|
||||
(display " seconds (")
|
||||
(write secs2)
|
||||
(display ") for ")
|
||||
(display name)
|
||||
(newline))
|
||||
result)
|
||||
(else
|
||||
(display "ERROR: returned incorrect result: ")
|
||||
(write result)
|
||||
(newline)
|
||||
result)))))
|
||||
|
||||
(main)
|
||||
File diff suppressed because it is too large
Load diff
File diff suppressed because one or more lines are too long
|
|
@ -1,849 +0,0 @@
|
|||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; File: sboyer.sch
|
||||
; Description: The Boyer benchmark
|
||||
; Author: Bob Boyer
|
||||
; Created: 5-Apr-85
|
||||
; Modified: 10-Apr-85 14:52:20 (Bob Shaw)
|
||||
; 22-Jul-87 (Will Clinger)
|
||||
; 2-Jul-88 (Will Clinger -- distinguished #f and the empty list)
|
||||
; 13-Feb-97 (Will Clinger -- fixed bugs in unifier and rules,
|
||||
; rewrote to eliminate property lists, and added
|
||||
; a scaling parameter suggested by Bob Boyer)
|
||||
; 19-Mar-99 (Will Clinger -- cleaned up comments)
|
||||
; Language: Scheme
|
||||
; Status: Public Domain
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;;; SBOYER -- Logic programming benchmark, originally written by Bob Boyer.
|
||||
;;; Much less CONS-intensive than NBOYER because it uses Henry Baker's
|
||||
;;; "sharing cons".
|
||||
|
||||
; Note: The version of this benchmark that appears in Dick Gabriel's book
|
||||
; contained several bugs that are corrected here. These bugs are discussed
|
||||
; by Henry Baker, "The Boyer Benchmark Meets Linear Logic", ACM SIGPLAN Lisp
|
||||
; Pointers 6(4), October-December 1993, pages 3-10. The fixed bugs are:
|
||||
;
|
||||
; The benchmark now returns a boolean result.
|
||||
; FALSEP and TRUEP use TERM-MEMBER? rather than MEMV (which is called MEMBER
|
||||
; in Common Lisp)
|
||||
; ONE-WAY-UNIFY1 now treats numbers correctly
|
||||
; ONE-WAY-UNIFY1-LST now treats empty lists correctly
|
||||
; Rule 19 has been corrected (this rule was not touched by the original
|
||||
; benchmark, but is used by this version)
|
||||
; Rules 84 and 101 have been corrected (but these rules are never touched
|
||||
; by the benchmark)
|
||||
;
|
||||
; According to Baker, these bug fixes make the benchmark 10-25% slower.
|
||||
; Please do not compare the timings from this benchmark against those of
|
||||
; the original benchmark.
|
||||
;
|
||||
; This version of the benchmark also prints the number of rewrites as a sanity
|
||||
; check, because it is too easy for a buggy version to return the correct
|
||||
; boolean result. The correct number of rewrites is
|
||||
;
|
||||
; n rewrites peak live storage (approximate, in bytes)
|
||||
; 0 95024
|
||||
; 1 591777
|
||||
; 2 1813975
|
||||
; 3 5375678
|
||||
; 4 16445406
|
||||
; 5 51507739
|
||||
|
||||
; Sboyer is a 2-phase benchmark.
|
||||
; The first phase attaches lemmas to symbols. This phase is not timed,
|
||||
; but it accounts for very little of the runtime anyway.
|
||||
; The second phase creates the test problem, and tests to see
|
||||
; whether it is implied by the lemmas.
|
||||
|
||||
(import (scheme base)
|
||||
(scheme cxr)
|
||||
(scheme read)
|
||||
(scheme write)
|
||||
(scheme time))
|
||||
|
||||
(define (main)
|
||||
(let* ((count (read))
|
||||
(input (read))
|
||||
(output (read))
|
||||
(s2 (number->string count))
|
||||
(s1 (number->string input))
|
||||
(name "sboyer"))
|
||||
(run-r7rs-benchmark
|
||||
(string-append name ":" s1 ":" s2)
|
||||
count
|
||||
(lambda ()
|
||||
(setup-boyer)
|
||||
(test-boyer alist term (hide count input)))
|
||||
(lambda (rewrites)
|
||||
(and (number? rewrites) (= rewrites output))))))
|
||||
|
||||
(define alist
|
||||
(quote ((x f (plus (plus a b)
|
||||
(plus c (zero))))
|
||||
(y f (times (times a b)
|
||||
(plus c d)))
|
||||
(z f (reverse (append (append a b)
|
||||
(nil))))
|
||||
(u equal (plus a b)
|
||||
(difference x y))
|
||||
(w lessp (remainder a b)
|
||||
(member a (length b))))))
|
||||
|
||||
(define term
|
||||
(quote (implies (and (implies x y)
|
||||
(and (implies y z)
|
||||
(and (implies z u)
|
||||
(implies u w))))
|
||||
(implies x w))))
|
||||
|
||||
(define (setup-boyer) #t) ; assigned below
|
||||
(define (test-boyer) #t) ; assigned below
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;
|
||||
; The first phase.
|
||||
;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
; In the original benchmark, it stored a list of lemmas on the
|
||||
; property lists of symbols.
|
||||
; In the new benchmark, it maintains an association list of
|
||||
; symbols and symbol-records, and stores the list of lemmas
|
||||
; within the symbol-records.
|
||||
|
||||
(let ()
|
||||
|
||||
(define (setup)
|
||||
(add-lemma-lst
|
||||
(quote ((equal (compile form)
|
||||
(reverse (codegen (optimize form)
|
||||
(nil))))
|
||||
(equal (eqp x y)
|
||||
(equal (fix x)
|
||||
(fix y)))
|
||||
(equal (greaterp x y)
|
||||
(lessp y x))
|
||||
(equal (lesseqp x y)
|
||||
(not (lessp y x)))
|
||||
(equal (greatereqp x y)
|
||||
(not (lessp x y)))
|
||||
(equal (boolean x)
|
||||
(or (equal x (t))
|
||||
(equal x (f))))
|
||||
(equal (iff x y)
|
||||
(and (implies x y)
|
||||
(implies y x)))
|
||||
(equal (even1 x)
|
||||
(if (zerop x)
|
||||
(t)
|
||||
(odd (_1- x))))
|
||||
(equal (countps- l pred)
|
||||
(countps-loop l pred (zero)))
|
||||
(equal (fact- i)
|
||||
(fact-loop i 1))
|
||||
(equal (reverse- x)
|
||||
(reverse-loop x (nil)))
|
||||
(equal (divides x y)
|
||||
(zerop (remainder y x)))
|
||||
(equal (assume-true var alist)
|
||||
(cons (cons var (t))
|
||||
alist))
|
||||
(equal (assume-false var alist)
|
||||
(cons (cons var (f))
|
||||
alist))
|
||||
(equal (tautology-checker x)
|
||||
(tautologyp (normalize x)
|
||||
(nil)))
|
||||
(equal (falsify x)
|
||||
(falsify1 (normalize x)
|
||||
(nil)))
|
||||
(equal (prime x)
|
||||
(and (not (zerop x))
|
||||
(not (equal x (add1 (zero))))
|
||||
(prime1 x (_1- x))))
|
||||
(equal (and p q)
|
||||
(if p (if q (t)
|
||||
(f))
|
||||
(f)))
|
||||
(equal (or p q)
|
||||
(if p (t)
|
||||
(if q (t)
|
||||
(f))))
|
||||
(equal (not p)
|
||||
(if p (f)
|
||||
(t)))
|
||||
(equal (implies p q)
|
||||
(if p (if q (t)
|
||||
(f))
|
||||
(t)))
|
||||
(equal (fix x)
|
||||
(if (numberp x)
|
||||
x
|
||||
(zero)))
|
||||
(equal (if (if a b c)
|
||||
d e)
|
||||
(if a (if b d e)
|
||||
(if c d e)))
|
||||
(equal (zerop x)
|
||||
(or (equal x (zero))
|
||||
(not (numberp x))))
|
||||
(equal (plus (plus x y)
|
||||
z)
|
||||
(plus x (plus y z)))
|
||||
(equal (equal (plus a b)
|
||||
(zero))
|
||||
(and (zerop a)
|
||||
(zerop b)))
|
||||
(equal (difference x x)
|
||||
(zero))
|
||||
(equal (equal (plus a b)
|
||||
(plus a c))
|
||||
(equal (fix b)
|
||||
(fix c)))
|
||||
(equal (equal (zero)
|
||||
(difference x y))
|
||||
(not (lessp y x)))
|
||||
(equal (equal x (difference x y))
|
||||
(and (numberp x)
|
||||
(or (equal x (zero))
|
||||
(zerop y))))
|
||||
(equal (meaning (plus-tree (append x y))
|
||||
a)
|
||||
(plus (meaning (plus-tree x)
|
||||
a)
|
||||
(meaning (plus-tree y)
|
||||
a)))
|
||||
(equal (meaning (plus-tree (plus-fringe x))
|
||||
a)
|
||||
(fix (meaning x a)))
|
||||
(equal (append (append x y)
|
||||
z)
|
||||
(append x (append y z)))
|
||||
(equal (reverse (append a b))
|
||||
(append (reverse b)
|
||||
(reverse a)))
|
||||
(equal (times x (plus y z))
|
||||
(plus (times x y)
|
||||
(times x z)))
|
||||
(equal (times (times x y)
|
||||
z)
|
||||
(times x (times y z)))
|
||||
(equal (equal (times x y)
|
||||
(zero))
|
||||
(or (zerop x)
|
||||
(zerop y)))
|
||||
(equal (exec (append x y)
|
||||
pds envrn)
|
||||
(exec y (exec x pds envrn)
|
||||
envrn))
|
||||
(equal (mc-flatten x y)
|
||||
(append (flatten x)
|
||||
y))
|
||||
(equal (member x (append a b))
|
||||
(or (member x a)
|
||||
(member x b)))
|
||||
(equal (member x (reverse y))
|
||||
(member x y))
|
||||
(equal (length (reverse x))
|
||||
(length x))
|
||||
(equal (member a (intersect b c))
|
||||
(and (member a b)
|
||||
(member a c)))
|
||||
(equal (nth (zero)
|
||||
i)
|
||||
(zero))
|
||||
(equal (exp i (plus j k))
|
||||
(times (exp i j)
|
||||
(exp i k)))
|
||||
(equal (exp i (times j k))
|
||||
(exp (exp i j)
|
||||
k))
|
||||
(equal (reverse-loop x y)
|
||||
(append (reverse x)
|
||||
y))
|
||||
(equal (reverse-loop x (nil))
|
||||
(reverse x))
|
||||
(equal (count-list z (sort-lp x y))
|
||||
(plus (count-list z x)
|
||||
(count-list z y)))
|
||||
(equal (equal (append a b)
|
||||
(append a c))
|
||||
(equal b c))
|
||||
(equal (plus (remainder x y)
|
||||
(times y (quotient x y)))
|
||||
(fix x))
|
||||
(equal (power-eval (big-plus1 l i base)
|
||||
base)
|
||||
(plus (power-eval l base)
|
||||
i))
|
||||
(equal (power-eval (big-plus x y i base)
|
||||
base)
|
||||
(plus i (plus (power-eval x base)
|
||||
(power-eval y base))))
|
||||
(equal (remainder y 1)
|
||||
(zero))
|
||||
(equal (lessp (remainder x y)
|
||||
y)
|
||||
(not (zerop y)))
|
||||
(equal (remainder x x)
|
||||
(zero))
|
||||
(equal (lessp (quotient i j)
|
||||
i)
|
||||
(and (not (zerop i))
|
||||
(or (zerop j)
|
||||
(not (equal j 1)))))
|
||||
(equal (lessp (remainder x y)
|
||||
x)
|
||||
(and (not (zerop y))
|
||||
(not (zerop x))
|
||||
(not (lessp x y))))
|
||||
(equal (power-eval (power-rep i base)
|
||||
base)
|
||||
(fix i))
|
||||
(equal (power-eval (big-plus (power-rep i base)
|
||||
(power-rep j base)
|
||||
(zero)
|
||||
base)
|
||||
base)
|
||||
(plus i j))
|
||||
(equal (gcd x y)
|
||||
(gcd y x))
|
||||
(equal (nth (append a b)
|
||||
i)
|
||||
(append (nth a i)
|
||||
(nth b (difference i (length a)))))
|
||||
(equal (difference (plus x y)
|
||||
x)
|
||||
(fix y))
|
||||
(equal (difference (plus y x)
|
||||
x)
|
||||
(fix y))
|
||||
(equal (difference (plus x y)
|
||||
(plus x z))
|
||||
(difference y z))
|
||||
(equal (times x (difference c w))
|
||||
(difference (times c x)
|
||||
(times w x)))
|
||||
(equal (remainder (times x z)
|
||||
z)
|
||||
(zero))
|
||||
(equal (difference (plus b (plus a c))
|
||||
a)
|
||||
(plus b c))
|
||||
(equal (difference (add1 (plus y z))
|
||||
z)
|
||||
(add1 y))
|
||||
(equal (lessp (plus x y)
|
||||
(plus x z))
|
||||
(lessp y z))
|
||||
(equal (lessp (times x z)
|
||||
(times y z))
|
||||
(and (not (zerop z))
|
||||
(lessp x y)))
|
||||
(equal (lessp y (plus x y))
|
||||
(not (zerop x)))
|
||||
(equal (gcd (times x z)
|
||||
(times y z))
|
||||
(times z (gcd x y)))
|
||||
(equal (value (normalize x)
|
||||
a)
|
||||
(value x a))
|
||||
(equal (equal (flatten x)
|
||||
(cons y (nil)))
|
||||
(and (nlistp x)
|
||||
(equal x y)))
|
||||
(equal (listp (gopher x))
|
||||
(listp x))
|
||||
(equal (samefringe x y)
|
||||
(equal (flatten x)
|
||||
(flatten y)))
|
||||
(equal (equal (greatest-factor x y)
|
||||
(zero))
|
||||
(and (or (zerop y)
|
||||
(equal y 1))
|
||||
(equal x (zero))))
|
||||
(equal (equal (greatest-factor x y)
|
||||
1)
|
||||
(equal x 1))
|
||||
(equal (numberp (greatest-factor x y))
|
||||
(not (and (or (zerop y)
|
||||
(equal y 1))
|
||||
(not (numberp x)))))
|
||||
(equal (times-list (append x y))
|
||||
(times (times-list x)
|
||||
(times-list y)))
|
||||
(equal (prime-list (append x y))
|
||||
(and (prime-list x)
|
||||
(prime-list y)))
|
||||
(equal (equal z (times w z))
|
||||
(and (numberp z)
|
||||
(or (equal z (zero))
|
||||
(equal w 1))))
|
||||
(equal (greatereqp x y)
|
||||
(not (lessp x y)))
|
||||
(equal (equal x (times x y))
|
||||
(or (equal x (zero))
|
||||
(and (numberp x)
|
||||
(equal y 1))))
|
||||
(equal (remainder (times y x)
|
||||
y)
|
||||
(zero))
|
||||
(equal (equal (times a b)
|
||||
1)
|
||||
(and (not (equal a (zero)))
|
||||
(not (equal b (zero)))
|
||||
(numberp a)
|
||||
(numberp b)
|
||||
(equal (_1- a)
|
||||
(zero))
|
||||
(equal (_1- b)
|
||||
(zero))))
|
||||
(equal (lessp (length (delete x l))
|
||||
(length l))
|
||||
(member x l))
|
||||
(equal (sort2 (delete x l))
|
||||
(delete x (sort2 l)))
|
||||
(equal (dsort x)
|
||||
(sort2 x))
|
||||
(equal (length (cons x1
|
||||
(cons x2
|
||||
(cons x3 (cons x4
|
||||
(cons x5
|
||||
(cons x6 x7)))))))
|
||||
(plus 6 (length x7)))
|
||||
(equal (difference (add1 (add1 x))
|
||||
2)
|
||||
(fix x))
|
||||
(equal (quotient (plus x (plus x y))
|
||||
2)
|
||||
(plus x (quotient y 2)))
|
||||
(equal (sigma (zero)
|
||||
i)
|
||||
(quotient (times i (add1 i))
|
||||
2))
|
||||
(equal (plus x (add1 y))
|
||||
(if (numberp y)
|
||||
(add1 (plus x y))
|
||||
(add1 x)))
|
||||
(equal (equal (difference x y)
|
||||
(difference z y))
|
||||
(if (lessp x y)
|
||||
(not (lessp y z))
|
||||
(if (lessp z y)
|
||||
(not (lessp y x))
|
||||
(equal (fix x)
|
||||
(fix z)))))
|
||||
(equal (meaning (plus-tree (delete x y))
|
||||
a)
|
||||
(if (member x y)
|
||||
(difference (meaning (plus-tree y)
|
||||
a)
|
||||
(meaning x a))
|
||||
(meaning (plus-tree y)
|
||||
a)))
|
||||
(equal (times x (add1 y))
|
||||
(if (numberp y)
|
||||
(plus x (times x y))
|
||||
(fix x)))
|
||||
(equal (nth (nil)
|
||||
i)
|
||||
(if (zerop i)
|
||||
(nil)
|
||||
(zero)))
|
||||
(equal (last (append a b))
|
||||
(if (listp b)
|
||||
(last b)
|
||||
(if (listp a)
|
||||
(cons (car (last a))
|
||||
b)
|
||||
b)))
|
||||
(equal (equal (lessp x y)
|
||||
z)
|
||||
(if (lessp x y)
|
||||
(equal (t) z)
|
||||
(equal (f) z)))
|
||||
(equal (assignment x (append a b))
|
||||
(if (assignedp x a)
|
||||
(assignment x a)
|
||||
(assignment x b)))
|
||||
(equal (car (gopher x))
|
||||
(if (listp x)
|
||||
(car (flatten x))
|
||||
(zero)))
|
||||
(equal (flatten (cdr (gopher x)))
|
||||
(if (listp x)
|
||||
(cdr (flatten x))
|
||||
(cons (zero)
|
||||
(nil))))
|
||||
(equal (quotient (times y x)
|
||||
y)
|
||||
(if (zerop y)
|
||||
(zero)
|
||||
(fix x)))
|
||||
(equal (get j (set i val mem))
|
||||
(if (eqp j i)
|
||||
val
|
||||
(get j mem)))))))
|
||||
|
||||
(define (add-lemma-lst lst)
|
||||
(cond ((null? lst)
|
||||
#t)
|
||||
(else (add-lemma (car lst))
|
||||
(add-lemma-lst (cdr lst)))))
|
||||
|
||||
(define (add-lemma term)
|
||||
(cond ((and (pair? term)
|
||||
(eq? (car term)
|
||||
(quote equal))
|
||||
(pair? (cadr term)))
|
||||
(put (car (cadr term))
|
||||
(quote lemmas)
|
||||
(cons
|
||||
(translate-term term)
|
||||
(get (car (cadr term)) (quote lemmas)))))
|
||||
(else (error #f "ADD-LEMMA did not like term: " term))))
|
||||
|
||||
; Translates a term by replacing its constructor symbols by symbol-records.
|
||||
|
||||
(define (translate-term term)
|
||||
(cond ((not (pair? term))
|
||||
term)
|
||||
(else (cons (symbol->symbol-record (car term))
|
||||
(translate-args (cdr term))))))
|
||||
|
||||
(define (translate-args lst)
|
||||
(cond ((null? lst)
|
||||
'())
|
||||
(else (cons (translate-term (car lst))
|
||||
(translate-args (cdr lst))))))
|
||||
|
||||
; For debugging only, so the use of MAP does not change
|
||||
; the first-order character of the benchmark.
|
||||
|
||||
(define (untranslate-term term)
|
||||
(cond ((not (pair? term))
|
||||
term)
|
||||
(else (cons (get-name (car term))
|
||||
(map untranslate-term (cdr term))))))
|
||||
|
||||
; A symbol-record is represented as a vector with two fields:
|
||||
; the symbol (for debugging) and
|
||||
; the list of lemmas associated with the symbol.
|
||||
|
||||
(define (put sym property value)
|
||||
(put-lemmas! (symbol->symbol-record sym) value))
|
||||
|
||||
(define (get sym property)
|
||||
(get-lemmas (symbol->symbol-record sym)))
|
||||
|
||||
(define (symbol->symbol-record sym)
|
||||
(let ((x (assq sym *symbol-records-alist*)))
|
||||
(if x
|
||||
(cdr x)
|
||||
(let ((r (make-symbol-record sym)))
|
||||
(set! *symbol-records-alist*
|
||||
(cons (cons sym r)
|
||||
*symbol-records-alist*))
|
||||
r))))
|
||||
|
||||
; Association list of symbols and symbol-records.
|
||||
|
||||
(define *symbol-records-alist* '())
|
||||
|
||||
; A symbol-record is represented as a vector with two fields:
|
||||
; the symbol (for debugging) and
|
||||
; the list of lemmas associated with the symbol.
|
||||
|
||||
(define (make-symbol-record sym)
|
||||
(vector sym '()))
|
||||
|
||||
(define (put-lemmas! symbol-record lemmas)
|
||||
(vector-set! symbol-record 1 lemmas))
|
||||
|
||||
(define (get-lemmas symbol-record)
|
||||
(vector-ref symbol-record 1))
|
||||
|
||||
(define (get-name symbol-record)
|
||||
(vector-ref symbol-record 0))
|
||||
|
||||
(define (symbol-record-equal? r1 r2)
|
||||
(eq? r1 r2))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;
|
||||
; The second phase.
|
||||
;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (test alist term n)
|
||||
(let ((term
|
||||
(apply-subst
|
||||
(translate-alist alist)
|
||||
(translate-term
|
||||
(do ((term term (list 'or term '(f)))
|
||||
(n n (- n 1)))
|
||||
((zero? n) term))))))
|
||||
(tautp term)))
|
||||
|
||||
(define (translate-alist alist)
|
||||
(cond ((null? alist)
|
||||
'())
|
||||
(else (cons (cons (caar alist)
|
||||
(translate-term (cdar alist)))
|
||||
(translate-alist (cdr alist))))))
|
||||
|
||||
(define (apply-subst alist term)
|
||||
(cond ((not (pair? term))
|
||||
(let ((temp-temp (assq term alist)))
|
||||
(if temp-temp
|
||||
(cdr temp-temp)
|
||||
term)))
|
||||
(else (cons (car term)
|
||||
(apply-subst-lst alist (cdr term))))))
|
||||
|
||||
(define (apply-subst-lst alist lst)
|
||||
(cond ((null? lst)
|
||||
'())
|
||||
(else (cons (apply-subst alist (car lst))
|
||||
(apply-subst-lst alist (cdr lst))))))
|
||||
|
||||
(define (tautp x)
|
||||
(tautologyp (rewrite x)
|
||||
'() '()))
|
||||
|
||||
(define (tautologyp x true-lst false-lst)
|
||||
(cond ((truep x true-lst)
|
||||
#t)
|
||||
((falsep x false-lst)
|
||||
#f)
|
||||
((not (pair? x))
|
||||
#f)
|
||||
((eq? (car x) if-constructor)
|
||||
(cond ((truep (cadr x)
|
||||
true-lst)
|
||||
(tautologyp (caddr x)
|
||||
true-lst false-lst))
|
||||
((falsep (cadr x)
|
||||
false-lst)
|
||||
(tautologyp (cadddr x)
|
||||
true-lst false-lst))
|
||||
(else (and (tautologyp (caddr x)
|
||||
(cons (cadr x)
|
||||
true-lst)
|
||||
false-lst)
|
||||
(tautologyp (cadddr x)
|
||||
true-lst
|
||||
(cons (cadr x)
|
||||
false-lst))))))
|
||||
(else #f)))
|
||||
|
||||
(define if-constructor '*) ; becomes (symbol->symbol-record 'if)
|
||||
|
||||
(define rewrite-count 0) ; sanity check
|
||||
|
||||
; The next procedure is Henry Baker's sharing CONS, which avoids
|
||||
; allocation if the result is already in hand.
|
||||
; The REWRITE and REWRITE-ARGS procedures have been modified to
|
||||
; use SCONS instead of CONS.
|
||||
|
||||
(define (scons x y original)
|
||||
(if (and (eq? x (car original))
|
||||
(eq? y (cdr original)))
|
||||
original
|
||||
(cons x y)))
|
||||
|
||||
(define (rewrite term)
|
||||
(set! rewrite-count (+ rewrite-count 1))
|
||||
(cond ((not (pair? term))
|
||||
term)
|
||||
(else (rewrite-with-lemmas (scons (car term)
|
||||
(rewrite-args (cdr term))
|
||||
term)
|
||||
(get-lemmas (car term))))))
|
||||
|
||||
(define (rewrite-args lst)
|
||||
(cond ((null? lst)
|
||||
'())
|
||||
(else (scons (rewrite (car lst))
|
||||
(rewrite-args (cdr lst))
|
||||
lst))))
|
||||
|
||||
(define (rewrite-with-lemmas term lst)
|
||||
(cond ((null? lst)
|
||||
term)
|
||||
((one-way-unify term (cadr (car lst)))
|
||||
(rewrite (apply-subst unify-subst (caddr (car lst)))))
|
||||
(else (rewrite-with-lemmas term (cdr lst)))))
|
||||
|
||||
(define unify-subst '*)
|
||||
|
||||
(define (one-way-unify term1 term2)
|
||||
(begin (set! unify-subst '())
|
||||
(one-way-unify1 term1 term2)))
|
||||
|
||||
(define (one-way-unify1 term1 term2)
|
||||
(cond ((not (pair? term2))
|
||||
(let ((temp-temp (assq term2 unify-subst)))
|
||||
(cond (temp-temp
|
||||
(term-equal? term1 (cdr temp-temp)))
|
||||
((number? term2) ; This bug fix makes
|
||||
(equal? term1 term2)) ; nboyer 10-25% slower!
|
||||
(else
|
||||
(set! unify-subst (cons (cons term2 term1)
|
||||
unify-subst))
|
||||
#t))))
|
||||
((not (pair? term1))
|
||||
#f)
|
||||
((eq? (car term1)
|
||||
(car term2))
|
||||
(one-way-unify1-lst (cdr term1)
|
||||
(cdr term2)))
|
||||
(else #f)))
|
||||
|
||||
(define (one-way-unify1-lst lst1 lst2)
|
||||
(cond ((null? lst1)
|
||||
(null? lst2))
|
||||
((null? lst2)
|
||||
#f)
|
||||
((one-way-unify1 (car lst1)
|
||||
(car lst2))
|
||||
(one-way-unify1-lst (cdr lst1)
|
||||
(cdr lst2)))
|
||||
(else #f)))
|
||||
|
||||
(define (falsep x lst)
|
||||
(or (term-equal? x false-term)
|
||||
(term-member? x lst)))
|
||||
|
||||
(define (truep x lst)
|
||||
(or (term-equal? x true-term)
|
||||
(term-member? x lst)))
|
||||
|
||||
(define false-term '*) ; becomes (translate-term '(f))
|
||||
(define true-term '*) ; becomes (translate-term '(t))
|
||||
|
||||
; The next two procedures were in the original benchmark
|
||||
; but were never used.
|
||||
|
||||
(define (trans-of-implies n)
|
||||
(translate-term
|
||||
(list (quote implies)
|
||||
(trans-of-implies1 n)
|
||||
(list (quote implies)
|
||||
0 n))))
|
||||
|
||||
(define (trans-of-implies1 n)
|
||||
(cond ((equal? n 1)
|
||||
(list (quote implies)
|
||||
0 1))
|
||||
(else (list (quote and)
|
||||
(list (quote implies)
|
||||
(- n 1)
|
||||
n)
|
||||
(trans-of-implies1 (- n 1))))))
|
||||
|
||||
; Translated terms can be circular structures, which can't be
|
||||
; compared using Scheme's equal? and member procedures, so we
|
||||
; use these instead.
|
||||
|
||||
(define (term-equal? x y)
|
||||
(cond ((pair? x)
|
||||
(and (pair? y)
|
||||
(symbol-record-equal? (car x) (car y))
|
||||
(term-args-equal? (cdr x) (cdr y))))
|
||||
(else (equal? x y))))
|
||||
|
||||
(define (term-args-equal? lst1 lst2)
|
||||
(cond ((null? lst1)
|
||||
(null? lst2))
|
||||
((null? lst2)
|
||||
#f)
|
||||
((term-equal? (car lst1) (car lst2))
|
||||
(term-args-equal? (cdr lst1) (cdr lst2)))
|
||||
(else #f)))
|
||||
|
||||
(define (term-member? x lst)
|
||||
(cond ((null? lst)
|
||||
#f)
|
||||
((term-equal? x (car lst))
|
||||
#t)
|
||||
(else (term-member? x (cdr lst)))))
|
||||
|
||||
(set! setup-boyer
|
||||
(lambda ()
|
||||
(set! *symbol-records-alist* '())
|
||||
(set! if-constructor (symbol->symbol-record 'if))
|
||||
(set! false-term (translate-term '(f)))
|
||||
(set! true-term (translate-term '(t)))
|
||||
(setup)))
|
||||
|
||||
(set! test-boyer
|
||||
(lambda (alist term n)
|
||||
(set! rewrite-count 0)
|
||||
(let ((answer (test alist term n)))
|
||||
; (write rewrite-count)
|
||||
; (display " rewrites")
|
||||
; (newline)
|
||||
(if answer
|
||||
rewrite-count
|
||||
#f)))))
|
||||
|
||||
;;; The following code is appended to all benchmarks.
|
||||
|
||||
;;; Given an integer and an object, returns the object
|
||||
;;; without making it too easy for compilers to tell
|
||||
;;; the object will be returned.
|
||||
|
||||
(define (hide r x)
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(values (vector values (lambda (x) x))
|
||||
(if (< r 100) 0 1)))
|
||||
(lambda (v i)
|
||||
((vector-ref v i) x))))
|
||||
|
||||
;;; Given the name of a benchmark,
|
||||
;;; the number of times it should be executed,
|
||||
;;; a thunk that runs the benchmark once,
|
||||
;;; and a unary predicate that is true of the
|
||||
;;; correct results the thunk may return,
|
||||
;;; runs the benchmark for the number of specified iterations.
|
||||
|
||||
(define (run-r7rs-benchmark name count thunk ok?)
|
||||
|
||||
;; Rounds to thousandths.
|
||||
(define (rounded x)
|
||||
(/ (round (* 1000 x)) 1000))
|
||||
|
||||
(display "Running ")
|
||||
(display name)
|
||||
(newline)
|
||||
(flush-output-port)
|
||||
(let* ((j/s (jiffies-per-second))
|
||||
(t0 (current-second))
|
||||
(j0 (current-jiffy)))
|
||||
(let loop ((i 0)
|
||||
(result (if #f #f)))
|
||||
(cond ((< i count)
|
||||
(loop (+ i 1) (thunk)))
|
||||
((ok? result)
|
||||
(let* ((j1 (current-jiffy))
|
||||
(t1 (current-second))
|
||||
(jifs (- j1 j0))
|
||||
(secs (inexact (/ jifs j/s)))
|
||||
(secs2 (rounded (- t1 t0))))
|
||||
(display "Elapsed time: ")
|
||||
(write secs)
|
||||
(display " seconds (")
|
||||
(write secs2)
|
||||
(display ") for ")
|
||||
(display name)
|
||||
(newline))
|
||||
result)
|
||||
(else
|
||||
(display "ERROR: returned incorrect result: ")
|
||||
(write result)
|
||||
(newline)
|
||||
result)))))
|
||||
|
||||
(main)
|
||||
|
|
@ -2,9 +2,9 @@
|
|||
|
||||
# Benchmarks
|
||||
|
||||
The following [benchmarks from Larceny](http://www.larcenists.org/benchmarksGenuineR7Linux.html) give an indication of how well Cyclone performs compared with other R<sup>7</sup>RS Schemes.
|
||||
The following [benchmarks from Larceny](http://www.larcenists.org/benchmarksGenuineR7Linux.html) give an indication of how well Cyclone performs compared with other R<sup>7</sup>RS Schemes. These benchmarks were recorded on a system with an Intel Core i5 CPU @ 2.20 GHz and indicate elapsed time in seconds. Longer bars indicate worse performance, although a bar is not displayed if the benchmark could not be completed in a reasonable amount of time.
|
||||
|
||||
These benchmarks were recorded on a system with an Intel Core i5 CPU @ 2.20 GHz and indicate elapsed time in seconds. Longer bars indicate worse performance, although a bar is not displayed if the benchmark could not be completed in a reasonable amount of time.
|
||||
## Gabriel Benchmarks
|
||||
|
||||
<img src="images/benchmarks/gabriel.png">
|
||||
|
||||
|
|
@ -15,11 +15,35 @@ deriv | 39 | 212 | 13
|
|||
destruc | 136 | 197 | 20
|
||||
diviter | 51 | 122.9 | 8
|
||||
divrec | 70 | 108 | 29
|
||||
puzzle | 184 | - | 32
|
||||
puzzle | 184 | Timeout | 32
|
||||
triangl | 95 | 201 | 26.6
|
||||
tak | 70 | 105 | 28.9
|
||||
takl | 132 | - | 78.7
|
||||
takl | 132 | Timeout | 78.7
|
||||
ntakl | 152 | 193 | 77.9
|
||||
cpstak | 92 | - | 35
|
||||
ctak | 7.9 | - | 8.6
|
||||
cpstak | 92 | Timeout | 35
|
||||
ctak | 7.9 | Timeout | 8.6
|
||||
|
||||
## Kernighan and Van Wyk Benchmarks
|
||||
|
||||
<img src="images/benchmarks/kvw.png">
|
||||
|
||||
Benchmark | Cyclone | Chibi | Chicken
|
||||
--------- | ------- | ----- | -------
|
||||
ack | 288 | 161 | 116
|
||||
array1 | 167 | 130 | 29.4
|
||||
string | 1 | 8.478 | 1.584
|
||||
sum1 | 27 | 74 | 7.737
|
||||
cat | 43.669 | 132 | 55
|
||||
tail | 367 | 674 | -
|
||||
wc | 202 | 1072 | 36.4
|
||||
|
||||
## Garbage Collection Benchmarks
|
||||
|
||||
<img src="images/benchmarks/gc.png">
|
||||
|
||||
Benchmark | Cyclone | Chibi | Chicken
|
||||
--------- | ------- | ----- | -------
|
||||
nboyer | 67.783 | 73.516 | 39.377
|
||||
sboyer | 48.044 | 69.243 | 23.628
|
||||
gcbench | 143.478 | Timeout | 16.75
|
||||
mperm | 328.741 | 260.358 | 57.5
|
||||
|
|
|
|||
|
|
@ -36,8 +36,8 @@ Section | Status | Comments
|
|||
6.3 Booleans | Yes | `#true` and `#false` are not recognized by parser.
|
||||
6.4 Pairs and lists | Yes | `member` functions are predicates, `member` and `assoc` do not accept `compare` argument.
|
||||
6.5 Symbols | Yes |
|
||||
6.6 Characters | Partial | No unicode support, `char-ci` predicates are not implemented.
|
||||
6.7 Strings | Partial | No unicode support, `string-ci` functions are not implemented.
|
||||
6.6 Characters | Partial | No unicode support.
|
||||
6.7 Strings | Partial | No unicode support.
|
||||
6.8 Vectors | Yes |
|
||||
6.9 Bytevectors | Yes |
|
||||
6.10 Control features | Yes | `dynamic-wind` is limited, and does not work across calls to continuations.
|
||||
|
|
|
|||
|
|
@ -14,6 +14,8 @@
|
|||
- [Language Details](#language-details)
|
||||
- [Multithreaded Programming](#multithreaded-programming)
|
||||
- [Foreign Function Interface](#foreign-function-interface)
|
||||
- [Writing a Scheme Function in C](#writing-a-scheme-function-in-c)
|
||||
- [Including a C Header File](#including-a-c-header-file)
|
||||
- [Licensing](#licensing)
|
||||
- [References and Further Reading](#references-and-further-reading)
|
||||
|
||||
|
|
@ -122,7 +124,7 @@ Cyclone implements the Scheme language as documented by the [R<sup>7</sup>RS Sch
|
|||
|
||||
A [R<sup>7</sup>RS Compliance Chart](Scheme-Language-Compliance.md) lists differences between the specification and Cyclone's implementation.
|
||||
|
||||
[API Documentation](API.md) is available for the libraries provide by Cyclone.
|
||||
[API Documentation](API.md) is available for the libraries provided by Cyclone.
|
||||
|
||||
# Multithreaded Programming
|
||||
|
||||
|
|
@ -140,18 +142,20 @@ Due to how Cyclone's garbage collector is implemented, objects are relocated in
|
|||
|
||||
Finally, note there are some objects that are not relocated so the above does not apply:
|
||||
|
||||
- Characters are stored using value types and do not need to be garbage collected.
|
||||
- Characters and integers are stored using value types and do not need to be garbage collected.
|
||||
- Symbols are stored in a global table rather than the stack/heap.
|
||||
- Mutexes are always allocated on the heap since by definition they are used by more than one thread.
|
||||
|
||||
# Foreign Function Interface
|
||||
|
||||
## Writing a Scheme Function in C
|
||||
|
||||
The `define-c` special form can be used to define a function containing user-defined C code. This code will be carried through from the Scheme file all the way to the compiled C file. For example:
|
||||
|
||||
(define-c Cyc-add-exception-handler
|
||||
"(void *data, int argc, closure _, object k, object h)"
|
||||
" gc_thread_data *thd = (gc_thread_data *)data;
|
||||
make_cons(c, h, thd->exception_handler_stack);
|
||||
make_pair(c, h, thd->exception_handler_stack);
|
||||
thd->exception_handler_stack = &c;
|
||||
return_closcall1(data, k, &c); ")
|
||||
|
||||
|
|
@ -180,6 +184,25 @@ Functions that may block must call the `set_thread_blocked` macro to let the sys
|
|||
|
||||
The Cyclone runtime can be used as a reference for how to write your own C functions. A good starting point would be [`runtime.c`](../runtime.c) and [`types.h`](../include/cyclone/types.h).
|
||||
|
||||
## Including a C Header File
|
||||
|
||||
A C header may be included using the `include-c-header` special form. This special form may be used either as part of a library definition:
|
||||
|
||||
(define-library (example life)
|
||||
(include-c-header "../write-png.h")
|
||||
(export life)
|
||||
... )
|
||||
|
||||
Or as part of a program (add any includes immediately after the `import` expression, if one is present):
|
||||
|
||||
(import (scheme base)
|
||||
(example life)
|
||||
(example grid))
|
||||
(include-c-header "stdlib.h")
|
||||
(include-c-header "<stdio.h>")
|
||||
|
||||
By default this will generate an `#include` preprocessor directive with the name of the header file in double quotes. However, if `include-c-header` is passed a text string with angle brackets (EG: `"<stdio.h>"`), the generated C code will use angle brackets instead.
|
||||
|
||||
# Licensing
|
||||
Cyclone is available under the [MIT license](http://www.opensource.org/licenses/mit-license.php).
|
||||
|
||||
|
|
|
|||
|
|
@ -85,7 +85,7 @@ After GC is finished, the C stack pointer is reset using [`longjmp`](http://man7
|
|||
Here is a snippet demonstrating how C functions may be written using Baker's approach:
|
||||
|
||||
object Cyc_make_vector(object cont, object len, object fill) {
|
||||
object v = nil;
|
||||
object v = NULL;
|
||||
int i;
|
||||
Cyc_check_int(len);
|
||||
|
||||
|
|
|
|||
BIN
docs/images/benchmarks/gc.png
Normal file
BIN
docs/images/benchmarks/gc.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 10 KiB |
BIN
docs/images/benchmarks/kvw.png
Normal file
BIN
docs/images/benchmarks/kvw.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 11 KiB |
BIN
docs/images/game-of-life-gliders.gif
Normal file
BIN
docs/images/game-of-life-gliders.gif
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 194 KiB |
44
examples/Makefile
Normal file
44
examples/Makefile
Normal file
|
|
@ -0,0 +1,44 @@
|
|||
# Build all example programs
|
||||
TARGETS = \
|
||||
tail-call-optimization \
|
||||
begin-splicing \
|
||||
fac \
|
||||
long-running-process \
|
||||
threading/cv-broadcast \
|
||||
threading/many-writers \
|
||||
threading/producer-consumer \
|
||||
threading/thread-join \
|
||||
game-of-life/life \
|
||||
hello-library/hello \
|
||||
|
||||
SRCFILES = $(addsuffix .scm, $(TARGETS))
|
||||
|
||||
all: $(TARGETS)
|
||||
|
||||
tail-call-optimization : tail-call-optimization.scm
|
||||
cyclone $^
|
||||
begin-splicing : begin-splicing.scm
|
||||
cyclone $^
|
||||
fac : fac.scm
|
||||
cyclone $^
|
||||
long-running-process : long-running-process.scm
|
||||
cyclone $^
|
||||
threading/cv-broadcast : threading/cv-broadcast.scm
|
||||
cyclone $^
|
||||
threading/many-writers : threading/many-writers.scm
|
||||
cyclone $^
|
||||
threading/producer-consumer: threading/producer-consumer.scm
|
||||
cyclone $^
|
||||
threading/thread-join : threading/thread-join.scm
|
||||
cyclone $^
|
||||
game-of-life/life:
|
||||
cd game-of-life ; make
|
||||
hello-library/hello:
|
||||
cd hello-library ; make
|
||||
|
||||
.PHONY: clean
|
||||
clean:
|
||||
rm -rf *.o *.c *.meta $(TARGETS)
|
||||
cd threading ; rm -rf *.o *.c *.meta
|
||||
cd game-of-life ; make clean
|
||||
cd hello-library ; make clean
|
||||
33
examples/game-of-life-png/Makefile
Normal file
33
examples/game-of-life-png/Makefile
Normal file
|
|
@ -0,0 +1,33 @@
|
|||
SCM_PROGRAM = life
|
||||
SCM_LIBS = example/grid example/life
|
||||
|
||||
SLD_FILES = $(addsuffix .sld, $(SCM_LIBS))
|
||||
SCM_FILE = $(addsuffix .scm, $(SCM_PROGRAM))
|
||||
META_FILES = $(addsuffix .meta, $(SCM_LIBS))
|
||||
GENC_FILES = $(addsuffix .c, $(SCM_LIBS))
|
||||
COBJECTS=$(SLD_FILES:.sld=.o)
|
||||
|
||||
all: $(SCM_PROGRAM) #write-png
|
||||
|
||||
%.o: %.sld
|
||||
cyclone $<
|
||||
|
||||
$(SCM_PROGRAM): $(SCM_FILE) $(COBJECTS) write-png.o
|
||||
# cyclone $<
|
||||
cyclone -d $<
|
||||
# For now, modify -d output manually to compile-in necessary objects/libs for PNG
|
||||
gcc life.c -g -c -o life.o
|
||||
gcc life.o /usr/local/share/cyclone/scheme/base.o example/grid.o /usr/local/share/cyclone/scheme/write.o example/life.o write-png.o -pthread -lcyclone -lck -lm -lpng -g -o life
|
||||
|
||||
#write-png: write-png.o
|
||||
# gcc -o write-png write-png.o -lpng
|
||||
|
||||
write-png.o: write-png.c write-png.h
|
||||
gcc -c write-png.c
|
||||
|
||||
clean:
|
||||
rm -f *.o $(SCM_PROGRAM).c $(SCM_PROGRAM) $(META_FILES) $(GENC_FILES) $(COBJECTS) write-png *.png *.gif
|
||||
rm -rf tmp
|
||||
|
||||
convert:
|
||||
./convert.sh
|
||||
12
examples/game-of-life-png/README.md
Normal file
12
examples/game-of-life-png/README.md
Normal file
|
|
@ -0,0 +1,12 @@
|
|||
# Game of Life - PNG Image Generator
|
||||
|
||||
ImageMagick, libpng, and libpng headers must be installed to build this project.
|
||||
To install these packages on Ubuntu:
|
||||
|
||||
sudo apt-get install imagemagick libpng-dev
|
||||
|
||||
To create PNG outputs and convert to an animation, run:
|
||||
|
||||
make && ./life && ./convert.sh
|
||||
|
||||
<img class="doc" src="../../docs/images/game-of-life-gliders.gif">
|
||||
10
examples/game-of-life-png/convert.sh
Executable file
10
examples/game-of-life-png/convert.sh
Executable file
|
|
@ -0,0 +1,10 @@
|
|||
#!/bin/bash
|
||||
rm -rf tmp
|
||||
mkdir tmp
|
||||
for f in `find . -name "*.png"`
|
||||
do
|
||||
convert -resize 100x $f tmp/$f.resize.png
|
||||
done
|
||||
cd tmp
|
||||
convert -delay 10 -loop 0 *.png animated.gif
|
||||
|
||||
35
examples/game-of-life-png/example/grid.sld
Normal file
35
examples/game-of-life-png/example/grid.sld
Normal file
|
|
@ -0,0 +1,35 @@
|
|||
; Example from draft 6 of R7RS
|
||||
(define-library (example grid)
|
||||
(export make rows cols ref each
|
||||
put!) ;(rename put! set!))
|
||||
(import (scheme base))
|
||||
(begin
|
||||
;; Create an NxM grid.
|
||||
(define (make n m)
|
||||
(let ((grid (make-vector n)))
|
||||
(do ((i 0 (+ i 1)))
|
||||
((= i n) grid)
|
||||
(let ((v (make-vector m #f)))
|
||||
(vector-set! grid i v)))))
|
||||
(define (rows grid)
|
||||
(vector-length grid))
|
||||
(define (cols grid)
|
||||
(vector-length (vector-ref grid 0)))
|
||||
;; Return #false if out of range.
|
||||
(define (ref grid n m)
|
||||
(and (< -1 n (rows grid))
|
||||
(< -1 m (cols grid))
|
||||
(vector-ref (vector-ref grid n) m)))
|
||||
(define (put! grid n m v)
|
||||
(define tmp (vector-ref grid n))
|
||||
(vector-set!
|
||||
grid
|
||||
n
|
||||
(vector-set! tmp m v)))
|
||||
;(vector-set! (vector-ref grid n) m v))
|
||||
(define (each grid proc)
|
||||
(do ((j 0 (+ j 1)))
|
||||
((= j (rows grid)))
|
||||
(do ((k 0 (+ k 1)))
|
||||
((= k (cols grid)))
|
||||
(proc j k (ref grid j k)))))))
|
||||
91
examples/game-of-life-png/example/life.sld
Normal file
91
examples/game-of-life-png/example/life.sld
Normal file
|
|
@ -0,0 +1,91 @@
|
|||
(define-library (example life)
|
||||
(include-c-header "../write-png.h")
|
||||
;Or, if you want angle brackets: (include-c-header "<stdio.h>")
|
||||
(export life)
|
||||
(import (scheme base) ;TODO: (except (scheme base) set!)
|
||||
(scheme write)
|
||||
(example grid))
|
||||
(begin
|
||||
(define (life-count grid i j)
|
||||
(define (count i j)
|
||||
(if (ref grid i j) 1 0))
|
||||
(+ (count (- i 1) (- j 1))
|
||||
(count (- i 1) j)
|
||||
(count (- i 1) (+ j 1))
|
||||
(count i (- j 1))
|
||||
(count i (+ j 1))
|
||||
(count (+ i 1) (- j 1))
|
||||
(count (+ i 1) j)
|
||||
(count (+ i 1) (+ j 1))))
|
||||
(define (life-alive? grid i j)
|
||||
(case (life-count grid i j)
|
||||
((3) #t)
|
||||
((2) (ref grid i j))
|
||||
(else #f)))
|
||||
(define (life-print grid iteration)
|
||||
(let ((img (png:init (cols grid) (rows grid)))
|
||||
(path (string-append
|
||||
"life-"
|
||||
(if (< iteration 10) "0" "")
|
||||
(number->string iteration)
|
||||
".png")))
|
||||
(png:fill! img 255 255 255)
|
||||
(each grid
|
||||
(lambda (i j v)
|
||||
(if v
|
||||
(png:set! img i j 0 250 (* 3 iteration))) ; 250 0))
|
||||
))
|
||||
(png:save img path)
|
||||
(png:free img)
|
||||
))
|
||||
(define (life grid iterations)
|
||||
(do ((i 0 (+ i 1))
|
||||
(grid0 grid grid1)
|
||||
(grid1 (make (rows grid) (cols grid))
|
||||
grid0))
|
||||
((= i iterations))
|
||||
(each grid0
|
||||
(lambda (j k v)
|
||||
(let ((a (life-alive? grid0 j k)))
|
||||
(put! grid1 j k a))))
|
||||
;(set! grid1 j k a))))
|
||||
(life-print grid1 i)))
|
||||
(define-c png:init
|
||||
"(void *data, int argc, closure _, object k, object width, object height)"
|
||||
" RGBBitmap *img = malloc(sizeof(RGBBitmap));
|
||||
make_c_opaque(opq, (void *)img);
|
||||
bitmap_init(img, (int)(unbox_number(width)), (int)(unbox_number(height)));
|
||||
return_closcall1(data, k, &opq);
|
||||
")
|
||||
(define-c png:free
|
||||
"(void *data, int argc, closure _, object k, object opq)"
|
||||
" RGBBitmap *img = (RGBBitmap *)opaque_ptr(opq);
|
||||
free(img->pixels);
|
||||
free(img);
|
||||
return_closcall1(data, k, boolean_t);
|
||||
")
|
||||
(define-c png:set!
|
||||
"(void *data, int argc, closure _, object k, object opq, object x, object y, object r, object g, object b)"
|
||||
" RGBBitmap *img = (RGBBitmap *)opaque_ptr(opq);
|
||||
bitmap_set(img,
|
||||
((int)(unbox_number(x))),
|
||||
((int)(unbox_number(y))),
|
||||
((int)(unbox_number(r))),
|
||||
((int)(unbox_number(g))),
|
||||
((int)(unbox_number(b))));
|
||||
return_closcall1(data, k, boolean_t); ")
|
||||
(define-c png:fill!
|
||||
"(void *data, int argc, closure _, object k, object opq, object r, object g, object b)"
|
||||
" RGBBitmap *img = (RGBBitmap *)opaque_ptr(opq);
|
||||
bitmap_fill(img,
|
||||
((int)(unbox_number(r))),
|
||||
((int)(unbox_number(g))),
|
||||
((int)(unbox_number(b))));
|
||||
return_closcall1(data, k, boolean_t); ")
|
||||
(define-c png:save
|
||||
"(void *data, int argc, closure _, object k, object opq, object path)"
|
||||
" RGBBitmap *img = (RGBBitmap *)opaque_ptr(opq);
|
||||
bitmap_save_to_png(img, string_str(path));
|
||||
return_closcall1(data, k, boolean_t);
|
||||
")
|
||||
))
|
||||
69
examples/game-of-life-png/life.scm
Normal file
69
examples/game-of-life-png/life.scm
Normal file
|
|
@ -0,0 +1,69 @@
|
|||
;;;
|
||||
;;; Justin Ethier
|
||||
;;; husk scheme
|
||||
;;;
|
||||
;;; The game of life example from r7rs.
|
||||
;;; Main program
|
||||
;;;
|
||||
;;; To execute from the husk directory:
|
||||
;;;
|
||||
;;; > cd examples/game-of-life
|
||||
;;; > huski life.scm
|
||||
;;;
|
||||
(import (scheme base)
|
||||
(example life)
|
||||
(example grid))
|
||||
;; TODO:
|
||||
; (only (example life) life)
|
||||
; (rename (prefix (example grid) grid-)
|
||||
; (grid-make make-grid)))
|
||||
|
||||
;; Simple example of including headers in a program.
|
||||
;; Just place them here in the top-level, after
|
||||
;; the (import) expression, if any.
|
||||
(include-c-header "stdlib.h")
|
||||
(include-c-header "<stdio.h>")
|
||||
;; END C headers
|
||||
|
||||
;; Initialize a grid with a glider.
|
||||
;(define grid (make-grid 24 24))
|
||||
;(grid-put! grid 1 1 #t)
|
||||
;(grid-put! grid 2 2 #t)
|
||||
;(grid-put! grid 3 0 #t)
|
||||
;(grid-put! grid 3 1 #t)
|
||||
;(grid-put! grid 3 2 #t)
|
||||
(define grid (make 24 24))
|
||||
(put! grid 1 1 #t)
|
||||
(put! grid 2 2 #t)
|
||||
(put! grid 3 0 #t)
|
||||
(put! grid 3 1 #t)
|
||||
(put! grid 3 2 #t)
|
||||
|
||||
(put! grid 11 11 #t)
|
||||
(put! grid 12 12 #t)
|
||||
(put! grid 13 10 #t)
|
||||
(put! grid 13 11 #t)
|
||||
(put! grid 13 12 #t)
|
||||
|
||||
(put! grid 6 6 #t)
|
||||
(put! grid 7 7 #t)
|
||||
(put! grid 8 5 #t)
|
||||
(put! grid 8 6 #t)
|
||||
(put! grid 8 7 #t)
|
||||
|
||||
(put! grid 1 11 #t)
|
||||
(put! grid 2 12 #t)
|
||||
(put! grid 3 10 #t)
|
||||
(put! grid 3 11 #t)
|
||||
(put! grid 3 12 #t)
|
||||
|
||||
(put! grid 15 0 #t)
|
||||
(put! grid 15 1 #t)
|
||||
(put! grid 16 1 #t)
|
||||
(put! grid 16 2 #t)
|
||||
(put! grid 17 2 #t)
|
||||
(put! grid 17 3 #t)
|
||||
(put! grid 18 2 #t)
|
||||
(put! grid 18 3 #t)
|
||||
;; Run for x iterations.
|
||||
(life grid 100)
|
||||
136
examples/game-of-life-png/write-png.c
Normal file
136
examples/game-of-life-png/write-png.c
Normal file
|
|
@ -0,0 +1,136 @@
|
|||
// Based on example program from
|
||||
// http://stackoverflow.com/q/1821806/101258
|
||||
#include "write-png.h"
|
||||
|
||||
/* Attempts to save PNG to file; returns 0 on success, non-zero on error. */
|
||||
int bitmap_save_to_png(RGBBitmap *bitmap, const char *path)
|
||||
{
|
||||
FILE *fp = fopen(path, "wb");
|
||||
png_structp png_ptr = NULL;
|
||||
png_infop info_ptr = NULL;
|
||||
size_t x, y;
|
||||
png_uint_32 bytes_per_row;
|
||||
png_byte **row_pointers = NULL;
|
||||
|
||||
if (fp == NULL) return -1;
|
||||
|
||||
/* Initialize the write struct. */
|
||||
png_ptr = png_create_write_struct(PNG_LIBPNG_VER_STRING, NULL, NULL, NULL);
|
||||
if (png_ptr == NULL) {
|
||||
fclose(fp);
|
||||
return -1;
|
||||
}
|
||||
|
||||
/* Initialize the info struct. */
|
||||
info_ptr = png_create_info_struct(png_ptr);
|
||||
if (info_ptr == NULL) {
|
||||
png_destroy_write_struct(&png_ptr, NULL);
|
||||
fclose(fp);
|
||||
return -1;
|
||||
}
|
||||
|
||||
/* Set up error handling. */
|
||||
if (setjmp(png_jmpbuf(png_ptr))) {
|
||||
png_destroy_write_struct(&png_ptr, &info_ptr);
|
||||
fclose(fp);
|
||||
return -1;
|
||||
}
|
||||
|
||||
/* Set image attributes. */
|
||||
png_set_IHDR(png_ptr,
|
||||
info_ptr,
|
||||
bitmap->width,
|
||||
bitmap->height,
|
||||
8,
|
||||
PNG_COLOR_TYPE_RGB,
|
||||
PNG_INTERLACE_NONE,
|
||||
PNG_COMPRESSION_TYPE_DEFAULT,
|
||||
PNG_FILTER_TYPE_DEFAULT);
|
||||
|
||||
/* Initialize rows of PNG. */
|
||||
bytes_per_row = bitmap->width * bitmap->bytes_per_pixel;
|
||||
row_pointers = png_malloc(png_ptr, bitmap->height * sizeof(png_byte *));
|
||||
for (y = 0; y < bitmap->height; ++y) {
|
||||
uint8_t *row = png_malloc(png_ptr, sizeof(uint8_t) * bytes_per_row);
|
||||
row_pointers[y] = (png_byte *)row;
|
||||
for (x = 0; x < bitmap->width; ++x) {
|
||||
RGBPixel color = RGBPixelAtPoint(bitmap, x, y);
|
||||
*row++ = color.red;
|
||||
*row++ = color.green;
|
||||
*row++ = color.blue;
|
||||
}
|
||||
}
|
||||
|
||||
/* Actually write the image data. */
|
||||
png_init_io(png_ptr, fp);
|
||||
png_set_rows(png_ptr, info_ptr, row_pointers);
|
||||
png_write_png(png_ptr, info_ptr, PNG_TRANSFORM_IDENTITY, NULL);
|
||||
|
||||
/* Cleanup. */
|
||||
for (y = 0; y < bitmap->height; y++) {
|
||||
png_free(png_ptr, row_pointers[y]);
|
||||
}
|
||||
png_free(png_ptr, row_pointers);
|
||||
|
||||
/* Finish writing. */
|
||||
png_destroy_write_struct(&png_ptr, &info_ptr);
|
||||
fclose(fp);
|
||||
return 0;
|
||||
}
|
||||
|
||||
int bitmap_init(RGBBitmap *img, int width, int height)
|
||||
{
|
||||
img->width = width;
|
||||
img->height = height;
|
||||
img->bytes_per_pixel = 3;
|
||||
img->pixels = calloc(1, sizeof(RGBPixel) * img->width * img->height);
|
||||
return 0;
|
||||
}
|
||||
|
||||
int bitmap_set(RGBBitmap *img, int x, int y, int r, int g, int b)
|
||||
{
|
||||
RGBPixel *pixel = RGBBufferAtPoint(img, x, y);
|
||||
pixel->red = r;
|
||||
pixel->green = g;
|
||||
pixel->blue = b;
|
||||
return 0;
|
||||
}
|
||||
|
||||
void bitmap_fill(RGBBitmap *img, int r, int g, int b)
|
||||
{
|
||||
int x, y;
|
||||
// TODO: could use pointers directly or even memcpy
|
||||
// to make this faster
|
||||
for (y = 0; y < img->height; y++) {
|
||||
for (x = 0; x < img->width; x++) {
|
||||
bitmap_set(img, x, y, r, g, b);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
//int main()
|
||||
//{
|
||||
// const char path[] = "test.png";
|
||||
// int status = 0, x, y;
|
||||
// RGBBitmap img;
|
||||
//
|
||||
// bitmap_init(&img, 100, 100);
|
||||
// for (y = 0; y < img.height; y++) {
|
||||
// for (x = 0; x < img.height; x++) {
|
||||
// bitmap_set(&img, x, y, 255, 255, 255);
|
||||
// }
|
||||
// }
|
||||
// bitmap_set(&img, 50, 50, 0, 0, 255);
|
||||
// bitmap_set(&img, 0, 0, 0, 0, 255);
|
||||
// bitmap_set(&img, 99, 0, 0, 0, 255);
|
||||
// bitmap_set(&img, 0, 99, 0, 0, 255);
|
||||
// bitmap_set(&img, 99, 99, 0, 0, 255);
|
||||
//
|
||||
// status = bitmap_save_to_png(&img, path);
|
||||
// if (!status){
|
||||
// printf("Successfully saved %s\n", path);
|
||||
// } else {
|
||||
// printf("Unable to save %s\n", path);
|
||||
// }
|
||||
// return status;
|
||||
//}
|
||||
37
examples/game-of-life-png/write-png.h
Normal file
37
examples/game-of-life-png/write-png.h
Normal file
|
|
@ -0,0 +1,37 @@
|
|||
#ifndef WRITE_PNG_H
|
||||
#define WRITE_PNG_H
|
||||
|
||||
#include <png.h>
|
||||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
#include <stdint.h>
|
||||
|
||||
/* Pixels in this bitmap structure are stored as BGR. */
|
||||
typedef struct _RGBPixel {
|
||||
uint8_t blue;
|
||||
uint8_t green;
|
||||
uint8_t red;
|
||||
} RGBPixel;
|
||||
|
||||
/* Structure for containing decompressed bitmaps. */
|
||||
typedef struct _RGBBitmap {
|
||||
RGBPixel *pixels;
|
||||
size_t width;
|
||||
size_t height;
|
||||
uint8_t bytes_per_pixel;
|
||||
} RGBBitmap;
|
||||
|
||||
/* Returns pixel of bitmap at given point. */
|
||||
#define RGBPixelAtPoint(image, x, y) \
|
||||
*(((image)->pixels) + (((image)->width * (y)) \
|
||||
+ ((x))))
|
||||
|
||||
#define RGBBufferAtPoint(image, x, y) \
|
||||
(((image)->pixels) + (((image)->width * (y)) \
|
||||
+ ((x))))
|
||||
int bitmap_init(RGBBitmap *img, int width, int height);
|
||||
int bitmap_set(RGBBitmap *img, int x, int y, int r, int g, int b);
|
||||
int bitmap_save_to_png(RGBBitmap *bitmap, const char *path);
|
||||
void bitmap_fill(RGBBitmap *img, int r, int g, int b);
|
||||
|
||||
#endif /* WRITE_PNG_H */
|
||||
1
examples/game-of-life/README.md
Normal file
1
examples/game-of-life/README.md
Normal file
|
|
@ -0,0 +1 @@
|
|||
This is the game of life example program from R7RS.
|
||||
|
|
@ -11,16 +11,25 @@
|
|||
;;; > huski life.scm
|
||||
;;;
|
||||
(import (scheme base)
|
||||
(only (example life) life)
|
||||
(rename (prefix (example grid) grid-)
|
||||
(grid-make make-grid)))
|
||||
(example life)
|
||||
(example grid))
|
||||
;; TODO:
|
||||
; (only (example life) life)
|
||||
; (rename (prefix (example grid) grid-)
|
||||
; (grid-make make-grid)))
|
||||
|
||||
;; Initialize a grid with a glider.
|
||||
(define grid (make-grid 24 24))
|
||||
(grid-put! grid 1 1 #t)
|
||||
(grid-put! grid 2 2 #t)
|
||||
(grid-put! grid 3 0 #t)
|
||||
(grid-put! grid 3 1 #t)
|
||||
(grid-put! grid 3 2 #t)
|
||||
;(define grid (make-grid 24 24))
|
||||
;(grid-put! grid 1 1 #t)
|
||||
;(grid-put! grid 2 2 #t)
|
||||
;(grid-put! grid 3 0 #t)
|
||||
;(grid-put! grid 3 1 #t)
|
||||
;(grid-put! grid 3 2 #t)
|
||||
(define grid (make 24 24))
|
||||
(put! grid 1 1 #t)
|
||||
(put! grid 2 2 #t)
|
||||
(put! grid 3 0 #t)
|
||||
(put! grid 3 1 #t)
|
||||
(put! grid 3 2 #t)
|
||||
;; Run for x iterations.
|
||||
(life grid 10) ;80
|
||||
(life grid 80)
|
||||
|
|
|
|||
|
|
@ -7,6 +7,13 @@
|
|||
)
|
||||
|
||||
(write "hello")
|
||||
;(test-lib1-hello)
|
||||
(newline)
|
||||
|
||||
(write lib1-test-renamed)
|
||||
(newline)
|
||||
|
||||
(write (lib1-hello))
|
||||
(newline)
|
||||
|
||||
(write "world")
|
||||
(newline)
|
||||
|
|
|
|||
|
|
@ -5,7 +5,9 @@
|
|||
;;; A sample library
|
||||
;;;
|
||||
(define-library (libs lib1)
|
||||
(export lib1-hello lib1-test)
|
||||
(export
|
||||
lib1-hello
|
||||
(rename lib1-test lib1-test-renamed))
|
||||
(include "lib1.scm")
|
||||
(import (scheme base)
|
||||
(scheme write)
|
||||
|
|
|
|||
|
|
@ -1,11 +1,11 @@
|
|||
;; This should run forever using a constant amount of memory
|
||||
;; and max CPU:
|
||||
|
||||
;; Original program:
|
||||
;; (define (foo) (bar))
|
||||
;; (define (bar) (foo))
|
||||
;; (foo)
|
||||
(define (foo) (bar))
|
||||
(define (bar) (foo))
|
||||
(foo)
|
||||
|
||||
(letrec ((foo (lambda () (bar)))
|
||||
(bar (lambda () (foo))))
|
||||
(foo))
|
||||
;; Another way to write it:
|
||||
;; (letrec ((foo (lambda () (bar)))
|
||||
;; (bar (lambda () (foo))))
|
||||
;; (foo))
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@
|
|||
(srfi 18))
|
||||
|
||||
(define (write-forever val)
|
||||
(write val)
|
||||
(display val)
|
||||
(write-forever val))
|
||||
|
||||
(define (make-writer val)
|
||||
|
|
|
|||
|
|
@ -18,24 +18,29 @@
|
|||
(cond
|
||||
((> n 0)
|
||||
(mutex-lock! *lock*)
|
||||
(write (cons 'a *queue*))
|
||||
(display (cons 'a *queue*))
|
||||
(newline)
|
||||
(set! *queue* (->heap (cons (->heap n) *queue*)))
|
||||
(mutex-unlock! *lock*)
|
||||
(loop (- n 1)))
|
||||
(else
|
||||
(write "producer thread done")))))
|
||||
(display "producer thread done")
|
||||
(newline)))))
|
||||
|
||||
(define (consumer)
|
||||
(let loop ()
|
||||
;(write (list (null? *queue*) *queue*))
|
||||
;(display (list (null? *queue*) *queue*))
|
||||
;(newline)
|
||||
(define sleep? #f)
|
||||
(mutex-lock! *lock*)
|
||||
(cond
|
||||
((not (null? *queue*))
|
||||
(write (car *queue*))
|
||||
(display (car *queue*))
|
||||
(newline)
|
||||
(set! *queue* (cdr *queue*)))
|
||||
(else
|
||||
(write "consumer sleeping")
|
||||
(display "consumer sleeping")
|
||||
(newline)
|
||||
(set! sleep? #t)))
|
||||
(mutex-unlock! *lock*)
|
||||
(if sleep? (thread-sleep! 1000))
|
||||
|
|
|
|||
|
|
@ -11,13 +11,16 @@
|
|||
(thread-start!
|
||||
(make-thread
|
||||
(lambda ()
|
||||
(write "started thread")
|
||||
(display "started thread")
|
||||
(newline)
|
||||
(thread-sleep! 3000)
|
||||
(write "thread done")
|
||||
(display "thread done")
|
||||
(newline)
|
||||
(condition-variable-broadcast! cv))))
|
||||
|
||||
;; Main thread - wait for thread to broadcast it is done
|
||||
(mutex-lock! m)
|
||||
(mutex-unlock! m cv) ;; Wait on cv
|
||||
(write "main thread done")
|
||||
(display "main thread done")
|
||||
(newline)
|
||||
(thread-sleep! 500)
|
||||
|
|
|
|||
|
|
@ -61,16 +61,16 @@
|
|||
|
||||
// Other compilers
|
||||
|
||||
#else // defined(_MSC_VER)
|
||||
#else // defined(_MSC_VER)
|
||||
|
||||
#define FORCE_INLINE inline __attribute__((always_inline))
|
||||
|
||||
static inline uint32_t rotl32 ( uint32_t x, int8_t r )
|
||||
static inline uint32_t rotl32(uint32_t x, int8_t r)
|
||||
{
|
||||
return (x << r) | (x >> (32 - r));
|
||||
}
|
||||
|
||||
static inline uint64_t rotl64 ( uint64_t x, int8_t r )
|
||||
static inline uint64_t rotl64(uint64_t x, int8_t r)
|
||||
{
|
||||
return (x << r) | (x >> (64 - r));
|
||||
}
|
||||
|
|
@ -80,13 +80,13 @@ static inline uint64_t rotl64 ( uint64_t x, int8_t r )
|
|||
|
||||
#define BIG_CONSTANT(x) (x##LLU)
|
||||
|
||||
#endif // !defined(_MSC_VER)
|
||||
#endif // !defined(_MSC_VER)
|
||||
|
||||
//-----------------------------------------------------------------------------
|
||||
// Block read - if your platform needs to do endian-swapping or can only
|
||||
// handle aligned reads, do the conversion here
|
||||
|
||||
FORCE_INLINE static uint32_t getblock ( const uint32_t * p, int i )
|
||||
FORCE_INLINE static uint32_t getblock(const uint32_t * p, int i)
|
||||
{
|
||||
return p[i];
|
||||
}
|
||||
|
|
@ -94,7 +94,7 @@ FORCE_INLINE static uint32_t getblock ( const uint32_t * p, int i )
|
|||
//-----------------------------------------------------------------------------
|
||||
// Finalization mix - force all bits of a hash block to avalanche
|
||||
|
||||
FORCE_INLINE static uint32_t fmix ( uint32_t h )
|
||||
FORCE_INLINE static uint32_t fmix(uint32_t h)
|
||||
{
|
||||
h ^= h >> 16;
|
||||
h *= 0x85ebca6b;
|
||||
|
|
@ -107,10 +107,10 @@ FORCE_INLINE static uint32_t fmix ( uint32_t h )
|
|||
|
||||
//-----------------------------------------------------------------------------
|
||||
|
||||
static inline void MurmurHash3_x86_32 ( const void * key, int len,
|
||||
uint32_t seed, uint32_t * out )
|
||||
static inline void MurmurHash3_x86_32(const void *key, int len,
|
||||
uint32_t seed, uint32_t * out)
|
||||
{
|
||||
const uint8_t * data = (const uint8_t*)key;
|
||||
const uint8_t *data = (const uint8_t *)key;
|
||||
const int nblocks = len / 4;
|
||||
int i;
|
||||
|
||||
|
|
@ -122,34 +122,38 @@ static inline void MurmurHash3_x86_32 ( const void * key, int len,
|
|||
//----------
|
||||
// body
|
||||
|
||||
const uint32_t * blocks = (const uint32_t *)(const void *)(data + nblocks*4);
|
||||
const uint32_t *blocks = (const uint32_t *)(const void *)(data + nblocks * 4);
|
||||
|
||||
for(i = -nblocks; i; i++)
|
||||
{
|
||||
uint32_t k1 = getblock(blocks,i);
|
||||
for (i = -nblocks; i; i++) {
|
||||
uint32_t k1 = getblock(blocks, i);
|
||||
|
||||
k1 *= c1;
|
||||
k1 = ROTL32(k1,15);
|
||||
k1 = ROTL32(k1, 15);
|
||||
k1 *= c2;
|
||||
|
||||
h1 ^= k1;
|
||||
h1 = ROTL32(h1,13);
|
||||
h1 = h1*5+0xe6546b64;
|
||||
h1 = ROTL32(h1, 13);
|
||||
h1 = h1 * 5 + 0xe6546b64;
|
||||
}
|
||||
|
||||
//----------
|
||||
// tail
|
||||
|
||||
const uint8_t * tail = (const uint8_t*)(data + nblocks*4);
|
||||
const uint8_t *tail = (const uint8_t *)(data + nblocks * 4);
|
||||
|
||||
uint32_t k1 = 0;
|
||||
|
||||
switch(len & 3)
|
||||
{
|
||||
case 3: k1 ^= tail[2] << 16;
|
||||
case 2: k1 ^= tail[1] << 8;
|
||||
case 1: k1 ^= tail[0];
|
||||
k1 *= c1; k1 = ROTL32(k1,15); k1 *= c2; h1 ^= k1;
|
||||
switch (len & 3) {
|
||||
case 3:
|
||||
k1 ^= tail[2] << 16;
|
||||
case 2:
|
||||
k1 ^= tail[1] << 8;
|
||||
case 1:
|
||||
k1 ^= tail[0];
|
||||
k1 *= c1;
|
||||
k1 = ROTL32(k1, 15);
|
||||
k1 *= c2;
|
||||
h1 ^= k1;
|
||||
};
|
||||
|
||||
//----------
|
||||
|
|
@ -159,28 +163,27 @@ static inline void MurmurHash3_x86_32 ( const void * key, int len,
|
|||
|
||||
h1 = fmix(h1);
|
||||
|
||||
*(uint32_t *)out = h1;
|
||||
*(uint32_t *) out = h1;
|
||||
}
|
||||
|
||||
static inline uint64_t MurmurHash64A ( const void * key, int len, uint64_t seed )
|
||||
static inline uint64_t MurmurHash64A(const void *key, int len, uint64_t seed)
|
||||
{
|
||||
const uint64_t m = BIG_CONSTANT(0xc6a4a7935bd1e995);
|
||||
const int r = 47;
|
||||
|
||||
uint64_t h = seed ^ (len * m);
|
||||
|
||||
const uint64_t * data = (const uint64_t *)key;
|
||||
const uint64_t * end = data + (len/8);
|
||||
const uint64_t *data = (const uint64_t *)key;
|
||||
const uint64_t *end = data + (len / 8);
|
||||
|
||||
while(data != end)
|
||||
{
|
||||
while (data != end) {
|
||||
uint64_t k;
|
||||
|
||||
if (!((uintptr_t)data & 0x7))
|
||||
k = *data++;
|
||||
if (!((uintptr_t) data & 0x7))
|
||||
k = *data++;
|
||||
else {
|
||||
memcpy(&k, data, sizeof(k));
|
||||
data++;
|
||||
memcpy(&k, data, sizeof(k));
|
||||
data++;
|
||||
}
|
||||
|
||||
k *= m;
|
||||
|
|
@ -191,18 +194,24 @@ static inline uint64_t MurmurHash64A ( const void * key, int len, uint64_t seed
|
|||
h *= m;
|
||||
}
|
||||
|
||||
const unsigned char * data2 = (const unsigned char*)data;
|
||||
const unsigned char *data2 = (const unsigned char *)data;
|
||||
|
||||
switch(len & 7)
|
||||
{
|
||||
case 7: h ^= (uint64_t)(data2[6]) << 48;
|
||||
case 6: h ^= (uint64_t)(data2[5]) << 40;
|
||||
case 5: h ^= (uint64_t)(data2[4]) << 32;
|
||||
case 4: h ^= (uint64_t)(data2[3]) << 24;
|
||||
case 3: h ^= (uint64_t)(data2[2]) << 16;
|
||||
case 2: h ^= (uint64_t)(data2[1]) << 8;
|
||||
case 1: h ^= (uint64_t)(data2[0]);
|
||||
h *= m;
|
||||
switch (len & 7) {
|
||||
case 7:
|
||||
h ^= (uint64_t) (data2[6]) << 48;
|
||||
case 6:
|
||||
h ^= (uint64_t) (data2[5]) << 40;
|
||||
case 5:
|
||||
h ^= (uint64_t) (data2[4]) << 32;
|
||||
case 4:
|
||||
h ^= (uint64_t) (data2[3]) << 24;
|
||||
case 3:
|
||||
h ^= (uint64_t) (data2[2]) << 16;
|
||||
case 2:
|
||||
h ^= (uint64_t) (data2[1]) << 8;
|
||||
case 1:
|
||||
h ^= (uint64_t) (data2[0]);
|
||||
h *= m;
|
||||
};
|
||||
|
||||
h ^= h >> r;
|
||||
|
|
@ -212,52 +221,64 @@ static inline uint64_t MurmurHash64A ( const void * key, int len, uint64_t seed
|
|||
return h;
|
||||
}
|
||||
|
||||
|
||||
// 64-bit hash for 32-bit platforms
|
||||
|
||||
static inline uint64_t MurmurHash64B ( const void * key, int len, uint64_t seed )
|
||||
static inline uint64_t MurmurHash64B(const void *key, int len, uint64_t seed)
|
||||
{
|
||||
const uint32_t m = 0x5bd1e995;
|
||||
const int r = 24;
|
||||
|
||||
uint32_t h1 = (uint32_t)(seed) ^ len;
|
||||
uint32_t h2 = (uint32_t)(seed >> 32);
|
||||
uint32_t h1 = (uint32_t) (seed) ^ len;
|
||||
uint32_t h2 = (uint32_t) (seed >> 32);
|
||||
|
||||
const uint32_t * data = (const uint32_t *)key;
|
||||
const uint32_t *data = (const uint32_t *)key;
|
||||
|
||||
while(len >= 8)
|
||||
{
|
||||
while (len >= 8) {
|
||||
uint32_t k1 = *data++;
|
||||
k1 *= m; k1 ^= k1 >> r; k1 *= m;
|
||||
h1 *= m; h1 ^= k1;
|
||||
k1 *= m;
|
||||
k1 ^= k1 >> r;
|
||||
k1 *= m;
|
||||
h1 *= m;
|
||||
h1 ^= k1;
|
||||
len -= 4;
|
||||
|
||||
uint32_t k2 = *data++;
|
||||
k2 *= m; k2 ^= k2 >> r; k2 *= m;
|
||||
h2 *= m; h2 ^= k2;
|
||||
k2 *= m;
|
||||
k2 ^= k2 >> r;
|
||||
k2 *= m;
|
||||
h2 *= m;
|
||||
h2 ^= k2;
|
||||
len -= 4;
|
||||
}
|
||||
|
||||
if(len >= 4)
|
||||
{
|
||||
if (len >= 4) {
|
||||
uint32_t k1 = *data++;
|
||||
k1 *= m; k1 ^= k1 >> r; k1 *= m;
|
||||
h1 *= m; h1 ^= k1;
|
||||
k1 *= m;
|
||||
k1 ^= k1 >> r;
|
||||
k1 *= m;
|
||||
h1 *= m;
|
||||
h1 ^= k1;
|
||||
len -= 4;
|
||||
}
|
||||
|
||||
switch(len)
|
||||
{
|
||||
case 3: h2 ^= ((const unsigned char*)data)[2] << 16;
|
||||
case 2: h2 ^= ((const unsigned char*)data)[1] << 8;
|
||||
case 1: h2 ^= ((const unsigned char*)data)[0];
|
||||
h2 *= m;
|
||||
switch (len) {
|
||||
case 3:
|
||||
h2 ^= ((const unsigned char *)data)[2] << 16;
|
||||
case 2:
|
||||
h2 ^= ((const unsigned char *)data)[1] << 8;
|
||||
case 1:
|
||||
h2 ^= ((const unsigned char *)data)[0];
|
||||
h2 *= m;
|
||||
};
|
||||
|
||||
h1 ^= h2 >> 18; h1 *= m;
|
||||
h2 ^= h1 >> 22; h2 *= m;
|
||||
h1 ^= h2 >> 17; h1 *= m;
|
||||
h2 ^= h1 >> 19; h2 *= m;
|
||||
h1 ^= h2 >> 18;
|
||||
h1 *= m;
|
||||
h2 ^= h1 >> 22;
|
||||
h2 *= m;
|
||||
h1 ^= h2 >> 17;
|
||||
h1 *= m;
|
||||
h2 ^= h1 >> 19;
|
||||
h2 *= m;
|
||||
|
||||
uint64_t h = h1;
|
||||
|
||||
|
|
@ -266,4 +287,4 @@ static inline uint64_t MurmurHash64B ( const void * key, int len, uint64_t seed
|
|||
return h;
|
||||
}
|
||||
|
||||
#endif /* CK_HT_HASH_H */
|
||||
#endif /* CK_HT_HASH_H */
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@
|
|||
long global_stack_size = 0;
|
||||
long global_heap_size = 0;
|
||||
|
||||
static void c_entry_pt(void *,int,closure,closure);
|
||||
static void c_entry_pt(void *, int, closure, closure);
|
||||
static void Cyc_heap_init(long heap_size);
|
||||
|
||||
static void Cyc_heap_init(long heap_size)
|
||||
|
|
@ -27,4 +27,4 @@ static void Cyc_heap_init(long heap_size)
|
|||
gc_start_collector();
|
||||
}
|
||||
|
||||
#endif /* CYCLONE_RUNTIME_MAIN_H */
|
||||
#endif /* CYCLONE_RUNTIME_MAIN_H */
|
||||
|
|
|
|||
|
|
@ -20,10 +20,10 @@
|
|||
}
|
||||
|
||||
#define Cyc_check_type(data, fnc_test, tag, obj) { \
|
||||
if (eq(boolean_f, fnc_test(obj))) Cyc_invalid_type_error(data, tag, obj); }
|
||||
if ((boolean_f == fnc_test(obj))) Cyc_invalid_type_error(data, tag, obj); }
|
||||
|
||||
#define Cyc_check_cons_or_nil(d,obj) { if (!nullp(obj)) { Cyc_check_cons(d,obj); }}
|
||||
#define Cyc_check_cons(d,obj) Cyc_check_type(d,Cyc_is_cons, cons_tag, obj);
|
||||
#define Cyc_check_pair_or_null(d,obj) { if (obj != NULL) { Cyc_check_pair(d,obj); }}
|
||||
#define Cyc_check_pair(d,obj) Cyc_check_type(d,Cyc_is_pair, pair_tag, obj);
|
||||
#define Cyc_check_num(d,obj) Cyc_check_type(d,Cyc_is_number, integer_tag, obj);
|
||||
#define Cyc_check_int(d,obj) Cyc_check_type(d,Cyc_is_integer, integer_tag, obj);
|
||||
#define Cyc_check_str(d,obj) Cyc_check_type(d,Cyc_is_string, string_tag, obj);
|
||||
|
|
@ -45,7 +45,7 @@ extern const object Cyc_EOF;
|
|||
object cell_get(object cell);
|
||||
|
||||
#define global_set(glo,value) Cyc_global_set(data, (object *)&glo, value)
|
||||
object Cyc_global_set(void *thd, object *glo, object value);
|
||||
object Cyc_global_set(void *thd, object * glo, object value);
|
||||
|
||||
/* Variable argument count support
|
||||
|
||||
|
|
@ -62,7 +62,7 @@ object Cyc_global_set(void *thd, object *glo, object value);
|
|||
args and the number of provided ones, and pass the difference as 'count'
|
||||
*/
|
||||
#define load_varargs(var, arg_var, count) \
|
||||
list var = (count > 0) ? alloca(sizeof(cons_type)*count) : nil; \
|
||||
list var = (count > 0) ? alloca(sizeof(pair_type)*count) : NULL; \
|
||||
{ \
|
||||
int i; \
|
||||
object tmp; \
|
||||
|
|
@ -77,9 +77,9 @@ object Cyc_global_set(void *thd, object *glo, object value);
|
|||
} \
|
||||
var[i].hdr.mark = gc_color_red; \
|
||||
var[i].hdr.grayed = 0; \
|
||||
var[i].tag = cons_tag; \
|
||||
var[i].cons_car = tmp; \
|
||||
var[i].cons_cdr = (i == (count-1)) ? nil : &var[i + 1]; \
|
||||
var[i].tag = pair_tag; \
|
||||
var[i].pair_car = tmp; \
|
||||
var[i].pair_cdr = (i == (count-1)) ? NULL : &var[i + 1]; \
|
||||
} \
|
||||
va_end(va); \
|
||||
} \
|
||||
|
|
@ -127,16 +127,19 @@ object Cyc_set_cvar(object var, object value);
|
|||
object apply(void *data, object cont, object func, object args);
|
||||
void Cyc_apply(void *data, int argc, closure cont, object prim, ...);
|
||||
object Cyc_string_cmp(void *data, object str1, object str2);
|
||||
void dispatch_string_91append(void *data, int argc, object clo, object cont, object str1, ...);
|
||||
list mcons(object,object);
|
||||
cvar_type *mcvar(object *var);
|
||||
object Cyc_display(object, FILE *port);
|
||||
object dispatch_display_va(void *data, int argc, object clo, object cont, object x, ...);
|
||||
void dispatch_string_91append(void *data, int argc, object clo, object cont,
|
||||
object str1, ...);
|
||||
list mcons(object, object);
|
||||
cvar_type *mcvar(object * var);
|
||||
object Cyc_display(object, FILE * port);
|
||||
object dispatch_display_va(void *data, int argc, object clo, object cont,
|
||||
object x, ...);
|
||||
object Cyc_display_va(int argc, object x, ...);
|
||||
object Cyc_display_va_list(int argc, object x, va_list ap);
|
||||
object Cyc_write_char(void *data, object c, object port);
|
||||
object Cyc_write(object, FILE *port);
|
||||
object dispatch_write_va(void *data, int argc, object clo, object cont, object x, ...);
|
||||
object Cyc_write_char(void *data, object c, object port);
|
||||
object Cyc_write(object, FILE * port);
|
||||
object dispatch_write_va(void *data, int argc, object clo, object cont,
|
||||
object x, ...);
|
||||
object Cyc_write_va(int argc, object x, ...);
|
||||
object Cyc_write_va_list(int argc, object x, va_list ap);
|
||||
|
||||
|
|
@ -144,17 +147,19 @@ object Cyc_has_cycle(object lst);
|
|||
object Cyc_num_eq(void *, object cont, int argc, object n, ...);
|
||||
object Cyc_num_gt(void *, object cont, int argc, object n, ...);
|
||||
object Cyc_num_lt(void *, object cont, int argc, object n, ...);
|
||||
object Cyc_num_gte(void *,object cont, int argc, object n, ...);
|
||||
object Cyc_num_lte(void *,object cont, int argc, object n, ...);
|
||||
object Cyc_num_gte(void *, object cont, int argc, object n, ...);
|
||||
object Cyc_num_lte(void *, object cont, int argc, object n, ...);
|
||||
int Cyc_num_eq_op(void *, object x, object y);
|
||||
int Cyc_num_gt_op(void *, object x, object y);
|
||||
int Cyc_num_lt_op(void *, object x, object y);
|
||||
int Cyc_num_gte_op(void *,object x, object y);
|
||||
int Cyc_num_lte_op(void *,object x, object y);
|
||||
object Cyc_num_cmp_va_list(void *data, int argc, int (fn_op(void *, object, object)), object n, va_list ns);
|
||||
int Cyc_num_gte_op(void *, object x, object y);
|
||||
int Cyc_num_lte_op(void *, object x, object y);
|
||||
object Cyc_num_cmp_va_list(void *data, int argc,
|
||||
int (fn_op(void *, object, object)), object n,
|
||||
va_list ns);
|
||||
object Cyc_eq(object x, object y);
|
||||
object Cyc_set_car(void *, object l, object val) ;
|
||||
object Cyc_set_cdr(void *, object l, object val) ;
|
||||
object Cyc_set_car(void *, object l, object val);
|
||||
object Cyc_set_cdr(void *, object l, object val);
|
||||
object Cyc_length(void *d, object l);
|
||||
integer_type Cyc_length_as_object(void *d, object l);
|
||||
object Cyc_vector_length(void *data, object v);
|
||||
|
|
@ -164,15 +169,19 @@ object Cyc_make_vector(void *data, object cont, int argc, object len, ...);
|
|||
object Cyc_make_bytevector(void *data, object cont, int argc, object len, ...);
|
||||
object Cyc_bytevector(void *data, object cont, int argc, object bval, ...);
|
||||
object Cyc_bytevector_length(void *data, object bv);
|
||||
object Cyc_bytevector_append(void *data, object cont, int _argc, object bv, ...);
|
||||
object Cyc_bytevector_copy(void *data, object cont, object bv, object start, object end);
|
||||
object Cyc_bytevector_append(void *data, object cont, int _argc, object bv,
|
||||
...);
|
||||
object Cyc_bytevector_copy(void *data, object cont, object bv, object start,
|
||||
object end);
|
||||
object Cyc_bytevector_u8_ref(void *data, object bv, object k);
|
||||
object Cyc_bytevector_u8_set(void *data, object bv, object k, object b);
|
||||
object Cyc_utf82string(void *data, object cont, object bv, object start, object end);
|
||||
object Cyc_string2utf8(void *data, object cont, object str, object start, object end);
|
||||
object Cyc_utf82string(void *data, object cont, object bv, object start,
|
||||
object end);
|
||||
object Cyc_string2utf8(void *data, object cont, object str, object start,
|
||||
object end);
|
||||
object Cyc_list2vector(void *data, object cont, object l);
|
||||
object Cyc_number2string2(void *data, object cont, int argc, object n, ...);
|
||||
object Cyc_symbol2string(void *d, object cont, object sym) ;
|
||||
object Cyc_symbol2string(void *d, object cont, object sym);
|
||||
object Cyc_string2symbol(void *d, object str);
|
||||
object Cyc_list2string(void *d, object cont, object lst);
|
||||
object Cyc_string2number_(void *d, object cont, object str);
|
||||
|
|
@ -182,7 +191,8 @@ int octstr2int(const char *str);
|
|||
int hexstr2int(const char *str);
|
||||
object Cyc_string_append(void *data, object cont, int argc, object str1, ...);
|
||||
object Cyc_string_length(void *data, object str);
|
||||
object Cyc_substring(void *data, object cont, object str, object start, object end);
|
||||
object Cyc_substring(void *data, object cont, object str, object start,
|
||||
object end);
|
||||
object Cyc_string_ref(void *data, object str, object k);
|
||||
object Cyc_string_set(void *data, object str, object k, object chr);
|
||||
object Cyc_installation_dir(void *data, object cont, object type);
|
||||
|
|
@ -190,7 +200,7 @@ object Cyc_command_line_arguments(void *data, object cont);
|
|||
object Cyc_system(object cmd);
|
||||
object Cyc_char2integer(object chr);
|
||||
object Cyc_integer2char(void *data, object n);
|
||||
void Cyc_halt(closure);
|
||||
void Cyc_halt(object obj);
|
||||
object __halt(object obj);
|
||||
port_type Cyc_stdout(void);
|
||||
port_type Cyc_stdin(void);
|
||||
|
|
@ -208,7 +218,7 @@ object Cyc_io_peek_char(void *data, object cont, object port);
|
|||
object Cyc_io_read_line(void *data, object cont, object port);
|
||||
|
||||
object Cyc_is_boolean(object o);
|
||||
object Cyc_is_cons(object o);
|
||||
object Cyc_is_pair(object o);
|
||||
object Cyc_is_null(object o);
|
||||
object Cyc_is_number(object o);
|
||||
object Cyc_is_real(object o);
|
||||
|
|
@ -225,53 +235,54 @@ object Cyc_is_procedure(void *data, object o);
|
|||
object Cyc_is_macro(object o);
|
||||
object Cyc_is_eof_object(object o);
|
||||
object Cyc_is_cvar(object o);
|
||||
object Cyc_sum_op(void *data, common_type *x, object y);
|
||||
object Cyc_sub_op(void *data, common_type *x, object y);
|
||||
object Cyc_mul_op(void *data, common_type *x, object y);
|
||||
object Cyc_div_op(void *data, common_type *x, object y);
|
||||
object Cyc_is_opaque(object o);
|
||||
object Cyc_sum_op(void *data, common_type * x, object y);
|
||||
object Cyc_sub_op(void *data, common_type * x, object y);
|
||||
object Cyc_mul_op(void *data, common_type * x, object y);
|
||||
object Cyc_div_op(void *data, common_type * x, object y);
|
||||
object Cyc_sum(void *data, object cont, int argc, object n, ...);
|
||||
object Cyc_sub(void *data, object cont, int argc, object n, ...);
|
||||
object Cyc_mul(void *data, object cont, int argc, object n, ...);
|
||||
object Cyc_div(void *data, object cont, int argc, object n, ...);
|
||||
object Cyc_num_op_va_list(void *data, int argc, object (fn_op(void *, common_type *, object)), int default_no_args, int default_one_arg, object n, va_list ns, common_type *buf);
|
||||
int equal(object,object);
|
||||
list assq(void *,object,list);
|
||||
list assoc(void *,object x, list l);
|
||||
object get(object,object);
|
||||
object equalp(object,object);
|
||||
object memberp(void *,object,list);
|
||||
object memqp(void *,object,list);
|
||||
object Cyc_num_op_va_list(void *data, int argc,
|
||||
object(fn_op(void *, common_type *, object)),
|
||||
int default_no_args, int default_one_arg, object n,
|
||||
va_list ns, common_type * buf);
|
||||
int equal(object, object);
|
||||
list assq(void *, object, list);
|
||||
list assoc(void *, object x, list l);
|
||||
object equalp(object, object);
|
||||
object memberp(void *, object, list);
|
||||
object memqp(void *, object, list);
|
||||
|
||||
object Cyc_spawn_thread(object thunk);
|
||||
void Cyc_start_trampoline(gc_thread_data *thd);
|
||||
void Cyc_end_thread(gc_thread_data *thd);
|
||||
void Cyc_exit_thread(gc_thread_data *thd);
|
||||
void Cyc_start_trampoline(gc_thread_data * thd);
|
||||
void Cyc_end_thread(gc_thread_data * thd);
|
||||
void Cyc_exit_thread(gc_thread_data * thd);
|
||||
object Cyc_thread_sleep(void *data, object timeout);
|
||||
void GC(void *,closure,object*,int);
|
||||
void GC(void *, closure, object *, int);
|
||||
object Cyc_trigger_minor_gc(void *data, object cont);
|
||||
object copy2heap(void *data, object obj);
|
||||
|
||||
void Cyc_st_add(void *data, char *frame);
|
||||
void Cyc_st_print(void *data, FILE *out);
|
||||
void Cyc_st_print(void *data, FILE * out);
|
||||
|
||||
char *_strdup (const char *s);
|
||||
object add_symbol(symbol_type *psym);
|
||||
char *_strdup(const char *s);
|
||||
object add_symbol(symbol_type * psym);
|
||||
object add_symbol_by_name(const char *name);
|
||||
object find_symbol_by_name(const char *name);
|
||||
object find_or_add_symbol(const char *name);
|
||||
|
||||
extern list global_table;
|
||||
void add_global(object *glo);
|
||||
void add_global(object * glo);
|
||||
|
||||
void dispatch(void *data, int argc, function_type func, object clo, object cont, object args);
|
||||
void dispatch_va(void *data, int argc, function_type_va func, object clo, object cont, object args);
|
||||
void do_dispatch(void *data, int argc, function_type func, object clo, object *buffer);
|
||||
void dispatch(void *data, int argc, function_type func, object clo, object cont,
|
||||
object args);
|
||||
void dispatch_va(void *data, int argc, function_type_va func, object clo,
|
||||
object cont, object args);
|
||||
void do_dispatch(void *data, int argc, function_type func, object clo,
|
||||
object * buffer);
|
||||
|
||||
/* Global variables. */
|
||||
extern long no_gcs; /* Count the number of GC's. */
|
||||
extern long no_major_gcs; /* Count the number of GC's. */
|
||||
|
||||
/* Define Lisp constants we need. */
|
||||
extern const object boolean_t;
|
||||
extern const object boolean_f;
|
||||
extern const object quote_void;
|
||||
|
|
@ -422,10 +433,11 @@ extern object Cyc_glo_call_cc;
|
|||
#define __glo_call_95cc_scheme_base Cyc_glo_call_cc
|
||||
|
||||
/* Exception handling */
|
||||
object Cyc_default_exception_handler(void *data, int argc, closure _, object err);
|
||||
object Cyc_default_exception_handler(void *data, int argc, closure _,
|
||||
object err);
|
||||
object Cyc_current_exception_handler(void *data);
|
||||
void Cyc_rt_raise(void *data, object err);
|
||||
void Cyc_rt_raise2(void *data, const char *msg, object err);
|
||||
void Cyc_rt_raise_msg(void *data, const char *err);
|
||||
|
||||
#endif /* CYCLONE_RUNTIME_H */
|
||||
#endif /* CYCLONE_RUNTIME_H */
|
||||
|
|
|
|||
|
|
@ -9,17 +9,17 @@
|
|||
#ifndef CYCLONE_TYPES_H
|
||||
#define CYCLONE_TYPES_H
|
||||
|
||||
#include <stdlib.h>
|
||||
#include <stdio.h>
|
||||
#include <time.h>
|
||||
#include <math.h>
|
||||
#include <setjmp.h>
|
||||
#include <stdarg.h>
|
||||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
#include <math.h>
|
||||
#include <time.h>
|
||||
#include <pthread.h>
|
||||
|
||||
// Maximum number of args that GC will accept
|
||||
#define NUM_GC_ANS 128
|
||||
#define NUM_GC_ARGS 128
|
||||
|
||||
// Which way does the CPU grow its stack?
|
||||
#define STACK_GROWTH_IS_DOWNWARD 1
|
||||
|
|
@ -28,8 +28,10 @@
|
|||
// This is used as the first generation of the GC.
|
||||
#define STACK_SIZE 500000
|
||||
|
||||
// Size of a "page" on the heap (the second generation), in bytes.
|
||||
#define HEAP_SIZE (16 * 1024 * 1024)
|
||||
// Parameters for size of a "page" on the heap (the second generation GC), in bytes.
|
||||
#define GROW_HEAP_BY_SIZE (2 * 1024 * 1024) // Grow first page by adding this amount to it
|
||||
#define INITIAL_HEAP_SIZE (3 * 1024 * 1024) // Size of the first page
|
||||
#define HEAP_SIZE (16 * 1024 * 1024) // Normal size of a page
|
||||
|
||||
/////////////////////////////
|
||||
// Major GC tuning parameters
|
||||
|
|
@ -60,16 +62,42 @@
|
|||
// General constants
|
||||
#define NANOSECONDS_PER_MILLISECOND 1000000
|
||||
|
||||
/* Define general object type. */
|
||||
// Generic object type
|
||||
typedef void *object;
|
||||
|
||||
// Define a tag for each possible type of object.
|
||||
// Remember to update tag_names in runtime.c when adding new tags
|
||||
enum object_tag {
|
||||
boolean_tag = 0 // 0
|
||||
, bytevector_tag // 1
|
||||
, c_opaque_tag // 2
|
||||
, closure0_tag // 3
|
||||
, closure1_tag // 4
|
||||
, closureN_tag // 5
|
||||
, cond_var_tag // 6
|
||||
, cvar_tag // 7
|
||||
, double_tag // 8
|
||||
, eof_tag // 9
|
||||
, forward_tag // 10
|
||||
, integer_tag // 11
|
||||
, macro_tag // 12
|
||||
, mutex_tag // 13
|
||||
, pair_tag // 14
|
||||
, port_tag // 15
|
||||
, primitive_tag // 16
|
||||
, string_tag // 17
|
||||
, symbol_tag // 18
|
||||
, vector_tag // 19
|
||||
};
|
||||
|
||||
// Define the size of object tags
|
||||
typedef unsigned char tag_type;
|
||||
|
||||
/* Threading */
|
||||
typedef enum { CYC_THREAD_STATE_NEW
|
||||
, CYC_THREAD_STATE_RUNNABLE
|
||||
, CYC_THREAD_STATE_BLOCKED
|
||||
, CYC_THREAD_STATE_BLOCKED_COOPERATING
|
||||
, CYC_THREAD_STATE_TERMINATED
|
||||
} cyc_thread_state_type;
|
||||
typedef enum { CYC_THREAD_STATE_NEW, CYC_THREAD_STATE_RUNNABLE,
|
||||
CYC_THREAD_STATE_BLOCKED, CYC_THREAD_STATE_BLOCKED_COOPERATING,
|
||||
CYC_THREAD_STATE_TERMINATED
|
||||
} cyc_thread_state_type;
|
||||
|
||||
/* Thread data structures */
|
||||
typedef struct gc_thread_data_t gc_thread_data;
|
||||
|
|
@ -111,6 +139,9 @@ struct gc_thread_data_t {
|
|||
|
||||
/* GC data structures */
|
||||
|
||||
typedef enum { HEAP_SM = 0, HEAP_MED, HEAP_REST
|
||||
} cached_heap_type;
|
||||
|
||||
typedef struct gc_free_list_t gc_free_list;
|
||||
struct gc_free_list_t {
|
||||
unsigned int size;
|
||||
|
|
@ -120,79 +151,53 @@ struct gc_free_list_t {
|
|||
typedef struct gc_heap_t gc_heap;
|
||||
struct gc_heap_t {
|
||||
unsigned int size;
|
||||
unsigned int chunk_size; // 0 for any size, other and heap will only alloc chunks of that size
|
||||
unsigned int chunk_size; // 0 for any size, other and heap will only alloc chunks of that size
|
||||
unsigned int max_size;
|
||||
//unsigned int free_size;
|
||||
gc_free_list *free_list;
|
||||
gc_heap *next; // TBD, linked list is not very efficient, but easy to work with as a start
|
||||
gc_heap *next; // TBD, linked list is not very efficient, but easy to work with as a start
|
||||
char *data;
|
||||
};
|
||||
|
||||
typedef struct gc_heap_root_t gc_heap_root;
|
||||
struct gc_heap_root_t {
|
||||
gc_heap *small_obj_heap;
|
||||
gc_heap *medium_obj_heap;
|
||||
gc_heap *heap;
|
||||
};
|
||||
|
||||
typedef struct gc_header_type_t gc_header_type;
|
||||
struct gc_header_type_t {
|
||||
unsigned int mark; // mark bits (TODO: only need 2, reduce size of type?)
|
||||
unsigned char grayed; // stack object to be grayed when moved to heap
|
||||
unsigned char mark; // mark bits (only need 2)
|
||||
unsigned char grayed; // stack object to be grayed when moved to heap
|
||||
};
|
||||
#define mark(x) (((list) x)->hdr.mark)
|
||||
#define grayed(x) (((list) x)->hdr.grayed)
|
||||
|
||||
/* Enums for tri-color marking */
|
||||
typedef enum { STATUS_ASYNC
|
||||
, STATUS_SYNC1
|
||||
, STATUS_SYNC2
|
||||
} gc_status_type;
|
||||
typedef enum { STATUS_ASYNC, STATUS_SYNC1, STATUS_SYNC2
|
||||
} gc_status_type;
|
||||
|
||||
typedef enum { STAGE_CLEAR_OR_MARKING
|
||||
, STAGE_TRACING
|
||||
//, STAGE_REF_PROCESSING
|
||||
, STAGE_SWEEPING
|
||||
, STAGE_RESTING
|
||||
} gc_stage_type;
|
||||
typedef enum { STAGE_CLEAR_OR_MARKING, STAGE_TRACING
|
||||
//, STAGE_REF_PROCESSING
|
||||
, STAGE_SWEEPING, STAGE_RESTING
|
||||
} gc_stage_type;
|
||||
|
||||
// Constant colors are defined here.
|
||||
// The mark/clear colors are defined in the gc module because
|
||||
// the collector swaps their values as an optimization.
|
||||
#define gc_color_red 0 // Memory not to be GC'd, such as on the stack
|
||||
#define gc_color_blue 2 // Unallocated memory
|
||||
#define gc_color_red 0 // Memory not to be GC'd, such as on the stack
|
||||
#define gc_color_blue 2 // Unallocated memory
|
||||
|
||||
/* Define size of object tags */
|
||||
typedef long tag_type;
|
||||
|
||||
/* Determine if stack has overflowed */
|
||||
// Determine if stack has overflowed
|
||||
#if STACK_GROWTH_IS_DOWNWARD
|
||||
#define stack_overflow(x,y) ((x) < (y))
|
||||
#else
|
||||
#define stack_overflow(x,y) ((x) > (y))
|
||||
#endif
|
||||
|
||||
/* Define object tag values. Could be an enum...
|
||||
Remember to update tag_names in runtime.c when adding new tags */
|
||||
#define cons_tag 0
|
||||
#define symbol_tag 1
|
||||
#define forward_tag 2
|
||||
#define closure0_tag 3
|
||||
#define closure1_tag 4
|
||||
#define closureN_tag 8
|
||||
#define integer_tag 9
|
||||
#define double_tag 10
|
||||
#define string_tag 11
|
||||
#define primitive_tag 12
|
||||
#define eof_tag 13
|
||||
#define port_tag 14
|
||||
#define boolean_tag 15
|
||||
#define cvar_tag 16
|
||||
#define vector_tag 17
|
||||
#define macro_tag 18
|
||||
#define mutex_tag 19
|
||||
#define cond_var_tag 20
|
||||
#define bytevector_tag 21
|
||||
|
||||
#define nil NULL
|
||||
#define eq(x,y) (x == y)
|
||||
#define nullp(x) (x == NULL)
|
||||
|
||||
#define type_of(x) (((list) x)->tag)
|
||||
#define forward(x) (((list) x)->cons_car)
|
||||
#define type_of(obj) (((pair_type *) obj)->tag)
|
||||
#define forward(obj) (((pair_type *) obj)->pair_car)
|
||||
|
||||
/** Define value types.
|
||||
* Depending on the underlying architecture, compiler, etc these types
|
||||
|
|
@ -220,62 +225,141 @@ typedef long tag_type;
|
|||
|
||||
/* Function type */
|
||||
|
||||
typedef void (*function_type)();
|
||||
typedef void (*function_type_va)(int, object, object, object, ...);
|
||||
typedef void (*function_type) ();
|
||||
typedef void (*function_type_va) (int, object, object, object, ...);
|
||||
|
||||
/* Define C-variable integration type */
|
||||
typedef struct {gc_header_type hdr; tag_type tag; object *pvar;} cvar_type;
|
||||
typedef struct {
|
||||
gc_header_type hdr;
|
||||
tag_type tag;
|
||||
object *pvar; /* GC assumes this is a Cyclone object! */
|
||||
} cvar_type;
|
||||
typedef cvar_type *cvar;
|
||||
#define make_cvar(n,v) cvar_type n; n.hdr.mark = gc_color_red; n.hdr.grayed = 0; n.tag = cvar_tag; n.pvar = v;
|
||||
#define make_cvar(n,v) \
|
||||
cvar_type n; \
|
||||
n.hdr.mark = gc_color_red; \
|
||||
n.hdr.grayed = 0; \
|
||||
n.tag = cvar_tag; \
|
||||
n.pvar = v;
|
||||
|
||||
/* C Opaque type - a wrapper around a pointer of any type.
|
||||
Note this requires application code to free any memory
|
||||
before an object is collected by GC. */
|
||||
typedef struct {
|
||||
gc_header_type hdr;
|
||||
tag_type tag;
|
||||
void *ptr; /* Can be anything, GC will not collect it */
|
||||
} c_opaque_type;
|
||||
typedef c_opaque_type *c_opaque;
|
||||
#define make_c_opaque(var, p) \
|
||||
c_opaque_type var; \
|
||||
var.hdr.mark = gc_color_red; \
|
||||
var.hdr.grayed = 0; \
|
||||
var.tag = c_opaque_tag; \
|
||||
var.ptr = p;
|
||||
|
||||
#define opaque_ptr(x) (((c_opaque)x)->ptr)
|
||||
|
||||
/* Define mutex type */
|
||||
typedef struct {gc_header_type hdr; tag_type tag; pthread_mutex_t lock;} mutex_type;
|
||||
typedef struct {
|
||||
gc_header_type hdr;
|
||||
tag_type tag;
|
||||
pthread_mutex_t lock;
|
||||
} mutex_type;
|
||||
typedef mutex_type *mutex;
|
||||
|
||||
/* Define condition variable type */
|
||||
typedef struct {gc_header_type hdr; tag_type tag; pthread_cond_t cond;} cond_var_type;
|
||||
typedef struct {
|
||||
gc_header_type hdr;
|
||||
tag_type tag;
|
||||
pthread_cond_t cond;
|
||||
} cond_var_type;
|
||||
typedef cond_var_type *cond_var;
|
||||
|
||||
/* Define boolean type. */
|
||||
typedef struct {gc_header_type hdr; const tag_type tag; const char *pname;} boolean_type;
|
||||
typedef struct {
|
||||
gc_header_type hdr;
|
||||
const tag_type tag;
|
||||
const char *pname;
|
||||
} boolean_type;
|
||||
typedef boolean_type *boolean;
|
||||
|
||||
#define boolean_pname(x) (((boolean_type *) x)->pname)
|
||||
|
||||
/* Define symbol type. */
|
||||
|
||||
typedef struct {gc_header_type hdr; const tag_type tag; const char *pname; object plist;} symbol_type;
|
||||
typedef struct {
|
||||
gc_header_type hdr;
|
||||
const tag_type tag;
|
||||
const char *pname;
|
||||
object plist;
|
||||
} symbol_type;
|
||||
typedef symbol_type *symbol;
|
||||
|
||||
#define symbol_pname(x) (((symbol_type *) x)->pname)
|
||||
#define symbol_plist(x) (((symbol_type *) x)->plist)
|
||||
|
||||
#define defsymbol(name) \
|
||||
static object quote_##name = nil;
|
||||
static object quote_##name = NULL;
|
||||
|
||||
/* Define numeric types */
|
||||
typedef struct {gc_header_type hdr; tag_type tag; int value; int padding;} integer_type;
|
||||
#define make_int(n,v) integer_type n; n.hdr.mark = gc_color_red; n.hdr.grayed = 0; n.tag = integer_tag; n.value = v;
|
||||
typedef struct {gc_header_type hdr; tag_type tag; double value;} double_type;
|
||||
#define make_double(n,v) double_type n; n.hdr.mark = gc_color_red; n.hdr.grayed = 0; n.tag = double_tag; n.value = v;
|
||||
|
||||
// Integer object type is still included for now, but ints
|
||||
// should be stored using value types instead.
|
||||
typedef struct {
|
||||
gc_header_type hdr;
|
||||
tag_type tag;
|
||||
int value;
|
||||
int padding; // Prevent mem corruption if sizeof(int) < sizeof(ptr)
|
||||
} integer_type;
|
||||
#define make_int(n,v) \
|
||||
integer_type n; \
|
||||
n.hdr.mark = gc_color_red; \
|
||||
n.hdr.grayed = 0; \
|
||||
n.tag = integer_tag; \
|
||||
n.value = v;
|
||||
|
||||
typedef struct {
|
||||
gc_header_type hdr;
|
||||
tag_type tag;
|
||||
double value;
|
||||
} double_type;
|
||||
#define make_double(n,v) \
|
||||
double_type n; \
|
||||
n.hdr.mark = gc_color_red; \
|
||||
n.hdr.grayed = 0; \
|
||||
n.tag = double_tag; \
|
||||
n.value = v;
|
||||
|
||||
#define integer_value(x) (((integer_type *) x)->value)
|
||||
#define double_value(x) (((double_type *) x)->value)
|
||||
|
||||
/* Define string type */
|
||||
typedef struct {gc_header_type hdr; tag_type tag; int len; char *str;} string_type;
|
||||
typedef struct {
|
||||
gc_header_type hdr;
|
||||
tag_type tag;
|
||||
int len;
|
||||
char *str;
|
||||
} string_type;
|
||||
#define make_string(cs, s) string_type cs; \
|
||||
{ int len = strlen(s); cs.tag = string_tag; cs.len = len; cs.hdr.mark = gc_color_red; cs.hdr.grayed = 0; \
|
||||
{ int len = strlen(s); \
|
||||
cs.hdr.mark = gc_color_red; \
|
||||
cs.hdr.grayed = 0; \
|
||||
cs.tag = string_tag; \
|
||||
cs.len = len; \
|
||||
cs.str = alloca(sizeof(char) * (len + 1)); \
|
||||
memcpy(cs.str, s, len + 1);}
|
||||
#define make_string_with_len(cs, s, length) string_type cs; cs.hdr.mark = gc_color_red; cs.hdr.grayed = 0; \
|
||||
#define make_string_with_len(cs, s, length) string_type cs; \
|
||||
{ int len = length; \
|
||||
cs.hdr.mark = gc_color_red; \
|
||||
cs.hdr.grayed = 0; \
|
||||
cs.tag = string_tag; cs.len = len; \
|
||||
cs.str = alloca(sizeof(char) * (len + 1)); \
|
||||
memcpy(cs.str, s, len); \
|
||||
cs.str[len] = '\0';}
|
||||
#define make_string_noalloc(cs, s, length) string_type cs; cs.hdr.mark = gc_color_red; cs.hdr.grayed = 0; \
|
||||
{ cs.tag = string_tag; cs.len = length; \
|
||||
#define make_string_noalloc(cs, s, length) string_type cs; \
|
||||
{ cs.hdr.mark = gc_color_red; cs.hdr.grayed = 0; \
|
||||
cs.tag = string_tag; cs.len = length; \
|
||||
cs.str = s; }
|
||||
|
||||
#define string_len(x) (((string_type *) x)->len)
|
||||
|
|
@ -287,30 +371,79 @@ typedef struct {gc_header_type hdr; tag_type tag; int len; char *str;} string_ty
|
|||
// consider http://stackoverflow.com/questions/6206893/how-to-implement-char-ready-in-c
|
||||
// TODO: a simple wrapper around FILE may not be good enough long-term
|
||||
// TODO: how exactly mode will be used. need to know r/w, bin/txt
|
||||
typedef struct {gc_header_type hdr; tag_type tag; FILE *fp; int mode;} port_type;
|
||||
#define make_port(p,f,m) port_type p; p.hdr.mark = gc_color_red; p.hdr.grayed = 0; p.tag = port_tag; p.fp = f; p.mode = m;
|
||||
typedef struct {
|
||||
gc_header_type hdr;
|
||||
tag_type tag;
|
||||
FILE *fp;
|
||||
int mode;
|
||||
} port_type;
|
||||
#define make_port(p,f,m) \
|
||||
port_type p; \
|
||||
p.hdr.mark = gc_color_red; \
|
||||
p.hdr.grayed = 0; \
|
||||
p.tag = port_tag; \
|
||||
p.fp = f; \
|
||||
p.mode = m;
|
||||
|
||||
/* Vector type */
|
||||
|
||||
typedef struct {gc_header_type hdr; tag_type tag; int num_elt; object *elts;} vector_type;
|
||||
typedef struct {
|
||||
gc_header_type hdr;
|
||||
tag_type tag;
|
||||
int num_elements;
|
||||
object *elements;
|
||||
} vector_type;
|
||||
typedef vector_type *vector;
|
||||
|
||||
#define make_empty_vector(v) vector_type v; v.hdr.mark = gc_color_red; v.hdr.grayed = 0; v.tag = vector_tag; v.num_elt = 0; v.elts = NULL;
|
||||
#define make_empty_vector(v) \
|
||||
vector_type v; \
|
||||
v.hdr.mark = gc_color_red; \
|
||||
v.hdr.grayed = 0; \
|
||||
v.tag = vector_tag; \
|
||||
v.num_elements = 0; \
|
||||
v.elements = NULL;
|
||||
|
||||
/* Bytevector type */
|
||||
|
||||
typedef struct {gc_header_type hdr; tag_type tag; int len; char *data;} bytevector_type;
|
||||
typedef struct {
|
||||
gc_header_type hdr;
|
||||
tag_type tag;
|
||||
int len;
|
||||
char *data;
|
||||
} bytevector_type;
|
||||
typedef bytevector_type *bytevector;
|
||||
|
||||
#define make_empty_bytevector(v) bytevector_type v; v.hdr.mark = gc_color_red; v.hdr.grayed = 0; v.tag = bytevector_tag; v.len = 0; v.data = NULL;
|
||||
#define make_empty_bytevector(v) \
|
||||
bytevector_type v; \
|
||||
v.hdr.mark = gc_color_red; \
|
||||
v.hdr.grayed = 0; \
|
||||
v.tag = bytevector_tag; \
|
||||
v.len = 0; \
|
||||
v.data = NULL;
|
||||
|
||||
/* Pair (cons) type */
|
||||
|
||||
typedef struct {gc_header_type hdr; tag_type tag; object cons_car,cons_cdr;} cons_type;
|
||||
typedef cons_type *list;
|
||||
typedef struct {
|
||||
gc_header_type hdr;
|
||||
tag_type tag;
|
||||
object pair_car;
|
||||
object pair_cdr;
|
||||
} pair_type;
|
||||
typedef pair_type *list;
|
||||
typedef pair_type *pair;
|
||||
|
||||
#define car(x) (((list) x)->cons_car)
|
||||
#define cdr(x) (((list) x)->cons_cdr)
|
||||
#define make_pair(n,a,d) \
|
||||
pair_type n; \
|
||||
n.hdr.mark = gc_color_red; \
|
||||
n.hdr.grayed = 0; \
|
||||
n.tag = pair_tag; \
|
||||
n.pair_car = a; \
|
||||
n.pair_cdr = d;
|
||||
|
||||
#define make_cell(n,a) make_pair(n,a,NULL);
|
||||
|
||||
#define car(x) (((pair_type *) x)->pair_car)
|
||||
#define cdr(x) (((pair_type *) x)->pair_cdr)
|
||||
#define caar(x) (car(car(x)))
|
||||
#define cadr(x) (car(cdr(x)))
|
||||
#define cdar(x) (cdr(car(x)))
|
||||
|
|
@ -340,15 +473,35 @@ typedef cons_type *list;
|
|||
#define cdddar(x) (cdr(cdr(cdr(car(x)))))
|
||||
#define cddddr(x) (cdr(cdr(cdr(cdr(x)))))
|
||||
|
||||
#define make_cons(n,a,d) \
|
||||
cons_type n; n.hdr.mark = gc_color_red; n.hdr.grayed = 0; n.tag = cons_tag; n.cons_car = a; n.cons_cdr = d;
|
||||
|
||||
/* Closure types */
|
||||
|
||||
typedef struct {gc_header_type hdr; tag_type tag; function_type fn; int num_args; } macro_type;
|
||||
typedef struct {gc_header_type hdr; tag_type tag; function_type fn; int num_args; } closure0_type;
|
||||
typedef struct {gc_header_type hdr; tag_type tag; function_type fn; int num_args; object elt1;} closure1_type;
|
||||
typedef struct {gc_header_type hdr; tag_type tag; function_type fn; int num_args; int num_elt; object *elts;} closureN_type;
|
||||
typedef struct {
|
||||
gc_header_type hdr;
|
||||
tag_type tag;
|
||||
function_type fn;
|
||||
int num_args;
|
||||
} macro_type;
|
||||
typedef struct {
|
||||
gc_header_type hdr;
|
||||
tag_type tag;
|
||||
function_type fn;
|
||||
int num_args;
|
||||
} closure0_type;
|
||||
typedef struct {
|
||||
gc_header_type hdr;
|
||||
tag_type tag;
|
||||
function_type fn;
|
||||
int num_args;
|
||||
object element;
|
||||
} closure1_type;
|
||||
typedef struct {
|
||||
gc_header_type hdr;
|
||||
tag_type tag;
|
||||
function_type fn;
|
||||
int num_args;
|
||||
int num_elements;
|
||||
object *elements;
|
||||
} closureN_type;
|
||||
|
||||
typedef closure0_type *closure0;
|
||||
typedef closure1_type *closure1;
|
||||
|
|
@ -356,15 +509,38 @@ typedef closureN_type *closureN;
|
|||
typedef closure0_type *closure;
|
||||
typedef closure0_type *macro;
|
||||
|
||||
#define mmacro(c,f) macro_type c; c.hdr.mark = gc_color_red; c.hdr.grayed = 0; c.tag = macro_tag; c.fn = f; c.num_args = -1;
|
||||
#define mclosure0(c,f) closure0_type c; c.hdr.mark = gc_color_red; c.hdr.grayed = 0; c.tag = closure0_tag; c.fn = f; c.num_args = -1;
|
||||
#define mclosure1(c,f,a) closure1_type c; c.hdr.mark = gc_color_red; c.hdr.grayed = 0; c.tag = closure1_tag; \
|
||||
c.fn = f; c.num_args = -1; c.elt1 = a;
|
||||
#define mmacro(c,f) \
|
||||
macro_type c; \
|
||||
c.hdr.mark = gc_color_red; \
|
||||
c.hdr.grayed = 0; \
|
||||
c.tag = macro_tag; \
|
||||
c.fn = f; \
|
||||
c.num_args = -1;
|
||||
|
||||
#define make_cell(n,a) make_cons(n,a,nil);
|
||||
#define mclosure0(c,f) \
|
||||
closure0_type c; \
|
||||
c.hdr.mark = gc_color_red; \
|
||||
c.hdr.grayed = 0; \
|
||||
c.tag = closure0_tag; \
|
||||
c.fn = f; \
|
||||
c.num_args = -1;
|
||||
|
||||
#define mclosure1(c,f,a) \
|
||||
closure1_type c; \
|
||||
c.hdr.mark = gc_color_red; \
|
||||
c.hdr.grayed = 0; \
|
||||
c.tag = closure1_tag; \
|
||||
c.fn = f; \
|
||||
c.num_args = -1; \
|
||||
c.element = a;
|
||||
|
||||
/* Primitive types */
|
||||
typedef struct {gc_header_type hdr; tag_type tag; const char *pname; function_type fn;} primitive_type;
|
||||
typedef struct {
|
||||
gc_header_type hdr;
|
||||
tag_type tag;
|
||||
const char *pname;
|
||||
function_type fn;
|
||||
} primitive_type;
|
||||
typedef primitive_type *primitive;
|
||||
|
||||
#define defprimitive(name, pname, fnc) \
|
||||
|
|
@ -377,7 +553,7 @@ static const object primitive_##name = &name##_primitive
|
|||
/* All constant-size objects */
|
||||
typedef union {
|
||||
boolean_type boolean_t;
|
||||
cons_type cons_t;
|
||||
pair_type pair_t;
|
||||
symbol_type symbol_t;
|
||||
primitive_type primitive_t;
|
||||
integer_type integer_t;
|
||||
|
|
@ -391,32 +567,36 @@ void vpbuffer_free(void **buf);
|
|||
|
||||
/* GC prototypes */
|
||||
void gc_initialize();
|
||||
void gc_add_mutator(gc_thread_data *thd);
|
||||
void gc_remove_mutator(gc_thread_data *thd);
|
||||
gc_heap *gc_heap_create(size_t size, size_t max_size, size_t chunk_size);
|
||||
void gc_print_stats(gc_heap *h);
|
||||
int gc_grow_heap(gc_heap *h, size_t size, size_t chunk_size);
|
||||
char *gc_copy_obj(object hp, char *obj, gc_thread_data *thd);
|
||||
void *gc_try_alloc(gc_heap *h, size_t size, char *obj, gc_thread_data *thd);
|
||||
void *gc_alloc(gc_heap *h, size_t size, char *obj, gc_thread_data *thd, int *heap_grown);
|
||||
size_t gc_allocated_bytes(object obj, gc_free_list *q, gc_free_list *r);
|
||||
gc_heap *gc_heap_last(gc_heap *h);
|
||||
size_t gc_heap_total_size(gc_heap *h);
|
||||
void gc_add_mutator(gc_thread_data * thd);
|
||||
void gc_remove_mutator(gc_thread_data * thd);
|
||||
gc_heap *gc_heap_create(int heap_type, size_t size, size_t max_size,
|
||||
size_t chunk_size);
|
||||
void gc_print_stats(gc_heap * h);
|
||||
int gc_grow_heap(gc_heap * h, int heap_type, size_t size, size_t chunk_size);
|
||||
char *gc_copy_obj(object hp, char *obj, gc_thread_data * thd);
|
||||
void *gc_try_alloc(gc_heap * h, int heap_type, size_t size, char *obj,
|
||||
gc_thread_data * thd);
|
||||
void *gc_alloc(gc_heap_root * h, size_t size, char *obj, gc_thread_data * thd,
|
||||
int *heap_grown);
|
||||
size_t gc_allocated_bytes(object obj, gc_free_list * q, gc_free_list * r);
|
||||
gc_heap *gc_heap_last(gc_heap * h);
|
||||
size_t gc_heap_total_size(gc_heap * h);
|
||||
//size_t gc_heap_total_free_size(gc_heap *h);
|
||||
//size_t gc_collect(gc_heap *h, size_t *sum_freed);
|
||||
//void gc_mark(gc_heap *h, object obj);
|
||||
void gc_mark_globals(void);
|
||||
size_t gc_sweep(gc_heap *h, size_t *sum_freed_ptr);
|
||||
void gc_thr_grow_move_buffer(gc_thread_data *d);
|
||||
void gc_thr_add_to_move_buffer(gc_thread_data *d, int *alloci, object obj);
|
||||
void gc_thread_data_init(gc_thread_data *thd, int mut_num, char *stack_base, long stack_size);
|
||||
void gc_thread_data_free(gc_thread_data *thd);
|
||||
size_t gc_sweep(gc_heap * h, int heap_type, size_t * sum_freed_ptr);
|
||||
void gc_thr_grow_move_buffer(gc_thread_data * d);
|
||||
void gc_thr_add_to_move_buffer(gc_thread_data * d, int *alloci, object obj);
|
||||
void gc_thread_data_init(gc_thread_data * thd, int mut_num, char *stack_base,
|
||||
long stack_size);
|
||||
void gc_thread_data_free(gc_thread_data * thd);
|
||||
// Prototypes for mutator/collector:
|
||||
int gc_is_stack_obj(gc_thread_data *thd, object obj);
|
||||
void gc_mut_update(gc_thread_data *thd, object old_obj, object value);
|
||||
void gc_mut_cooperate(gc_thread_data *thd, int buf_len);
|
||||
void gc_mark_gray(gc_thread_data *thd, object obj);
|
||||
void gc_mark_gray2(gc_thread_data *thd, object obj);
|
||||
int gc_is_stack_obj(gc_thread_data * thd, object obj);
|
||||
void gc_mut_update(gc_thread_data * thd, object old_obj, object value);
|
||||
void gc_mut_cooperate(gc_thread_data * thd, int buf_len);
|
||||
void gc_mark_gray(gc_thread_data * thd, object obj);
|
||||
void gc_mark_gray2(gc_thread_data * thd, object obj);
|
||||
void gc_collector_trace();
|
||||
void gc_mark_black(object obj);
|
||||
void gc_collector_mark_gray(object parent, object obj);
|
||||
|
|
@ -425,8 +605,8 @@ void gc_handshake(gc_status_type s);
|
|||
void gc_post_handshake(gc_status_type s);
|
||||
void gc_wait_handshake();
|
||||
void gc_start_collector();
|
||||
void gc_mutator_thread_blocked(gc_thread_data *thd, object cont);
|
||||
void gc_mutator_thread_runnable(gc_thread_data *thd, object result);
|
||||
void gc_mutator_thread_blocked(gc_thread_data * thd, object cont);
|
||||
void gc_mutator_thread_runnable(gc_thread_data * thd, object result);
|
||||
#define set_thread_blocked(d, c) \
|
||||
gc_mutator_thread_blocked(((gc_thread_data *)d), (c))
|
||||
#define return_thread_runnable(d, r) \
|
||||
|
|
@ -435,10 +615,11 @@ void gc_mutator_thread_runnable(gc_thread_data *thd, object result);
|
|||
// set_thread_blocked((data), (cont)); \
|
||||
// body \
|
||||
// return_thread_runnable((data), (result));
|
||||
gc_heap *gc_get_heap();
|
||||
int gc_minor(void *data, object low_limit, object high_limit, closure cont, object *args, int num_args);
|
||||
gc_heap_root *gc_get_heap();
|
||||
int gc_minor(void *data, object low_limit, object high_limit, closure cont,
|
||||
object * args, int num_args);
|
||||
/* Mutation table to support minor GC write barrier */
|
||||
void add_mutation(void *data, object var, int index, object value);
|
||||
void clear_mutations(void *data);
|
||||
|
||||
#endif /* CYCLONE_TYPES_H */
|
||||
#endif /* CYCLONE_TYPES_H */
|
||||
|
|
|
|||
|
|
@ -877,7 +877,7 @@
|
|||
(define-c Cyc-add-exception-handler
|
||||
"(void *data, int argc, closure _, object k, object h)"
|
||||
" gc_thread_data *thd = (gc_thread_data *)data;
|
||||
make_cons(c, h, thd->exception_handler_stack);
|
||||
make_pair(c, h, thd->exception_handler_stack);
|
||||
thd->exception_handler_stack = &c;
|
||||
return_closcall1(data, k, &c); ")
|
||||
(define-c Cyc-remove-exception-handler
|
||||
|
|
|
|||
|
|
@ -127,8 +127,13 @@
|
|||
" char top; \\\n"
|
||||
" if (stack_overflow(&top, (((gc_thread_data *)data)->stack_limit))) { \\\n"
|
||||
" object buf[" n "]; " arry-assign "\\\n"
|
||||
" GC(td,clo,buf," n "); return; \\\n"
|
||||
" } else {closcall" n "(td,(closure) (clo)" args "); return;}}\n")))
|
||||
" GC(td, clo, buf, " n "); \\\n"
|
||||
" return; \\\n"
|
||||
" } else {\\\n"
|
||||
" closcall" n "(td, (closure) (clo)" args "); \\\n"
|
||||
" return;\\\n"
|
||||
" } \\\n"
|
||||
"}\n")))
|
||||
|
||||
(define (c-macro-return-direct num-args)
|
||||
(let ((args (c-macro-n-prefix num-args ",a"))
|
||||
|
|
@ -141,8 +146,11 @@
|
|||
" if (stack_overflow(&top, (((gc_thread_data *)data)->stack_limit))) { \\\n"
|
||||
" object buf[" n "]; " arry-assign " \\\n"
|
||||
" mclosure0(c1, _fn); \\\n"
|
||||
" GC(td, &c1, buf, " n "); return; \\\n"
|
||||
" } else { (_fn)(td," n ",(closure)_fn" args "); }}\n")))
|
||||
" GC(td, &c1, buf, " n "); \\\n"
|
||||
" return; \\\n"
|
||||
" } else { \\\n"
|
||||
" (_fn)(td, " n ", (closure)_fn" args "); \\\n"
|
||||
" }}\n")))
|
||||
|
||||
(define (c-macro-closcall num-args)
|
||||
(let ((args (c-macro-n-prefix num-args ",a"))
|
||||
|
|
@ -150,11 +158,13 @@
|
|||
(n-1 (number->string (if (> num-args 0) (- num-args 1) 0)))
|
||||
(wrap (lambda (s) (if (> num-args 0) s ""))))
|
||||
(string-append
|
||||
"#define closcall" n "(td,clo" args ") "
|
||||
(wrap (string-append "if (type_of(clo) == cons_tag || prim(clo)) { Cyc_apply(td," n-1 ", (closure)(a1), clo" (if (> num-args 1) (substring args 3 (string-length args)) "") "); }"))
|
||||
(wrap " else { ")
|
||||
"((clo)->fn)(td," n ",clo" args ")"
|
||||
(wrap ";}")
|
||||
"#define closcall" n "(td, clo" args ") \\\n"
|
||||
(wrap (string-append "if (type_of(clo) == pair_tag || prim(clo)) { \\\n"
|
||||
" Cyc_apply(td, " n-1 ", (closure)(a1), clo" (if (> num-args 1) (substring args 3 (string-length args)) "") "); \\\n"
|
||||
"}"))
|
||||
(wrap " else { \\\n")
|
||||
" ((clo)->fn)(td, " n ", clo" args ")"
|
||||
(wrap ";\\\n}")
|
||||
)))
|
||||
|
||||
(define (c-macro-n-prefix n prefix)
|
||||
|
|
@ -282,7 +292,7 @@
|
|||
;; this is experimental and probably needs refinement
|
||||
;; trace - trace information. presently a pair containing:
|
||||
;; * source file
|
||||
;; * function name (or nil if none)
|
||||
;; * function name (or NULL if none)
|
||||
(define (c-compile-exp exp append-preamble cont trace)
|
||||
(cond
|
||||
; Core forms:
|
||||
|
|
@ -322,14 +332,14 @@
|
|||
(create-cons
|
||||
(lambda (cvar a b)
|
||||
(c-code/vars
|
||||
(string-append "make_cons(" cvar "," (c:body a) "," (c:body b) ");")
|
||||
(string-append "make_pair(" cvar "," (c:body a) "," (c:body b) ");")
|
||||
(append (c:allocs a) (c:allocs b))))
|
||||
)
|
||||
(_c-compile-scalars
|
||||
(lambda (args)
|
||||
(cond
|
||||
((null? args)
|
||||
(c-code "nil"))
|
||||
(c-code "NULL"))
|
||||
((not (pair? args))
|
||||
(c-compile-const args))
|
||||
(else
|
||||
|
|
@ -368,7 +378,7 @@
|
|||
(c:allocs idx-code) ;; Member alloc at index i
|
||||
(list ;; Assign this member to vector
|
||||
(string-append
|
||||
cvar-name ".elts[" (number->string i) "] = "
|
||||
cvar-name ".elements[" (number->string i) "] = "
|
||||
(c:body idx-code)
|
||||
";")))))))))
|
||||
)
|
||||
|
|
@ -386,8 +396,8 @@
|
|||
(list ; Allocate the vector
|
||||
(string-append
|
||||
"make_empty_vector(" cvar-name ");"
|
||||
cvar-name ".num_elt = " (number->string len) ";"
|
||||
cvar-name ".elts = (object *)alloca(sizeof(object) * "
|
||||
cvar-name ".num_elements = " (number->string len) ";"
|
||||
cvar-name ".elements = (object *)alloca(sizeof(object) * "
|
||||
(number->string len) ");")))))
|
||||
(loop 0 code))))))
|
||||
|
||||
|
|
@ -443,7 +453,7 @@
|
|||
(define (c-compile-const exp)
|
||||
(cond
|
||||
((null? exp)
|
||||
(c-code "nil"))
|
||||
(c-code "NULL"))
|
||||
((pair? exp)
|
||||
(c-compile-scalars exp))
|
||||
((vector? exp)
|
||||
|
|
@ -502,6 +512,7 @@
|
|||
((eq? p 'Cyc-get-cvar) "Cyc_get_cvar")
|
||||
((eq? p 'Cyc-set-cvar!) "Cyc_set_cvar")
|
||||
((eq? p 'Cyc-cvar?) "Cyc_is_cvar")
|
||||
; TODO: ((eq? p 'Cyc-opaque?) "Cyc_is_opaque")
|
||||
((eq? p 'Cyc-has-cycle?) "Cyc_has_cycle")
|
||||
((eq? p 'Cyc-spawn-thread!) "Cyc_spawn_thread")
|
||||
((eq? p 'Cyc-end-thread!) "Cyc_end_thread")
|
||||
|
|
@ -614,7 +625,7 @@
|
|||
((eq? p 'number?) "Cyc_is_number")
|
||||
((eq? p 'real?) "Cyc_is_real")
|
||||
((eq? p 'integer?) "Cyc_is_integer")
|
||||
((eq? p 'pair?) "Cyc_is_cons")
|
||||
((eq? p 'pair?) "Cyc_is_pair")
|
||||
((eq? p 'procedure?) "Cyc_is_procedure")
|
||||
((eq? p 'macro?) "Cyc_is_macro")
|
||||
((eq? p 'port?) "Cyc_is_port")
|
||||
|
|
@ -623,7 +634,7 @@
|
|||
((eq? p 'string?) "Cyc_is_string")
|
||||
((eq? p 'eof-object?) "Cyc_is_eof_object")
|
||||
((eq? p 'symbol?) "Cyc_is_symbol")
|
||||
((eq? p 'cons) "make_cons")
|
||||
((eq? p 'cons) "make_pair")
|
||||
((eq? p 'cell) "make_cell")
|
||||
((eq? p 'cell-get) "cell_get")
|
||||
((eq? p 'set-cell!) "Cyc_set_car")
|
||||
|
|
@ -993,10 +1004,10 @@
|
|||
;; TODO: probably not the ideal solution, but works for now
|
||||
"(closureN)"
|
||||
(mangle (car args))
|
||||
")->elts["
|
||||
")->elements["
|
||||
(number->string (- (cadr args) 1))"]"))))
|
||||
|
||||
;; TODO: may not be good enough, closure app could be from an elt
|
||||
;; 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))
|
||||
(this-cont (c:body cfun))
|
||||
|
|
@ -1044,7 +1055,7 @@
|
|||
(els (compile (if->else exp))))
|
||||
(c-code (string-append
|
||||
(c:allocs->str (c:allocs test) " ")
|
||||
"if( !eq(boolean_f, "
|
||||
"if( (boolean_f != "
|
||||
(c:body test)
|
||||
") ){ \n"
|
||||
(c:serialize then " ")
|
||||
|
|
@ -1221,7 +1232,7 @@
|
|||
(let ((var (cadr free-var))
|
||||
(idx (number->string (- (caddr free-var) 1))))
|
||||
(string-append
|
||||
"((closureN)" (mangle var) ")->elts[" idx "]"))
|
||||
"((closureN)" (mangle var) ")->elements[" idx "]"))
|
||||
(mangle free-var)))
|
||||
(closure->fv exp))) ; Note these are not necessarily symbols, but in cc form
|
||||
(cv-name (mangle (gensym 'c)))
|
||||
|
|
@ -1235,15 +1246,15 @@
|
|||
cv-name ".tag = closureN_tag;\n "
|
||||
cv-name ".fn = (function_type)__lambda_" (number->string lid) ";\n"
|
||||
cv-name ".num_args = " (number->string (compute-num-args lam)) ";\n"
|
||||
cv-name ".num_elt = " (number->string (length free-vars)) ";\n"
|
||||
cv-name ".elts = (object *)alloca(sizeof(object) * "
|
||||
cv-name ".num_elements = " (number->string (length free-vars)) ";\n"
|
||||
cv-name ".elements = (object *)alloca(sizeof(object) * "
|
||||
(number->string (length free-vars)) ");\n"
|
||||
(let loop ((i 0)
|
||||
(vars free-vars))
|
||||
(if (null? vars)
|
||||
""
|
||||
(string-append
|
||||
cv-name ".elts[" (number->string i) "] = "
|
||||
cv-name ".elements[" (number->string i) "] = "
|
||||
(car vars) ";\n"
|
||||
(loop (+ i 1) (cdr vars))))))))
|
||||
(create-mclosure (lambda ()
|
||||
|
|
@ -1370,6 +1381,7 @@
|
|||
lib-exports
|
||||
imported-globals
|
||||
globals
|
||||
c-headers
|
||||
required-libs
|
||||
src-file)
|
||||
(set! *global-syms* (append globals (lib:idb:ids imported-globals)))
|
||||
|
|
@ -1411,6 +1423,16 @@
|
|||
(foldr string-append "" (reverse compiled-program-lst)))
|
||||
|
||||
(emit-c-arity-macros 0)
|
||||
(for-each
|
||||
(lambda (h)
|
||||
(cond
|
||||
((and (string? h)
|
||||
(> (string-length h) 0)
|
||||
(equal? (string-ref h 0) #\<))
|
||||
(emit* "#include " h ""))
|
||||
(else
|
||||
(emit* "#include \"" h "\""))))
|
||||
c-headers)
|
||||
(emit "#include \"cyclone/types.h\"")
|
||||
|
||||
;; Globals defined in this module
|
||||
|
|
@ -1418,7 +1440,7 @@
|
|||
(lambda (global)
|
||||
(emits "object ")
|
||||
(emits (cgen:mangle-global (car global)))
|
||||
(emits " = nil;\n"))
|
||||
(emits " = NULL;\n"))
|
||||
*globals*)
|
||||
;; Globals defined by another module
|
||||
(for-each
|
||||
|
|
@ -1539,7 +1561,7 @@
|
|||
" make_cvar(" cvar-sym
|
||||
", (object *)&" (cgen:mangle-global (car g)) ");")
|
||||
(emits*
|
||||
"make_cons(" pair-sym ", find_or_add_symbol(\"" (symbol->string (car g))
|
||||
"make_pair(" pair-sym ", find_or_add_symbol(\"" (symbol->string (car g))
|
||||
"\"), &" cvar-sym ");\n")
|
||||
(set! pairs (cons pair-sym pairs))
|
||||
))
|
||||
|
|
@ -1556,13 +1578,13 @@
|
|||
((null? (cdr ps))
|
||||
(if (not head-pair)
|
||||
(set! head-pair (car cs)))
|
||||
(loop (cons (string-append "make_cons(" (car cs) ", &" (car ps) ",Cyc_global_variables);\n") code)
|
||||
(loop (cons (string-append "make_pair(" (car cs) ", &" (car ps) ",Cyc_global_variables);\n") code)
|
||||
(cdr ps)
|
||||
(cdr cs)))
|
||||
(else
|
||||
(if (not head-pair)
|
||||
(set! head-pair (car cs)))
|
||||
(loop (cons (string-append "make_cons(" (car cs) ", &" (car ps) ", &" (cadr cs) ");\n") code)
|
||||
(loop (cons (string-append "make_pair(" (car cs) ", &" (car ps) ", &" (cadr cs) ");\n") code)
|
||||
(cdr ps)
|
||||
(cdr cs)))))
|
||||
(if head-pair
|
||||
|
|
@ -1596,7 +1618,7 @@
|
|||
(emit compiled-program)))
|
||||
(else
|
||||
;; Do not use closcall1 macro as it might not have been defined
|
||||
(emit "cont = ((closure1_type *)cont)->elt1;")
|
||||
(emit "cont = ((closure1_type *)cont)->element;")
|
||||
;(emit "((cont)->fn)(1, cont, cont);")
|
||||
(emit*
|
||||
"(((closure)"
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@
|
|||
*version-banner*
|
||||
*c-file-header-comment*)
|
||||
(begin
|
||||
(define *version* "0.0.6 (Pre-release)")
|
||||
(define *version* "0.0.7 (Pre-release)")
|
||||
|
||||
(define *version-banner*
|
||||
(string-append "
|
||||
|
|
|
|||
|
|
@ -26,9 +26,11 @@
|
|||
lib:name->symbol
|
||||
lib:result
|
||||
lib:exports
|
||||
lib:rename-exports
|
||||
lib:imports
|
||||
lib:body
|
||||
lib:includes
|
||||
lib:include-c-headers
|
||||
lib:import->filename
|
||||
lib:import->metalist
|
||||
lib:import->path
|
||||
|
|
@ -80,10 +82,23 @@
|
|||
;; TODO: most of these below assume 0 or 1 instances of the directive.
|
||||
;; may need to replace some of these later with filter operations to
|
||||
;; support more than 1 instance.
|
||||
(define (lib:exports ast)
|
||||
(define (lib:raw-exports ast)
|
||||
(lib:result
|
||||
(let ((code (assoc 'export (cddr ast))))
|
||||
(if code (cdr code) #f))))
|
||||
(define (lib:rename-exports ast)
|
||||
(filter
|
||||
(lambda (ex)
|
||||
(tagged-list? 'rename ex))
|
||||
(lib:raw-exports ast)))
|
||||
(define (lib:exports ast)
|
||||
(map
|
||||
(lambda (ex)
|
||||
;; Replace any renamed exports
|
||||
(if (tagged-list? 'rename ex)
|
||||
(caddr ex)
|
||||
ex))
|
||||
(lib:raw-exports ast)))
|
||||
(define (lib:imports ast)
|
||||
(lib:result
|
||||
(let ((code (assoc 'import (cddr ast))))
|
||||
|
|
@ -101,6 +116,15 @@
|
|||
(tagged-list? 'include code))
|
||||
(cddr ast))))
|
||||
|
||||
(define (lib:include-c-headers ast)
|
||||
(map
|
||||
(lambda (inc-lst)
|
||||
(cadr inc-lst))
|
||||
(filter
|
||||
(lambda (code)
|
||||
(tagged-list? 'include-c-header code))
|
||||
(cddr ast))))
|
||||
|
||||
;; TODO: include-ci, cond-expand
|
||||
|
||||
(define (lib:atom->string atom)
|
||||
|
|
|
|||
|
|
@ -786,7 +786,7 @@
|
|||
(cond
|
||||
;; TODO: could check for a define-syntax here and load into memory
|
||||
;; if found. would then want to continue expanding. may need to
|
||||
;; return some value such as #t or nil as a placeholder, since the
|
||||
;; return some value such as #t or NULL as a placeholder, since the
|
||||
;; define-syntax form would not be carried forward in the compiled code
|
||||
((define-syntax? exp) ;; TODO: not good enough, should do error checking, and make sure list is big enough for cadr
|
||||
;(trace:info `(define-syntax ,exp))
|
||||
|
|
@ -917,7 +917,7 @@
|
|||
;; handled by the existing CPS conversion.
|
||||
((or
|
||||
;; TODO: the following line may not be good enough, a global assigned to another
|
||||
;; global may still be init'd to nil if the order is incorrect in the "top level"
|
||||
;; global may still be init'd to NULL if the order is incorrect in the "top level"
|
||||
;; initialization code.
|
||||
(symbol? (car (define->exp (car top-lvl)))) ;; TODO: put these at the end of top-lvl???
|
||||
(and (list? (car (define->exp (car top-lvl))))
|
||||
|
|
|
|||
|
|
@ -311,7 +311,7 @@
|
|||
;; TODO: temporary testing
|
||||
;; also, it would be nice to pass around something other than
|
||||
;; symbols for primitives. could the runtime inject something into the env?
|
||||
;; of course that is a problem for stuff like make_cons, that is just a
|
||||
;; of course that is a problem for stuff like make_pair, that is just a
|
||||
;; C macro...
|
||||
;; (define (primitive-procedure? proc)
|
||||
;; (equal? proc 'cons))
|
||||
|
|
|
|||
|
|
@ -20,17 +20,17 @@
|
|||
"(void *data, int argc, closure _, object k)"
|
||||
;; TODO: consolidate with Cyc_command_line_arguments from runtime.c
|
||||
" int i;
|
||||
object lis = nil;
|
||||
object lis = NULL;
|
||||
for (i = _cyc_argc; i > 0; i--) {
|
||||
object ps = alloca(sizeof(string_type));
|
||||
object pl = alloca(sizeof(cons_type));
|
||||
object pl = alloca(sizeof(pair_type));
|
||||
make_string(s, _cyc_argv[i - 1]);
|
||||
memcpy(ps, &s, sizeof(string_type));
|
||||
((list)pl)->hdr.mark = gc_color_red;
|
||||
((list)pl)->hdr.grayed = 0;
|
||||
((list)pl)->tag = cons_tag;
|
||||
((list)pl)->cons_car = ps;
|
||||
((list)pl)->cons_cdr = lis;
|
||||
((list)pl)->tag = pair_tag;
|
||||
((list)pl)->pair_car = ps;
|
||||
((list)pl)->pair_cdr = lis;
|
||||
lis = pl;
|
||||
}
|
||||
return_closcall1(data, k, lis); ")
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue