diff --git a/scheme/ikarus.compiler.altcogen.ss b/scheme/ikarus.compiler.altcogen.ss
index 33b3920..79e5fb4 100644
--- a/scheme/ikarus.compiler.altcogen.ss
+++ b/scheme/ikarus.compiler.altcogen.ss
@@ -14,7 +14,7 @@
;;; along with this program. If not, see .
-(module (alt-cogen)
+(module (alt-cogen compile-call-frame)
;;; input to cogen is :
;;; ::= (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
diff --git a/scheme/ikarus.compiler.ss b/scheme/ikarus.compiler.ss
index ea65faa..1521895 100644
--- a/scheme/ikarus.compiler.ss
+++ b/scheme/ikarus.compiler.ss
@@ -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
diff --git a/scheme/ikarus.intel-assembler.ss b/scheme/ikarus.intel-assembler.ss
index 6956f34..ce70a03 100644
--- a/scheme/ikarus.intel-assembler.ss
+++ b/scheme/ikarus.intel-assembler.ss
@@ -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*)