conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

- More work on the new optimizer 

- Deleted old optimizer and changed the meaning of optimize level to
  be:
    0: bypass the optimizer
    1: copy propagation, constant folding, no inlining
    1: copy propagation, constant folding, with inlining
  The default is set to 1.
This commit is contained in:
Abdulaziz Ghuloum 2008-06-29 12:35:34 -07:00
parent 66464cc348
commit d73dfd1287
13 changed files with 381 additions and 1134 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
benchmarks/Makefile.am
View File

@ -71,3 +71,5 @@ benchall:
../src/ikarus -b ../scheme/ikarus.boot --r6rs-script benchall.ss 2>>timelog ../src/ikarus -b ../scheme/ikarus.boot --r6rs-script benchall.ss 2>>timelog
rm -f z*.scm z*.tex rm -f z*.scm z*.tex
clean:
rm -f z*.scm z*.tex

5
benchmarks/Makefile.in
View File

@ -304,8 +304,6 @@ distclean-generic:
maintainer-clean-generic: maintainer-clean-generic:
@echo "This command is intended for maintainers to use" @echo "This command is intended for maintainers to use"
@echo "it deletes files that may require special tools to rebuild." @echo "it deletes files that may require special tools to rebuild."
clean: clean-am
clean-am: clean-generic mostlyclean-am clean-am: clean-generic mostlyclean-am
distclean: distclean-am distclean: distclean-am
@ -375,6 +373,9 @@ benchall:
date +"NOW: %Y-%m-%d %H:%M:%S" >>timelog date +"NOW: %Y-%m-%d %H:%M:%S" >>timelog
../src/ikarus -b ../scheme/ikarus.boot --r6rs-script benchall.ss 2>>timelog ../src/ikarus -b ../scheme/ikarus.boot --r6rs-script benchall.ss 2>>timelog
rm -f z*.scm z*.tex rm -f z*.scm z*.tex
clean:
rm -f z*.scm z*.tex
# Tell versions [3.59,3.63) of GNU make to not export all variables. # Tell versions [3.59,3.63) of GNU make to not export all variables.
# Otherwise a system limit (for SysV at least) may be exceeded. # Otherwise a system limit (for SysV at least) may be exceeded.
.NOEXPORT: .NOEXPORT:

7
benchmarks/bench.ss
View File

