optimize direct calls online

lib/how-to-optimize-arg-checks.tex

@@ -0,0 +1,58 @@
+
+Step1: Optimize direct calls:
+
+Suppose we have a case-lambda as follows
+
+(case-lambda
+  [<formals_0> <code_0>]
+  [<formals_1> <code_1>]
+  ...
+  [<formals_n> <code_n>])
+
+First, generate labels for every clause as well as a label for top
+
+(case-lambda <label>
+  [<formals_0> <label_0> <code0_>]
+  [<formals_1> <label_1> <code1_>]
+  ...
+  [<formals_n> <label_n> <coden_>])
+
+Now everywhere there is a call to a closure bound variable:
+  (funcall x args ...)
+We match on the labels of x:
+  * If a matching label is found, we transform the call to
+    (dircall <label_i> x args ...)
+  * If no matching label is found, we transform the call to
+    (dircall <label> x args ...)
+If we match on a case with ". rest" formals, we emit a call
+to "list" on the rest arguments because the label will be
+inside the code (after the rest-args are constructed).
+
+
+Step2: Eliminate passing arg-counts:
+
+All direct calls to inner labels do not require passing an argument
+count since it will not be used by the procedure.
+
+
+
+Step3:  Eliminate useless case-lambda cases. (not important)
+
+For every label generated, determine whether it is actually used or
+not.  
+
+We assume the main label unused until we find:
+  * A reference to it in a closure that's not a dircall operator.
+  * A reference to it as the target label to a dircall.
+
+We assume an inner label unused until we find:
+  * A direct call to it.
+  * The main label used.
+
+If a case-lambda has unused clauses, they can be eliminated.
+
+If a case-lambda has an unused main label, the dispatch can be
+eliminated.
+
+
+

lib/libcompile.ss

@@ -221,8 +221,8 @@
 (define-record eval-cp (check body))
 (define-record return (value))
 (define-record call-cp
-  (call-convention rp-convention base-idx arg-count live-mask))
+  (call-convention label rp-convention base-idx arg-count live-mask))
-(define-record tailcall-cp (convention arg-count))
+(define-record tailcall-cp (convention label arg-count))
 (define-record primcall (op arg*))
 (define-record primref (name))
 (define-record conditional (test conseq altern))
@@ -236,6 +236,7 @@
 (define-record clambda (label cases free))
 (define-record closure (code free*))
 (define-record funcall (op rand*))
+(define-record jmpcall (label op rand*))
 (define-record appcall (op rand*))
 (define-record forcall (op rand*))
 (define-record codes (list body))
@@ -448,6 +449,8 @@
        `(codes ,(map E list)
           ,(E body))]
       [(funcall rator rand*) `(funcall ,(E rator) . ,(map E rand*))]
+      [(jmpcall label rator rand*)
+       `(jmpcall ,label ,(E rator) . ,(map E rand*))]
       [(appcall rator rand*) `(appcall ,(E rator) . ,(map E rand*))]
       [(forcall rator rand*) `(foreign-call ,rator . ,(map E rand*))]
       [(assign lhs rhs) `(set! ,(E lhs) ,(E rhs))]
@@ -464,8 +467,9 @@
        `(save-cp ,(E expr))]
       [(eval-cp check body)
        `(eval-cp ,check ,(E body))]
