guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] 03/06: Emit instrument-loop in loops.


From: Andy Wingo
Subject: [Guile-commits] 03/06: Emit instrument-loop in loops.
Date: Sun, 29 Jul 2018 10:10:57 -0400 (EDT)

wingo pushed a commit to branch lightning
in repository guile.

commit a6b5049aa8476408e452603bf2171789ddaac9ea
Author: Andy Wingo <address@hidden>
Date:   Wed Jul 25 13:08:05 2018 +0200

    Emit instrument-loop in loops.
    
    * am/bootstrap.am (SOURCES):
    * module/Makefile.am (SOURCES): Handle renamve of handle-interrupts.scm
      to loop-instrumentation.scm.
    * libguile/jit.h (SCM_JIT_COUNTER_ENTRY_INCREMENT): Rename from
      SCM_JIT_COUNTER_CALL_INCREMENT.
    * libguile/vm-engine.c (instrument-entry): Rename from instrument-call.
    * module/language/cps/compile-bytecode.scm (compile-function): Add
      handle-interrupts code before calls and returns.  Compile the
      "instrument-loop" primcall to an "instrument-loop" instruction and a
      "handle-interrupts" instruction.
      (lower-cps): Adapt to add-loop-instrumentation name change.
    * module/language/cps/loop-instrumentation.scm: Rename from
      handle-interrupts.scm and just add "instrument-loop" primcalls in
      loops.  The compiler will add handle-interrupts primcalls as
      appropriate.
    * module/system/vm/assembler.scm (<jit-data>): New data type, for
      emitting embedded JIT data.
      (<meta>): Add field for current JIT data.
      (make-meta): Initialize current JIT data.
      (emit-instrument-entry*, emit-instrument-loop*): New instruction
      emitters that reference the current JIT data.
      (end-program): Now that all labels are known, arrange to serialize the
      JIT data.
      (link-data): Reserve space for JIT data, and add relocs to initialize
      the "start" / "end" fields.
---
 am/bootstrap.am                                    |  2 +-
 libguile/jit.c                                     |  2 +-
 libguile/jit.h                                     |  2 +-
 libguile/vm-engine.c                               |  6 +--
 module/Makefile.am                                 |  2 +-
 module/language/cps/compile-bytecode.scm           | 11 +++--
 ...dle-interrupts.scm => loop-instrumentation.scm} | 48 +++++++------------
 module/system/vm/assembler.scm                     | 56 +++++++++++++++++++---
 8 files changed, 82 insertions(+), 47 deletions(-)

diff --git a/am/bootstrap.am b/am/bootstrap.am
index cb5301f..e2367b7 100644
--- a/am/bootstrap.am
+++ b/am/bootstrap.am
@@ -81,8 +81,8 @@ SOURCES =                                     \
   language/cps/dce.scm                         \
   language/cps/devirtualize-integers.scm       \
   language/cps/effects-analysis.scm            \
-  language/cps/handle-interrupts.scm           \
   language/cps/licm.scm                                \
+  language/cps/loop-instrumentation.scm                \
   language/cps/peel-loops.scm                  \
   language/cps/prune-top-level-scopes.scm      \
   language/cps/reify-primitives.scm            \
diff --git a/libguile/jit.c b/libguile/jit.c
index 92df1d6..178fd8a 100644
--- a/libguile/jit.c
+++ b/libguile/jit.c
@@ -71,7 +71,7 @@ compile_tail_call_label (scm_jit_state *j, const uint32_t 
*vcode)
 }
 
 static void
-compile_instrument_call (scm_jit_state *j, void *data)
+compile_instrument_entry (scm_jit_state *j, void *data)
 {
 }
 
diff --git a/libguile/jit.h b/libguile/jit.h
index 5067b61..fe53320 100644
--- a/libguile/jit.h
+++ b/libguile/jit.h
@@ -45,7 +45,7 @@ struct scm_jit_function_data
 
 enum scm_jit_counter_value
 {
-  SCM_JIT_COUNTER_CALL_INCREMENT = 15,
+  SCM_JIT_COUNTER_ENTRY_INCREMENT = 15,
   SCM_JIT_COUNTER_LOOP_INCREMENT = 1,
   SCM_JIT_COUNTER_THRESHOLD = 50
 };
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 1b0647e..2eea8c1 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -468,14 +468,14 @@ VM_NAME (scm_thread *thread)
       NEXT (0);
     }
 
-  /* instrument-call _:24 data:32
+  /* instrument-entry _:24 data:32
    *
    * Increase execution counter for this function and potentially tier
    * up to the next JIT level.  DATA is an offset to raw profiler,
    * recording execution counts and the next-level JIT code
    * corresponding to this function.  Also run the apply hook.
    */
-  VM_DEFINE_OP (5, instrument_call, "instrument-call", OP2 (X32, N32))
+  VM_DEFINE_OP (5, instrument_entry, "instrument-entry", OP2 (X32, N32))
     {
       int32_t data_offset = ip[1];
       struct scm_jit_function_data *data;
@@ -497,7 +497,7 @@ VM_NAME (scm_thread *thread)
             }
         }
       else
-        data->counter += SCM_JIT_COUNTER_CALL_INCREMENT;
+        data->counter += SCM_JIT_COUNTER_ENTRY_INCREMENT;
 
       NEXT (2);
     }
diff --git a/module/Makefile.am b/module/Makefile.am
index 3d105f1..8c43ff5 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -136,10 +136,10 @@ SOURCES =                                 \
   language/cps/dce.scm                         \
   language/cps/devirtualize-integers.scm       \
   language/cps/effects-analysis.scm            \
-  language/cps/handle-interrupts.scm           \
   language/cps/intmap.scm                      \
   language/cps/intset.scm                      \
   language/cps/licm.scm                                \
+  language/cps/loop-instrumentation.scm                \
   language/cps/optimize.scm                    \
   language/cps/peel-loops.scm                  \
   language/cps/prune-top-level-scopes.scm      \
diff --git a/module/language/cps/compile-bytecode.scm 
b/module/language/cps/compile-bytecode.scm
index 60aac23..f0a5506 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -30,7 +30,7 @@
   #:use-module (language cps slot-allocation)
   #:use-module (language cps utils)
   #:use-module (language cps closure-conversion)
-  #:use-module (language cps handle-interrupts)
+  #:use-module (language cps loop-instrumentation)
   #:use-module (language cps optimize)
   #:use-module (language cps reify-primitives)
   #:use-module (language cps renumber)
@@ -119,18 +119,21 @@
                     ((src . dst) (emit-mov asm (from-sp dst) (from-sp src))))
                    (lookup-parallel-moves label allocation))
          (maybe-reset-frame (1+ (length args)))