@ -2,9 +2,10 @@
(import (ikarus)) (import (ikarus))
(optimize-level 2) (optimize-level 2)
;(cp0-effort-limit 1000) ;(cp0-effort-limit 100)
;(cp0-size-limit 100) ;(cp0-size-limit 10)
;(debug-optimizer #t) ;(optimizer-output #t)
(pretty-width 200)
(define (run name) (define (run name)
(let ([proc (time-it (format "compile-~a" name) (let ([proc (time-it (format "compile-~a" name)
(lambda () (lambda ()

4
benchmarks/benchall.ss
View File

@ -8,8 +8,8 @@
fpsum gcbench #|gcold|# graphs lattice matrix maze mazefun mbrot fpsum gcbench #|gcold|# graphs lattice matrix maze mazefun mbrot
nbody nboyer nqueens ntakl nucleic paraffins parsing perm9 peval nbody nboyer nqueens ntakl nucleic paraffins parsing perm9 peval
pi pnpoly primes puzzle quicksort ray sboyer scheme simplex pi pnpoly primes puzzle quicksort ray sboyer scheme simplex
slatex string sum sum1 sumfp sumloop tail tak takl trav1 trav2 slatex string sum sum1 sumfp sumloop sumloop2 tail tak takl
triangl wc)) trav1 trav2 triangl wc))
;(define all-benchmarks ;(define all-benchmarks
; '(cat tail wc slatex)) ; '(cat tail wc slatex))

20
benchmarks/rnrs-benchmarks/sumloop2.ss Normal file
View File

@ -0,0 +1,20 @@
;;; SUMLOOP -- One of the Kernighan and Van Wyk benchmarks.
(library (rnrs-benchmarks sumloop2)
(export main)
(import (rnrs) (rnrs-benchmarks))
(define (do-loop n)
(define sum 0)
(set! sum 0)
(do ((i 0 (+ i 1)))
((>= i n) sum)
(set! sum (+ sum 1))))
(define (main . args)
(run-benchmark
"sumloop"
sumloop-iters
(lambda (result) (equal? result 100000000))
(lambda (n) (lambda () (do-loop n)))
100000000)))

2
scheme/Makefile.am
View File

@ -43,5 +43,5 @@ CLEANFILES=$(nodist_pkglib_DATA) ikarus.config.ss
MAINTAINERCLEANFILES=last-revision MAINTAINERCLEANFILES=last-revision
ikarus.boot: $(EXTRA_DIST) ikarus.config.ss ikarus.boot: $(EXTRA_DIST) ikarus.config.ss
../src/ikarus -b ./ikarus.boot.prebuilt --r6rs-script makefile.ss ../src/ikarus -b ./ikarus.boot.prebuilt -O2 --r6rs-script makefile.ss

2
scheme/Makefile.in
View File

@ -378,7 +378,7 @@ ikarus.config.ss: Makefile last-revision ../config.h
echo '(define wordsize $(shell grep SIZEOF_VOID_P ../config.h | sed "s/.*\(.\)/\1/g"))' >>$@ echo '(define wordsize $(shell grep SIZEOF_VOID_P ../config.h | sed "s/.*\(.\)/\1/g"))' >>$@
ikarus.boot: $(EXTRA_DIST) ikarus.config.ss ikarus.boot: $(EXTRA_DIST) ikarus.config.ss
../src/ikarus -b ./ikarus.boot.prebuilt --r6rs-script makefile.ss ../src/ikarus -b ./ikarus.boot.prebuilt -O2 --r6rs-script makefile.ss
# Tell versions [3.59,3.63) of GNU make to not export all variables. # Tell versions [3.59,3.63) of GNU make to not export all variables.
# Otherwise a system limit (for SysV at least) may be exceeded. # Otherwise a system limit (for SysV at least) may be exceeded.
.NOEXPORT: .NOEXPORT:

BIN
scheme/ikarus.boot.prebuilt
View File

Binary file not shown.

1
scheme/ikarus.compiler.altcogen.ss
View File

@ -2999,7 +2999,6 @@
(parameterize ([exceptions-conc ac]) (parameterize ([exceptions-conc ac])
(T body ac)))) (T body ac))))
(map Clambda code*))])) (map Clambda code*))]))
(when (assembler-output) (print-code x))
(Program x)) (Program x))
(define (print-code x) (define (print-code x)

190
scheme/ikarus.compiler.source-optimizer.ss
View File

@ -23,42 +23,6 @@
(module (source-optimize optimize-level cp0-effort-limit cp0-size-limit) (module (source-optimize optimize-level cp0-effort-limit cp0-size-limit)
(define who 'source-optimize) (define who 'source-optimize)
;;; this define-structure definition for compatibility with the
;;; notation used in Oscar's thesis.
(define-syntax define-structure
(lambda (stx)
(define (fmt ctxt)
(lambda (str . args)
(datum->syntax ctxt
(string->symbol
(apply format str (map syntax->datum args))))))
(syntax-case stx ()
[(_ (name fields ...))
#'(define-struct name (fields ...))]
[(_ (name fields ...) ([others defaults] ...))
(with-syntax ([(pred maker (getters ...) (setters ...))
(let ([fmt (fmt #'name)])
(list (fmt "~s?" #'name)
(fmt "make-~s" #'name)
(map (lambda (x) (fmt "~s-~s" #'name x))
#'(fields ... others ...))
(map (lambda (x) (fmt "set-~s-~s!" #'name x))
#'(fields ... others ...))))])
#'(module (name pred getters ... setters ... maker)
(module P (name pred getters ... setters ... maker)
(define-struct name (fields ... others ...)))
(module (maker)
(define (maker fields ...)
(import P)
(maker fields ... defaults ...)))
(module (name pred getters ... setters ...)
(import P))))])))
;;;
(define-structure (prelex operand)
([source-referenced? #f]
[source-assigned? #f]
[residual-referenced? #f]
[residual-assigned? #f]))
;;; ;;;
(define-structure (app rand* ctxt) (define-structure (app rand* ctxt)
([inlined #f])) ([inlined #f]))
@ -101,95 +65,49 @@
(reset-integrated! ctxt)))) (reset-integrated! ctxt))))
;;; ;;;
;;; ;;;
(module (init-var! var-prelex)
(define (init-var! x)
(set-var-index! x (make-prelex #f)))
(define (var-prelex x)
(let ([v (var-index x)])
(if (prelex? v)
v
(error 'var-prelex "not initialized" x)))))
(module (with-extended-env copy-var) (module (with-extended-env copy-var)
(define (copy-var x) (define (copy-var x)
(let ([xi (var-prelex x)]) (let ([y (make-prelex (prelex-name x) #f)])
(let ([y (unique-var (var-name x))] (set-prelex-source-referenced?! y
[yi (make-prelex #f)]) (prelex-source-referenced? x))
(set-var-index! y yi) (set-prelex-source-assigned?! y
(set-prelex-source-referenced?! yi (prelex-source-assigned? x))
(prelex-source-referenced? xi)) (let ([loc (prelex-global-location x)])
(set-prelex-source-assigned?! yi
(prelex-source-assigned? xi))
(let ([loc (var-global-loc x)])
(when loc (when loc
(set-var-global-loc! y loc) (set-prelex-global-location! y loc)
(set-prelex-source-referenced?! yi #t) (set-prelex-source-referenced?! y #t)
(set-prelex-residual-referenced?! yi #t))) (set-prelex-residual-referenced?! y #t)))
y))) y))
(define (extend env lhs* rands) (define (extend env lhs* rands)
(if (null? lhs*)
(values env '())
(let ([nlhs* (map copy-var lhs*)]) (let ([nlhs* (map copy-var lhs*)])
(when rands (when rands
(for-each (for-each
(lambda (lhs rhs) (lambda (lhs rhs)
(assert (operand? rhs)) (set-prelex-operand! lhs rhs))
(set-prelex-operand! (var-prelex lhs) rhs))
nlhs* rands)) nlhs* rands))
(values (vector lhs* nlhs* env) nlhs*))) (values (vector lhs* nlhs* env) nlhs*))))
(define (copy-back ls)
(for-each
(lambda (x)
(set-prelex-source-assigned?! x
(prelex-residual-assigned? x))
(set-prelex-source-referenced?! x
(prelex-residual-referenced? x)))
ls))
(define-syntax with-extended-env (define-syntax with-extended-env
(syntax-rules () (syntax-rules ()
[(_ ((e2 args2) (e1 args1 rands)) b b* ...) [(_ ((e2 args2) (e1 args1 rands)) b b* ...)
(let-values ([(e2 args2) (extend e1 args1 rands)]) (let-values ([(e2 args2) (extend e1 args1 rands)])
b b* ...)]))) (let ([v (let () b b* ...)])
;;; purpose of prepare: (copy-back args2)
;;; 1. attach an info struct to every bound variable v))])))
;;; 2. set the plref and plset flags to indicate whether
;;; there is a reference/assignment to the variable.
;;; 3. verify well-formness of the input.
(define (prepare x)
(define who 'prepare)
(define (L x)
(for-each
(lambda (x)
(struct-case x
[(clambda-case info body)
(for-each init-var! (case-info-args info))
(E body)]))
(clambda-cases x)))
(define (E x)
(struct-case x
[(constant) (void)]
[(var) (set-prelex-source-referenced?! (var-prelex x) #t)]
[(primref) (void)]
[(clambda) (L x)]
[(seq e0 e1) (E e0) (E e1)]
[(conditional e0 e1 e2)
(E e0) (E e1) (E e2)]
[(assign x val)
(set-prelex-source-assigned?! (var-prelex x) #t)
(E val)]
[(bind lhs* rhs* body)
(for-each E rhs*)
(for-each init-var! lhs*)
(E body)]
[(fix lhs* rhs* body)
(for-each init-var! lhs*)
(for-each L rhs*)
(E body)
(for-each ;;; sanity check
(lambda (x)
(assert (not (prelex-source-assigned? (var-prelex x)))))
lhs*)]
[(funcall rator rand*)
(for-each E rand*)
(E rator)]
[(forcall name rand*)
(for-each E rand*)]
[else (error who "invalid expr in prepare" x)]))
(E x))
(define cp0-effort-limit (make-parameter 50))
(define cp0-effort-limit (make-parameter 40)) (define cp0-size-limit (make-parameter 8))
(define cp0-size-limit (make-parameter 7)) ;(define cp0-effort-limit (make-parameter 100))
;(define cp0-size-limit (make-parameter 0)) ;(define cp0-size-limit (make-parameter 10))
(define primitive-info-list (define primitive-info-list
@ -284,6 +202,7 @@
[(fxnot _) foldable result-true] [(fxnot _) foldable result-true]
[(fxadd1 _) foldable result-true] [(fxadd1 _) foldable result-true]
[(fxsub1 _) foldable result-true] [(fxsub1 _) foldable result-true]
[(fxzero? _) foldable ]
[(fx=? _ . _) foldable ] [(fx=? _ . _) foldable ]
[(fx<? _ . _) foldable ] [(fx<? _ . _) foldable ]
[(fx<=? _ . _) foldable ] [(fx<=? _ . _) foldable ]
@ -525,7 +444,7 @@
(define (simple? x) (define (simple? x)
(struct-case x (struct-case x
[(constant) #t] [(constant) #t]
[(var) #t] [(prelex) #t]
[(primref) #t] [(primref) #t]
[(clambda) #t] [(clambda) #t]
[else #f])) [else #f]))
@ -593,14 +512,14 @@
[(e) (make-constant (void))] [(e) (make-constant (void))]
[else [else
(let ([x (lookup x env)]) (let ([x (lookup x env)])
(let ([opnd (prelex-operand (var-prelex x))]) (let ([opnd (prelex-operand x)])
(if (and opnd (not (operand-inner-pending opnd))) (if (and opnd (not (operand-inner-pending opnd)))
(begin (begin
(dynamic-wind (dynamic-wind
(lambda () (set-operand-inner-pending! opnd #t)) (lambda () (set-operand-inner-pending! opnd #t))
(lambda () (value-visit-operand! opnd)) (lambda () (value-visit-operand! opnd))
(lambda () (set-operand-inner-pending! opnd #f))) (lambda () (set-operand-inner-pending! opnd #f)))
(if (prelex-source-assigned? (var-prelex x)) (if (prelex-source-assigned? x)
(residualize-ref x sc) (residualize-ref x sc)
(copy x opnd ctxt ec sc))) (copy x opnd ctxt ec sc)))
(residualize-ref x sc))))])) (residualize-ref x sc))))]))
@ -609,10 +528,10 @@
(let ([rhs (result-expr (operand-value opnd))]) (let ([rhs (result-expr (operand-value opnd))])
(struct-case rhs (struct-case rhs
[(constant) rhs] [(constant) rhs]
[(var) [(prelex)
(if (prelex-source-assigned? (var-prelex rhs)) (if (prelex-source-assigned? rhs)
(residualize-ref x sc) (residualize-ref x sc)
(let ([opnd (prelex-operand (var-prelex rhs))]) (let ([opnd (prelex-operand rhs)])
(if (and opnd (operand-value opnd)) (if (and opnd (operand-value opnd))
(copy2 rhs opnd ctxt ec sc) (copy2 rhs opnd ctxt ec sc)
(residualize-ref rhs sc))))] (residualize-ref rhs sc))))]
@ -720,12 +639,11 @@
(define (make-let-binding var* rand* body sc) (define (make-let-binding var* rand* body sc)
(define (process1 var rand lhs* rhs*) (define (process1 var rand lhs* rhs*)
(cond (cond
[(prelex-residual-referenced? (var-prelex var)) [(prelex-residual-referenced? var)
(assert (not (operand-residualize-for-effect rand)))
(values (values
(cons var lhs*) (cons var lhs*)
(cons (score-value-visit-operand! rand sc) rhs*))] (cons (score-value-visit-operand! rand sc) rhs*))]
[(prelex-residual-assigned? (var-prelex var)) [(prelex-residual-assigned? var)
(set-operand-residualize-for-effect! rand #t) (set-operand-residualize-for-effect! rand #t)
(values (values
(cons var lhs*) (cons var lhs*)
@ -789,14 +707,14 @@
;;; ;;;
(define (residualize-ref x sc) (define (residualize-ref x sc)
(decrement sc 1) (decrement sc 1)
(set-prelex-residual-referenced?! (var-prelex x) #t) (set-prelex-residual-referenced?! x #t)
x) x)
;;; ;;;
(define (E x ctxt env ec sc) (define (E x ctxt env ec sc)
(decrement ec 1) (decrement ec 1)
(struct-case x (struct-case x
[(constant) (decrement sc 1) x] [(constant) (decrement sc 1) x]
[(var) (E-var x ctxt env ec sc)] [(prelex) (E-var x ctxt env ec sc)]
[(seq e0 e1) [(seq e0 e1)
(mkseq (E e0 'e env ec sc) (E e1 ctxt env ec sc))] (mkseq (E e0 'e env ec sc) (E e1 ctxt env ec sc))]
[(conditional e0 e1 e2) [(conditional e0 e1 e2)
@ -816,15 +734,15 @@
[(assign x v) [(assign x v)
(mkseq (mkseq
(let ([x (lookup x env)]) (let ([x (lookup x env)])
(let ([xi (var-prelex x)])
(cond (cond
[(not (prelex-source-referenced? xi)) [(not (prelex-source-referenced? x))
;;; dead on arrival ;;; dead on arrival
(E v 'e env ec sc)] (E v 'e env ec sc)]
[else [else
(decrement sc 1) (decrement sc 1)
(set-prelex-residual-assigned?! xi #t) (set-prelex-residual-assigned?! x
(make-assign x (E v 'v env ec sc))]))) (prelex-source-assigned? x))
(make-assign x (E v 'v env ec sc))]))
(make-constant (void)))] (make-constant (void)))]
[(funcall rator rand*) [(funcall rator rand*)
(E-call rator (E-call rator
@ -863,13 +781,12 @@
(with-extended-env ((env lhs*) (env lhs* #f)) (with-extended-env ((env lhs*) (env lhs* #f))
(for-each (for-each
(lambda (lhs rhs) (lambda (lhs rhs)
(set-prelex-operand! (var-prelex lhs) (set-prelex-operand! lhs (make-operand rhs env ec)))
(make-operand rhs env ec)))
lhs* rhs*) lhs* rhs*)
(let ([body (E body ctxt env ec sc)]) (let ([body (E body ctxt env ec sc)])
(let ([lhs* (remp (let ([lhs* (remp
(lambda (x) (lambda (x)
(not (prelex-residual-referenced? (var-prelex x)))) (not (prelex-residual-referenced? x)))
lhs*)]) lhs*)])
(cond (cond
[(null? lhs*) body] [(null? lhs*) body]
@ -877,24 +794,23 @@
(decrement sc 1) (decrement sc 1)
(make-fix lhs* (make-fix lhs*
(map (lambda (x) (map (lambda (x)
(let ([opnd (prelex-operand (var-prelex x))]) (let ([opnd (prelex-operand x)])
(decrement sc (+ (operand-size opnd) 1)) (decrement sc (+ (operand-size opnd) 1))
(value-visit-operand! opnd))) (value-visit-operand! opnd)))
lhs*) lhs*)
body)]))))] body)]))))]
[else (error who "invalid expression" x)])) [else
(error who "invalid expression" x)]))
(define empty-env '()) (define empty-env '())
(define (lookup x orig-env) (define (lookup x env)
(define (lookup env)
(cond (cond
[(vector? env) [(vector? env)
(let f ([lhs* (vector-ref env 0)] [rhs* (vector-ref env 1)]) (let f ([lhs* (vector-ref env 0)] [rhs* (vector-ref env 1)])
(cond (cond
[(null? lhs*) (lookup (vector-ref env 2))] [(null? lhs*) (lookup x (vector-ref env 2))]
[(eq? x (car lhs*)) (car rhs*)] [(eq? x (car lhs*)) (car rhs*)]
[else (f (cdr lhs*) (cdr rhs*))]))] [else (f (cdr lhs*) (cdr rhs*))]))]
[else x])) [else x]))
(lookup orig-env))
(define optimize-level (define optimize-level
(make-parameter 1 (make-parameter 1
(lambda (x) (lambda (x)
@ -903,10 +819,12 @@
(die 'optimize-level "valid levels are 0, 1, and 2"))))) (die 'optimize-level "valid levels are 0, 1, and 2")))))
(define (source-optimize expr) (define (source-optimize expr)
(define (source-optimize expr) (define (source-optimize expr)
(prepare expr)
(E expr 'v empty-env (passive-counter) (passive-counter))) (E expr 'v empty-env (passive-counter) (passive-counter)))
(case (optimize-level) (case (optimize-level)
[(2) (source-optimize expr)] [(2) (source-optimize expr)]
[(1)
(parameterize ([cp0-size-limit 0])
(source-optimize expr))]
[else expr])) [else expr]))
) )

1215
scheme/ikarus.compiler.ss
View File

File diff suppressed because it is too large Load Diff

2
scheme/last-revision
View File

@ -1 +1 @@
1524 1526

13
scheme/makefile.ss
View File

@ -1,4 +1,4 @@
#!../src/ikarus -b ikarus.boot -O2 --r6rs-script #!../src/ikarus -b ikarus.boot --r6rs-script
;;; Ikarus Scheme -- A compiler for R6RS Scheme. ;;; Ikarus Scheme -- A compiler for R6RS Scheme.
;;; Copyright (C) 2006,2007,2008 Abdulaziz Ghuloum ;;; Copyright (C) 2006,2007,2008 Abdulaziz Ghuloum
;;; ;;;
@ -17,16 +17,16 @@
;;; vim:syntax=scheme ;;; vim:syntax=scheme
(import (only (ikarus) import)) (import (only (ikarus) import))
(import (except (ikarus) (import (except (ikarus)
assembler-output scc-letrec optimize-cp optimize-level assembler-output optimize-cp optimize-level
cp0-size-limit cp0-effort-limit)) cp0-size-limit cp0-effort-limit expand/optimize
optimizer-output))
(import (ikarus.compiler)) (import (ikarus.compiler))
(import (except (psyntax system $bootstrap) (import (except (psyntax system $bootstrap)
eval-core eval-core
current-primitive-locations current-primitive-locations
compile-core-expr-to-port)) compile-core-expr-to-port))
(import (ikarus.compiler)) ; just for fun (import (ikarus.compiler)) ; just for fun
(optimize-level 1) (optimize-level 2)
(pretty-width 160) (pretty-width 160)
((pretty-format 'fix) ((pretty-format 'letrec))) ((pretty-format 'fix) ((pretty-format 'letrec)))
@ -368,8 +368,10 @@
[interrupt-handler i] [interrupt-handler i]
[engine-handler i] [engine-handler i]
[assembler-output i] [assembler-output i]
[optimizer-output i]
[new-cafe i] [new-cafe i]
[expand i] [expand i]
[expand/optimize i]
[environment? i] [environment? i]
[time-it i] [time-it i]
[verbose-timer i] [verbose-timer i]
@ -1432,7 +1434,6 @@
;[i/o-would-block-condition? i] ;[i/o-would-block-condition? i]
;[i/o-would-block-port i] ;[i/o-would-block-port i]
[ellipsis-map ] [ellipsis-map ]
[scc-letrec i]
[optimize-cp i] [optimize-cp i]
[optimize-level i] [optimize-level i]
[cp0-size-limit i] [cp0-size-limit i]