src/libcompile.ss => src/ikarus.compiler.ss
  src/libintelasm.ss => src/ikarus.intel-assembler.ss
This commit is contained in:
Abdulaziz Ghuloum 2007-05-05 21:18:41 -04:00
parent 68cb3e8d1a
commit facdfd959f
4 changed files with 23 additions and 54 deletions

Binary file not shown.

View File

@ -1,22 +1,15 @@
;;; 9.0: * calls (gensym <symbol>) instead of
;;; (gensym (symbol->string <symbol>)) in order to avoid incrementing
;;; gensym-count.
;;; 6.7: * open-coded top-level-value, car, cdr
;;; 6.2: * side-effects now modify the dirty-vector
;;; * added bwp-object?
;;; * added pointer-value
;;; * added tcbuckets
;;; 6.1: * added case-lambda, dropped lambda
;;; 6.0: * basic compiler
(library (ikarus compiler) (library (ikarus compiler)
(export) (export compile-core-expr-to-port assembler-output
(import (scheme) (ikarus intel-assembler)) current-primitive-locations eval-core)
(import
(only (scheme) $record-ref $record/rtd? $code->closure)
(except (ikarus)
compile-core-expr-to-port assembler-output
current-primitive-locations eval-core)
(ikarus intel-assembler))
(let ()
(define-syntax record-case (define-syntax record-case
(lambda (x) (lambda (x)
@ -921,24 +914,6 @@
(Expr x) (Expr x)
x) x)
(module (tally-giveup)
(define giveup-list '())
(define (tally-giveup op)
(cond
[(getprop op '*compiler-giveup-tally*) =>
(lambda (n)
(putprop op '*compiler-giveup-tally* (add1 n)))]
[else
(set! giveup-list (cons op giveup-list))
(putprop op '*compiler-giveup-tally* 1)]))
(define (print-tally)
(for-each
(lambda (x)
(let ([n (getprop x '*compiler-giveup-tally*)])
(when (>= n 30)
(printf "~s ~s\n" n x))))
giveup-list))
(primitive-set! 'compiler-giveup-tally print-tally))
#|FIXME:missing-optimizations #|FIXME:missing-optimizations
128 list* 128 list*
@ -979,7 +954,6 @@
(lambda () (lambda ()
(make-funcall (make-primref op) rand*))))] (make-funcall (make-primref op) rand*))))]
[else [else
(tally-giveup op)
(make-funcall (make-primref op) rand*)])) (make-funcall (make-primref op) rand*)]))
(define (constant-value x k) (define (constant-value x k)
(record-case x (record-case x
@ -2098,7 +2072,7 @@
(or (null? rand*) (or (null? rand*)
(valid-arg-types? op rand*)))) (valid-arg-types? op rand*))))
(begin ;;; UNINLINED ANALYSIS (module (mark-uninlined uninlined-stats) ;;; UNINLINED ANALYSIS
;;; the output of simplify-operands differs from the input in that the ;;; the output of simplify-operands differs from the input in that the
;;; operands to primcalls are all simple (variables, primrefs, or constants). ;;; operands to primcalls are all simple (variables, primrefs, or constants).
;;; funcalls to open-codable primrefs whos arguments are "ok" are converted to ;;; funcalls to open-codable primrefs whos arguments are "ok" are converted to
@ -2109,15 +2083,14 @@
[(assq x uninlined) => [(assq x uninlined) =>
(lambda (p) (set-cdr! p (fxadd1 (cdr p))))] (lambda (p) (set-cdr! p (fxadd1 (cdr p))))]
[else (set! uninlined (cons (cons x 1) uninlined))])) [else (set! uninlined (cons (cons x 1) uninlined))]))
(module () (define uninlined-stats
(primitive-set! 'uninlined-stats (lambda ()
(lambda () (let f ([ls uninlined] [ac '()])
(let f ([ls uninlined] [ac '()]) (cond
(cond [(null? ls) ac]
[(null? ls) ac] [(fx> (cdar ls) 15)
[(fx> (cdar ls) 15) (f (cdr ls) (cons (car ls) ac))]
(f (cdr ls) (cons (car ls) ac))] [else (f (cdr ls) ac)])))))
[else (f (cdr ls) ac)]))))))
(define (introduce-primcalls x) (define (introduce-primcalls x)
(define who 'introduce-primcalls) (define who 'introduce-primcalls)
@ -5264,11 +5237,9 @@
(let ([code (compile-core-expr->code x)]) (let ([code (compile-core-expr->code x)])
($code->closure code))) ($code->closure code)))
(primitive-set! 'compile-core-expr-to-port compile-core-expr-to-port) (define assembler-output (make-parameter #f))
(primitive-set! 'assembler-output (make-parameter #f)) (define current-primitive-locations
(primitive-set! 'current-primitive-locations
(let ([plocs (lambda (x) #f)]) (let ([plocs (lambda (x) #f)])
(case-lambda (case-lambda
[() plocs] [() plocs]
@ -5279,12 +5250,10 @@
(refresh-cached-labels!)) (refresh-cached-labels!))
(error 'current-primitive-locations "~s is not a procedure" p))]))) (error 'current-primitive-locations "~s is not a procedure" p))])))
(primitive-set! 'eval-core (define eval-core
(lambda (x) ((compile-core-expr x)))) (lambda (x) ((compile-core-expr x))))
)
))
#!eof junk #!eof junk

View File

@ -53,10 +53,10 @@
"ikarus.reader.ss" "ikarus.reader.ss"
"ikarus.code-objects.ss" "ikarus.code-objects.ss"
"libintelasm.ss" "ikarus.intel-assembler.ss"
"libfasl.ss" "libfasl.ss"
"libtrace.ss" "libtrace.ss"
"libcompile.ss" "ikarus.compiler.ss"
"libsyntax.ss" "libsyntax.ss"
"libpp.ss" "libpp.ss"
"libcafe.ss" "libcafe.ss"