one more fix for 64-bit jumps and calls. Some conditional jumps

required cross-code offsets which are now eliminated.

scheme/ikarus.compiler.ss

@@ -2104,18 +2104,20 @@
         (let ([L_cwv_done (gensym)]
               [L_cwv_loop (gensym)]
               [L_cwv_multi_rp (gensym)]
-              [L_cwv_call (gensym)])
+              [L_cwv_call (gensym)]
+              [SL_nonprocedure (gensym "SL_nonprocedure")]
+              [SL_invalid_args (gensym "SL_invalid_args")])
           (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-label)))
+              (jne (label SL_invalid_args))
               (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-error-label)))
+              (jne (label SL_nonprocedure))
               (movl (int (argc-convention 0)) eax)
               (compile-call-frame
                  3
@@ -2129,7 +2131,7 @@
               (movl (int (argc-convention 1)) eax)
               (andl (int closure-mask) ebx)
               (cmpl (int closure-tag) ebx)
-              (jne (label (sl-nonprocedure-error-label)))
+              (jne (label SL_nonprocedure))
               (tail-indirect-cpr-call)
               ;;; multiple values returned
               (label L_cwv_multi_rp)
@@ -2153,8 +2155,27 @@
               (movl cpr ebx)
               (andl (int closure-mask) ebx)
               (cmpl (int closure-tag) ebx)
-              (jne (label (sl-nonprocedure-error-label)))
+              (jne (label SL_nonprocedure))
-              (tail-indirect-cpr-call)))))
+              (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)
+
+              ))))
     SL_call_with_values]
    ))
 

scheme/ikarus.intel-assembler.ss

@@ -35,9 +35,11 @@
       [else
        (f (car ls) (fold f init (cdr ls)))])))
 
+
 (define convert-instructions
   (lambda (ls)
-    (fold convert-instruction '() ls)))
+    (parameterize ([local-labels (uncover-local-labels ls)])
+      (fold convert-instruction '() ls))))
 
 (define register-mapping
   ;;; reg  cls  idx  REX.R
@@ -216,7 +218,11 @@
          (byte (sra n 24))
          ac)]
       [(label? n)
-       (cons (cons 'relative (label-name n)) ac)]
+       (cond 
+         [(local-label? (label-name n))
+          (cons (cons 'local-relative (label-name n)) ac)]
+         [else
+          (cons (cons 'relative (label-name n)) ac)])]
       [else (die 'IMM32 "invalid" n)])))
 
 (define IMM
@@ -255,7 +261,12 @@
       [(foreign? n)
        (cons (cons 'foreign-label (label-name n)) ac)]
       [(label? n)
-       (cons (cons 'relative (label-name n)) ac)]
+       (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 'IMM "invalid" n)])))
 
 
@@ -376,6 +387,7 @@
      (begin
        (add-instruction (name* instr ac arg** ...) b* b** ...) ...)]))
 
+
 (define (convert-instruction a ac)
   (cond
     [(getprop (car a) *cogen*) =>
@@ -747,18 +759,20 @@
     (cond
       [(reg? dst)                     (CR* #xF7 '/3 dst ac)]
       [else (die who "invalid" instr)])]
-   [(local-jmp dst) (CODE #xE9 (IMM32 dst ac))]
    [(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)
+       (if (= wordsize 4) 
            (CODE #xE9 (IMM32 dst ac))
            (jmp-pc-relative #xFF #x25 dst ac))]
       [(mem? dst)                     (CR*  #xFF '/4 dst ac)]
       [else (die who "invalid jmp target" dst)])]
-   [(local-call dst) (CODE #xE8 (IMM32 dst ac))]
    [(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))
@@ -904,37 +918,21 @@
           (code-set! code (fx+ idx 7) (fxlogand (fxsra x 53) #xFF))])]
       [else (die 'set-code-word! "unhandled" x)])))
  
-(define (preoptimize-local-jumps ls)
+(define local-labels (make-parameter '()))
-  (define locals '())
+(define (local-label? x) (and (memq x (local-labels)) #t))
-  (define g (gensym))
-  (define mark
-    (lambda (x)
-      (when (pair? x)
-        (case (car x)
-          [(label) 
-           (let ([name (label-name x)])
-             (putprop name g 'local)
-             (set! locals (cons name locals)))]
-          [(seq pad)
-           (for-each mark (cdr x))]))))
-  (define (local-label? x)
-    (and (label? x) (eq? (getprop (label-name x) g) 'local)))
-  (define opt
-    (lambda (x)
-      (when (pair? x)
-        (case (car x)
-          [(call) 
-           (when (local-label? (cadr x))
-             (set-car! x 'local-call))]
-          [(jmp) 
-           (when (local-label? (cadr x))
-             (set-car! x 'local-jmp))]
-          [(seq pad)
-           (for-each opt (cdr x))]))))
-  (for-each mark ls)
-  (for-each opt ls)
-  (for-each (lambda (x) (remprop x g)) locals))
 
+(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 '())
@@ -1124,8 +1122,6 @@
       (let ([closure-size* (map car ls*)]
             [code-name* (map code-name ls*)]
             [ls* (map code-list ls*)])
-        (when (= wordsize 8)
-          (for-each preoptimize-local-jumps ls*))
         (let* ([ls* (map convert-instructions ls*)]
                [ls* (map optimize-local-jumps ls*)])
           (let ([n* (map compute-code-size ls*)]

scheme/last-revision

@@ -1 +1 @@
-1866
+1867