* removed the reg? argument to build-graph. Reg? was needed when
build-graph was used for constructing both frame conflicts and register conflicts. Now, it's only used for register conflicts so reg? is no longer needed.
This commit is contained in:
parent
01658fe195
commit
0db57fbb69
BIN
src/ikarus.boot
BIN
src/ikarus.boot
Binary file not shown.
|
@ -23,183 +23,6 @@
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
(module (must-open-code? prim-context)
|
|
||||||
(define core-prims
|
|
||||||
;;;ctxt: p=predicate v=value vt=true-value e=effect
|
|
||||||
'([pair? p]
|
|
||||||
[vector? p]
|
|
||||||
[null? p]
|
|
||||||
[bwp-object? p]
|
|
||||||
[eof-object? p]
|
|
||||||
[eof-object vt]
|
|
||||||
[$unbound-object? p]
|
|
||||||
[procedure? p]
|
|
||||||
[symbol? p]
|
|
||||||
[boolean? p]
|
|
||||||
[string? p]
|
|
||||||
[char? p]
|
|
||||||
[fixnum? p]
|
|
||||||
[string? p]
|
|
||||||
[immediate? p]
|
|
||||||
[char? p]
|
|
||||||
[eq? p]
|
|
||||||
[not pv]
|
|
||||||
[void vt]
|
|
||||||
[$fx+ vt]
|
|
||||||
[$fx- vt]
|
|
||||||
[$fx* vt]
|
|
||||||
[$fxadd1 vt]
|
|
||||||
[$fxsub1 vt]
|
|
||||||
[$fxsll vt]
|
|
||||||
[$fxsra vt]
|
|
||||||
[$fxlogand vt]
|
|
||||||
[$fxlogor vt]
|
|
||||||
[$fxlogxor vt]
|
|
||||||
[$fxlognot vt]
|
|
||||||
[$fxmodulo vt]
|
|
||||||
[$fxquotient vt]
|
|
||||||
[$fxzero? p]
|
|
||||||
[$fx> p]
|
|
||||||
[$fx>= p]
|
|
||||||
[$fx< p]
|
|
||||||
[$fx<= p]
|
|
||||||
[$fx= p]
|
|
||||||
[- v]
|
|
||||||
[+ v]
|
|
||||||
[= p]
|
|
||||||
[< p]
|
|
||||||
[<= p]
|
|
||||||
[> p]
|
|
||||||
[>= p]
|
|
||||||
[zero? p]
|
|
||||||
|
|
||||||
|
|
||||||
[$char= p]
|
|
||||||
[$char< p]
|
|
||||||
[$char<= p]
|
|
||||||
[$char> p]
|
|
||||||
[$char>= p]
|
|
||||||
|
|
||||||
[$char->fixnum vt]
|
|
||||||
[$fixnum->char vt]
|
|
||||||
|
|
||||||
[cons vt]
|
|
||||||
[list vt]
|
|
||||||
[list* pv]
|
|
||||||
[car v]
|
|
||||||
[cdr v]
|
|
||||||
[$car v]
|
|
||||||
[$cdr v]
|
|
||||||
[set-car! e]
|
|
||||||
[set-cdr! e]
|
|
||||||
[$set-car! e]
|
|
||||||
[$set-cdr! e]
|
|
||||||
|
|
||||||
|
|
||||||
[vector vt]
|
|
||||||
[$make-vector vt]
|
|
||||||
[$vector-length vt]
|
|
||||||
[vector-length vt]
|
|
||||||
[$vector-ref v]
|
|
||||||
[vector-ref v]
|
|
||||||
[vector-set! e]
|
|
||||||
[$vector-set! e]
|
|
||||||
|
|
||||||
[$make-string vt]
|
|
||||||
[$string-length vt]
|
|
||||||
[$string-ref vt]
|
|
||||||
[string-ref vt]
|
|
||||||
[$string-set! e]
|
|
||||||
|
|
||||||
[$make-symbol vt]
|
|
||||||
[$set-symbol-value! e]
|
|
||||||
[$symbol-string v]
|
|
||||||
[$symbol-unique-string v]
|
|
||||||
[$set-symbol-unique-string! e]
|
|
||||||
[$symbol-plist vt]
|
|
||||||
[$set-symbol-plist! e]
|
|
||||||
[$set-symbol-string! e]
|
|
||||||
[top-level-value v]
|
|
||||||
[$symbol-value v]
|
|
||||||
|
|
||||||
[$memq pv]
|
|
||||||
[$procedure-check v]
|
|
||||||
|
|
||||||
[$record vt]
|
|
||||||
[$record/rtd? p]
|
|
||||||
[$record-ref v]
|
|
||||||
[$record-set! e]
|
|
||||||
[$record? p]
|
|
||||||
[$record-rtd vt]
|
|
||||||
[$make-record vt]
|
|
||||||
|
|
||||||
;;; ports
|
|
||||||
[output-port? p]
|
|
||||||
[input-port? p]
|
|
||||||
[port? p]
|
|
||||||
[$make-port/input vt]
|
|
||||||
[$make-port/output vt]
|
|
||||||
[$make-port/both vt]
|
|
||||||
[$port-handler vt]
|
|
||||||
[$port-input-buffer vt]
|
|
||||||
[$port-input-index vt]
|
|
||||||
[$port-input-size vt]
|
|
||||||
[$port-output-buffer vt]
|
|
||||||
[$port-output-index vt]
|
|
||||||
[$port-output-size vt]
|
|
||||||
[$set-port-input-index! e]
|
|
||||||
[$set-port-input-size! e]
|
|
||||||
[$set-port-output-index! e]
|
|
||||||
[$set-port-output-size! e]
|
|
||||||
|
|
||||||
[$code? p]
|
|
||||||
[$code-size vt]
|
|
||||||
[$code-reloc-vector vt]
|
|
||||||
[$code-freevars vt]
|
|
||||||
[$code-ref vt]
|
|
||||||
[$code-set! e]
|
|
||||||
[$code->closure vt]
|
|
||||||
[$closure-code vt]
|
|
||||||
|
|
||||||
[$make-tcbucket vt]
|
|
||||||
[$tcbucket-key v]
|
|
||||||
[$tcbucket-val v]
|
|
||||||
[$tcbucket-next vt]
|
|
||||||
[$set-tcbucket-tconc! e]
|
|
||||||
[$set-tcbucket-val! e]
|
|
||||||
[$set-tcbucket-next! e]
|
|
||||||
|
|
||||||
[$cpref v]
|
|
||||||
[primitive-set! e]
|
|
||||||
[primitive-ref v]
|
|
||||||
|
|
||||||
[pointer-value vt]
|
|
||||||
[$fp-at-base p]
|
|
||||||
[$current-frame vt]
|
|
||||||
[$seal-frame-and-call tail]
|
|
||||||
[$frame->continuation vt]
|
|
||||||
[$forward-ptr? p]
|
|
||||||
|
|
||||||
[$make-call-with-values-procedure vt]
|
|
||||||
[$make-values-procedure vt]
|
|
||||||
[$arg-list vt]
|
|
||||||
[$interrupted? p]
|
|
||||||
[$unset-interrupted! e]
|
|
||||||
|
|
||||||
))
|
|
||||||
(define (must-open-code? x)
|
|
||||||
(and (assq x core-prims) #t))
|
|
||||||
(define (prim-context x)
|
|
||||||
(cond
|
|
||||||
[(assq x core-prims) => cadr]
|
|
||||||
[else (error 'prim-context "~s is not a core prim" x)])))
|
|
||||||
|
|
||||||
|
|
||||||
;;; the program so far includes both primcalls and funcalls to
|
|
||||||
;;; primrefs. This pass removes all primcalls. Once everything
|
|
||||||
;;; works, we need to fix all previous passes to eliminate this
|
|
||||||
;;; whole primcall business.
|
|
||||||
|
|
||||||
|
|
||||||
(define (introduce-primcalls x)
|
(define (introduce-primcalls x)
|
||||||
;;;
|
;;;
|
||||||
|
@ -376,9 +199,14 @@
|
||||||
(define parameter-registers '(%edi))
|
(define parameter-registers '(%edi))
|
||||||
(define return-value-register '%eax)
|
(define return-value-register '%eax)
|
||||||
(define cp-register '%edi)
|
(define cp-register '%edi)
|
||||||
(define all-registers '(%eax %edi %ebx %edx %ecx))
|
(define all-registers '(%eax %edi %ebx %edx %ecx)) ; %esi %esp %ebp))
|
||||||
(define argc-register '%eax)
|
(define argc-register '%eax)
|
||||||
|
|
||||||
|
;;; apr = %ebp
|
||||||
|
;;; esp = %esp
|
||||||
|
;;; pcr = %esi
|
||||||
|
;;; cpr = %edi
|
||||||
|
|
||||||
(define (register-index x)
|
(define (register-index x)
|
||||||
(cond
|
(cond
|
||||||
[(assq x '([%eax 0] [%edi 1] [%ebx 2] [%edx 3]
|
[(assq x '([%eax 0] [%edi 1] [%ebx 2] [%edx 3]
|
||||||
|
@ -1943,7 +1771,7 @@
|
||||||
(define (set-for-each f s)
|
(define (set-for-each f s)
|
||||||
(for-each f (set->list s)))
|
(for-each f (set->list s)))
|
||||||
;;;
|
;;;
|
||||||
(define (build-graph x reg?)
|
(define (build-graph x)
|
||||||
(define who 'build-graph)
|
(define who 'build-graph)
|
||||||
(define g (empty-graph))
|
(define g (empty-graph))
|
||||||
(define (R* ls)
|
(define (R* ls)
|
||||||
|
@ -1955,11 +1783,14 @@
|
||||||
[(constant) (make-empty-set)]
|
[(constant) (make-empty-set)]
|
||||||
[(var) (list->set (list x))]
|
[(var) (list->set (list x))]
|
||||||
[(disp s0 s1) (set-union (R s0) (R s1))]
|
[(disp s0 s1) (set-union (R s0) (R s1))]
|
||||||
[(fvar) (list->set (if (reg? x) (list x) '()))]
|
[(fvar) (make-empty-set)]
|
||||||
[(code-loc) (make-empty-set)]
|
[(code-loc) (make-empty-set)]
|
||||||
[else
|
[else
|
||||||
(cond
|
(cond
|
||||||
[(symbol? x) (if (reg? x) (list->set (list x)) (make-empty-set))]
|
[(symbol? x)
|
||||||
|
(if (memq x all-registers)
|
||||||
|
(set-add x (make-empty-set))
|
||||||
|
(make-empty-set))]
|
||||||
[else (error who "invalid R ~s" x)])]))
|
[else (error who "invalid R ~s" x)])]))
|
||||||
;;; build effect
|
;;; build effect
|
||||||
(define (E x s)
|
(define (E x s)
|
||||||
|
@ -2379,10 +2210,7 @@
|
||||||
(let ([varvec (car vars)] [sp* (cdr vars)])
|
(let ([varvec (car vars)] [sp* (cdr vars)])
|
||||||
(let loop ([sp* (list->set sp*)] [un* (make-empty-set)] [body body])
|
(let loop ([sp* (list->set sp*)] [un* (make-empty-set)] [body body])
|
||||||
(let-values ([(un* body) (add-unspillables un* body)])
|
(let-values ([(un* body) (add-unspillables un* body)])
|
||||||
(let ([g (build-graph body
|
(let ([g (build-graph body)])
|
||||||
(lambda (x)
|
|
||||||
(and (symbol? x)
|
|
||||||
(memq x all-registers))))])
|
|
||||||
(let-values ([(spills sp* env) (color-graph sp* un* g)])
|
(let-values ([(spills sp* env) (color-graph sp* un* g)])
|
||||||
(cond
|
(cond
|
||||||
[(null? spills) (substitute env body)]
|
[(null? spills) (substitute env body)]
|
||||||
|
|
Loading…
Reference in New Issue