1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-07-09 19:00: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 2015-11-27 11:44:11 +01:00
parent 3b3405e504
commit 8af3423efe
7 changed files with 67 additions and 55 deletions

View file

@ -251,6 +251,17 @@ create_subr (int define, const char *name,
return ret; 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. /* Given a program that is a primitive, determine its minimum arity.
This is possible because each primitive's code is 4 32-bit words This is possible because each primitive's code is 4 32-bit words
long, and they are laid out contiguously in an ordered pattern. */ 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); const scm_t_uint32 *code = SCM_PROGRAM_CODE (prim);
unsigned idx, nargs, base, next; unsigned idx, nargs, base, next;
if (code < subr_stub_code) if (!scm_i_primitive_code_p (code))
return 0;
if (code > subr_stub_code + (sizeof(subr_stub_code) / sizeof(scm_t_uint32)))
return 0; return 0;
idx = (code - subr_stub_code) / 4; idx = (code - subr_stub_code) / 4;

View file

@ -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 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); SCM_INTERNAL scm_t_uintptr scm_i_primitive_call_ip (SCM subr);

View file

@ -144,19 +144,21 @@ SCM_DEFINE (scm_program_p, "program?", 1, 0, 0,
} }
#undef FUNC_NAME #undef FUNC_NAME
SCM_DEFINE (scm_primitive_p, "primitive?", 1, 0, 0, SCM_DEFINE (scm_primitive_code_p, "primitive-code?", 1, 0, 0,
(SCM obj), (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 #undef FUNC_NAME
SCM_DEFINE (scm_primitive_call_ip, "primitive-call-ip", 1, 0, 0, SCM_DEFINE (scm_primitive_call_ip, "primitive-call-ip", 1, 0, 0,
(SCM prim), (SCM prim),
"") "")
#define FUNC_NAME s_scm_primitive_p #define FUNC_NAME s_scm_primitive_call_ip
{ {
SCM_MAKE_VALIDATE (1, prim, PRIMITIVE_P); SCM_MAKE_VALIDATE (1, prim, PRIMITIVE_P);

View file

@ -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_p (SCM obj);
SCM_INTERNAL SCM scm_program_code (SCM program); 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_primitive_call_ip (SCM prim);
SCM_INTERNAL SCM scm_i_program_name (SCM program); SCM_INTERNAL SCM scm_i_program_name (SCM program);

View file

@ -327,10 +327,13 @@
(set-buffer! state buffer) (set-buffer! state buffer)
(set-buffer-pos! state (1+ pos))) (set-buffer-pos! state (1+ pos)))
(else (else
(let ((proc (frame-procedure frame))) (let ((ip (frame-instruction-pointer frame)))
(write-sample-and-continue (if (primitive? proc) (write-sample-and-continue
(procedure-name proc) (if (primitive-code? ip)
(frame-instruction-pointer frame)))))))) ;; 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) (define (reset-sigprof-timer usecs)
;; Guile's setitimer binding is terrible. ;; Guile's setitimer binding is terrible.
@ -376,11 +379,11 @@
(unless (inside-profiler? state) (unless (inside-profiler? state)
(accumulate-time state (get-internal-run-time)) (accumulate-time state (get-internal-run-time))
(let* ((key (let ((proc (frame-procedure frame))) ;; We know local 0 is a SCM value: the c
(cond (let* ((ip (frame-instruction-pointer frame))
((primitive? proc) (procedure-name proc)) (key (if (primitive-code? ip)
((program? proc) (program-code proc)) (procedure-name (frame-local-ref frame 0 'scm))
(else proc)))) ip))
(handle (hashv-create-handle! (call-counts state) key 0))) (handle (hashv-create-handle! (call-counts state) key 0)))
(set-cdr! handle (1+ (cdr handle)))) (set-cdr! handle (1+ (cdr handle))))
@ -594,11 +597,13 @@ it represents different functions with the same name."
none is available." none is available."
(when (statprof-active?) (when (statprof-active?)
(error "Can't call statprof-proc-call-data while profiler is running.")) (error "Can't call statprof-proc-call-data while profiler is running."))
(hashv-ref (stack-samples->procedure-data state) (unless (program? proc)
(cond (error "statprof-call-data only works for VM programs"))
((primitive? proc) (procedure-name proc)) (let* ((code (program-code proc))
((program? proc) (program-code proc)) (key (if (primitive-code? code)
(else (program-code proc))))) (procedure-name proc)
code)))
(hashv-ref (stack-samples->procedure-data state) key)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Stats ;; Stats

View file

@ -402,7 +402,7 @@
(arity-keyword-args arity) (arity-keyword-args arity)
(arity-has-rest? arity) (arity-has-rest? arity)
1)))) 1))))
((and (primitive? closure) ((and (primitive-code? ip)
(program-arguments-alist closure ip)) (program-arguments-alist closure ip))
=> (lambda (args) => (lambda (args)
(match args (match args

View file

@ -44,7 +44,7 @@
print-program print-program
primitive?)) primitive-code?))
(load-extension (string-append "libguile-" (effective-version)) (load-extension (string-append "libguile-" (effective-version))
"scm_init_programs") "scm_init_programs")
@ -195,8 +195,9 @@ of integers."
;; the name "program-arguments" is taken by features.c... ;; the name "program-arguments" is taken by features.c...
(define* (program-arguments-alist prog #:optional ip) (define* (program-arguments-alist prog #:optional ip)
"Returns the signature of the given procedure in the form of an association list." "Returns the signature of the given procedure in the form of an association list."
(let ((code (program-code prog)))
(cond (cond
((primitive? prog) ((primitive-code? code)
(match (procedure-minimum-arity prog) (match (procedure-minimum-arity prog)
(#f #f) (#f #f)
((nreq nopt rest?) ((nreq nopt rest?)
@ -206,17 +207,13 @@ of integers."
(arity->arguments-alist (arity->arguments-alist
prog prog
(list 0 0 nreq nopt rest? '(#f . ())))))))) (list 0 0 nreq nopt rest? '(#f . ()))))))))
((program? prog) (else
(or-map (lambda (arity) (or-map (lambda (arity)
(and (or (not ip) (and (or (not ip)
(and (<= (arity-low-pc arity) ip) (and (<= (arity-low-pc arity) ip)
(< ip (arity-high-pc arity)))) (< ip (arity-high-pc arity))))
(arity-arguments-alist arity))) (arity-arguments-alist arity)))
(or (find-program-arities (program-code prog)) '()))) (or (find-program-arities code) '()))))))
(else
(let ((arity (program-arity prog ip)))
(and arity
(arity->arguments-alist prog arity))))))
(define* (program-lambda-list prog #:optional ip) (define* (program-lambda-list prog #:optional ip)
"Returns the signature of the given procedure in the form of an argument list." "Returns the signature of the given procedure in the form of an argument list."
@ -252,14 +249,12 @@ lists."
(arity->arguments-alist (arity->arguments-alist
prog prog
(list 0 0 nreq nopt rest? '(#f . ()))))))) (list 0 0 nreq nopt rest? '(#f . ())))))))
(cond (let* ((code (program-code prog))
((primitive? prog) (fallback)) (arities (and (not (primitive-code? code))
((program? prog) (find-program-arities code))))
(let ((arities (find-program-arities (program-code prog))))
(if arities (if arities
(map arity-arguments-alist arities) (map arity-arguments-alist arities)
(fallback)))) (fallback))))
(else (error "expected a program" prog))))
(define* (print-program #:optional program (port (current-output-port)) (define* (print-program #:optional program (port (current-output-port))
#:key (addr (program-code program)) #:key (addr (program-code program))