* Simple thunks do not allocate now.
This commit is contained in:
Abdulaziz Ghuloum
parent
3ba89a0638
commit
ff9439d3c1
BIN
bin/ikarus
BIN
bin/ikarus
Binary file not shown.
|
|
@ -359,7 +359,6 @@ static ikp do_read(ikpcb* pcb, fasl_port* p){
|
|||
return rtd;
|
||||
}
|
||||
else if(c == 'Q'){ /* thunk */
|
||||
fprintf(stderr, "THUNK\n");
|
||||
ikp proc = ik_alloc(pcb, align(disp_closure_data)) + closure_tag;
|
||||
if(put_mark_index){
|
||||
p->marks[put_mark_index] = proc;
|
||||
|
|
|
|||
BIN
lib/ikarus.boot
BIN
lib/ikarus.boot
Binary file not shown.
|
|
@ -234,7 +234,6 @@
|
|||
(define-record clambda (cases))
|
||||
(define-record clambda-code (label cases free))
|
||||
(define-record closure (code free*))
|
||||
(define-record thunk (code))
|
||||
(define-record funcall (op rand*))
|
||||
(define-record appcall (op rand*))
|
||||
(define-record forcall (op rand*))
|
||||
|
|
@ -1104,8 +1103,6 @@
|
|||
|
||||
|
||||
|
||||
;(define thunk-count 0)
|
||||
;(define total-count 0)
|
||||
(define (convert-closures prog)
|
||||
(define who 'convert-closures)
|
||||
(define (Expr* x*)
|
||||
|
|
@ -1139,10 +1136,6 @@
|
|||
cls*)
|
||||
(union (difference body-free fml*)
|
||||
cls*-free)))])]))])
|
||||
;(set! total-count (fxadd1 total-count))
|
||||
;(when (null? free)
|
||||
; (set! thunk-count (fxadd1 thunk-count))
|
||||
; (printf "EMPTY CLOSURE ~s/~s\n" thunk-count total-count))
|
||||
(values (make-closure (make-clambda-code (gensym) cls* free) free)
|
||||
free))]))
|
||||
(define (Expr ex)
|
||||
|
|
@ -1613,6 +1606,9 @@
|
|||
(make-primcall 'void '()))
|
||||
body))
|
||||
(define (check-const n body)
|
||||
(cond
|
||||
[(fxzero? n) body]
|
||||
[else
|
||||
(make-seq
|
||||
(make-conditional
|
||||
(make-primcall '$ap-check-const
|
||||
|
|
@ -1620,8 +1616,9 @@
|
|||
(make-forcall "ik_collect" ;(make-primref 'do-overflow)
|
||||
(list (make-constant (fx+ n 4096))))
|
||||
(make-primcall 'void '()))
|
||||
body))
|
||||
body)]))
|
||||
(define (closure-size x)
|
||||
#|FIXME: closures with free vars should not alloc|#
|
||||
(record-case x
|
||||
[(closure code free*)
|
||||
(align (fx+ disp-closure-data (fx* (length free*) wordsize)))]
|
||||
|
|
@ -3245,6 +3242,14 @@
|
|||
[(code-loc label) (label-address label)]
|
||||
[(primref op) (primref-loc op)]
|
||||
[else (error 'Simple "what ~s" x)]))
|
||||
(define (do-fix lhs* rhs* ac)
|
||||
;;; 1. first, set the code pointers in the right places
|
||||
;;; 2. next, for every variable appearing in the rhs* but is not in
|
||||
;;; the lhs*, load it once and set it everywhere it occurs.
|
||||
;;; 3. next, compute the values of the lhs*, and for every computed
|
||||
;;; value, store it on the stack, and set it everywhere it occurs
|
||||
;;; in the rhs*
|
||||
;;; 4. that's it.
|
||||
(define (closure-size x)
|
||||
(align (fx+ disp-closure-data
|
||||
(fx* wordsize (length (closure-free* x))))))
|
||||
|
|
@ -3305,19 +3310,50 @@
|
|||
(cond
|
||||
[(null? ls) ac]
|
||||
[else (sum (fx+ ac (car ls)) (cdr ls))]))
|
||||
(define (do-fix lhs* rhs* ac)
|
||||
;;; 1. first, set the code pointers in the right places
|
||||
;;; 2. next, for every variable appearing in the rhs* but is not in
|
||||
;;; the lhs*, load it once and set it everywhere it occurs.
|
||||
;;; 3. next, compute the values of the lhs*, and for every computed
|
||||
;;; value, store it on the stack, and set it everywhere it occurs
|
||||
;;; in the rhs*
|
||||
;;; 4. that's it.
|
||||
(define partition
|
||||
(lambda (lhs* rhs*)
|
||||
(let f ([lhs* lhs*] [rhs* rhs*]
|
||||
[tlhs* '()] [trhs* '()]
|
||||
[clhs* '()] [crhs* '()])
|
||||
(cond
|
||||
[(null? lhs*)
|
||||
(values tlhs* trhs* clhs* crhs*)]
|
||||
[(null? (closure-free* (car rhs*)))
|
||||
(f (cdr lhs*) (cdr rhs*)
|
||||
(cons (car lhs*) tlhs*) (cons (car rhs*) trhs*)
|
||||
clhs* crhs*)]
|
||||
[else
|
||||
(f (cdr lhs*) (cdr rhs*)
|
||||
tlhs* trhs*
|
||||
(cons (car lhs*) clhs*)
|
||||
(cons (car rhs*) crhs*))]))))
|
||||
(define do-closures
|
||||
(lambda (lhs* rhs* ac)
|
||||
(let* ([n* (map closure-size rhs*)])
|
||||
(assign-codes rhs* n* 0
|
||||
(assign-nonrec-free* rhs* rhs* n* lhs*
|
||||
(assign-rec-free* lhs* rhs* n*
|
||||
(cons (addl (int (sum 0 n*)) apr) ac))))))
|
||||
(cons (addl (int (sum 0 n*)) apr) ac)))))))
|
||||
(define do-thunks
|
||||
(lambda (lhs* rhs* ac)
|
||||
(cond
|
||||
[(null? lhs*) ac]
|
||||
[else
|
||||
(do-thunks (cdr lhs*) (cdr rhs*)
|
||||
(cons (movl (obj (car rhs*))
|
||||
(idx->frame-loc
|
||||
(frame-var-idx (car lhs*))))
|
||||
ac))])))
|
||||
(let-values ([(tlhs* trhs* clhs* crhs*)
|
||||
(partition lhs* rhs*)])
|
||||
(cond
|
||||
[(null? clhs*)
|
||||
(do-thunks tlhs* trhs* ac)]
|
||||
[(null? tlhs*)
|
||||
(do-closures clhs* crhs* ac)]
|
||||
[else
|
||||
(do-thunks tlhs* trhs*
|
||||
(do-closures clhs* crhs* ac))])))
|
||||
(define (frame-adjustment offset)
|
||||
(fx* (fxsub1 offset) (fx- 0 wordsize)))
|
||||
(define (NonTail x ac)
|
||||
|
|
@ -3333,6 +3369,10 @@
|
|||
[(primref c)
|
||||
(cons (movl (primref-loc c) eax) ac)]
|
||||
[(closure label arg*)
|
||||
(cond
|
||||
[(null? arg*)
|
||||
(cons (movl (obj x) eax) ac)]
|
||||
[else
|
||||
(let f ([arg* arg*] [off disp-closure-data])
|
||||
(cond
|
||||
[(null? arg*)
|
||||
|
|
@ -3344,7 +3384,7 @@
|
|||
[else
|
||||
(list* (movl (Simple (car arg*)) eax)
|
||||
(movl eax (mem off apr))
|
||||
(f (cdr arg*) (fx+ off wordsize)))]))]
|
||||
(f (cdr arg*) (fx+ off wordsize)))]))])]
|
||||
[(conditional test conseq altern)
|
||||
(let ([Lj (unique-label)] [Lf (unique-label)])
|
||||
(Pred test #f Lf
|
||||
|
|
@ -3895,8 +3935,10 @@
|
|||
ls*))
|
||||
(let ([code* (list*->code*
|
||||
(lambda (x)
|
||||
(if (thunk? x)
|
||||
(thunk-code x)
|
||||
(if (closure? x)
|
||||
(if (null? (closure-free* x))
|
||||
(code-loc-label (closure-code x))
|
||||
(error 'compile "BUG: non-thunk escaped: ~s" x))
|
||||
#f))
|
||||
ls*)])
|
||||
(car code*)))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue