mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-07-09 10:50:27 +02:00
Remove primitive?, add primitive-code?
We need to be able to identify frames that are primitive applications without assuming that slot 0 in a frame is an SCM value and without assuming that value is the procedure being applied. * libguile/gsubr.c (scm_i_primitive_code_p): New helper. (scm_i_primitive_arity): Use the new helper. * libguile/gsubr.h: Declare the new helper. * libguile/programs.h: * libguile/programs.c (scm_program_code_p): New function, replacing scm_primitive_p. (scm_primitive_call_ip): Fix FUNC_NAME definition. * module/statprof.scm (sample-stack-procs, count-call): Identify primitive frames from the IP, not the frame-procedure. Avoids the assumption that slot 0 in a frame is a SCM value. (statprof-proc-call-data): Adapt to primitive-code? change. * module/system/vm/frame.scm (frame-call-representation): Identify primitive frames from the IP, not the closure. Still more work to do here to avoid assuming slot 0 is a procedure. * module/system/vm/program.scm: Export primitive-code? instead of primitive?. (program-arguments-alist, program-arguments-alists): Identify primitives from the code instead of the flags on the program. Not sure this is a great change, but it does avoid having to define a primitive? predicate in Scheme.
This commit is contained in:
Andy Wingo
parent
3b3405e504
commit
8af3423efe
7 changed files with 67 additions and 55 deletions
|
|
@ -251,6 +251,17 @@ create_subr (int define, const char *name,
|
|||
return ret;
|
||||
}
|
||||
|
||||
int
|
||||
scm_i_primitive_code_p (const scm_t_uint32 *code)
|
||||
{
|
||||
if (code < subr_stub_code)
|
||||
return 0;
|
||||
if (code > subr_stub_code + (sizeof(subr_stub_code) / sizeof(scm_t_uint32)))
|
||||
return 0;
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
/* Given a program that is a primitive, determine its minimum arity.
|
||||
This is possible because each primitive's code is 4 32-bit words
|
||||
long, and they are laid out contiguously in an ordered pattern. */
|
||||
|
|
@ -260,9 +271,7 @@ scm_i_primitive_arity (SCM prim, int *req, int *opt, int *rest)
|
|||
const scm_t_uint32 *code = SCM_PROGRAM_CODE (prim);
|
||||
unsigned idx, nargs, base, next;
|
||||
|
||||
if (code < subr_stub_code)
|
||||
return 0;
|
||||
if (code > subr_stub_code + (sizeof(subr_stub_code) / sizeof(scm_t_uint32)))
|
||||
if (!scm_i_primitive_code_p (code))
|
||||
return 0;
|
||||
|
||||
idx = (code - subr_stub_code) / 4;
|
||||
|
|
|
|||
|
|
@ -54,6 +54,7 @@
|
|||
|
||||
|
||||
|
||||
SCM_INTERNAL int scm_i_primitive_code_p (const scm_t_uint32 *code);
|
||||
SCM_INTERNAL int scm_i_primitive_arity (SCM subr, int *req, int *opt, int *rest);
|
||||
SCM_INTERNAL scm_t_uintptr scm_i_primitive_call_ip (SCM subr);
|
||||
|
||||
|
|
|
|||
|
|
@ -144,19 +144,21 @@ SCM_DEFINE (scm_program_p, "program?", 1, 0, 0,
|
|||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
SCM_DEFINE (scm_primitive_p, "primitive?", 1, 0, 0,
|
||||
(SCM obj),
|
||||
SCM_DEFINE (scm_primitive_code_p, "primitive-code?", 1, 0, 0,
|
||||
(SCM code),
|
||||
"")
|
||||
#define FUNC_NAME s_scm_primitive_p
|
||||
#define FUNC_NAME s_scm_primitive_code_p
|
||||
{
|
||||
return scm_from_bool (SCM_PRIMITIVE_P (obj));
|
||||
const scm_t_uint32 * ptr = (const scm_t_uint32 *) scm_to_uintptr_t (code);
|
||||
|
||||
return scm_from_bool (scm_i_primitive_code_p (ptr));
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
SCM_DEFINE (scm_primitive_call_ip, "primitive-call-ip", 1, 0, 0,
|
||||
(SCM prim),
|
||||
"")
|
||||
#define FUNC_NAME s_scm_primitive_p
|
||||
#define FUNC_NAME s_scm_primitive_call_ip
|
||||
{
|
||||
SCM_MAKE_VALIDATE (1, prim, PRIMITIVE_P);
|
||||
|
||||
|
|
|
|||
|
|
@ -58,7 +58,7 @@ scm_i_make_program (const scm_t_uint32 *code)
|
|||
SCM_INTERNAL SCM scm_program_p (SCM obj);
|
||||
SCM_INTERNAL SCM scm_program_code (SCM program);
|
||||
|
||||
SCM_INTERNAL SCM scm_primitive_p (SCM obj);
|
||||
SCM_INTERNAL SCM scm_primitive_code_p (SCM code);
|
||||
SCM_INTERNAL SCM scm_primitive_call_ip (SCM prim);
|
||||
|
||||
SCM_INTERNAL SCM scm_i_program_name (SCM program);
|
||||
|
|
|
|||
|
|
@ -327,10 +327,13 @@
|
|||
(set-buffer! state buffer)
|
||||
(set-buffer-pos! state (1+ pos)))
|
||||
(else
|
||||
(let ((proc (frame-procedure frame)))
|
||||
(write-sample-and-continue (if (primitive? proc)
|
||||
(procedure-name proc)
|
||||
(frame-instruction-pointer frame))))))))
|
||||
(let ((ip (frame-instruction-pointer frame)))
|
||||
(write-sample-and-continue
|
||||
(if (primitive-code? ip)
|
||||
;; Grovel and get the primitive name from the gsubr, which
|
||||
;; we know to be in slot 0.
|
||||
(procedure-name (frame-local-ref frame 0 'scm))
|
||||
ip)))))))
|
||||
|
||||
(define (reset-sigprof-timer usecs)
|
||||
;; Guile's setitimer binding is terrible.
|
||||
|
|
@ -376,11 +379,11 @@
|
|||
(unless (inside-profiler? state)
|
||||
(accumulate-time state (get-internal-run-time))
|
||||
|
||||
(let* ((key (let ((proc (frame-procedure frame)))
|
||||
(cond
|
||||
((primitive? proc) (procedure-name proc))
|
||||
((program? proc) (program-code proc))
|
||||
(else proc))))
|
||||
;; We know local 0 is a SCM value: the c
|
||||
(let* ((ip (frame-instruction-pointer frame))
|
||||
(key (if (primitive-code? ip)
|
||||
(procedure-name (frame-local-ref frame 0 'scm))
|
||||
ip))
|
||||
(handle (hashv-create-handle! (call-counts state) key 0)))
|
||||
(set-cdr! handle (1+ (cdr handle))))
|
||||
|
||||
|
|
@ -594,11 +597,13 @@ it represents different functions with the same name."
|
|||
none is available."
|
||||
(when (statprof-active?)
|
||||
(error "Can't call statprof-proc-call-data while profiler is running."))
|
||||
(hashv-ref (stack-samples->procedure-data state)
|
||||
(cond
|
||||
((primitive? proc) (procedure-name proc))
|
||||
((program? proc) (program-code proc))
|
||||
(else (program-code proc)))))
|
||||
(unless (program? proc)
|
||||
(error "statprof-call-data only works for VM programs"))
|
||||
(let* ((code (program-code proc))
|
||||
(key (if (primitive-code? code)
|
||||
(procedure-name proc)
|
||||
code)))
|
||||
(hashv-ref (stack-samples->procedure-data state) key)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Stats
|
||||
|
|
|
|||
|
|
@ -402,7 +402,7 @@
|
|||
(arity-keyword-args arity)
|
||||
(arity-has-rest? arity)
|
||||
1))))
|
||||
((and (primitive? closure)
|
||||
((and (primitive-code? ip)
|
||||
(program-arguments-alist closure ip))
|
||||
=> (lambda (args)
|
||||
(match args
|
||||
|
|
|
|||
|
|
@ -44,7 +44,7 @@
|
|||
|
||||
print-program
|
||||
|
||||
primitive?))
|
||||
primitive-code?))
|
||||
|
||||
(load-extension (string-append "libguile-" (effective-version))
|
||||
"scm_init_programs")
|
||||
|
|
@ -195,8 +195,9 @@ of integers."
|
|||
;; the name "program-arguments" is taken by features.c...
|
||||
(define* (program-arguments-alist prog #:optional ip)
|
||||
"Returns the signature of the given procedure in the form of an association list."
|
||||
(let ((code (program-code prog)))
|
||||
(cond
|
||||
((primitive? prog)
|
||||
((primitive-code? code)
|
||||
(match (procedure-minimum-arity prog)
|
||||
(#f #f)
|
||||
((nreq nopt rest?)
|
||||
|
|
@ -206,17 +207,13 @@ of integers."
|
|||
(arity->arguments-alist
|
||||
prog
|
||||
(list 0 0 nreq nopt rest? '(#f . ()))))))))
|
||||
((program? prog)
|
||||
(else
|
||||
(or-map (lambda (arity)
|
||||
(and (or (not ip)
|
||||
(and (<= (arity-low-pc arity) ip)
|
||||
(< ip (arity-high-pc arity))))
|
||||
(arity-arguments-alist arity)))
|
||||
(or (find-program-arities (program-code prog)) '())))
|
||||
(else
|
||||
(let ((arity (program-arity prog ip)))
|
||||
(and arity
|
||||
(arity->arguments-alist prog arity))))))
|
||||
(or (find-program-arities code) '()))))))
|
||||
|
||||
(define* (program-lambda-list prog #:optional ip)
|
||||
"Returns the signature of the given procedure in the form of an argument list."
|
||||
|
|
@ -252,14 +249,12 @@ lists."
|
|||
(arity->arguments-alist
|
||||
prog
|
||||
(list 0 0 nreq nopt rest? '(#f . ())))))))
|
||||
(cond
|
||||
((primitive? prog) (fallback))
|
||||
((program? prog)
|
||||
(let ((arities (find-program-arities (program-code prog))))
|
||||
(let* ((code (program-code prog))
|
||||
(arities (and (not (primitive-code? code))
|
||||
(find-program-arities code))))
|
||||
(if arities
|
||||
(map arity-arguments-alist arities)
|
||||
(fallback))))
|
||||
(else (error "expected a program" prog))))
|
||||
|
||||
(define* (print-program #:optional program (port (current-output-port))
|
||||
#:key (addr (program-code program))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue