Compare commits
No commits in common. "1f2b250ed9e8cb1c2466c939a9a305461db71739" and "84e0f4ab6d3459cb752b43024e054c6717b23a0d" have entirely different histories.
1f2b250ed9
...
84e0f4ab6d
Binary file not shown.
|
|
@ -2227,23 +2227,6 @@
|
|||
[else (error 'small-operand? "huh?")]))
|
||||
(define (mem? x)
|
||||
(or (disp? x) (fvar? x)))
|
||||
(define (fix-address x k)
|
||||
(cond
|
||||
[(disp? x)
|
||||
(let ([s0 (disp-s0 x)] [s1 (disp-s1 x)])
|
||||
(cond
|
||||
[(not (small-operand? s0))
|
||||
(let ([u (mku)])
|
||||
(make-seq
|
||||
(E (make-asm-instr 'move u s0))
|
||||
(fix-address (make-disp u s1) k)))]
|
||||
[(not (small-operand? s1))
|
||||
(let ([u (mku)])
|
||||
(make-seq
|
||||
(E (make-asm-instr 'move u s1))
|
||||
(fix-address (make-disp s0 u) k)))]
|
||||
[else (k x)]))]
|
||||
[else (k x)]))
|
||||
;;; unspillable effect
|
||||
(define (E x)
|
||||
(struct-case x
|
||||
|
|
@ -2252,19 +2235,9 @@
|
|||
(make-conditional (P e0) (E e1) (E e2))]
|
||||
[(asm-instr op a b)
|
||||
(case op
|
||||
[(load8 load32)
|
||||
(fix-address b
|
||||
(lambda (b)
|
||||
(cond
|
||||
[(or (register? a) (var? a))
|
||||
(make-asm-instr op a b)]
|
||||
[else
|
||||
(let ([u (mku)])
|
||||
(make-seq
|
||||
(make-asm-instr op u b)
|
||||
(E (make-asm-instr 'move a u))))])))]
|
||||
[(logor logxor logand int+ int- int* move
|
||||
int-/overflow int+/overflow int*/overflow)
|
||||
load8 load32
|
||||
int-/overflow int+/overflow int*/overflow)
|
||||
(cond
|
||||
[(and (eq? op 'move) (eq? a b))
|
||||
(make-primcall 'nop '())]
|
||||
|
|
@ -2283,10 +2256,17 @@
|
|||
(E (make-asm-instr op u b)))
|
||||
(E (make-asm-instr 'move a u))))]
|
||||
[(and (mem? a) (not (small-operand? b)))
|
||||
(let ([u (mku)])
|
||||
(make-seq
|
||||
(E (make-asm-instr 'move u b))
|
||||
(E (make-asm-instr op a u))))]
|
||||
(case op
|
||||
[(load32)
|
||||
(let ([u (mku)])
|
||||
(make-seq
|
||||
(E (make-asm-instr 'load32 u b))
|
||||
(E (make-asm-instr 'move a u))))]
|
||||
[else
|
||||
(let ([u (mku)])
|
||||
(make-seq
|
||||
(E (make-asm-instr 'move u b))
|
||||
(E (make-asm-instr op a u))))])]
|
||||
[(disp? a)
|
||||
(let ([s0 (disp-s0 a)] [s1 (disp-s1 a)])
|
||||
(cond
|
||||
|
|
@ -2500,7 +2480,12 @@
|
|||
|
||||
|
||||
(define (compile-call-frame framesize livemask-vec multiarg-rp call-sequence)
|
||||
(let ([L_CALL (label (gensym))])
|
||||
(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
|
||||
(if (or (= framesize 0) (= framesize 1))
|
||||
'(seq)
|
||||
|
|
@ -2510,9 +2495,9 @@
|
|||
`(int ,(* framesize wordsize))
|
||||
'(current-frame-offset)
|
||||
multiarg-rp
|
||||
`(pad ,call-instruction-size
|
||||
,L_CALL
|
||||
,call-sequence)
|
||||
`(byte-vector ,(make-vector padding 0))
|
||||
L_CALL
|
||||
call-sequence
|
||||
(if (or (= framesize 0) (= framesize 1))
|
||||
'(seq)
|
||||
`(addl ,(* (fxsub1 framesize) wordsize) ,fpr)))))
|
||||
|
|
|
|||
|
|
@ -2084,6 +2084,19 @@
|
|||
(movl (mem (fx- 0 wordsize) fpr) eax)
|
||||
(ret)))))
|
||||
SL_values]
|
||||
[(sl-nonprocedure-error-label)
|
||||
(define SL_nonprocedure (gensym "SL_nonprocedure"))
|
||||
(assemble-sources (lambda (x) #f)
|
||||
(list
|
||||
(list 0
|
||||
(label SL_nonprocedure)
|
||||
(movl cpr (mem (fx- 0 wordsize) fpr)) ; first arg
|
||||
(movl (obj (primref->symbol '$apply-nonprocedure-error-handler)) cpr)
|
||||
(movl (mem (- disp-symbol-record-proc record-tag) cpr) cpr)
|
||||
;(movl (primref-loc '$apply-nonprocedure-error-handler) cpr)
|
||||
(movl (int (argc-convention 1)) eax)
|
||||
(tail-indirect-cpr-call))))
|
||||
SL_nonprocedure]
|
||||
[(sl-cwv-label)
|
||||
(define SL_call_with_values (gensym "SL_call_with_values"))
|
||||
(assemble-sources (lambda (x) #f)
|
||||
|
|
@ -2091,20 +2104,18 @@
|
|||
(let ([L_cwv_done (gensym)]
|
||||
[L_cwv_loop (gensym)]
|
||||
[L_cwv_multi_rp (gensym)]
|
||||
[L_cwv_call (gensym)]
|
||||
[SL_nonprocedure (gensym "SL_nonprocedure")]
|
||||
[SL_invalid_args (gensym "SL_invalid_args")])
|
||||
[L_cwv_call (gensym)])
|
||||
(list
|
||||
0 ; no free vars
|
||||
'(name call-with-values)
|
||||
(label SL_call_with_values)
|
||||
(cmpl (int (argc-convention 2)) eax)
|
||||
(jne (label SL_invalid_args))
|
||||
(jne (label (sl-invalid-args-label)))
|
||||
(movl (mem (fx- 0 wordsize) fpr) ebx) ; producer
|
||||
(movl ebx cpr)
|
||||
(andl (int closure-mask) ebx)
|
||||
(cmpl (int closure-tag) ebx)
|
||||
(jne (label SL_nonprocedure))
|
||||
(jne (label (sl-nonprocedure-error-label)))
|
||||
(movl (int (argc-convention 0)) eax)
|
||||
(compile-call-frame
|
||||
3
|
||||
|
|
@ -2118,7 +2129,7 @@
|
|||
(movl (int (argc-convention 1)) eax)
|
||||
(andl (int closure-mask) ebx)
|
||||
(cmpl (int closure-tag) ebx)
|
||||
(jne (label SL_nonprocedure))
|
||||
(jne (label (sl-nonprocedure-error-label)))
|
||||
(tail-indirect-cpr-call)
|
||||
;;; multiple values returned
|
||||
(label L_cwv_multi_rp)
|
||||
|
|
@ -2142,27 +2153,8 @@
|
|||
(movl cpr ebx)
|
||||
(andl (int closure-mask) ebx)
|
||||
(cmpl (int closure-tag) ebx)
|
||||
(jne (label SL_nonprocedure))
|
||||
(tail-indirect-cpr-call)
|
||||
|
||||
(label SL_nonprocedure)
|
||||
(movl cpr (mem (fx- 0 wordsize) fpr)) ; first arg
|
||||
(movl (obj (primref->symbol '$apply-nonprocedure-error-handler)) cpr)
|
||||
(movl (mem (- disp-symbol-record-proc record-tag) cpr) cpr)
|
||||
(movl (int (argc-convention 1)) eax)
|
||||
(tail-indirect-cpr-call)
|
||||
|
||||
(label SL_invalid_args)
|
||||
;;;
|
||||
(movl cpr (mem (fx- 0 wordsize) fpr)) ; first arg
|
||||
(negl eax)
|
||||
(movl eax (mem (fx- 0 (fx* 2 wordsize)) fpr))
|
||||
(movl (obj (primref->symbol '$incorrect-args-error-handler)) cpr)
|
||||
(movl (mem (- disp-symbol-record-proc record-tag) cpr) cpr)
|
||||
(movl (int (argc-convention 2)) eax)
|
||||
(tail-indirect-cpr-call)
|
||||
|
||||
))))
|
||||
(jne (label (sl-nonprocedure-error-label)))
|
||||
(tail-indirect-cpr-call)))))
|
||||
SL_call_with_values]
|
||||
))
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
@ -35,11 +35,9 @@
|
|||
[else
|
||||
(f (car ls) (fold f init (cdr ls)))])))
|
||||
|
||||
|
||||
(define convert-instructions
|
||||
(lambda (ls)
|
||||
(parameterize ([local-labels (uncover-local-labels ls)])
|
||||
(fold convert-instruction '() ls))))
|
||||
(fold convert-instruction '() ls)))
|
||||
|
||||
(define register-mapping
|
||||
;;; reg cls idx REX.R
|
||||
|
|
@ -218,11 +216,7 @@
|
|||
(byte (sra n 24))
|
||||
ac)]
|
||||
[(label? n)
|
||||
(cond
|
||||
[(local-label? (label-name n))
|
||||
(cons (cons 'local-relative (label-name n)) ac)]
|
||||
[else
|
||||
(cons (cons 'relative (label-name n)) ac)])]
|
||||
(cons (cons 'relative (label-name n)) ac)]
|
||||
[else (die 'IMM32 "invalid" n)])))
|
||||
|
||||
(define IMM
|
||||
|
|
@ -261,12 +255,7 @@
|
|||
[(foreign? n)
|
||||
(cons (cons 'foreign-label (label-name n)) ac)]
|
||||
[(label? n)
|
||||
(cond
|
||||
[(local-label? (label-name n))
|
||||
(cons (cons 'local-relative (label-name n)) ac)]
|
||||
[else
|
||||
(cons (cons 'relative (label-name n)) ac)])]
|
||||
;(cons (cons 'relative (label-name n)) ac)]
|
||||
(cons (cons 'relative (label-name n)) ac)]
|
||||
[else (die 'IMM "invalid" n)])))
|
||||
|
||||
|
||||
|
|
@ -387,7 +376,6 @@
|
|||
(begin
|
||||
(add-instruction (name* instr ac arg** ...) b* b** ...) ...)]))
|
||||
|
||||
|
||||
(define (convert-instruction a ac)
|
||||
(cond
|
||||
[(getprop (car a) *cogen*) =>
|
||||
|
|
@ -412,21 +400,6 @@
|
|||
(die 'convert-instruction "incorrect args" a))])))]
|
||||
[(eq? (car a) 'seq)
|
||||
(fold convert-instruction ac (cdr a))]
|
||||
[(eq? (car a) 'pad)
|
||||
(let ()
|
||||
(define (find-prefix x ls)
|
||||
(let f ([ls ls])
|
||||
(cond
|
||||
[(eq? ls x) '()]
|
||||
[else
|
||||
(let ([a (car ls)])
|
||||
(if (and (pair? a) (eq? (car a) 'bottom-code))
|
||||
(f (cdr ls))
|
||||
(cons a (f (cdr ls)))))])))
|
||||
(let ([n (cadr a)] [code (cddr a)])
|
||||
(let ([ls (fold convert-instruction ac code)])
|
||||
(let ([m (compute-code-size (find-prefix ac ls))])
|
||||
(append (make-list (- n m) 0) ls)))))]
|
||||
[else (die 'convert-instruction "unknown instruction" a)]))
|
||||
|
||||
(define (RM /d dst ac)
|
||||
|
|
@ -589,19 +562,6 @@
|
|||
(cons (car ls) (f (cdr ls))))))
|
||||
ls)
|
||||
|
||||
(define (jmp-pc-relative code0 code1 dst ac)
|
||||
(when (= wordsize 4)
|
||||
(error 'intel-assembler "no pc-relative jumps in 32-bit mode"))
|
||||
(let ([g (gensym)])
|
||||
(CODE code0
|
||||
(CODE code1
|
||||
(cons*
|
||||
`(local-relative . ,g)
|
||||
`(bottom-code
|
||||
(label . ,g)
|
||||
(label-addr . ,(label-name dst)))
|
||||
ac)))))
|
||||
|
||||
(add-instructions instr ac
|
||||
[(ret) (CODE #xC3 ac)]
|
||||
[(cltd) (C #x99 ac)]
|
||||
|
|
@ -761,22 +721,12 @@
|
|||
[else (die who "invalid" instr)])]
|
||||
[(jmp dst)
|
||||
(cond
|
||||
[(and (label? dst) (local-label? (label-name dst)))
|
||||
(CODE #xE9 (cons `(local-relative . ,(label-name dst)) ac))]
|
||||
[(imm? dst)
|
||||
(if (= wordsize 4)
|
||||
(CODE #xE9 (IMM32 dst ac))
|
||||
(jmp-pc-relative #xFF #x25 dst ac))]
|
||||
[(imm? dst) (CODE #xE9 (IMM32 dst ac))]
|
||||
[(mem? dst) (CR* #xFF '/4 dst ac)]
|
||||
[else (die who "invalid jmp target" dst)])]
|
||||
[(call dst)
|
||||
(cond
|
||||
[(and (label? dst) (local-label? (label-name dst)))
|
||||
(CODE #xE8 (cons `(local-relative . ,(label-name dst)) ac))]
|
||||
[(imm? dst)
|
||||
(if (= wordsize 4)
|
||||
(CODE #xE8 (IMM32 dst ac))
|
||||
(jmp-pc-relative #xFF #x15 dst ac))]
|
||||
[(imm? dst) (CODE #xE8 (IMM32 dst ac))]
|
||||
[(mem? dst) (CR* #xFF '/2 dst ac)]
|
||||
[(reg? dst) (CR* #xFF '/2 dst ac)]
|
||||
[else (die who "invalid jmp target" dst)])]
|
||||
|
|
@ -862,7 +812,7 @@
|
|||
))
|
||||
|
||||
|
||||
(define compute-code-size
|
||||
(define compute-code-size
|
||||
(lambda (ls)
|
||||
(fold (lambda (x ac)
|
||||
(if (fixnum? x)
|
||||
|
|
@ -874,13 +824,12 @@
|
|||
[(label) ac]
|
||||
[(word reloc-word reloc-word+ label-addr
|
||||
current-frame-offset foreign-label)
|
||||
(fx+ ac wordsize)]
|
||||
[(bottom-code)
|
||||
(fx+ ac (compute-code-size (cdr x)))]
|
||||
(+ ac wordsize)]
|
||||
[else (die 'compute-code-size "unknown instr" x)])))
|
||||
0
|
||||
ls)))
|
||||
|
||||
|
||||
(define set-label-loc!
|
||||
(lambda (x loc)
|
||||
(when (getprop x '*label-loc*)
|
||||
|
|
@ -892,6 +841,7 @@
|
|||
(or (getprop x '*label-loc*)
|
||||
(die 'compile "undefined label" x))))
|
||||
|
||||
|
||||
(define unset-label-loc!
|
||||
(lambda (x)
|
||||
(remprop x '*label-loc*)))
|
||||
|
|
@ -918,41 +868,22 @@
|
|||
(code-set! code (fx+ idx 7) (fxlogand (fxsra x 53) #xFF))])]
|
||||
[else (die 'set-code-word! "unhandled" x)])))
|
||||
|
||||
(define local-labels (make-parameter '()))
|
||||
(define (local-label? x) (and (memq x (local-labels)) #t))
|
||||
|
||||
(define (uncover-local-labels ls)
|
||||
(define locals '())
|
||||
(define find
|
||||
(lambda (x)
|
||||
(when (pair? x)
|
||||
(case (car x)
|
||||
[(label)
|
||||
(set! locals (cons (label-name x) locals))]
|
||||
[(seq pad)
|
||||
(for-each find (cdr x))]))))
|
||||
(for-each find ls)
|
||||
locals)
|
||||
|
||||
(define (optimize-local-jumps ls)
|
||||
(define locals '())
|
||||
(define g (gensym))
|
||||
(define (mark x)
|
||||
(when (pair? x)
|
||||
(case (car x)
|
||||
[(label)
|
||||
(putprop (cdr x) g 'local)
|
||||
(set! locals (cons (cdr x) locals))]
|
||||
[(bottom-code) (for-each mark (cdr x))])))
|
||||
(define (opt x)
|
||||
(when (pair? x)
|
||||
(case (car x)
|
||||
[(relative)
|
||||
(when (eq? (getprop (cdr x) g) 'local)
|
||||
(set-car! x 'local-relative))]
|
||||
[(bottom-code) (for-each opt (cdr x))])))
|
||||
(for-each mark ls)
|
||||
(for-each opt ls)
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(when (and (pair? x) (eq? (car x) 'label))
|
||||
(putprop (cdr x) g 'local)
|
||||
(set! locals (cons (cdr x) locals))))
|
||||
ls)
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(when (and (pair? x)
|
||||
(eq? (car x) 'relative)
|
||||
(eq? (getprop (cdr x) g) 'local))
|
||||
(set-car! x 'local-relative)))
|
||||
ls)
|
||||
(for-each (lambda (x) (remprop x g)) locals)
|
||||
ls)
|
||||
|
||||
|
|
@ -961,52 +892,47 @@
|
|||
(define whack-instructions
|
||||
(lambda (x ls)
|
||||
(define f
|
||||
(lambda (ls idx reloc bot*)
|
||||
(lambda (ls idx reloc)
|
||||
(cond
|
||||
[(null? ls)
|
||||
(if (null? bot*)
|
||||
reloc
|
||||
(f (car bot*) idx reloc (cdr bot*)))]
|
||||
[(null? ls) reloc]
|
||||
[else
|
||||
(let ([a (car ls)])
|
||||
(if (fixnum? a)
|
||||
(begin
|
||||
(code-set! x idx a)
|
||||
(f (cdr ls) (fxadd1 idx) reloc bot*))
|
||||
(f (cdr ls) (fxadd1 idx) reloc))
|
||||
(case (car a)
|
||||
[(byte)
|
||||
(code-set! x idx (cdr a))
|
||||
(f (cdr ls) (fx+ idx 1) reloc bot*)]
|
||||
(f (cdr ls) (fx+ idx 1) reloc)]
|
||||
[(relative local-relative)
|
||||
(f (cdr ls) (fx+ idx 4) (cons (cons idx a) reloc) bot*)]
|
||||
(f (cdr ls) (fx+ idx 4) (cons (cons idx a) reloc))]
|
||||
[(reloc-word reloc-word+ label-addr foreign-label)
|
||||
(f (cdr ls) (fx+ idx wordsize) (cons (cons idx a) reloc) bot*)]
|
||||
(f (cdr ls) (fx+ idx wordsize) (cons (cons idx a) reloc))]
|
||||
[(word)
|
||||
(let ([v (cdr a)])
|
||||
(set-code-word! x idx v)
|
||||
(f (cdr ls) (fx+ idx wordsize) reloc bot*))]
|
||||
(f (cdr ls) (fx+ idx wordsize) reloc))]
|
||||
[(current-frame-offset)
|
||||
(set-code-word! x idx idx) ;;; FIXME 64bit
|
||||
(f (cdr ls) (fx+ idx wordsize) reloc bot*)]
|
||||
(f (cdr ls) (fx+ idx wordsize) reloc)]
|
||||
[(label)
|
||||
(set-label-loc! (cdr a) (list x idx))
|
||||
(f (cdr ls) idx reloc bot*)]
|
||||
[(bottom-code)
|
||||
(f (cdr ls) idx reloc (cons (cdr a) bot*))]
|
||||
(f (cdr ls) idx reloc)]
|
||||
[else
|
||||
(die 'whack-instructions "unknown instr" a)])))])))
|
||||
(f ls 0 '() '())))
|
||||
(f ls 0 '())))
|
||||
|
||||
(define compute-reloc-size
|
||||
|
||||
(define compute-reloc-size
|
||||
(lambda (ls)
|
||||
(fold (lambda (x ac)
|
||||
(if (fixnum? x)
|
||||
ac
|
||||
(case (car x)
|
||||
[(word byte label current-frame-offset local-relative) ac]
|
||||
[(reloc-word foreign-label) (fx+ ac 2)]
|
||||
[(relative reloc-word+ label-addr) (fx+ ac 3)]
|
||||
[(bottom-code) (fx+ ac (compute-reloc-size (cdr x)))]
|
||||
[(word byte label current-frame-offset local-relative) ac]
|
||||
[else (die 'compute-reloc-size "unknown instr" x)])))
|
||||
0
|
||||
ls)))
|
||||
|
|
@ -1105,6 +1031,14 @@
|
|||
[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 assemble-sources
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
1869
|
||||
1864
|
||||
|
|
|
|||
|
|
@ -1226,7 +1226,7 @@
|
|||
[(V x)
|
||||
(prm 'sll
|
||||
(prm 'srl
|
||||
(prm 'mref32 (T x)
|
||||
(prm 'mref (T x)
|
||||
(K (- (+ disp-flonum-data 4) vector-tag)))
|
||||
(K 20))
|
||||
(K fx-shift))])
|
||||
|
|
|
|||
|
|
@ -40,9 +40,6 @@ ikptr ik_exec_code(ikpcb* pcb, ikptr code_ptr, ikptr argcount, ikptr cp){
|
|||
fprintf(stderr, "exec framesize=0x%016lx ksize=%ld rp=0x%016lx\n",
|
||||
framesize, k->size, rp);
|
||||
#endif
|
||||
if(framesize == 0){
|
||||
framesize = ref(top, wordsize);
|
||||
}
|
||||
if(framesize <= 0){
|
||||
fprintf(stderr, "invalid framesize %ld\n", framesize);
|
||||
exit(-10);
|
||||
|
|
|
|||
Loading…
Reference in New Issue