mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-29 19:30:36 +02:00
Code Activity

Emit instrument-loop in loops.

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2018-07-25 13:08:05 +02:00
parent 87da1c8d20
commit a6b5049aa8
8 changed files with 82 additions and 47 deletions
Download patch file Download diff file Expand all files Collapse all files

2
am/bootstrap.am
View file

@ -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 \

2
libguile/jit.c
View file

@ -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)
{
}

2
libguile/jit.h
View file

@ -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
};

6
libguile/vm-engine.c
View file

@ -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);
}

2
module/Makefile.am
View file

@ -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 \

11
module/language/cps/compile-bytecode.scm
View file

@ -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)

48
module/language/cps/handle-interrupts.scm → module/language/cps/loop-instrumentation.scm
View file

@ -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)))))

56
module/system/vm/assembler.scm
View file

@ -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))))))))))