[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))))))))))
- [Guile-commits] branch lightning updated (950a762 -> b8a9a66), Andy Wingo, 2018/07/29
- [Guile-commits] 04/06: Emit instrument-entry before programs, Andy Wingo, 2018/07/29
- [Guile-commits] 02/06: Add instrument-call, instrument-loop VM instructions, Andy Wingo, 2018/07/29
- [Guile-commits] 03/06: Emit instrument-loop in loops.,
Andy Wingo <=
- [Guile-commits] 01/06: Update frames.h comments., Andy Wingo, 2018/07/29
- [Guile-commits] 05/06: Fix function bound offsets of JIT data to be signed, Andy Wingo, 2018/07/29
- [Guile-commits] 06/06: Rewrite subr implementation, Andy Wingo, 2018/07/29