+         (emit-handle-interrupts asm)
          (emit-tail-call asm))
         (($ $callk k proc args)
          (for-each (match-lambda
                     ((src . dst) (emit-mov asm (from-sp dst) (from-sp src))))
                    (lookup-parallel-moves label allocation))
          (maybe-reset-frame (1+ (length args)))
+         (emit-handle-interrupts asm)
          (emit-tail-call-label asm k))
         (($ $values args)
          (for-each (match-lambda
                     ((src . dst) (emit-mov asm (from-sp dst) (from-sp src))))
                    (lookup-parallel-moves label allocation))
          (maybe-reset-frame (length args))
+         (emit-handle-interrupts asm)
          (emit-return-values asm))))
 
     (define (compile-value label exp dst)
@@ -363,7 +366,8 @@
         (($ $primcall 'atomic-scm-set!/immediate (annotation . idx) (obj val))
          (emit-atomic-scm-set!/immediate asm (from-sp (slot obj)) idx
                                          (from-sp (slot val))))
-        (($ $primcall 'handle-interrupts #f ())
+        (($ $primcall 'instrument-loop #f ())
+         (emit-instrument-loop asm)
          (emit-handle-interrupts asm))))
 
     (define (compile-throw op param args)
@@ -520,6 +524,7 @@
           (for-each (match-lambda
                      ((src . dst) (emit-mov asm (from-sp dst) (from-sp src))))
                     (lookup-parallel-moves label allocation))
+          (emit-handle-interrupts asm)
           (emit-call asm proc-slot nargs)
           (emit-slot-map asm proc-slot (lookup-slot-map label allocation))
           (cond
@@ -671,7 +676,7 @@
   (set! exp (convert-closures exp))
   (set! exp (optimize-first-order-cps exp opts))
   (set! exp (reify-primitives exp))
-  (set! exp (add-handle-interrupts exp))
+  (set! exp (add-loop-instrumentation exp))
   (renumber exp))
 
 (define (compile-bytecode exp env opts)
diff --git a/module/language/cps/handle-interrupts.scm 
b/module/language/cps/loop-instrumentation.scm
similarity index 56%
rename from module/language/cps/handle-interrupts.scm
rename to module/language/cps/loop-instrumentation.scm
index 614b7a4..845a35a 100644
--- a/module/language/cps/handle-interrupts.scm
+++ b/module/language/cps/loop-instrumentation.scm
@@ -18,12 +18,11 @@
 
 ;;; Commentary:
 ;;;
-;;; A pass to add "handle-interrupts" primcalls before calls, loop
-;;; back-edges, and returns.
+;;; A pass to add "instrument-loop" primcalls at loop headers.
 ;;;
 ;;; Code:
 
-(define-module (language cps handle-interrupts)
+(define-module (language cps loop-instrumentation)
   #:use-module (ice-9 match)
   #:use-module (language cps)
   #:use-module (language cps utils)
@@ -31,36 +30,25 @@
   #:use-module (language cps intmap)
   #:use-module (language cps intset)
   #:use-module (language cps renumber)
-  #:export (add-handle-interrupts))
+  #:export (add-loop-instrumentation))
 
-(define (compute-safepoints cps)
-  (define (maybe-add-safepoint label k safepoints)
-    "Add K to safepoints if it is a target of a backward branch."
+(define (compute-loop-headers cps)
+  (define (maybe-add-header label k headers)
+    "Add K to headers if it is a target of a backward branch."
     (if (<= k label)
-        (intset-add! safepoints k)
-        safepoints))
-  (define (visit-cont label cont safepoints)
+        (intset-add! headers k)
+        headers))
+  (define (visit-cont label cont headers)
     (match cont
-      (($ $kargs names vars ($ $continue k src exp))
-       (let ((safepoints (maybe-add-safepoint label k safepoints)))
-         (if (match exp
-               (($ $call) #t)
-               (($ $callk) #t)
-               (($ $values)
-                (match (intmap-ref cps k)
-                  (($ $ktail) #t)
-                  (_ #f)))
-               (_ #f))
-             (intset-add! safepoints label)
-             safepoints)))
+      (($ $kargs names vars ($ $continue k))
+       (maybe-add-header label k headers))
       (($ $kargs names vars ($ $branch kf kt))
-       (maybe-add-safepoint label kf
-                            (maybe-add-safepoint label kt safepoints)))
-      (_ safepoints)))
+       (maybe-add-header label kf (maybe-add-header label kt headers)))
+      (_ headers)))
   (persistent-intset (intmap-fold visit-cont cps empty-intset)))
 
-(define (add-handle-interrupts cps)
-  (define (add-safepoint label cps)
+(define (add-loop-instrumentation cps)
+  (define (add-instrumentation label cps)
     (match (intmap-ref cps label)
       (($ $kargs names vars term)
        (with-cps cps
@@ -68,8 +56,8 @@
          (setk label
                ($kargs names vars
                  ($continue k #f
-                   ($primcall 'handle-interrupts #f ()))))))))
+                   ($primcall 'instrument-loop #f ()))))))))
   (let* ((cps (renumber cps))
-         (safepoints (compute-safepoints cps)))
+         (headers (compute-loop-headers cps)))
     (with-fresh-name-state cps
-      (persistent-intmap (intset-fold add-safepoint safepoints cps)))))
+      (persistent-intmap (intset-fold add-instrumentation headers cps)))))
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 678abb3..e834ef6 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -236,8 +236,8 @@
             emit-call-label
             emit-tail-call
             emit-tail-call-label
-            emit-instrument-call
-            emit-instrument-loop
+            (emit-instrument-entry* . emit-instrument-entry)
+            (emit-instrument-loop* . emit-instrument-loop)
             emit-receive-values
             emit-return-values
             emit-call/cc
@@ -399,19 +399,28 @@ N-byte unit."
       (unless (match x (pattern #t) (_ #f))
         (error (string-append "expected " kind) x)))))
 
+(define-record-type <jit-data>
+  (make-jit-data label entry-label exit-label)
+  jit-data?
+  (label jit-data-label)
+  (entry-label jit-data-entry-label)
+  (exit-label jit-data-exit-label))
+
 (define-record-type <meta>
-  (%make-meta label properties low-pc high-pc arities)
+  (%make-meta label properties low-pc high-pc arities jit-data)
   meta?
   (label meta-label)
   (properties meta-properties set-meta-properties!)
   (low-pc meta-low-pc)
   (high-pc meta-high-pc set-meta-high-pc!)
-  (arities meta-arities set-meta-arities!))
+  (arities meta-arities set-meta-arities!)
+  (jit-data meta-jit-data))
 
 (define (make-meta label properties low-pc)
   (assert-match label (or (? exact-integer?) (? symbol?)) "symbol")
   (assert-match properties (((? symbol?) . _) ...) "alist with symbolic keys")
-  (%make-meta label properties low-pc #f '()))
+  (let ((jit-data (make-jit-data (gensym "jit-data") label (gensym "end"))))
+    (%make-meta label properties low-pc #f '() jit-data)))
 
 (define (meta-name meta)
   (assq-ref (meta-properties meta) 'name))
@@ -1053,6 +1062,14 @@ later by the linker."
 (define (emit-throw/value+data* asm val param)
   (emit-throw/value+data asm val (intern-non-immediate asm param)))
 
+(define (emit-instrument-entry* asm)
+  (let ((meta (car (asm-meta asm))))
+    (emit-instrument-entry asm (jit-data-label (meta-jit-data meta)))))
+
+(define (emit-instrument-loop* asm)
+  (let ((meta (car (asm-meta asm))))
+    (emit-instrument-loop asm (jit-data-label (meta-jit-data meta)))))
+
 (define (emit-text asm instructions)
   "Assemble @var{instructions} using the assembler @var{asm}.
 @var{instructions} is a sequence of instructions, expressed as a list of
@@ -1389,6 +1406,10 @@ returned instead."
 
 (define-macro-assembler (end-program asm)
   (let ((meta (car (asm-meta asm))))
+    (match (meta-jit-data meta)
+      ((and jit-data ($ <jit-data> label entry-label exit-label))
+       (emit-label asm exit-label)
+       (set-asm-constants! asm (vhash-cons jit-data label (asm-constants 
asm)))))
     (set-meta-high-pc! meta (asm-start asm))
     (set-meta-arities! meta (reverse (meta-arities meta)))))
 
@@ -1619,6 +1640,11 @@ should be .data or .rodata), and return the resulting 
linker object.
         (* (1+ (vector-length x)) word-size))
        ((syntax? x)
         (* 4 word-size))
+       ((jit-data? x)
+        (case word-size
+          ((4) (+ word-size (* 4 3)))
+          ((8) (+ word-size (* 4 4))) ;; One additional uint32_t for padding.
+          (else (error word-size))))
        ((simple-uniform-vector? x)
         (* 4 word-size))
        ((uniform-vector-backing-store? x)
@@ -1685,6 +1711,10 @@ should be .data or .rodata), and return the resulting 
linker object.
        ((cache-cell? obj)
         (write-placeholder asm buf pos))
 
+       ((jit-data? obj)
+        ;; Default initialization of 0.
+        (values))
+
        ((string? obj)
         (let ((tag (logior tc7-string string-read-only-flag)))
           (case word-size
@@ -1805,6 +1835,17 @@ should be .data or .rodata), and return the resulting 
linker object.
        (else
         (error "unrecognized object" obj))))
 
+    (define (add-relocs obj pos relocs)
+      (match obj
+        (($ <jit-data> label entry-label exit-label)
+         ;; Patch "start" and "end" fields of "struct jit_data".
+         (cons* (make-linker-reloc 'rel32/1 (+ pos word-size 4) (+ word-size 4)
+                                   entry-label)
+                (make-linker-reloc 'rel32/1 (+ pos word-size 8) (+ word-size 8)
+                                   exit-label)
+                relocs))
+        (_ relocs)))
+
     (cond
      ((vlist-null? data) #f)
      (else
@@ -1812,7 +1853,7 @@ should be .data or .rodata), and return the resulting 
linker object.
                                      (+ (byte-length k) (align len 8)))
                                    0 data))
              (buf (make-bytevector byte-len 0)))
-        (let lp ((i 0) (pos 0) (symbols '()))
+        (let lp ((i 0) (pos 0) (relocs '()) (symbols '()))
           (if (< i (vlist-length data))
               (let* ((pair (vlist-ref data i))
                      (obj (car pair))
@@ -1820,8 +1861,9 @@ should be .data or .rodata), and return the resulting 
linker object.
                 (write buf pos obj)
                 (lp (1+ i)
                     (align (+ (byte-length obj) pos) 8)
+                    (add-relocs obj pos relocs)
                     (cons (make-linker-symbol obj-label pos) symbols)))
-              (make-object asm name buf '() symbols
+              (make-object asm name buf relocs symbols
                            #:flags (match name
                                      ('.data (logior SHF_ALLOC SHF_WRITE))
                                      ('.rodata SHF_ALLOC))))))))))



reply via email to

[Prev in Thread] Current Thread [Next in Thread]