diff options
author | Andy Wingo <wingo@pobox.com> | 2015-11-27 11:44:11 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2015-12-01 11:30:54 +0100 |
commit | 8af3423efe1aa4168a097cf9ae11d3c4338894bb (patch) | |
tree | 48a07cb6fe453883931f0555b13549b1a764b55c | |
parent | 3b3405e5040ea5d264706bc82e2a5bb224c704cd (diff) | |
download | guile-8af3423efe1aa4168a097cf9ae11d3c4338894bb.tar.gz |
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.
-rw-r--r-- | libguile/gsubr.c | 15 | ||||
-rw-r--r-- | libguile/gsubr.h | 1 | ||||
-rw-r--r-- | libguile/programs.c | 12 | ||||
-rw-r--r-- | libguile/programs.h | 2 | ||||
-rw-r--r-- | module/statprof.scm | 33 | ||||
-rw-r--r-- | module/system/vm/frame.scm | 2 | ||||
-rw-r--r-- | module/system/vm/program.scm | 57 |
7 files changed, 67 insertions, 55 deletions
diff --git a/libguile/gsubr.c b/libguile/gsubr.c index a3b804bb5..d80e5dd42 100644 --- a/libguile/gsubr.c +++ b/libguile/gsubr.c @@ -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; diff --git a/libguile/gsubr.h b/libguile/gsubr.h index a9db85e44..725de2cbd 100644 --- a/libguile/gsubr.h +++ b/libguile/gsubr.h @@ -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); diff --git a/libguile/programs.c b/libguile/programs.c index 64c861a71..c03865de1 100644 --- a/libguile/programs.c +++ b/libguile/programs.c @@ -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); diff --git a/libguile/programs.h b/libguile/programs.h index d170c1b77..c962995eb 100644 --- a/libguile/programs.h +++ b/libguile/programs.h @@ -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); diff --git a/module/statprof.scm b/module/statprof.scm index e613aad2d..74b32c0ba 100644 --- a/module/statprof.scm +++ b/module/statprof.scm @@ -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 diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm index 38850b61e..8945e58fb 100644 --- a/module/system/vm/frame.scm +++ b/module/system/vm/frame.scm @@ -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 diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm index 59cb8c019..9f5b764d0 100644 --- a/module/system/vm/program.scm +++ b/module/system/vm/program.scm @@ -44,7 +44,7 @@ print-program - primitive?)) + primitive-code?)) (load-extension (string-append "libguile-" (effective-version)) "scm_init_programs") @@ -195,28 +195,25 @@ 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." - (cond - ((primitive? prog) - (match (procedure-minimum-arity prog) - (#f #f) - ((nreq nopt rest?) - (let ((start (primitive-call-ip prog))) - ;; Assume that there is only one IP for the call. - (and (or (not ip) (= start ip)) - (arity->arguments-alist - prog - (list 0 0 nreq nopt rest? '(#f . ())))))))) - ((program? prog) - (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)))))) + (let ((code (program-code prog))) + (cond + ((primitive-code? code) + (match (procedure-minimum-arity prog) + (#f #f) + ((nreq nopt rest?) + (let ((start (primitive-call-ip prog))) + ;; Assume that there is only one IP for the call. + (and (or (not ip) (= start ip)) + (arity->arguments-alist + prog + (list 0 0 nreq nopt rest? '(#f . ())))))))) + (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 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)))) - (if arities - (map arity-arguments-alist arities) - (fallback)))) - (else (error "expected a program" prog)))) + (let* ((code (program-code prog)) + (arities (and (not (primitive-code? code)) + (find-program-arities code)))) + (if arities + (map arity-arguments-alist arities) + (fallback)))) (define* (print-program #:optional program (port (current-output-port)) #:key (addr (program-code program)) |