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*)