-      [(call-cp call-convention rp-convention base-idx arg-count live-mask)
+      [(call-cp call-convention label rp-convention base-idx arg-count live-mask)
        `(call-cp [conv: ,call-convention]
+                 [label: ,label]
                  [rpconv: ,rp-convention]
                  [base-idx: ,base-idx]
                  [arg-count: ,arg-count]
@@ -1088,6 +1092,90 @@
       [else (error who "invalid expression ~s" (unparse x))]))
   (Expr x))
 
+(define (optimize-for-direct-jumps x)
+  (define who 'optimize-for-direct-jumps)
+  (define (init-var x)
+    (set-var-referenced! x #f))
+  (define (set-var x v)
+    (record-case v
+      [(clambda) (set-var-referenced! x v)]
+      [(var) 
+       (cond
+         [(bound-var v) => (lambda (v) (set-var-referenced! x v))]
+         [else (void)])]
+      [else (void)]))
+  (define (bound-var x)
+    (var-referenced x))
+  (define (optimize c rator rand*)
+    (let ([n (length rand*)])
+      (record-case c
+        [(clambda main-label cls*)
+         (let f ([cls* cls*])
+           (cond
+             [(null? cls*) 
+              ;;; none matching?
+              (make-funcall rator rand*)]
+             [else
+              (record-case (clambda-case-info (car cls*))
+                [(case-info label fml* proper)
+                 (cond
+                   [proper
+                    (if (fx= n (length fml*))
+                        (make-jmpcall label rator rand*)
+                        (f (cdr cls*)))]
+                   [else
+                    (if (fx<= (length (cdr fml*)) n)
+                        (make-jmpcall label rator
+                           (let f ([fml* (cdr fml*)] [rand* rand*])
+                             (cond
+                               [(null? fml*) 
+                                (list (make-primcall 'list rand*))]
+                               [else
+                                (cons (car rand*)
+                                      (f (cdr fml*) (cdr rand*)))])))
+                        (f (cdr cls*)))])])]))])))
+  (define (Expr x)
+    (record-case x
+      [(constant) x]
+      [(var)      x]
+      [(primref)  x]
+      [(bind lhs* rhs* body)
+       (for-each init-var lhs*)
+       (let ([rhs* (map Expr rhs*)])
+         (for-each set-var lhs* rhs*)
+         (make-bind lhs* rhs* (Expr body)))]
+      [(fix lhs* rhs* body)
+       (for-each set-var lhs* rhs*)
+       (make-fix lhs* (map Expr rhs*) (Expr body))]
+      [(conditional test conseq altern)
+       (make-conditional (Expr test) (Expr conseq) (Expr altern))]
+      [(seq e0 e1) (make-seq (Expr e0) (Expr e1))]
+      [(clambda g cls*) 
+       (make-clambda g
+         (map (lambda (cls)
+                (record-case cls
+                  [(clambda-case info body)
+                   (for-each init-var (case-info-args info))
+                   (make-clambda-case info (Expr body))]))
+              cls*)
+         #f)]
+      [(primcall op rand*)
+       (make-primcall op (map Expr rand*))]
+      [(forcall op rand*)
+       (make-forcall op (map Expr rand*))]
+      [(funcall rator rand*)
+       (let ([rator (Expr rator)])
+         (cond
+           [(and (var? rator) (bound-var rator)) =>
+            (lambda (c)
+              (optimize c rator (map Expr rand*)))]
+           [else
+            (make-funcall rator (map Expr rand*))]))]
+      [(appcall rator rand*)
+       (make-appcall (Expr rator) (map Expr rand*))]
+      [else (error who "invalid expression ~s" (unparse x))]))
+  (Expr x))
+
 (define (convert-closures prog)
   (define who 'convert-closures)
   (define (Expr* x*)
@@ -1160,6 +1248,11 @@
                     [(rand* rand*-free) (Expr* rand*)])
          (values (make-funcall rator rand*) 
                  (union rat-free rand*-free)))]
+      [(jmpcall label rator rand*)
+       (let-values ([(rator rat-free) (Expr rator)]
+                    [(rand* rand*-free) (Expr* rand*)])
+         (values (make-jmpcall label rator rand*) 
+                 (union rat-free rand*-free)))] 
       [(appcall rator rand*)
        (let-values ([(rator rat-free) (Expr rator)]
                     [(rand* rand*-free) (Expr* rand*)])
@@ -1301,6 +1394,7 @@
       [(primcall op rand*)   (make-primcall op (map E rand*))]
       [(forcall op rand*)    (make-forcall op (map E rand*))]
       [(funcall rator rand*) (make-funcall (E rator) (map E rand*))]
+      [(jmpcall label rator rand*) (make-jmpcall label (E rator) (map E rand*))]
       [(appcall rator rand*) (make-appcall (E rator) (map E rand*))]
       [else (error who "invalid expression ~s" (unparse x))]))
   (let ([x (E x)])
@@ -1503,6 +1597,8 @@
           (when (primref? rator)
             (mark-uninlined (primref-name rator)))
           (make-funcall (Expr rator) (map Expr rand*))])]
+      [(jmpcall label op arg*)
+       (make-jmpcall label (Expr op) (map Expr arg*))]
       [(appcall op arg*)
        (make-appcall (Expr op) (map Expr arg*))]
       [else (error who "invalid expression ~s" (unparse x))]))
@@ -1537,6 +1633,8 @@
           (Tail (make-primcall (primref-name rator) rand*))]
          [else
           (make-funcall (Expr rator) (map Expr rand*))])]
+      [(jmpcall label op arg*)
+       (make-jmpcall label (Expr op) (map Expr arg*))]
       [(appcall op arg*)
        (make-appcall (Expr op) (map Expr arg*))]
       [else (error who "invalid expression ~s" (unparse x))]))
@@ -1605,6 +1703,8 @@
        (make-funcall (Expr rator) (map Expr rand*))]
       [(appcall op arg*)
        (make-appcall (Expr op) (map Expr arg*))]
+      [(jmpcall label op arg*)
+       (make-jmpcall label (Expr op) (map Expr arg*))]
       [else (error who "invalid expression ~s" (unparse x))]))
   (define (Tail x)
     (record-case x
@@ -1620,6 +1720,8 @@
        (make-funcall (Expr rator) (map Expr rand*))]
       [(appcall op arg*)
        (make-appcall (Expr op) (map Expr arg*))]
+      [(jmpcall label op arg*)
+       (make-jmpcall label (Expr op) (map Expr arg*))]
       [else (error who "invalid expression ~s" (unparse x))]))
   (define (CaseExpr x)
     (record-case x 
@@ -1660,6 +1762,7 @@
       [(forcall op arg*)  (ormap Expr arg*)]
       [(funcall rator arg*) #t] 
       [(appcall rator arg*)    #t]
+      [(jmpcall label rator arg*)    #t]
       [else (error who "invalid expression ~s" (unparse x))]))
   (define (Tail x)
     (record-case x
@@ -1672,6 +1775,7 @@
       [(seq e0 e1) (or (Expr e0) (Tail e1))]
       [(funcall rator arg*) (or (Expr rator) (ormap Expr arg*))] 
       [(appcall rator arg*) (or (Expr rator) (ormap Expr arg*))]
+      [(jmpcall label rator arg*) (or (Expr rator) (ormap Expr arg*))]
       [else (error who "invalid tail expression ~s" (unparse x))]))
   (define (CaseExpr x)
     (record-case x 
@@ -1801,6 +1905,8 @@
        (make-funcall (Expr rator) (map Expr rand*))]
       [(appcall op arg*)
        (make-appcall (Expr op) (map Expr arg*))]
+      [(jmpcall label op arg*)
+       (make-jmpcall label (Expr op) (map Expr arg*))]
       [else (error who "invalid expression ~s" (unparse x))]))
   (define (Tail x)
     (record-case x
@@ -1818,6 +1924,8 @@
       [(seq e0 e1) (make-seq (Expr e0) (Tail e1))]
       [(funcall rator rand*)
        (make-funcall (Expr rator) (map Expr rand*))]
+      [(jmpcall label op arg*)
+       (make-jmpcall label (Expr op) (map Expr arg*))]
       [(appcall op arg*)
        (make-appcall (Expr op) (map Expr arg*))]
       [else (error who "invalid expression ~s" (unparse x))]))
@@ -1860,7 +1968,7 @@
       [(primref? x) #f]  ;;;; PRIMREF CHECK
       [(closure? x) #f]
       [else         #t]))
-  (define (do-new-frame op rand* si r call-convention rp-convention orig-live)
+  (define (do-new-frame label op rand* si r call-convention rp-convention orig-live)
     (make-new-frame (fxadd1 si) (fx+ (length rand*) 2)
       (let f ([r* rand*] [nsi (fx+ si 2)] [live orig-live])
         (cond
@@ -1869,12 +1977,12 @@
              (make-seq 
                (make-save-cp (make-frame-var si))
                (case call-convention
-                 [(normal apply)
+                 [(normal apply direct)
                   (make-eval-cp (check? op) (Expr op nsi r (cons si live)))]
                  [(foreign)
                   (make-eval-cp #f (make-foreign-label op))]
                  [else (error who "invalid convention ~s" call-convention)]))
-             (make-call-cp call-convention 
+             (make-call-cp call-convention label
                 rp-convention
                 (fxadd1 si)    ; frame size
                 (length rand*) ; argc
@@ -1914,7 +2022,7 @@
            (f (cdr l*) (cons v nlhs*) (fxadd1 si) 
               (cons (cons (car l*) v) r)
               (cons si live)))])))
-  (define (do-tail-frame op rand* si r call-conv live)
+  (define (do-tail-frame label op rand* si r call-conv live)
     (define (const? x)
       (record-case x
         [(constant) #t]
@@ -1955,7 +2063,7 @@
                     (make-assign (make-frame-var i) vsi))))]))]))
     (make-seq
       (evalrand* rand* 1 si r live (make-primcall 'void '()))
-      (make-tailcall-cp call-conv (length rand*))))
+      (make-tailcall-cp call-conv label (length rand*))))
   (define (Tail x si r live)
     (record-case x
       [(return v) (make-return (Expr v si r live))]
@@ -1975,13 +2083,11 @@
            (map (lambda (x) (Expr x si r live)) arg*)))]
                                   
       [(funcall op rand*)
-       (do-tail-frame op rand* si r 'normal live)]
+       (do-tail-frame #f op rand* si r 'normal live)]
       [(appcall op rand*)
-       (do-tail-frame op rand* si r 'apply live)]
+       (do-tail-frame #f op rand* si r 'apply live)]
-;;;      [(funcall op rand*)
+      [(jmpcall label op rand*)
-;;;       (do-new-frame op rand* si r 'normal 'tail live)]
+       (do-tail-frame label op rand* si r 'direct live)]
-;;;      [(appcall op rand*)
-;;;       (do-new-frame op rand* si r 'apply 'tail live)]
       [else (error who "invalid expression ~s" (unparse x))]))
   (define (Effect x si r live)
     (record-case x
@@ -2003,11 +2109,13 @@
        (make-primcall op 
          (map (lambda (x) (Expr x si r live)) arg*))]
       [(forcall op rand*)
-       (do-new-frame op rand* si r 'foreign 'effect live)]
+       (do-new-frame #f op rand* si r 'foreign 'effect live)]
       [(funcall op rand*)
-       (do-new-frame op rand* si r 'normal 'effect live)]
+       (do-new-frame #f op rand* si r 'normal 'effect live)]
+      [(jmpcall label op rand*)
+       (do-new-frame label op rand* si r 'direct 'effect live)]
       [(appcall op rand*)
-       (do-new-frame op rand* si r 'apply 'effect live)]
+       (do-new-frame #f op rand* si r 'apply 'effect live)]
       [else (error who "invalid effect expression ~s" (unparse x))]))
   (define (Expr x si r live)
     (record-case x
@@ -2033,11 +2141,13 @@
        (make-primcall op 
          (map (lambda (x) (Expr x si r live)) arg*))]
       [(forcall op rand*)
-       (do-new-frame op rand* si r 'foreign 'value live)]
+       (do-new-frame #f op rand* si r 'foreign 'value live)]
       [(funcall op rand*)
-       (do-new-frame op rand* si r 'normal 'value live)]
+       (do-new-frame #f op rand* si r 'normal 'value live)]
+      [(jmpcall label op rand*)
+       (do-new-frame label op rand* si r 'direct 'value live)]
       [(appcall op rand*)
-       (do-new-frame op rand* si r 'apply 'value live)]
+       (do-new-frame #f op rand* si r 'apply 'value live)]
       [else (error who "invalid expression ~s" (unparse x))]))
   (define (bind-fml* fml* r)
     (let f ([si 1] [fml* fml*])
@@ -3509,7 +3619,7 @@
        (do-value-prim op rand* ac)]
       [(new-frame base-idx size body)
        (NonTail body ac)]
-      [(call-cp call-convention rp-convention offset size mask)
+      [(call-cp call-convention direct-label rp-convention offset size mask)
        (let ([L_CALL (unique-label)])
          (case call-convention
            [(normal)
@@ -3528,6 +3638,20 @@
                    (movl (mem 0 fpr) cpr)
                    (subl (int (frame-adjustment offset)) fpr)
                    ac)]
+           [(direct)
+            (list* (addl (int (frame-adjustment offset)) fpr)
+                   ;(movl (int (argc-convention size)) eax)
+                   (jmp L_CALL)
+                   ; NEW FRAME
+                   `(byte-vector ,mask)
+                   `(int ,(fx* offset wordsize))
+                   `(current-frame-offset)
+                   (rp-label rp-convention)
+                   L_CALL
+                   (call (label direct-label))
+                   (movl (mem 0 fpr) cpr)
+                   (subl (int (frame-adjustment offset)) fpr)
+                   ac)] 
            [(foreign) 
             (list* (addl (int (frame-adjustment offset)) fpr)
                    (movl (int (argc-convention size)) eax)
@@ -3669,15 +3793,23 @@
       (do-fix lhs* rhs* (Tail body ac))]
      [(new-frame idx size body)
       (Tail body ac)]
-     [(tailcall-cp call-convention argc)
+     [(tailcall-cp call-convention direct-label argc)
-      (list* 
+      (case call-convention
-        (movl (int (argc-convention argc)) eax)
+        [(normal) 
-        (case call-convention
+         (list*
-          [(normal) (tail-indirect-cpr-call)]
+           (movl (int (argc-convention argc)) eax)
-          [(apply)  (jmp (label SL_apply))]
+           (tail-indirect-cpr-call)
-          [else 
+           ac)]
-           (error who "invalid tail-call convention ~s" call-convention)])
+        [(apply)  
-        ac)]
+         (list*
+           (movl (int (argc-convention argc)) eax)
+           (jmp (label SL_apply))
+           ac)]
+        [(direct) 
+         (list* (jmp (label direct-label)) ac)]
+        [else 
+         (error who "invalid tail-call convention ~s"
+                call-convention)])]
       [else (error 'Tail "invalid expression ~s" x)]))
   (define (handle-vararg fml-count ac)
     (define CONTINUE_LABEL (unique-label))
@@ -4028,6 +4160,7 @@
          [p (uncover-assigned/referenced p)]
          [p (copy-propagate p)]
          [p (rewrite-assignments p)]
+         [p (optimize-for-direct-jumps p)]
          [p (convert-closures p)]
          [p (optimize-closures/lift-codes p)]
          [p (introduce-primcalls p)]