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

* The procedure whack-reloc in intelasm is changed to check if a 

reloc data is a thunk; and if so, it creates (and caches) a
  procedure pointing to the code of the label of the thunk.
  The label has to be at index 0 from the code.
This commit is contained in:
Abdulaziz Ghuloum 2006-12-04 10:20:59 -05:00
parent 15468bd741
commit 925cecbe3b
2 changed files with 26 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
lib/ikarus.boot
View File

Binary file not shown.

34
lib/libintelasm.ss
View File

@ -782,7 +782,7 @@
(set-code-word! x idx idx) (set-code-word! x idx idx)
(f (cdr ls) (fx+ idx 4) reloc)] (f (cdr ls) (fx+ idx 4) reloc)]
[(label) [(label)
(set-label-loc! (cdr a) (cons x idx)) (set-label-loc! (cdr a) (list x idx))
(f (cdr ls) idx reloc)] (f (cdr ls) idx reloc)]
[else [else
(error 'whack-instructions "unknown instr ~s" a)])))]))) (error 'whack-instructions "unknown instr ~s" a)])))])))
@ -805,10 +805,28 @@
ls))) ls)))
(define whack-reloc (define whack-reloc
(lambda (code vec) (lambda (thunk?-label code vec)
(define reloc-idx 0) (define reloc-idx 0)
(lambda (r) (lambda (r)
(let ([idx (car r)] [type (cadr r)] [v (cddr r)]) (let ([idx (car r)] [type (cadr r)]
[v
(let ([v (cddr r)])
(cond
[(thunk?-label v) =>
(lambda (label)
(let ([p (label-loc label)])
(cond
[(fx= (length p) 2)
(let ([code (car p)] [idx (cadr p)])
(unless (fx= idx 0)
(error 'whack-reloc
"cannot create a thunk pointing at ~s"
idx))
(let ([thunk ($code->closure code)])
(set-cdr! (cdr p) (list thunk))
thunk))]
[else (caddr p)])))]
[else v]))])
(case type (case type
[(reloc-word) [(reloc-word)
(vector-set! vec reloc-idx (fxsll idx 2)) (vector-set! vec reloc-idx (fxsll idx 2))
@ -826,14 +844,14 @@
(set! reloc-idx (fx+ reloc-idx 3)))] (set! reloc-idx (fx+ reloc-idx 3)))]
[(label-addr) [(label-addr)
(let ([loc (label-loc v)]) (let ([loc (label-loc v)])
(let ([obj (car loc)] [disp (cdr loc)]) (let ([obj (car loc)] [disp (cadr loc)])
(vector-set! vec reloc-idx (fxlogor 2 (fxsll idx 2))) (vector-set! vec reloc-idx (fxlogor 2 (fxsll idx 2)))
(vector-set! vec (fx+ reloc-idx 1) (fx+ disp 11)) (vector-set! vec (fx+ reloc-idx 1) (fx+ disp 11))
(vector-set! vec (fx+ reloc-idx 2) obj))) (vector-set! vec (fx+ reloc-idx 2) obj)))
(set! reloc-idx (fx+ reloc-idx 3))] (set! reloc-idx (fx+ reloc-idx 3))]
[(local-relative) [(local-relative)
(let ([loc (label-loc v)]) (let ([loc (label-loc v)])
(let ([obj (car loc)] [disp (cdr loc)]) (let ([obj (car loc)] [disp (cadr loc)])
(unless (eq? obj code) (unless (eq? obj code)
(error 'whack-reloc "local-relative differ")) (error 'whack-reloc "local-relative differ"))
(let ([rel (fx- disp (fx+ idx 4))]) (let ([rel (fx- disp (fx+ idx 4))])
@ -843,7 +861,7 @@
(code-set! code (fx+ idx 3) (fxlogand (fxsra rel 24) #xFF)))))] (code-set! code (fx+ idx 3) (fxlogand (fxsra rel 24) #xFF)))))]
[(relative) [(relative)
(let ([loc (label-loc v)]) (let ([loc (label-loc v)])
(let ([obj (car loc)] [disp (cdr loc)]) (let ([obj (car loc)] [disp (cadr loc)])
(vector-set! vec reloc-idx (fxlogor 3 (fxsll idx 2))) (vector-set! vec reloc-idx (fxlogor 3 (fxsll idx 2)))
(vector-set! vec (fx+ reloc-idx 1) (fx+ disp 11)) (vector-set! vec (fx+ reloc-idx 1) (fx+ disp 11))
(vector-set! vec (fx+ reloc-idx 2) obj))) (vector-set! vec (fx+ reloc-idx 2) obj)))
@ -864,7 +882,7 @@
;;; x))))) ;;; x)))))
(define list*->code* (define list*->code*
(lambda (thunk? ls*) (lambda (thunk?-label ls*)
(let ([closure-size* (map car ls*)] (let ([closure-size* (map car ls*)]
[ls* (map cdr ls*)]) [ls* (map cdr ls*)])
(let* ([ls* (map convert-instructions ls*)] (let* ([ls* (map convert-instructions ls*)]
@ -876,7 +894,7 @@
(let ([reloc** (map whack-instructions code* ls*)]) (let ([reloc** (map whack-instructions code* ls*)])
(for-each (for-each
(lambda (foo reloc*) (lambda (foo reloc*)
(for-each (whack-reloc (car foo) (cdr foo)) reloc*)) (for-each (whack-reloc thunk?-label (car foo) (cdr foo)) reloc*))
(map cons code* relv*) reloc**) (map cons code* relv*) reloc**)
(for-each set-code-reloc-vector! code* relv*) (for-each set-code-reloc-vector! code* relv*)
code*))))))) code*)))))))