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

Abstracted the construction of call frames and automated the padding 

process.  The compiler no longer has hardcoded null bytes inserted
into the code streams.
This commit is contained in:
Abdulaziz Ghuloum 2008-01-02 07:01:45 -05:00
parent 0db7d1d6d0
commit c15876aebe
3 changed files with 52 additions and 63 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -14,7 +14,7 @@
;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
(module (alt-cogen)
(module (alt-cogen compile-call-frame)
;;; input to cogen is <Program>:
;;; <Expr> ::= (constant x)
;;; | (var)
@ -2343,6 +2343,24 @@
(define (compile-call-frame framesize livemask-vec multiarg-rp call-sequence)
(let ([L_CALL (label (gensym))]
[padding
(- call-instruction-size
(instruction-size call-sequence))])
(when (< padding 0)
(error 'compile-call-frame "call sequence too long" call-sequence))
(list 'seq
(jmp L_CALL)
`(byte-vector ,livemask-vec)
`(int ,framesize)
'(current-frame-offset)
multiarg-rp
`(byte-vector ,(make-vector padding 0))
L_CALL
call-sequence)))
(define (flatten-codes x)
@ -2448,43 +2466,30 @@
[(string? target) ;; foreign call
(cons* `(subl ,(* (fxsub1 size) wordsize) ,fpr)
`(movl (foreign-label "ik_foreign_call") %ebx)
`(jmp ,LCALL)
`(byte-vector ,mask)
`(int ,(* size wordsize))
`(current-frame-offset)
(rp-label value)
;;; FIXME: hardcoded number of bytes
'(byte 0)
'(byte 0)
'(byte 0)
LCALL
`(call %ebx)
(compile-call-frame
(* size wordsize)
mask
(rp-label value)
`(call %ebx))
`(addl ,(* (fxsub1 size) wordsize) ,fpr)
ac)]
[target ;;; known call
(cons* `(subl ,(* (fxsub1 size) wordsize) ,fpr)
`(jmp ,LCALL)
`(byte-vector ,mask)
`(int ,(* size wordsize))
`(current-frame-offset)
(rp-label value)
;;; FIXME: hardcoded number of bytes
LCALL
`(call (label ,target))
(compile-call-frame
(* size wordsize)
mask
(rp-label value)
`(call (label ,target)))
`(addl ,(* (fxsub1 size) wordsize) ,fpr)
ac)]
[else
(cons* `(subl ,(* (fxsub1 size) wordsize) ,fpr)
`(jmp ,LCALL)
`(byte-vector ,mask)
`(int ,(* size wordsize))
`(current-frame-offset)
(rp-label value)
;;; FIXME: hardcoded number of bytes
'(byte 0)
'(byte 0)
LCALL
`(call (disp ,(fx- disp-closure-code closure-tag) ,cp-register))
(compile-call-frame
(* size wordsize)
mask
(rp-label value)
`(call (disp ,(fx- disp-closure-code closure-tag)
,cp-register)))
`(addl ,(* (fxsub1 size) wordsize) ,fpr)
ac)]))]
[(asm-instr op d s)
@ -2728,7 +2733,6 @@
(define LOOP_HEAD (unique-label))
(define L_CALL (unique-label))
(cons* (cmpl (int (argc-convention (fxsub1 fml-count))) eax)
;(jg (label SL_invalid_args))
(jl CONS_LABEL)
(movl (int nil) ebx)
(jmp DONE_LABEL)
@ -2749,16 +2753,7 @@
(movl eax (mem (fx* -2 wordsize) fpr)) ; pass it as first arg
(movl (int (argc-convention 1)) eax) ; setup argc
(movl (primref-loc 'do-vararg-overflow) cpr) ; load handler
(jmp L_CALL) ; go to overflow handler
; NEW FRAME
'(int 0) ; if the framesize=0, then the framesize is dynamic
'(current-frame-offset)
'(int 0) ; multiarg rp
;;; FIXME: hardcoded number of bytes
(byte 0)
(byte 0)
L_CALL
(indirect-cpr-call)
(compile-call-frame 0 '#() '(int 0) (indirect-cpr-call))
(popl eax) ; pop framesize and drop it
(popl eax) ; reload argc
(popl cpr) ; reload cp

16
scheme/ikarus.compiler.ss
View File

@ -2323,17 +2323,11 @@
(jne (label (sl-nonprocedure-error-label)))
(movl (int (argc-convention 0)) eax)
(subl (int (fx* wordsize 2)) fpr)
(jmp (label L_cwv_call))
; MV NEW FRAME
(byte-vector '#(#b110))
`(int ,(fx* wordsize 3))
'(current-frame-offset)
(label-address L_cwv_multi_rp)
;;; FIXME: hardcoded number of bytes
(byte 0)
(byte 0)
(label L_cwv_call)
(indirect-cpr-call)
(compile-call-frame
(* wordsize 3)
'#(#b110)
(label-address L_cwv_multi_rp)
(indirect-cpr-call))
;;; one value returned
(addl (int (fx* wordsize 2)) fpr)
(movl (mem (fx* -2 wordsize) fpr) ebx) ; consumer

22
scheme/ikarus.intel-assembler.ss
View File

@ -16,7 +16,7 @@
(library (ikarus intel-assembler)
(export assemble-sources code-entry-adjustment)
(export instruction-size assemble-sources code-entry-adjustment)
(import
(ikarus)
(rnrs bytevectors)
@ -351,6 +351,8 @@
(if (fx= (length args) n)
(apply proc a ac args)
(die 'convert-instruction "incorrect args" a))])))]
[(eq? (car a) 'seq)
(fold convert-instruction ac (cdr a))]
[else (die 'convert-instruction "unknown instruction" a)]))
(define (RM /d dst ac)
@ -908,17 +910,15 @@
[else (die 'whack-reloc "invalid reloc type" type)]))
)))
(define (instruction-size x)
(unless (and (pair? x) (getprop (car x) *cogen*))
(die 'instruction-size "not an instruction" x))
;;; limitations: does not work if the instruction contains
;;; a jump to a local label, and the jump is later optimized
;;; to a short jump.
(compute-code-size
(convert-instruction x '())))
;;; (define list->code
;;; (lambda (ls)
;;; (let ([ls (convert-instructions ls)])
;;; (let ([n (compute-code-size ls)]
;;; [m (compute-reloc-size ls)])
;;; (let ([x (make-code n m 1)])
;;; (let ([reloc* (whack-instructions x ls)])
;;; (for-each (whack-reloc x) reloc*))
;;; (make-code-executable! x)
;;; x)))))
(define assemble-sources
(lambda (thunk?-label ls*)