From 48760756c64bcc5a3290cb381c98ef477f5e639f Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 27 Nov 2008 00:45:45 +0000 Subject: [PATCH 01/42] svn: r12604 --- collects/redex/examples/contracts.ss | 154 +++++++++++++++++++++++++++ 1 file changed, 154 insertions(+) create mode 100644 collects/redex/examples/contracts.ss diff --git a/collects/redex/examples/contracts.ss b/collects/redex/examples/contracts.ss new file mode 100644 index 0000000000..70b9a34d6b --- /dev/null +++ b/collects/redex/examples/contracts.ss @@ -0,0 +1,154 @@ +#lang scheme + +#| + +A core contract calculus, including blame, +with function contracts, (eager) pair contracts, +and a few numeric predicates + +|# + +(require redex redex/examples/subst) + +(reduction-steps-cutoff 10) + +(define-language lang + (e (e e ...) + x + number + (λ (x ...) e) + + (if e e e) + #t #f + + cons car cdr + + -> or/c + ac + pred? + (blame l) + l) + (pred? number? + odd? + positive?) + (E (v ... E e ...) + (if E e e) + hole) + (v number + (λ (x ...) e) + cons car cdr + (cons v v) + pred? + -> or/c ac + (-> v ...) + (or/c v ...) + #t #f + l) + + (l + -) ;; blame labels + + (x variable-not-otherwise-mentioned)) + +(define reds + (reduction-relation + lang + (--> (in-hole E ((λ (x ...) e) v ...)) + (in-hole E (subst-n ((x v) ... e))) + (side-condition (= (length (term (x ...))) + (length (term (v ...))))) + βv) + + (--> (in-hole E (if #t e_1 e_2)) (in-hole E e_1) ift) + (--> (in-hole E (if #f e_1 e_2)) (in-hole E e_2) iff) + + (--> (in-hole E (number? number)) (in-hole E #t)) + (--> (in-hole E (number? v)) + (in-hole E #f) + (side-condition (not (number? (term v))))) + + (--> (in-hole E (car (cons v_1 v_2))) + (in-hole E v_1)) + (--> (in-hole E (cdr (cons v_1 v_2))) + (in-hole E v_2)) + + (--> (in-hole E (odd? number)) + (in-hole E #t) + (side-condition (odd? (term number)))) + (--> (in-hole E (odd? v)) + (in-hole E #f) + (side-condition (or (not (number? (term v))) + (not (odd? (term v)))))) + + (--> (in-hole E (positive? number)) + (in-hole E #t) + (side-condition (positive? (term number)))) + (--> (in-hole E (positive? v)) + (in-hole E #f) + (side-condition (or (not (number? (term v))) + (not (positive? (term v)))))) + + + (--> (in-hole E (blame l)) + (blame l) + (side-condition (not (equal? (term E) (term hole))))) + + (--> (in-hole E (ac pred? v l)) + (in-hole E (if (pred? v) v (blame l)))) + (--> (in-hole E (ac (-> v_dom ... v_rng) (λ (x ...) e) l)) + (in-hole E (λ (x ...) (ac v_rng ((λ (x ...) e) (ac v_dom x l_2) ...) l))) + (where l_2 (¬ l))) + + (--> (in-hole E (ac (cons v_1 v_2) (cons v_3 v_4) l)) + (in-hole E (cons (ac v_1 v_3 l) (ac v_2 v_4 l)))) + + (--> (in-hole E (ac (or/c pred? v_1 v_2 ...) v_3 l)) + (in-hole E (if (pred? v_3) + v_3 + (ac (or/c v_1 v_2 ...) v_3 l)))) + (--> (in-hole E (ac (or/c v_1) v_2 l)) + (in-hole E (ac v_1 v_2 l))) + )) + +(define-metafunction lang + [(¬ +) -] + [(¬ -) +]) + +(test--> reds (term ((λ (x y) x) 1 2)) 1) +(test--> reds (term ((λ (x y) y) 1 2)) 2) +(test--> reds (term (if (if #t #f #t) #f #t)) (term #t)) +(test--> reds (term (positive? 1)) #t) +(test--> reds (term (positive? -1)) #f) +(test--> reds (term (positive? (λ (x) x))) #f) +(test--> reds (term (odd? 1)) #t) +(test--> reds (term (odd? 2)) #f) +(test--> reds (term (odd? (λ (x) x))) #f) +(test--> reds (term (car (cdr (cdr (cons 1 (cons 2 (cons 3 #f))))))) 3) + +(test--> reds (term ((λ (x) x) (blame -))) (term (blame -))) +(test--> reds (term (ac number? 1 +)) 1) +(test--> reds (term (ac number? (λ (x) x) +)) (term (blame +))) +(test--> reds (term ((ac (-> number? number?) (λ (x) x) +) 1)) 1) +(test--> reds + (term ((ac (-> number? number?) (λ (x) x) +) #f)) + (term (blame -))) +(test--> reds + (term ((ac (-> number? number?) (λ (x) #f) +) 1)) + (term (blame +))) +(test--> reds + (term (ac (or/c odd? positive?) 1 +)) + 1) +(test--> reds + (term (ac (or/c odd? positive?) -1 +)) + -1) +(test--> reds + (term (ac (or/c odd? positive?) 2 +)) + 2) +(test--> reds + (term (ac (or/c odd? positive?) -2 +)) + (term (blame +))) + +(test--> reds + (term (ac (cons odd? positive?) (cons 3 1) +)) + (term (cons 3 1))) + +(test-results) \ No newline at end of file From 2207df048dad5172c8f76fc43942722e1c4cb817 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 27 Nov 2008 00:46:25 +0000 Subject: [PATCH 02/42] now using the normalized versions of all of these unicode thingies svn: r12605 --- collects/mrlib/tex-table.ss | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/collects/mrlib/tex-table.ss b/collects/mrlib/tex-table.ss index 1fefd5994e..ff7062508d 100644 --- a/collects/mrlib/tex-table.ss +++ b/collects/mrlib/tex-table.ss @@ -41,7 +41,7 @@ ;􏰃→ \mapsto - ("aleph" "ℵ") + ("aleph" "א") ("prime" "′") ("emptyset" "∅") ("nabla" "∇") @@ -63,22 +63,22 @@ ("theta" "θ") ("tau" "τ") ("beta" "β") - ("vartheta" "ϑ") + ("vartheta" "θ") ("pi" "π") ("upsilon" "υ") ("gamma" "γ") - ("varpi" "ϖ") + ("varpi" "π") ("phi" "φ") ("delta" "δ") ("kappa" "κ") ("rho" "ρ") - ("varphi" "ϕ") - ("epsilon" "ϵ") + ("varphi" "φ") + ("epsilon" "ε") ("lambda" "λ") - ("varrho" "ϱ") + ("varrho" "ρ") ("chi" "χ") ("varepsilon" "ε") - ("mu" "µ") + ("mu" "μ") ("sigma" "σ") ("psi" "ψ") ("zeta" "ζ") @@ -94,7 +94,7 @@ ("Delta" "∆") ("Xi" "Ξ") ("Upsilon" "Υ") - ("Omega" "Ω") + ("Omega" "Ω") ("Theta" "Θ") ("Pi" "Π") ("Phi" "Φ") @@ -150,7 +150,7 @@ ("cong" "≌") ("sqsubsetb" "⊏") ("sqsupsetb" "⊐") - ("neq" #;"≠" "≠") + ("neq" #;"≠" "≠") ("smile" "⌣") ("sqsubseteq" "⊑") ("sqsupseteq" "⊒") From 2c78076fe604b9ed8908ebfc78ff2d973a150f06 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 27 Nov 2008 00:46:56 +0000 Subject: [PATCH 03/42] svn: r12606 --- collects/lang/htdp-langs.ss | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/collects/lang/htdp-langs.ss b/collects/lang/htdp-langs.ss index 570aa2e061..8b14895f7e 100644 --- a/collects/lang/htdp-langs.ss +++ b/collects/lang/htdp-langs.ss @@ -1072,6 +1072,7 @@ (send off-sd set-delta-background "darkblue")) ;; picture 5.png + #; (begin (send on-sd set-delta-foreground (make-object color% 0 80 0)) (send off-sd set-delta-foreground "orange") @@ -1082,7 +1083,13 @@ (send on-sd set-delta-foreground "black") (send off-sd set-delta-foreground "orange") (send off-sd set-delta-background "black")) - ]) + + ;; mike's preferred color scheme, but looks just like the selection + #; + (begin + (send on-sd set-delta-foreground "black") + (send off-sd set-delta-background "lightblue") + (send off-sd set-delta-foreground "black"))]) (send rep set-test-coverage-info ht on-sd off-sd #f))))))))) (let ([ht (thread-cell-ref current-test-coverage-info)]) (when ht From 792ab171b065f40a197276d1d16975b4545ecf6e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 27 Nov 2008 00:47:18 +0000 Subject: [PATCH 04/42] improved error backtraces for a few for JIT-inlined primitives, notably 'car' and 'cdr' svn: r12607 --- src/mzscheme/src/jit.c | 79 ++++++++++++++++++++++++++---------------- 1 file changed, 49 insertions(+), 30 deletions(-) diff --git a/src/mzscheme/src/jit.c b/src/mzscheme/src/jit.c index 89b9481b09..7fc4a0f764 100644 --- a/src/mzscheme/src/jit.c +++ b/src/mzscheme/src/jit.c @@ -2315,6 +2315,15 @@ typedef struct { int direct_prim, direct_native, nontail_self; } Generate_Call_Data; +static void register_sub_func(mz_jit_state *jitter, void *code, Scheme_Object *protocol) +{ + void *code_end; + + code_end = jit_get_ip().ptr; + if (jitter->retain_start) + add_symbol((unsigned long)code, (unsigned long)code_end - 1, protocol, 0); +} + int do_generate_shared_call(mz_jit_state *jitter, void *_data) { Generate_Call_Data *data = (Generate_Call_Data *)_data; @@ -2330,7 +2339,7 @@ int do_generate_shared_call(mz_jit_state *jitter, void *_data) return generate_tail_call(jitter, data->num_rands, data->direct_native, 1); } else { int ok; - void *code, *code_end; + void *code; code = jit_get_ip().ptr; @@ -2339,9 +2348,7 @@ int do_generate_shared_call(mz_jit_state *jitter, void *_data) else ok = generate_non_tail_call(jitter, data->num_rands, data->direct_native, 1, data->multi_ok, data->nontail_self, 1); - code_end = jit_get_ip().ptr; - if (jitter->retain_start) - add_symbol((unsigned long)code, (unsigned long)code_end - 1, scheme_false, 0); + register_sub_func(jitter, code, scheme_false); return ok; } @@ -3923,22 +3930,22 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in __END_TINY_JUMPS__(1); if (steps == 1) { if (name[1] == 'a') { - (void)jit_jmpi(bad_car_code); + (void)jit_calli(bad_car_code); } else { - (void)jit_jmpi(bad_cdr_code); + (void)jit_calli(bad_cdr_code); } } else { if (name[1] == 'a') { if (name[2] == 'a') { - (void)jit_jmpi(bad_caar_code); + (void)jit_calli(bad_caar_code); } else { - (void)jit_jmpi(bad_cadr_code); + (void)jit_calli(bad_cadr_code); } } else { if (name[2] == 'a') { - (void)jit_jmpi(bad_cdar_code); + (void)jit_calli(bad_cdar_code); } else { - (void)jit_jmpi(bad_cddr_code); + (void)jit_calli(bad_cddr_code); } } } @@ -3980,9 +3987,9 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in reffail = _jit.x.pc; __END_TINY_JUMPS__(1); if (name[2] == 'a') { - (void)jit_jmpi(bad_mcar_code); + (void)jit_calli(bad_mcar_code); } else { - (void)jit_jmpi(bad_mcdr_code); + (void)jit_calli(bad_mcdr_code); } __START_TINY_JUMPS__(1); mz_patch_branch(ref); @@ -4015,7 +4022,7 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in __END_TINY_JUMPS__(1); reffail = _jit.x.pc; - (void)jit_jmpi(bad_vector_length_code); + (void)jit_calli(bad_vector_length_code); __START_TINY_JUMPS__(1); mz_patch_branch(ref); @@ -4045,7 +4052,7 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in __END_TINY_JUMPS__(1); reffail = _jit.x.pc; - (void)jit_jmpi(bad_unbox_code); + (void)jit_calli(bad_unbox_code); __START_TINY_JUMPS__(1); mz_patch_branch(ref); @@ -4552,9 +4559,9 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i reffail = _jit.x.pc; __END_TINY_JUMPS__(1); if (set_mcar) - (void)jit_jmpi(bad_set_mcar_code); + (void)jit_calli(bad_set_mcar_code); else - (void)jit_jmpi(bad_set_mcdr_code); + (void)jit_calli(bad_set_mcdr_code); __START_TINY_JUMPS__(1); mz_patch_branch(ref); jit_ldxi_s(JIT_R2, JIT_R0, &((Scheme_Object *)0x0)->type); @@ -6443,32 +6450,36 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) /* *** bad_[m]{car,cdr,...}_code *** */ /* Bad argument is in R0 for car/cdr, R2 otherwise */ for (i = 0; i < 8; i++) { + void *code; + + code = jit_get_ip().ptr; switch (i) { case 0: - bad_car_code = jit_get_ip().ptr; + bad_car_code = code; break; case 1: - bad_cdr_code = jit_get_ip().ptr; + bad_cdr_code = code; break; case 2: - bad_caar_code = jit_get_ip().ptr; + bad_caar_code = code; break; case 3: - bad_cadr_code = jit_get_ip().ptr; + bad_cadr_code = code; break; case 4: - bad_cdar_code = jit_get_ip().ptr; + bad_cdar_code = code; break; case 5: - bad_cddr_code = jit_get_ip().ptr; + bad_cddr_code = code; break; case 6: - bad_mcar_code = jit_get_ip().ptr; + bad_mcar_code = code; break; case 7: - bad_mcdr_code = jit_get_ip().ptr; + bad_mcdr_code = code; break; } + mz_prolog(JIT_R1); jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(1)); CHECK_RUNSTACK_OVERFLOW(); if ((i < 2) || (i > 5)) { @@ -6509,19 +6520,24 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) break; } CHECK_LIMIT(); + + register_sub_func(jitter, code, scheme_false); } /* *** bad_set_{car,cdr}_code *** */ /* Bad argument is in R0, other is in R1 */ for (i = 0; i < 2; i++) { + void *code; + code = jit_get_ip().ptr; switch (i) { case 0: - bad_set_mcar_code = jit_get_ip().ptr; + bad_set_mcar_code = code; break; case 1: - bad_set_mcdr_code = jit_get_ip().ptr; + bad_set_mcdr_code = code; break; } + mz_prolog(JIT_R1); jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(2)); CHECK_RUNSTACK_OVERFLOW(); jit_str_p(JIT_RUNSTACK, JIT_R0); @@ -6541,29 +6557,34 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) break; } CHECK_LIMIT(); + register_sub_func(jitter, code, scheme_false); } /* *** bad_unbox_code *** */ /* R0 is argument */ bad_unbox_code = jit_get_ip().ptr; + mz_prolog(JIT_R1); jit_prepare(1); jit_pusharg_i(JIT_R0); (void)mz_finish(scheme_unbox); CHECK_LIMIT(); + register_sub_func(jitter, bad_unbox_code, scheme_false); /* *** bad_vector_length_code *** */ /* R0 is argument */ bad_vector_length_code = jit_get_ip().ptr; + mz_prolog(JIT_R1); jit_prepare(1); jit_pusharg_i(JIT_R0); (void)mz_finish(scheme_vector_length); CHECK_LIMIT(); + register_sub_func(jitter, bad_vector_length_code, scheme_false); /* *** call_original_unary_arith_code *** */ /* R0 is arg, R2 is code pointer, V1 is return address */ for (i = 0; i < 3; i++) { int argc, j; - void *code, *code_end; + void *code; for (j = 0; j < 2; j++) { code = jit_get_ip().ptr; if (!i) { @@ -6625,9 +6646,7 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) } CHECK_LIMIT(); - code_end = jit_get_ip().ptr; - if (jitter->retain_start) - add_symbol((unsigned long)code, (unsigned long)code_end - 1, scheme_void, 0); + register_sub_func(jitter, code, scheme_void); } } From b28bf7025d73a784d27b39539ec5fdfd8409352e Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 27 Nov 2008 04:00:59 +0000 Subject: [PATCH 05/42] Welcome to a new PLT day. svn: r12616 --- src/worksp/mred/mred.manifest | 2 +- src/worksp/mred/mred.rc | 8 ++++---- src/worksp/mzcom/mzcom.rc | 8 ++++---- src/worksp/mzcom/mzobj.rgs | 6 +++--- src/worksp/mzscheme/mzscheme.rc | 8 ++++---- src/worksp/starters/start.rc | 8 ++++---- 6 files changed, 20 insertions(+), 20 deletions(-) diff --git a/src/worksp/mred/mred.manifest b/src/worksp/mred/mred.manifest index 0ab155b489..3492ff454a 100644 --- a/src/worksp/mred/mred.manifest +++ b/src/worksp/mred/mred.manifest @@ -1,7 +1,7 @@ Date: Thu, 27 Nov 2008 08:50:19 +0000 Subject: [PATCH 06/42] Welcome to a new PLT day. svn: r12617 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index 56c75225ef..427f92f726 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "26nov2008") +#lang scheme/base (provide stamp) (define stamp "27nov2008") From 961d459a7d6f156119f6f6b45c7e6dc5a6edab6c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 27 Nov 2008 14:52:09 +0000 Subject: [PATCH 07/42] import a slice of libunwind, a step toward JIT backtraces for x86_64 svn: r12619 --- src/mzscheme/src/unwind/libunwind.c | 2469 +++++++++++++++++++++++++ src/mzscheme/src/unwind/libunwind.h | 477 +++++ src/mzscheme/src/unwind/libunwind_i.h | 1182 ++++++++++++ 3 files changed, 4128 insertions(+) create mode 100644 src/mzscheme/src/unwind/libunwind.c create mode 100644 src/mzscheme/src/unwind/libunwind.h create mode 100644 src/mzscheme/src/unwind/libunwind_i.h diff --git a/src/mzscheme/src/unwind/libunwind.c b/src/mzscheme/src/unwind/libunwind.c new file mode 100644 index 0000000000..d149a1ff39 --- /dev/null +++ b/src/mzscheme/src/unwind/libunwind.c @@ -0,0 +1,2469 @@ +/* libunwind - a platform-independent unwind library + Copyright (c) 2003-2005 Hewlett-Packard Development Company, L.P. + Contributed by David Mosberger-Tang + +This file is several parts of libunwind concatenated. + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. */ + +#include +#include "libunwind_i.h" + +/*XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX*/ +/* Gexpr.c */ +/*XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX*/ + +/* The "pick" operator provides an index range of 0..255 indicating + that the stack could at least have a depth of up to 256 elements, + but the GCC unwinder restricts the depth to 64, which seems + reasonable so we use the same value here. */ +#define MAX_EXPR_STACK_SIZE 64 + +#define NUM_OPERANDS(signature) (((signature) >> 6) & 0x3) +#define OPND1_TYPE(signature) (((signature) >> 3) & 0x7) +#define OPND2_TYPE(signature) (((signature) >> 0) & 0x7) + +#define OPND_SIGNATURE(n, t1, t2) (((n) << 6) | ((t1) << 3) | ((t2) << 0)) +#define OPND1(t1) OPND_SIGNATURE(1, t1, 0) +#define OPND2(t1, t2) OPND_SIGNATURE(2, t1, t2) + +#define VAL8 0x0 +#define VAL16 0x1 +#define VAL32 0x2 +#define VAL64 0x3 +#define ULEB128 0x4 +#define SLEB128 0x5 +#define OFFSET 0x6 /* 32-bit offset for 32-bit DWARF, 64-bit otherwise */ + +static uint8_t operands[256] = + { + [DW_OP_addr] = OPND1 (sizeof (unw_word_t) == 4 ? VAL32 : VAL64), + [DW_OP_const1u] = OPND1 (VAL8), + [DW_OP_const1s] = OPND1 (VAL8), + [DW_OP_const2u] = OPND1 (VAL16), + [DW_OP_const2s] = OPND1 (VAL16), + [DW_OP_const4u] = OPND1 (VAL32), + [DW_OP_const4s] = OPND1 (VAL32), + [DW_OP_const8u] = OPND1 (VAL64), + [DW_OP_const8s] = OPND1 (VAL64), + [DW_OP_pick] = OPND1 (VAL8), + [DW_OP_plus_uconst] = OPND1 (ULEB128), + [DW_OP_skip] = OPND1 (VAL16), + [DW_OP_bra] = OPND1 (VAL16), + [DW_OP_breg0 + 0] = OPND1 (SLEB128), + [DW_OP_breg0 + 1] = OPND1 (SLEB128), + [DW_OP_breg0 + 2] = OPND1 (SLEB128), + [DW_OP_breg0 + 3] = OPND1 (SLEB128), + [DW_OP_breg0 + 4] = OPND1 (SLEB128), + [DW_OP_breg0 + 5] = OPND1 (SLEB128), + [DW_OP_breg0 + 6] = OPND1 (SLEB128), + [DW_OP_breg0 + 7] = OPND1 (SLEB128), + [DW_OP_breg0 + 8] = OPND1 (SLEB128), + [DW_OP_breg0 + 9] = OPND1 (SLEB128), + [DW_OP_breg0 + 10] = OPND1 (SLEB128), + [DW_OP_breg0 + 11] = OPND1 (SLEB128), + [DW_OP_breg0 + 12] = OPND1 (SLEB128), + [DW_OP_breg0 + 13] = OPND1 (SLEB128), + [DW_OP_breg0 + 14] = OPND1 (SLEB128), + [DW_OP_breg0 + 15] = OPND1 (SLEB128), + [DW_OP_breg0 + 16] = OPND1 (SLEB128), + [DW_OP_breg0 + 17] = OPND1 (SLEB128), + [DW_OP_breg0 + 18] = OPND1 (SLEB128), + [DW_OP_breg0 + 19] = OPND1 (SLEB128), + [DW_OP_breg0 + 20] = OPND1 (SLEB128), + [DW_OP_breg0 + 21] = OPND1 (SLEB128), + [DW_OP_breg0 + 22] = OPND1 (SLEB128), + [DW_OP_breg0 + 23] = OPND1 (SLEB128), + [DW_OP_breg0 + 24] = OPND1 (SLEB128), + [DW_OP_breg0 + 25] = OPND1 (SLEB128), + [DW_OP_breg0 + 26] = OPND1 (SLEB128), + [DW_OP_breg0 + 27] = OPND1 (SLEB128), + [DW_OP_breg0 + 28] = OPND1 (SLEB128), + [DW_OP_breg0 + 29] = OPND1 (SLEB128), + [DW_OP_breg0 + 30] = OPND1 (SLEB128), + [DW_OP_breg0 + 31] = OPND1 (SLEB128), + [DW_OP_regx] = OPND1 (ULEB128), + [DW_OP_fbreg] = OPND1 (SLEB128), + [DW_OP_bregx] = OPND2 (ULEB128, SLEB128), + [DW_OP_piece] = OPND1 (ULEB128), + [DW_OP_deref_size] = OPND1 (VAL8), + [DW_OP_xderef_size] = OPND1 (VAL8), + [DW_OP_call2] = OPND1 (VAL16), + [DW_OP_call4] = OPND1 (VAL32), + [DW_OP_call_ref] = OPND1 (OFFSET) + }; + +#define sword(X) ((unw_sword_t) (X)) + +static inline unw_word_t +read_operand (unw_addr_space_t as, unw_accessors_t *a, + unw_word_t *addr, int operand_type, unw_word_t *val, void *arg) +{ + uint8_t u8; + uint16_t u16; + uint32_t u32; + uint64_t u64; + int ret; + + switch (operand_type) + { + case VAL8: + ret = dwarf_readu8 (as, a, addr, &u8, arg); + *val = u8; + break; + + case VAL16: + ret = dwarf_readu16 (as, a, addr, &u16, arg); + *val = u16; + break; + + case VAL32: + ret = dwarf_readu32 (as, a, addr, &u32, arg); + *val = u32; + break; + + case VAL64: + ret = dwarf_readu64 (as, a, addr, &u64, arg); + *val = u64; + break; + + case ULEB128: + ret = dwarf_read_uleb128 (as, a, addr, val, arg); + break; + + case SLEB128: + ret = dwarf_read_sleb128 (as, a, addr, val, arg); + break; + + case OFFSET: /* only used by DW_OP_call_ref, which we don't implement */ + default: + Debug (1, "Unexpected operand type %d\n", operand_type); + ret = -UNW_EINVAL; + } + return ret; +} + +HIDDEN int +dwarf_eval_expr (struct dwarf_cursor *c, unw_word_t *addr, unw_word_t len, + unw_word_t *valp, int *is_register) +{ + unw_word_t operand1 = 0, operand2 = 0, tmp1, tmp2, tmp3, end_addr; + uint8_t opcode, operands_signature, u8; + unw_addr_space_t as; + unw_accessors_t *a; + void *arg; + unw_word_t stack[MAX_EXPR_STACK_SIZE]; + unsigned int tos = 0; + uint16_t u16; + uint32_t u32; + uint64_t u64; + int ret; +# define pop() \ +({ \ + if ((tos - 1) >= MAX_EXPR_STACK_SIZE) \ + { \ + Debug (1, "Stack underflow\n"); \ + return -UNW_EINVAL; \ + } \ + stack[--tos]; \ +}) +# define push(x) \ +do { \ + if (tos >= MAX_EXPR_STACK_SIZE) \ + { \ + Debug (1, "Stack overflow\n"); \ + return -UNW_EINVAL; \ + } \ + stack[tos++] = (x); \ +} while (0) +# define pick(n) \ +({ \ + unsigned int _index = tos - 1 - (n); \ + if (_index >= MAX_EXPR_STACK_SIZE) \ + { \ + Debug (1, "Out-of-stack pick\n"); \ + return -UNW_EINVAL; \ + } \ + stack[_index]; \ +}) + + as = c->as; + arg = c->as_arg; + a = unw_get_accessors (as); + end_addr = *addr + len; + *is_register = 0; + + Debug (14, "len=%lu, pushing cfa=0x%lx\n", + (unsigned long) len, (unsigned long) c->cfa); + + push (c->cfa); /* push current CFA as required by DWARF spec */ + + while (*addr < end_addr) + { + if ((ret = dwarf_readu8 (as, a, addr, &opcode, arg)) < 0) + return ret; + + operands_signature = operands[opcode]; + + if (unlikely (NUM_OPERANDS (operands_signature) > 0)) + { + if ((ret = read_operand (as, a, addr, + OPND1_TYPE (operands_signature), + &operand1, arg)) < 0) + return ret; + if (NUM_OPERANDS (operands_signature > 1)) + if ((ret = read_operand (as, a, addr, + OPND2_TYPE (operands_signature), + &operand2, arg)) < 0) + return ret; + } + + switch ((dwarf_expr_op_t) opcode) + { + case DW_OP_lit0: case DW_OP_lit1: case DW_OP_lit2: + case DW_OP_lit3: case DW_OP_lit4: case DW_OP_lit5: + case DW_OP_lit6: case DW_OP_lit7: case DW_OP_lit8: + case DW_OP_lit9: case DW_OP_lit10: case DW_OP_lit11: + case DW_OP_lit12: case DW_OP_lit13: case DW_OP_lit14: + case DW_OP_lit15: case DW_OP_lit16: case DW_OP_lit17: + case DW_OP_lit18: case DW_OP_lit19: case DW_OP_lit20: + case DW_OP_lit21: case DW_OP_lit22: case DW_OP_lit23: + case DW_OP_lit24: case DW_OP_lit25: case DW_OP_lit26: + case DW_OP_lit27: case DW_OP_lit28: case DW_OP_lit29: + case DW_OP_lit30: case DW_OP_lit31: + Debug (15, "OP_lit(%d)\n", (int) opcode - DW_OP_lit0); + push (opcode - DW_OP_lit0); + break; + + case DW_OP_breg0: case DW_OP_breg1: case DW_OP_breg2: + case DW_OP_breg3: case DW_OP_breg4: case DW_OP_breg5: + case DW_OP_breg6: case DW_OP_breg7: case DW_OP_breg8: + case DW_OP_breg9: case DW_OP_breg10: case DW_OP_breg11: + case DW_OP_breg12: case DW_OP_breg13: case DW_OP_breg14: + case DW_OP_breg15: case DW_OP_breg16: case DW_OP_breg17: + case DW_OP_breg18: case DW_OP_breg19: case DW_OP_breg20: + case DW_OP_breg21: case DW_OP_breg22: case DW_OP_breg23: + case DW_OP_breg24: case DW_OP_breg25: case DW_OP_breg26: + case DW_OP_breg27: case DW_OP_breg28: case DW_OP_breg29: + case DW_OP_breg30: case DW_OP_breg31: + Debug (15, "OP_breg(r%d,0x%lx)\n", + (int) opcode - DW_OP_breg0, (unsigned long) operand1); + if ((ret = unw_get_reg (dwarf_to_cursor (c), + dwarf_to_unw_regnum (opcode - DW_OP_breg0), + &tmp1)) < 0) + return ret; + push (tmp1 + operand1); + break; + + case DW_OP_bregx: + Debug (15, "OP_bregx(r%d,0x%lx)\n", + (int) operand1, (unsigned long) operand2); + if ((ret = unw_get_reg (dwarf_to_cursor (c), + dwarf_to_unw_regnum (operand1), &tmp1)) < 0) + return ret; + push (tmp1 + operand2); + break; + + case DW_OP_reg0: case DW_OP_reg1: case DW_OP_reg2: + case DW_OP_reg3: case DW_OP_reg4: case DW_OP_reg5: + case DW_OP_reg6: case DW_OP_reg7: case DW_OP_reg8: + case DW_OP_reg9: case DW_OP_reg10: case DW_OP_reg11: + case DW_OP_reg12: case DW_OP_reg13: case DW_OP_reg14: + case DW_OP_reg15: case DW_OP_reg16: case DW_OP_reg17: + case DW_OP_reg18: case DW_OP_reg19: case DW_OP_reg20: + case DW_OP_reg21: case DW_OP_reg22: case DW_OP_reg23: + case DW_OP_reg24: case DW_OP_reg25: case DW_OP_reg26: + case DW_OP_reg27: case DW_OP_reg28: case DW_OP_reg29: + case DW_OP_reg30: case DW_OP_reg31: + Debug (15, "OP_reg(r%d)\n", (int) opcode - DW_OP_reg0); + *valp = dwarf_to_unw_regnum (opcode - DW_OP_reg0); + *is_register = 1; + return 0; + + case DW_OP_regx: + Debug (15, "OP_regx(r%d)\n", (int) operand1); + *valp = dwarf_to_unw_regnum (operand1); + *is_register = 1; + return 0; + + case DW_OP_addr: + case DW_OP_const1u: + case DW_OP_const2u: + case DW_OP_const4u: + case DW_OP_const8u: + case DW_OP_constu: + case DW_OP_const8s: + case DW_OP_consts: + Debug (15, "OP_const(0x%lx)\n", (unsigned long) operand1); + push (operand1); + break; + + case DW_OP_const1s: + if (operand1 & 0x80) + operand1 |= ((unw_word_t) -1) << 8; + Debug (15, "OP_const1s(%ld)\n", (long) operand1); + push (operand1); + break; + + case DW_OP_const2s: + if (operand1 & 0x8000) + operand1 |= ((unw_word_t) -1) << 16; + Debug (15, "OP_const2s(%ld)\n", (long) operand1); + push (operand1); + break; + + case DW_OP_const4s: + if (operand1 & 0x80000000) + operand1 |= (((unw_word_t) -1) << 16) << 16; + Debug (15, "OP_const4s(%ld)\n", (long) operand1); + push (operand1); + break; + + case DW_OP_deref: + Debug (15, "OP_deref\n"); + tmp1 = pop (); + if ((ret = dwarf_readw (as, a, &tmp1, &tmp2, arg)) < 0) + return ret; + push (tmp2); + break; + + case DW_OP_deref_size: + Debug (15, "OP_deref_size(%d)\n", (int) operand1); + tmp1 = pop (); + switch (operand1) + { + default: + case 0: + tmp2 = 0; + break; + + case 1: + if ((ret = dwarf_readu8 (as, a, &tmp1, &u8, arg)) < 0) + return ret; + tmp2 = u8; + break; + + case 2: + if ((ret = dwarf_readu16 (as, a, &tmp1, &u16, arg)) < 0) + return ret; + tmp2 = u16; + break; + + case 3: + case 4: + if ((ret = dwarf_readu32 (as, a, &tmp1, &u32, arg)) < 0) + return ret; + tmp2 = u32; + if (operand1 == 3) + { + if (dwarf_is_big_endian (as)) + tmp2 >>= 8; + else + tmp2 &= 0xffffff; + } + break; + case 5: + case 6: + case 7: + case 8: + if ((ret = dwarf_readu64 (as, a, &tmp1, &u64, arg)) < 0) + return ret; + tmp2 = u64; + if (operand1 != 8) + { + if (dwarf_is_big_endian (as)) + tmp2 >>= 64 - 8 * operand1; + else + tmp2 &= (~ (unw_word_t) 0) << (8 * operand1); + } + break; + } + push (tmp2); + break; + + case DW_OP_dup: + Debug (15, "OP_dup\n"); + push (pick (0)); + break; + + case DW_OP_drop: + Debug (15, "OP_drop\n"); + pop (); + break; + + case DW_OP_pick: + Debug (15, "OP_pick(%d)\n", (int) operand1); + push (pick (operand1)); + break; + + case DW_OP_over: + Debug (15, "OP_over\n"); + push (pick (1)); + break; + + case DW_OP_swap: + Debug (15, "OP_swap\n"); + tmp1 = pop (); + tmp2 = pop (); + push (tmp1); + push (tmp2); + break; + + case DW_OP_rot: + Debug (15, "OP_rot\n"); + tmp1 = pop (); + tmp2 = pop (); + tmp3 = pop (); + push (tmp1); + push (tmp3); + push (tmp2); + break; + + case DW_OP_abs: + Debug (15, "OP_abs\n"); + tmp1 = pop (); + if (tmp1 & ((unw_word_t) 1 << (8 * sizeof (unw_word_t) - 1))) + tmp1 = -tmp1; + push (tmp1); + break; + + case DW_OP_and: + Debug (15, "OP_and\n"); + tmp1 = pop (); + tmp2 = pop (); + push (tmp1 & tmp2); + break; + + case DW_OP_div: + Debug (15, "OP_div\n"); + tmp1 = pop (); + tmp2 = pop (); + if (tmp1) + tmp1 = sword (tmp2) / sword (tmp1); + push (tmp1); + break; + + case DW_OP_minus: + Debug (15, "OP_minus\n"); + tmp1 = pop (); + tmp2 = pop (); + tmp1 = tmp2 - tmp1; + push (tmp1); + break; + + case DW_OP_mod: + Debug (15, "OP_mod\n"); + tmp1 = pop (); + tmp2 = pop (); + if (tmp1) + tmp1 = tmp2 % tmp1; + push (tmp1); + break; + + case DW_OP_mul: + Debug (15, "OP_mul\n"); + tmp1 = pop (); + tmp2 = pop (); + if (tmp1) + tmp1 = tmp2 * tmp1; + push (tmp1); + break; + + case DW_OP_neg: + Debug (15, "OP_neg\n"); + push (-pop ()); + break; + + case DW_OP_not: + Debug (15, "OP_not\n"); + push (~pop ()); + break; + + case DW_OP_or: + Debug (15, "OP_or\n"); + tmp1 = pop (); + tmp2 = pop (); + push (tmp1 | tmp2); + break; + + case DW_OP_plus: + Debug (15, "OP_plus\n"); + tmp1 = pop (); + tmp2 = pop (); + push (tmp1 + tmp2); + break; + + case DW_OP_plus_uconst: + Debug (15, "OP_plus_uconst(%lu)\n", (unsigned long) operand1); + tmp1 = pop (); + push (tmp1 + operand1); + break; + + case DW_OP_shl: + Debug (15, "OP_shl\n"); + tmp1 = pop (); + tmp2 = pop (); + push (tmp2 << tmp1); + break; + + case DW_OP_shr: + Debug (15, "OP_shr\n"); + tmp1 = pop (); + tmp2 = pop (); + push (tmp2 >> tmp1); + break; + + case DW_OP_shra: + Debug (15, "OP_shra\n"); + tmp1 = pop (); + tmp2 = pop (); + push (sword (tmp2) >> tmp1); + break; + + case DW_OP_xor: + Debug (15, "OP_xor\n"); + tmp1 = pop (); + tmp2 = pop (); + push (tmp1 ^ tmp2); + break; + + case DW_OP_le: + Debug (15, "OP_le\n"); + tmp1 = pop (); + tmp2 = pop (); + push (sword (tmp1) <= sword (tmp2)); + break; + + case DW_OP_ge: + Debug (15, "OP_ge\n"); + tmp1 = pop (); + tmp2 = pop (); + push (sword (tmp1) >= sword (tmp2)); + break; + + case DW_OP_eq: + Debug (15, "OP_eq\n"); + tmp1 = pop (); + tmp2 = pop (); + push (sword (tmp1) == sword (tmp2)); + break; + + case DW_OP_lt: + Debug (15, "OP_lt\n"); + tmp1 = pop (); + tmp2 = pop (); + push (sword (tmp1) < sword (tmp2)); + break; + + case DW_OP_gt: + Debug (15, "OP_gt\n"); + tmp1 = pop (); + tmp2 = pop (); + push (sword (tmp1) > sword (tmp2)); + break; + + case DW_OP_ne: + Debug (15, "OP_ne\n"); + tmp1 = pop (); + tmp2 = pop (); + push (sword (tmp1) != sword (tmp2)); + break; + + case DW_OP_skip: + Debug (15, "OP_skip(%d)\n", (int16_t) operand1); + *addr += (int16_t) operand1; + break; + + case DW_OP_bra: + Debug (15, "OP_skip(%d)\n", (int16_t) operand1); + tmp1 = pop (); + if (tmp1) + *addr += (int16_t) operand1; + break; + + case DW_OP_nop: + Debug (15, "OP_nop\n"); + break; + + case DW_OP_call2: + case DW_OP_call4: + case DW_OP_call_ref: + case DW_OP_fbreg: + case DW_OP_piece: + case DW_OP_push_object_address: + case DW_OP_xderef: + case DW_OP_xderef_size: + default: + Debug (1, "Unexpected opcode 0x%x\n", opcode); + return -UNW_EINVAL; + } + } + *valp = pop (); + Debug (14, "final value = 0x%lx\n", (unsigned long) *valp); + return 0; +} + +/*XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX*/ +/* Gfde.c */ +/*XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX*/ + +static inline int +is_cie_id (unw_word_t val) +{ + /* DWARF spec says CIE_id is 0xffffffff (for 32-bit ELF) or + 0xffffffffffffffff (for 64-bit ELF). However, the GNU toolchain + uses 0. */ + return (val == 0 || val == - (unw_word_t) 1); +} + +/* Note: we don't need to keep track of more than the first four + characters of the augmentation string, because we (a) ignore any + augmentation string contents once we find an unrecognized character + and (b) those characters that we do recognize, can't be + repeated. */ +static inline int +parse_cie (unw_addr_space_t as, unw_accessors_t *a, unw_word_t addr, + const unw_proc_info_t *pi, struct dwarf_cie_info *dci, void *arg) +{ + uint8_t version, ch, augstr[5], fde_encoding, handler_encoding; + unw_word_t len, cie_end_addr, aug_size; + uint32_t u32val; + uint64_t u64val; + size_t i; + int ret; +# define STR2(x) #x +# define STR(x) STR2(x) + + /* Pick appropriate default for FDE-encoding. DWARF spec says + start-IP (initial_location) and the code-size (address_range) are + "address-unit sized constants". The `R' augmentation can be used + to override this, but by default, we pick an address-sized unit + for fde_encoding. */ + switch (sizeof (unw_word_t)) + { + case 4: fde_encoding = DW_EH_PE_udata4; break; + case 8: fde_encoding = DW_EH_PE_udata8; break; + default: fde_encoding = DW_EH_PE_omit; break; + } + + dci->lsda_encoding = DW_EH_PE_omit; + dci->handler = 0; + + if ((ret = dwarf_readu32 (as, a, &addr, &u32val, arg)) < 0) + return ret; + + if (u32val != 0xffffffff) + { + /* the CIE is in the 32-bit DWARF format */ + uint32_t cie_id; + + len = u32val; + cie_end_addr = addr + len; + if ((ret = dwarf_readu32 (as, a, &addr, &cie_id, arg)) < 0) + return ret; + /* DWARF says CIE id should be 0xffffffff, but in .eh_frame, it's 0 */ + if (cie_id != 0) + { + Debug (1, "Unexpected CIE id %x\n", cie_id); + return -UNW_EINVAL; + } + } + else + { + /* the CIE is in the 64-bit DWARF format */ + uint64_t cie_id; + + if ((ret = dwarf_readu64 (as, a, &addr, &u64val, arg)) < 0) + return ret; + len = u64val; + cie_end_addr = addr + len; + if ((ret = dwarf_readu64 (as, a, &addr, &cie_id, arg)) < 0) + return ret; + /* DWARF says CIE id should be 0xffffffffffffffff, but in + .eh_frame, it's 0 */ + if (cie_id != 0) + { + Debug (1, "Unexpected CIE id %llx\n", (long long) cie_id); + return -UNW_EINVAL; + } + } + dci->cie_instr_end = cie_end_addr; + + if ((ret = dwarf_readu8 (as, a, &addr, &version, arg)) < 0) + return ret; + + if (version != 1 && version != DWARF_CIE_VERSION) + { + Debug (1, "Got CIE version %u, expected version 1 or " + STR (DWARF_CIE_VERSION) "\n", version); + return -UNW_EBADVERSION; + } + + /* read and parse the augmentation string: */ + memset (augstr, 0, sizeof (augstr)); + for (i = 0;;) + { + if ((ret = dwarf_readu8 (as, a, &addr, &ch, arg)) < 0) + return ret; + + if (!ch) + break; /* end of augmentation string */ + + if (i < sizeof (augstr) - 1) + augstr[i++] = ch; + } + + if ((ret = dwarf_read_uleb128 (as, a, &addr, &dci->code_align, arg)) < 0 + || (ret = dwarf_read_sleb128 (as, a, &addr, &dci->data_align, arg)) < 0) + return ret; + + /* Read the return-address column either as a u8 or as a uleb128. */ + if (version == 1) + { + if ((ret = dwarf_readu8 (as, a, &addr, &ch, arg)) < 0) + return ret; + dci->ret_addr_column = ch; + } + else if ((ret = dwarf_read_uleb128 (as, a, &addr, &dci->ret_addr_column, + arg)) < 0) + return ret; + + if (augstr[0] == 'z') + { + dci->sized_augmentation = 1; + if ((ret = dwarf_read_uleb128 (as, a, &addr, &aug_size, arg)) < 0) + return ret; + } + + for (i = 1; i < sizeof (augstr) && augstr[i]; ++i) + switch (augstr[i]) + { + case 'L': + /* read the LSDA pointer-encoding format. */ + if ((ret = dwarf_readu8 (as, a, &addr, &ch, arg)) < 0) + return ret; + dci->lsda_encoding = ch; + break; + + case 'R': + /* read the FDE pointer-encoding format. */ + if ((ret = dwarf_readu8 (as, a, &addr, &fde_encoding, arg)) < 0) + return ret; + break; + + case 'P': + /* read the personality-routine pointer-encoding format. */ + if ((ret = dwarf_readu8 (as, a, &addr, &handler_encoding, arg)) < 0) + return ret; + if ((ret = dwarf_read_encoded_pointer (as, a, &addr, handler_encoding, + pi, &dci->handler, arg)) < 0) + return ret; + break; + + case 'S': + /* Temporarily set it to one so dwarf_parse_fde() knows that + it should fetch the actual ABI/TAG pair from the FDE. */ + dci->have_abi_marker = 1; + break; + + default: + if (dci->sized_augmentation) + /* If we have the size of the augmentation body, we can skip + over the parts that we don't understand, so we're OK. */ + return 0; + else + { + Debug (1, "Unexpected augmentation string `%s'\n", augstr); + return -UNW_EINVAL; + } + } + dci->fde_encoding = fde_encoding; + dci->cie_instr_start = addr; + Debug (15, "CIE parsed OK, augmentation = \"%s\", handler=0x%lx\n", + augstr, (long) dci->handler); + return 0; +} + +/* Extract proc-info from the FDE starting at adress ADDR. */ + +HIDDEN int +dwarf_extract_proc_info_from_fde (unw_addr_space_t as, unw_accessors_t *a, + unw_word_t *addrp, unw_proc_info_t *pi, + int need_unwind_info, + void *arg) +{ + unw_word_t fde_end_addr, cie_addr, cie_offset_addr, aug_end_addr = 0; + unw_word_t start_ip, ip_range, aug_size, addr = *addrp; + int ret, ip_range_encoding; + struct dwarf_cie_info dci; + uint64_t u64val; + uint32_t u32val; + + Debug (12, "FDE @ 0x%lx\n", (long) addr); + + memset (&dci, 0, sizeof (dci)); + + if ((ret = dwarf_readu32 (as, a, &addr, &u32val, arg)) < 0) + return ret; + + if (u32val != 0xffffffff) + { + uint32_t cie_offset; + + /* In some configurations, an FDE with a 0 length indicates the + end of the FDE-table. */ + if (u32val == 0) + return -UNW_ENOINFO; + + /* the FDE is in the 32-bit DWARF format */ + + *addrp = fde_end_addr = addr + u32val; + cie_offset_addr = addr; + + if ((ret = dwarf_readu32 (as, a, &addr, &cie_offset, arg)) < 0) + return ret; + + if (is_cie_id (cie_offset)) + /* ignore CIEs (happens during linear searches) */ + return 0; + + /* DWARF says that the CIE_pointer in the FDE is a + .debug_frame-relative offset, but the GCC-generated .eh_frame + sections instead store a "pcrelative" offset, which is just + as fine as it's self-contained. */ + cie_addr = cie_offset_addr - cie_offset; + } + else + { + uint64_t cie_offset; + + /* the FDE is in the 64-bit DWARF format */ + + if ((ret = dwarf_readu64 (as, a, &addr, &u64val, arg)) < 0) + return ret; + + *addrp = fde_end_addr = addr + u64val; + cie_offset_addr = addr; + + if ((ret = dwarf_readu64 (as, a, &addr, &cie_offset, arg)) < 0) + return ret; + + if (is_cie_id (cie_offset)) + /* ignore CIEs (happens during linear searches) */ + return 0; + + /* DWARF says that the CIE_pointer in the FDE is a + .debug_frame-relative offset, but the GCC-generated .eh_frame + sections instead store a "pcrelative" offset, which is just + as fine as it's self-contained. */ + cie_addr = (unw_word_t) ((uint64_t) cie_offset_addr - cie_offset); + } + + if ((ret = parse_cie (as, a, cie_addr, pi, &dci, arg)) < 0) + return ret; + + /* IP-range has same encoding as FDE pointers, except that it's + always an absolute value: */ + ip_range_encoding = dci.fde_encoding & DW_EH_PE_FORMAT_MASK; + + if ((ret = dwarf_read_encoded_pointer (as, a, &addr, dci.fde_encoding, + pi, &start_ip, arg)) < 0 + || (ret = dwarf_read_encoded_pointer (as, a, &addr, ip_range_encoding, + pi, &ip_range, arg)) < 0) + return ret; + pi->start_ip = start_ip; + pi->end_ip = start_ip + ip_range; + pi->handler = dci.handler; + + if (dci.sized_augmentation) + { + if ((ret = dwarf_read_uleb128 (as, a, &addr, &aug_size, arg)) < 0) + return ret; + aug_end_addr = addr + aug_size; + } + + if ((ret = dwarf_read_encoded_pointer (as, a, &addr, dci.lsda_encoding, + pi, &pi->lsda, arg)) < 0) + return ret; + + Debug (15, "FDE covers IP 0x%lx-0x%lx, LSDA=0x%lx\n", + (long) pi->start_ip, (long) pi->end_ip, (long) pi->lsda); + + if (need_unwind_info) + { + pi->format = UNW_INFO_FORMAT_TABLE; + pi->unwind_info_size = sizeof (dci); + pi->unwind_info = malloc (sizeof(struct dwarf_cie_info)); + if (!pi->unwind_info) + return UNW_ENOMEM; + + if (dci.have_abi_marker) + { + if ((ret = dwarf_readu16 (as, a, &addr, &dci.abi, arg)) < 0 + || (ret = dwarf_readu16 (as, a, &addr, &dci.tag, arg)) < 0) + return ret; + Debug (13, "Found ABI marker = (abi=%u, tag=%u)\n", + dci.abi, dci.tag); + } + + if (dci.sized_augmentation) + dci.fde_instr_start = aug_end_addr; + else + dci.fde_instr_start = addr; + dci.fde_instr_end = fde_end_addr; + + memcpy (pi->unwind_info, &dci, sizeof (dci)); + } + return 0; +} + +/*XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX*/ +/* Gparser.c */ +/*XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX*/ + +#define alloc_reg_state() (malloc (sizeof(dwarf_reg_state_t))) +#define free_reg_state(rs) (free (rs)) + +static inline int +read_regnum (unw_addr_space_t as, unw_accessors_t *a, unw_word_t *addr, + unw_word_t *valp, void *arg) +{ + int ret; + + if ((ret = dwarf_read_uleb128 (as, a, addr, valp, arg)) < 0) + return ret; + + if (*valp >= DWARF_NUM_PRESERVED_REGS) + { + Debug (1, "Invalid register number %u\n", (unsigned int) *valp); + return -UNW_EBADREG; + } + return 0; +} + +static inline void +set_reg (dwarf_state_record_t *sr, unw_word_t regnum, dwarf_where_t where, + unw_word_t val) +{ + sr->rs_current.reg[regnum].where = where; + sr->rs_current.reg[regnum].val = val; +} + +/* Run a CFI program to update the register state. */ +static int +run_cfi_program (struct dwarf_cursor *c, dwarf_state_record_t *sr, + unw_word_t ip, unw_word_t *addr, unw_word_t end_addr, + struct dwarf_cie_info *dci) +{ + unw_word_t curr_ip, operand = 0, regnum, val, len, fde_encoding; + dwarf_reg_state_t *rs_stack = NULL, *new_rs, *old_rs; + unw_addr_space_t as; + unw_accessors_t *a; + uint8_t u8, op; + uint16_t u16; + uint32_t u32; + void *arg; + int ret; + + as = c->as; + arg = c->as_arg; + a = unw_get_accessors (as); + curr_ip = c->pi.start_ip; + + while (curr_ip < ip && *addr < end_addr) + { + if ((ret = dwarf_readu8 (as, a, addr, &op, arg)) < 0) + return ret; + + if (op & DWARF_CFA_OPCODE_MASK) + { + operand = op & DWARF_CFA_OPERAND_MASK; + op &= ~DWARF_CFA_OPERAND_MASK; + } + switch ((dwarf_cfa_t) op) + { + case DW_CFA_advance_loc: + curr_ip += operand * dci->code_align; + Debug (15, "CFA_advance_loc to 0x%lx\n", (long) curr_ip); + break; + + case DW_CFA_advance_loc1: + if ((ret = dwarf_readu8 (as, a, addr, &u8, arg)) < 0) + goto fail; + curr_ip += u8 * dci->code_align; + Debug (15, "CFA_advance_loc1 to 0x%lx\n", (long) curr_ip); + break; + + case DW_CFA_advance_loc2: + if ((ret = dwarf_readu16 (as, a, addr, &u16, arg)) < 0) + goto fail; + curr_ip += u16 * dci->code_align; + Debug (15, "CFA_advance_loc2 to 0x%lx\n", (long) curr_ip); + break; + + case DW_CFA_advance_loc4: + if ((ret = dwarf_readu32 (as, a, addr, &u32, arg)) < 0) + goto fail; + curr_ip += u32 * dci->code_align; + Debug (15, "CFA_advance_loc4 to 0x%lx\n", (long) curr_ip); + break; + + case DW_CFA_MIPS_advance_loc8: +#ifdef UNW_TARGET_MIPS + { + uint64_t u64; + + if ((ret = dwarf_readu64 (as, a, addr, &u64, arg)) < 0) + goto fail; + curr_ip += u64 * dci->code_align; + Debug (15, "CFA_MIPS_advance_loc8\n"); + break; + } +#else + Debug (1, "DW_CFA_MIPS_advance_loc8 on non-MIPS target\n"); + ret = -UNW_EINVAL; + goto fail; +#endif + + case DW_CFA_offset: + regnum = operand; + if (regnum >= DWARF_NUM_PRESERVED_REGS) + { + Debug (1, "Invalid register number %u in DW_cfa_OFFSET\n", + (unsigned int) regnum); + ret = -UNW_EBADREG; + goto fail; + } + if ((ret = dwarf_read_uleb128 (as, a, addr, &val, arg)) < 0) + goto fail; + set_reg (sr, regnum, DWARF_WHERE_CFAREL, val * dci->data_align); + Debug (15, "CFA_offset r%lu at cfa+0x%lx\n", + (long) regnum, (long) (val * dci->data_align)); + break; + + case DW_CFA_offset_extended: + if (((ret = read_regnum (as, a, addr, ®num, arg)) < 0) + || ((ret = dwarf_read_uleb128 (as, a, addr, &val, arg)) < 0)) + goto fail; + set_reg (sr, regnum, DWARF_WHERE_CFAREL, val * dci->data_align); + Debug (15, "CFA_offset_extended r%lu at cf+0x%lx\n", + (long) regnum, (long) (val * dci->data_align)); + break; + + case DW_CFA_offset_extended_sf: + if (((ret = read_regnum (as, a, addr, ®num, arg)) < 0) + || ((ret = dwarf_read_sleb128 (as, a, addr, &val, arg)) < 0)) + goto fail; + set_reg (sr, regnum, DWARF_WHERE_CFAREL, val * dci->data_align); + Debug (15, "CFA_offset_extended_sf r%lu at cf+0x%lx\n", + (long) regnum, (long) (val * dci->data_align)); + break; + + case DW_CFA_restore: + regnum = operand; + if (regnum >= DWARF_NUM_PRESERVED_REGS) + { + Debug (1, "Invalid register number %u in DW_CFA_restore\n", + (unsigned int) regnum); + ret = -UNW_EINVAL; + goto fail; + } + sr->rs_current.reg[regnum] = sr->rs_initial.reg[regnum]; + Debug (15, "CFA_restore r%lu\n", (long) regnum); + break; + + case DW_CFA_restore_extended: + if ((ret = dwarf_read_uleb128 (as, a, addr, ®num, arg)) < 0) + goto fail; + if (regnum >= DWARF_NUM_PRESERVED_REGS) + { + Debug (1, "Invalid register number %u in " + "DW_CFA_restore_extended\n", (unsigned int) regnum); + ret = -UNW_EINVAL; + goto fail; + } + sr->rs_current.reg[regnum] = sr->rs_initial.reg[regnum]; + Debug (15, "CFA_restore_extended r%lu\n", (long) regnum); + break; + + case DW_CFA_nop: + break; + + case DW_CFA_set_loc: + fde_encoding = dci->fde_encoding; + if ((ret = dwarf_read_encoded_pointer (as, a, addr, fde_encoding, + &c->pi, &curr_ip, + arg)) < 0) + goto fail; + Debug (15, "CFA_set_loc to 0x%lx\n", (long) curr_ip); + break; + + case DW_CFA_undefined: + if ((ret = read_regnum (as, a, addr, ®num, arg)) < 0) + goto fail; + set_reg (sr, regnum, DWARF_WHERE_UNDEF, 0); + Debug (15, "CFA_undefined r%lu\n", (long) regnum); + break; + + case DW_CFA_same_value: + if ((ret = read_regnum (as, a, addr, ®num, arg)) < 0) + goto fail; + set_reg (sr, regnum, DWARF_WHERE_SAME, 0); + Debug (15, "CFA_same_value r%lu\n", (long) regnum); + break; + + case DW_CFA_register: + if (((ret = read_regnum (as, a, addr, ®num, arg)) < 0) + || ((ret = dwarf_read_uleb128 (as, a, addr, &val, arg)) < 0)) + goto fail; + set_reg (sr, regnum, DWARF_WHERE_REG, val); + Debug (15, "CFA_register r%lu to r%lu\n", (long) regnum, (long) val); + break; + + case DW_CFA_remember_state: + new_rs = alloc_reg_state (); + if (!new_rs) + { + Debug (1, "Out of memory in DW_CFA_remember_state\n"); + ret = -UNW_ENOMEM; + goto fail; + } + + memcpy (new_rs->reg, sr->rs_current.reg, sizeof (new_rs->reg)); + new_rs->next = rs_stack; + rs_stack = new_rs; + Debug (15, "CFA_remember_state\n"); + break; + + case DW_CFA_restore_state: + if (!rs_stack) + { + Debug (1, "register-state stack underflow\n"); + ret = -UNW_EINVAL; + goto fail; + } + memcpy (&sr->rs_current.reg, &rs_stack->reg, sizeof (rs_stack->reg)); + old_rs = rs_stack; + rs_stack = rs_stack->next; + free_reg_state (old_rs); + Debug (15, "CFA_restore_state\n"); + break; + + case DW_CFA_def_cfa: + if (((ret = read_regnum (as, a, addr, ®num, arg)) < 0) + || ((ret = dwarf_read_uleb128 (as, a, addr, &val, arg)) < 0)) + goto fail; + set_reg (sr, DWARF_CFA_REG_COLUMN, DWARF_WHERE_REG, regnum); + set_reg (sr, DWARF_CFA_OFF_COLUMN, 0, val); /* NOT factored! */ + Debug (15, "CFA_def_cfa r%lu+0x%lx\n", (long) regnum, (long) val); + break; + + case DW_CFA_def_cfa_sf: + if (((ret = read_regnum (as, a, addr, ®num, arg)) < 0) + || ((ret = dwarf_read_sleb128 (as, a, addr, &val, arg)) < 0)) + goto fail; + set_reg (sr, DWARF_CFA_REG_COLUMN, DWARF_WHERE_REG, regnum); + set_reg (sr, DWARF_CFA_OFF_COLUMN, 0, + val * dci->data_align); /* factored! */ + Debug (15, "CFA_def_cfa_sf r%lu+0x%lx\n", + (long) regnum, (long) (val * dci->data_align)); + break; + + case DW_CFA_def_cfa_register: + if ((ret = read_regnum (as, a, addr, ®num, arg)) < 0) + goto fail; + set_reg (sr, DWARF_CFA_REG_COLUMN, DWARF_WHERE_REG, regnum); + Debug (15, "CFA_def_cfa_register r%lu\n", (long) regnum); + break; + + case DW_CFA_def_cfa_offset: + if ((ret = dwarf_read_uleb128 (as, a, addr, &val, arg)) < 0) + goto fail; + set_reg (sr, DWARF_CFA_OFF_COLUMN, 0, val); /* NOT factored! */ + Debug (15, "CFA_def_cfa_offset 0x%lx\n", (long) val); + break; + + case DW_CFA_def_cfa_offset_sf: + if ((ret = dwarf_read_sleb128 (as, a, addr, &val, arg)) < 0) + goto fail; + set_reg (sr, DWARF_CFA_OFF_COLUMN, 0, + val * dci->data_align); /* factored! */ + Debug (15, "CFA_def_cfa_offset_sf 0x%lx\n", + (long) (val * dci->data_align)); + break; + + case DW_CFA_def_cfa_expression: + /* Save the address of the DW_FORM_block for later evaluation. */ + set_reg (sr, DWARF_CFA_REG_COLUMN, DWARF_WHERE_EXPR, *addr); + + if ((ret = dwarf_read_uleb128 (as, a, addr, &len, arg)) < 0) + goto fail; + + Debug (15, "CFA_def_cfa_expr @ 0x%lx [%lu bytes]\n", + (long) *addr, (long) len); + *addr += len; + break; + + case DW_CFA_expression: + if ((ret = read_regnum (as, a, addr, ®num, arg)) < 0) + goto fail; + + /* Save the address of the DW_FORM_block for later evaluation. */ + set_reg (sr, regnum, DWARF_WHERE_EXPR, *addr); + + if ((ret = dwarf_read_uleb128 (as, a, addr, &len, arg)) < 0) + goto fail; + + Debug (15, "CFA_expression r%lu @ 0x%lx [%lu bytes]\n", + (long) regnum, (long) addr, (long) len); + *addr += len; + break; + + case DW_CFA_GNU_args_size: + if ((ret = dwarf_read_uleb128 (as, a, addr, &val, arg)) < 0) + goto fail; + sr->args_size = val; + Debug (15, "CFA_GNU_args_size %lu\n", (long) val); + break; + + case DW_CFA_GNU_negative_offset_extended: + /* A comment in GCC says that this is obsoleted by + DW_CFA_offset_extended_sf, but that it's used by older + PowerPC code. */ + if (((ret = read_regnum (as, a, addr, ®num, arg)) < 0) + || ((ret = dwarf_read_uleb128 (as, a, addr, &val, arg)) < 0)) + goto fail; + set_reg (sr, regnum, DWARF_WHERE_CFAREL, -(val * dci->data_align)); + Debug (15, "CFA_GNU_negative_offset_extended cfa+0x%lx\n", + (long) -(val * dci->data_align)); + break; + + case DW_CFA_GNU_window_save: +#ifdef UNW_TARGET_SPARC + /* This is a special CFA to handle all 16 windowed registers + on SPARC. */ + for (regnum = 16; regnum < 32; ++regnum) + set_reg (sr, regnum, DWARF_WHERE_CFAREL, + (regnum - 16) * sizeof (unw_word_t)); + Debug (15, "CFA_GNU_window_save\n"); + break; +#else + /* FALL THROUGH */ +#endif + case DW_CFA_lo_user: + case DW_CFA_hi_user: + Debug (1, "Unexpected CFA opcode 0x%x\n", op); + ret = -UNW_EINVAL; + goto fail; + } + } + ret = 0; + + fail: + /* Free the register-state stack, if not empty already. */ + while (rs_stack) + { + old_rs = rs_stack; + rs_stack = rs_stack->next; + free_reg_state (old_rs); + } + return ret; +} + +static int +fetch_proc_info (struct dwarf_cursor *c, unw_word_t ip, int need_unwind_info) +{ + int ret; + + --ip; + + if (c->pi_valid && !need_unwind_info) + return 0; + + memset (&c->pi, 0, sizeof (c->pi)); + + if ((ret = tdep_find_proc_info (c, ip, need_unwind_info)) < 0) + return ret; + + c->pi_valid = 1; + return ret; +} + +static inline void +put_unwind_info (struct dwarf_cursor *c, unw_proc_info_t *pi) +{ + if (!c->pi_valid) + return; + + if (pi->unwind_info); + { + free (pi->unwind_info); + pi->unwind_info = NULL; + } +} + +static inline int +parse_fde (struct dwarf_cursor *c, unw_word_t ip, dwarf_state_record_t *sr) +{ + struct dwarf_cie_info *dci; + unw_word_t addr; + int ret; + + dci = c->pi.unwind_info; + c->ret_addr_column = dci->ret_addr_column; + + addr = dci->cie_instr_start; + if ((ret = run_cfi_program (c, sr, ~(unw_word_t) 0, &addr, + dci->cie_instr_end, dci)) < 0) + return ret; + + memcpy (&sr->rs_initial, &sr->rs_current, sizeof (sr->rs_initial)); + + addr = dci->fde_instr_start; + if ((ret = run_cfi_program (c, sr, ip, &addr, dci->fde_instr_end, dci)) < 0) + return ret; + + return 0; +} + +static inline void +flush_rs_cache (struct dwarf_rs_cache *cache) +{ + int i; + + cache->lru_head = DWARF_UNW_CACHE_SIZE - 1; + cache->lru_tail = 0; + + for (i = 0; i < DWARF_UNW_CACHE_SIZE; ++i) + { + if (i > 0) + cache->buckets[i].lru_chain = (i - 1); + cache->buckets[i].coll_chain = -1; + cache->buckets[i].ip = 0; + } + for (i = 0; ihash[i] = -1; +} + +static inline struct dwarf_rs_cache * +get_rs_cache (unw_addr_space_t as, intrmask_t *saved_maskp) +{ + struct dwarf_rs_cache *cache = &as->global_cache; + unw_caching_policy_t caching = as->caching_policy; + + if (caching == UNW_CACHE_NONE) + return NULL; + +#ifndef UW_NO_SYNC +#ifdef HAVE_ATOMIC_H + if (!spin_trylock_irqsave (&cache->busy, *saved_maskp)) + return NULL; +#else +# ifdef HAVE_ATOMIC_OPS_H + if (AO_test_and_set (&cache->busy) == AO_TS_SET) + return NULL; +# else + sigprocmask (SIG_SETMASK, &unwi_full_mask, saved_maskp); + if (likely (caching == UNW_CACHE_GLOBAL)) + { + Debug (16, "%s: acquiring lock\n", __FUNCTION__); + mutex_lock (&cache->lock); + } +# endif +#endif +#endif + + if (atomic_read (&as->cache_generation) != atomic_read (&cache->generation)) + { + flush_rs_cache (cache); + cache->generation = as->cache_generation; + } + + return cache; +} + +static inline void +put_rs_cache (unw_addr_space_t as, struct dwarf_rs_cache *cache, + intrmask_t *saved_maskp) +{ + assert (as->caching_policy != UNW_CACHE_NONE); + + Debug (16, "unmasking signals/interrupts and releasing lock\n"); +#ifndef UW_NO_SYNC +#ifdef HAVE_ATOMIC_H + spin_unlock_irqrestore (&cache->busy, *saved_maskp); +#else +# ifdef HAVE_ATOMIC_OPS_H + AO_CLEAR (&cache->busy); +# else + if (likely (as->caching_policy == UNW_CACHE_GLOBAL)) + mutex_unlock (&cache->lock); + sigprocmask (SIG_SETMASK, saved_maskp, NULL); +# endif +#endif +#endif +} + +static inline unw_hash_index_t +hash (unw_word_t ip) +{ + /* based on (sqrt(5)/2-1)*2^64 */ +# define magic ((unw_word_t) 0x9e3779b97f4a7c16ULL) + + return ip * magic >> ((sizeof(unw_word_t) * 8) - DWARF_LOG_UNW_HASH_SIZE); +} + +static inline long +cache_match (dwarf_reg_state_t *rs, unw_word_t ip) +{ + if (ip == rs->ip) + return 1; + return 0; +} + +static dwarf_reg_state_t * +rs_lookup (struct dwarf_rs_cache *cache, struct dwarf_cursor *c) +{ + dwarf_reg_state_t *rs = cache->buckets + c->hint; + unsigned short index; + unw_word_t ip; + + ip = c->ip; + + if (cache_match (rs, ip)) + return rs; + + index = cache->hash[hash (ip)]; + if (index >= DWARF_UNW_CACHE_SIZE) + return 0; + + rs = cache->buckets + index; + while (1) + { + if (cache_match (rs, ip)) + { + /* update hint; no locking needed: single-word writes are atomic */ + c->hint = cache->buckets[c->prev_rs].hint = + (rs - cache->buckets); + return rs; + } + if (rs->coll_chain >= DWARF_UNW_HASH_SIZE) + return 0; + rs = cache->buckets + rs->coll_chain; + } +} + +static inline dwarf_reg_state_t * +rs_new (struct dwarf_rs_cache *cache, struct dwarf_cursor * c) +{ + dwarf_reg_state_t *rs, *prev, *tmp; + unw_hash_index_t index; + unsigned short head; + + head = cache->lru_head; + rs = cache->buckets + head; + cache->lru_head = rs->lru_chain; + + /* re-insert rs at the tail of the LRU chain: */ + cache->buckets[cache->lru_tail].lru_chain = head; + cache->lru_tail = head; + + /* remove the old rs from the hash table (if it's there): */ + if (rs->ip) + { + index = hash (rs->ip); + tmp = cache->buckets + cache->hash[index]; + prev = 0; + while (1) + { + if (tmp == rs) + { + if (prev) + prev->coll_chain = tmp->coll_chain; + else + cache->hash[index] = tmp->coll_chain; + break; + } + else + prev = tmp; + if (tmp->coll_chain >= DWARF_UNW_CACHE_SIZE) + /* old rs wasn't in the hash-table */ + break; + tmp = cache->buckets + tmp->coll_chain; + } + } + + /* enter new rs in the hash table */ + index = hash (c->ip); + rs->coll_chain = cache->hash[index]; + cache->hash[index] = rs - cache->buckets; + + rs->hint = 0; + rs->ip = c->ip; + rs->ret_addr_column = c->ret_addr_column; + + return rs; +} + +static int +create_state_record_for (struct dwarf_cursor *c, dwarf_state_record_t *sr, + unw_word_t ip) +{ + int i, ret; + + assert (c->pi_valid); + + memset (sr, 0, sizeof (*sr)); + for (i = 0; i < DWARF_NUM_PRESERVED_REGS + 2; ++i) + set_reg (sr, i, DWARF_WHERE_SAME, 0); + + switch (c->pi.format) + { + case UNW_INFO_FORMAT_TABLE: + case UNW_INFO_FORMAT_REMOTE_TABLE: + ret = parse_fde (c, ip, sr); + break; +#if 0 + case UNW_INFO_FORMAT_DYNAMIC: + ret = parse_dynamic (c, ip, sr); + break; +#endif + + default: + Debug (1, "Unexpected unwind-info format %d\n", c->pi.format); + ret = -UNW_EINVAL; + } + return ret; +} + +static inline int +eval_location_expr (struct dwarf_cursor *c, unw_addr_space_t as, + unw_accessors_t *a, unw_word_t addr, + dwarf_loc_t *locp, void *arg) +{ + int ret, is_register; + unw_word_t len, val; + + /* read the length of the expression: */ + if ((ret = dwarf_read_uleb128 (as, a, &addr, &len, arg)) < 0) + return ret; + + /* evaluate the expression: */ + if ((ret = dwarf_eval_expr (c, &addr, len, &val, &is_register)) < 0) + return ret; + + if (is_register) + *locp = DWARF_REG_LOC (c, dwarf_to_unw_regnum (val)); + else + *locp = DWARF_MEM_LOC (c, val); + + return 0; +} + +static int +apply_reg_state (struct dwarf_cursor *c, struct dwarf_reg_state *rs) +{ + unw_word_t regnum, addr, cfa, ip; + unw_word_t prev_ip, prev_cfa; + unw_addr_space_t as; + dwarf_loc_t cfa_loc; + unw_accessors_t *a; + int i, ret; + void *arg; + + prev_ip = c->ip; + prev_cfa = c->cfa; + + as = c->as; + arg = c->as_arg; + a = unw_get_accessors (as); + + /* Evaluate the CFA first, because it may be referred to by other + expressions. */ + + if (rs->reg[DWARF_CFA_REG_COLUMN].where == DWARF_WHERE_REG) + { + /* CFA is equal to [reg] + offset: */ + + /* As a special-case, if the stack-pointer is the CFA and the + stack-pointer wasn't saved, popping the CFA implicitly pops + the stack-pointer as well. */ + if ((rs->reg[DWARF_CFA_REG_COLUMN].val == UNW_TDEP_SP) + && (rs->reg[UNW_TDEP_SP].where == DWARF_WHERE_SAME)) + cfa = c->cfa; + else + { + regnum = dwarf_to_unw_regnum (rs->reg[DWARF_CFA_REG_COLUMN].val); + if ((ret = unw_get_reg ((unw_cursor_t *) c, regnum, &cfa)) < 0) + return ret; + } + cfa += rs->reg[DWARF_CFA_OFF_COLUMN].val; + } + else + { + /* CFA is equal to EXPR: */ + + assert (rs->reg[DWARF_CFA_REG_COLUMN].where == DWARF_WHERE_EXPR); + + addr = rs->reg[DWARF_CFA_REG_COLUMN].val; + if ((ret = eval_location_expr (c, as, a, addr, &cfa_loc, arg)) < 0) + return ret; + /* the returned location better be a memory location... */ + if (DWARF_IS_REG_LOC (cfa_loc)) + return -UNW_EBADFRAME; + cfa = DWARF_GET_LOC (cfa_loc); + } + + for (i = 0; i < DWARF_NUM_PRESERVED_REGS; ++i) + { + switch ((dwarf_where_t) rs->reg[i].where) + { + case DWARF_WHERE_UNDEF: + c->loc[i] = DWARF_NULL_LOC; + break; + + case DWARF_WHERE_SAME: + break; + + case DWARF_WHERE_CFAREL: + c->loc[i] = DWARF_MEM_LOC (c, cfa + rs->reg[i].val); + break; + + case DWARF_WHERE_REG: + c->loc[i] = DWARF_REG_LOC (c, dwarf_to_unw_regnum (rs->reg[i].val)); + break; + + case DWARF_WHERE_EXPR: + addr = rs->reg[i].val; + if ((ret = eval_location_expr (c, as, a, addr, c->loc + i, arg)) , 0) + return ret; + break; + } + } + c->cfa = cfa; + ret = dwarf_get (c, c->loc[c->ret_addr_column], &ip); + if (ret < 0) + return ret; + c->ip = ip; + /* XXX: check for ip to be code_aligned */ + + if (c->ip == prev_ip && c->cfa == prev_cfa) + { + dprintf ("%s: ip and cfa unchanged; stopping here (ip=0x%lx)\n", + __FUNCTION__, (long) c->ip); + return -UNW_EBADFRAME; + } + return 0; +} + +static int +uncached_dwarf_find_save_locs (struct dwarf_cursor *c) +{ + dwarf_state_record_t sr; + int ret; + + if ((ret = fetch_proc_info (c, c->ip, 1)) < 0) + return ret; + + if ((ret = create_state_record_for (c, &sr, c->ip)) < 0) + return ret; + + if ((ret = apply_reg_state (c, &sr.rs_current)) < 0) + return ret; + + put_unwind_info (c, &c->pi); + return 0; +} + +/* The function finds the saved locations and applies the register + state as well. */ +HIDDEN int +dwarf_find_save_locs (struct dwarf_cursor *c) +{ + dwarf_state_record_t sr; + dwarf_reg_state_t *rs, *rs1; + struct dwarf_rs_cache *cache; + int ret = 0; + intrmask_t saved_mask; + + if (c->as->caching_policy == UNW_CACHE_NONE) + return uncached_dwarf_find_save_locs (c); + + cache = get_rs_cache(c->as, &saved_mask); + if (!cache) + return -UNW_ENOINFO; /* cache is busy */ + rs = rs_lookup(cache, c); + + if (rs) + { + c->ret_addr_column = rs->ret_addr_column; + goto apply; + } + + if ((ret = fetch_proc_info (c, c->ip, 1)) < 0) + goto out; + + if ((ret = create_state_record_for (c, &sr, c->ip)) < 0) + goto out; + + rs1 = &sr.rs_current; + if (rs1) + { + rs = rs_new (cache, c); + memcpy(rs, rs1, offsetof(struct dwarf_reg_state, ip)); + if (!rs) + { + dprintf ("%s: failed to create unwind rs\n", __FUNCTION__); + ret = -UNW_EUNSPEC; + goto out; + } + } + cache->buckets[c->prev_rs].hint = rs - cache->buckets; + + c->hint = rs->hint; + c->prev_rs = rs - cache->buckets; + + put_unwind_info (c, &c->pi); + ret = apply_reg_state (c, rs); + +out: + put_rs_cache (c->as, cache, &saved_mask); + return ret; + +apply: + put_rs_cache (c->as, cache, &saved_mask); + if ((ret = apply_reg_state (c, rs)) < 0) + return ret; + + return 0; +} + +/* The proc-info must be valid for IP before this routine can be + called. */ +HIDDEN int +dwarf_create_state_record (struct dwarf_cursor *c, dwarf_state_record_t *sr) +{ + return create_state_record_for (c, sr, c->ip); +} + +HIDDEN int +dwarf_make_proc_info (struct dwarf_cursor *c) +{ +#if 0 + if (c->as->caching_policy == UNW_CACHE_NONE + || get_cached_proc_info (c) < 0) +#endif + /* Lookup it up the slow way... */ + return fetch_proc_info (c, c->ip, 0); + return 0; +} + +HIDDEN int +dwarf_step (struct dwarf_cursor *c) +{ + /* unw_word_t prev_cfa = c->cfa; */ + int ret; + + if ((ret = dwarf_find_save_locs (c)) >= 0) { + c->pi_valid = 0; + ret = (c->ip == 0) ? 0 : 1; + } + + Debug (15, "returning %d\n", ret); + return ret; +} + +/*XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX*/ +/* Gpe.c */ +/*XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX*/ + +HIDDEN int +dwarf_read_encoded_pointer (unw_addr_space_t as, unw_accessors_t *a, + unw_word_t *addr, unsigned char encoding, + const unw_proc_info_t *pi, + unw_word_t *valp, void *arg) +{ + return dwarf_read_encoded_pointer_inlined (as, a, addr, encoding, + pi, valp, arg); +} + +/*XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX*/ +/* Gfind_proc_info-lsb.c */ +/*XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX*/ + +struct table_entry + { + int32_t start_ip_offset; + int32_t fde_offset; + }; + +#ifndef UNW_REMOTE_ONLY + +struct callback_data + { + /* in: */ + unw_word_t ip; /* instruction-pointer we're looking for */ + unw_proc_info_t *pi; /* proc-info pointer */ + int need_unwind_info; + /* out: */ + int single_fde; /* did we find a single FDE? (vs. a table) */ + unw_dyn_info_t di; /* table info (if single_fde is false) */ + }; + +static int +linear_search (unw_addr_space_t as, unw_word_t ip, + unw_word_t eh_frame_start, unw_word_t eh_frame_end, + unw_word_t fde_count, + unw_proc_info_t *pi, int need_unwind_info, void *arg) +{ + unw_accessors_t *a = unw_get_accessors (unw_local_addr_space); + unw_word_t i = 0, fde_addr, addr = eh_frame_start; + int ret; + + while (i++ < fde_count && addr < eh_frame_end) + { + fde_addr = addr; + if ((ret = dwarf_extract_proc_info_from_fde (as, a, &addr, pi, 0, arg)) + < 0) + return ret; + + if (ip >= pi->start_ip && ip < pi->end_ip) + { + if (!need_unwind_info) + return 1; + addr = fde_addr; + if ((ret = dwarf_extract_proc_info_from_fde (as, a, &addr, pi, + need_unwind_info, arg)) + < 0) + return ret; + return 1; + } + } + return -UNW_ENOINFO; +} + +/* Info is a pointer to a unw_dyn_info_t structure and, on entry, + member u.rti.segbase contains the instruction-pointer we're looking + for. */ +static int +callback (struct dl_phdr_info *info, size_t size, void *ptr) +{ + struct callback_data *cb_data = ptr; + unw_dyn_info_t *di = &cb_data->di; + const Elf_W(Phdr) *phdr, *p_eh_hdr, *p_dynamic, *p_text; + unw_word_t addr, eh_frame_start, eh_frame_end, fde_count, ip; + Elf_W(Addr) load_base, segbase = 0, max_load_addr = 0; + int ret, need_unwind_info = cb_data->need_unwind_info; + unw_proc_info_t *pi = cb_data->pi; + struct dwarf_eh_frame_hdr *hdr; + unw_accessors_t *a; + long n; + + ip = cb_data->ip; + + /* Make sure struct dl_phdr_info is at least as big as we need. */ + if (size < offsetof (struct dl_phdr_info, dlpi_phnum) + + sizeof (info->dlpi_phnum)) + return -1; + + Debug (15, "checking %s, base=0x%lx)\n", + info->dlpi_name, (long) info->dlpi_addr); + + phdr = info->dlpi_phdr; + load_base = info->dlpi_addr; + p_text = NULL; + p_eh_hdr = NULL; + p_dynamic = NULL; + + /* See if PC falls into one of the loaded segments. Find the + eh-header segment at the same time. */ + for (n = info->dlpi_phnum; --n >= 0; phdr++) + { + if (phdr->p_type == PT_LOAD) + { + Elf_W(Addr) vaddr = phdr->p_vaddr + load_base; + + Debug(18, "check %lx versus %lx-%lx\n", ip, vaddr, vaddr + phdr->p_memsz); + + if (ip >= vaddr && ip < vaddr + phdr->p_memsz) + p_text = phdr; + + if (vaddr + phdr->p_filesz > max_load_addr) + max_load_addr = vaddr + phdr->p_filesz; + } + else if (phdr->p_type == PT_GNU_EH_FRAME) + p_eh_hdr = phdr; + else if (phdr->p_type == PT_DYNAMIC) + p_dynamic = phdr; + } + if (!p_text || !p_eh_hdr) + return 0; + + if (likely (p_eh_hdr->p_vaddr >= p_text->p_vaddr + && p_eh_hdr->p_vaddr < p_text->p_vaddr + p_text->p_memsz)) + /* normal case: eh-hdr is inside text segment */ + segbase = p_text->p_vaddr + load_base; + else + { + /* Special case: eh-hdr is in some other segment; this may + happen, e.g., for the Linux kernel's gate DSO, for + example. */ + phdr = info->dlpi_phdr; + for (n = info->dlpi_phnum; --n >= 0; phdr++) + { + if (phdr->p_type == PT_LOAD && p_eh_hdr->p_vaddr >= phdr->p_vaddr + && p_eh_hdr->p_vaddr < phdr->p_vaddr + phdr->p_memsz) + { + segbase = phdr->p_vaddr + load_base; + break; + } + } + } + + if (p_dynamic) + { + /* For dynamicly linked executables and shared libraries, + DT_PLTGOT is the value that data-relative addresses are + relative to for that object. We call this the "gp". */ + Elf_W(Dyn) *dyn = (Elf_W(Dyn) *)(p_dynamic->p_vaddr + load_base); + for (; dyn->d_tag != DT_NULL; ++dyn) + if (dyn->d_tag == DT_PLTGOT) + { + /* Assume that _DYNAMIC is writable and GLIBC has + relocated it (true for x86 at least). */ + di->gp = dyn->d_un.d_ptr; + break; + } + } + else + /* Otherwise this is a static executable with no _DYNAMIC. Assume + that data-relative addresses are relative to 0, i.e., + absolute. */ + di->gp = 0; + pi->gp = di->gp; + + hdr = (struct dwarf_eh_frame_hdr *) (p_eh_hdr->p_vaddr + load_base); + if (hdr->version != DW_EH_VERSION) + { + Debug (1, "table `%s' has unexpected version %d\n", + info->dlpi_name, hdr->version); + return 0; + } + + a = unw_get_accessors (unw_local_addr_space); + addr = (unw_word_t) (hdr + 1); + + /* (Optionally) read eh_frame_ptr: */ + if ((ret = dwarf_read_encoded_pointer (unw_local_addr_space, a, + &addr, hdr->eh_frame_ptr_enc, pi, + &eh_frame_start, NULL)) < 0) + return ret; + + /* (Optionally) read fde_count: */ + if ((ret = dwarf_read_encoded_pointer (unw_local_addr_space, a, + &addr, hdr->fde_count_enc, pi, + &fde_count, NULL)) < 0) + return ret; + + if (hdr->table_enc != (DW_EH_PE_datarel | DW_EH_PE_sdata4)) + { + /* If there is no search table or it has an unsupported + encoding, fall back on linear search. */ + if (hdr->table_enc == DW_EH_PE_omit) + Debug (4, "table `%s' lacks search table; doing linear search\n", + info->dlpi_name); + else + Debug (4, "table `%s' has encoding 0x%x; doing linear search\n", + info->dlpi_name, hdr->table_enc); + + eh_frame_end = max_load_addr; /* XXX can we do better? */ + + if (hdr->fde_count_enc == DW_EH_PE_omit) + fde_count = ~0UL; + if (hdr->eh_frame_ptr_enc == DW_EH_PE_omit) + abort (); + + cb_data->single_fde = 1; + return linear_search (unw_local_addr_space, ip, + eh_frame_start, eh_frame_end, fde_count, + pi, need_unwind_info, NULL); + } + + cb_data->single_fde = 0; + di->format = UNW_INFO_FORMAT_REMOTE_TABLE; + di->start_ip = p_text->p_vaddr + load_base; + di->end_ip = p_text->p_vaddr + load_base + p_text->p_memsz; + di->u.rti.name_ptr = (unw_word_t) info->dlpi_name; + di->u.rti.table_data = addr; + assert (sizeof (struct table_entry) % sizeof (unw_word_t) == 0); + di->u.rti.table_len = (fde_count * sizeof (struct table_entry) + / sizeof (unw_word_t)); + /* For the binary-search table in the eh_frame_hdr, data-relative + means relative to the start of that section... */ + di->u.rti.segbase = (unw_word_t) hdr; + + Debug (15, "found table `%s': segbase=0x%lx, len=%lu, gp=0x%lx, " + "table_data=0x%lx\n", (char *) di->u.rti.name_ptr, + (long) di->u.rti.segbase, (long) di->u.rti.table_len, + (long) di->gp, (long) di->u.rti.table_data); + return 1; +} + +HIDDEN int +dwarf_find_proc_info (unw_addr_space_t as, unw_word_t ip, + unw_proc_info_t *pi, int need_unwind_info, void *arg) +{ + struct callback_data cb_data; +#ifndef UW_NO_SYNC + intrmask_t saved_mask; +#endif + int ret; + + Debug (14, "looking for IP=0x%lx\n", (long) ip); + + cb_data.ip = ip; + cb_data.pi = pi; + cb_data.need_unwind_info = need_unwind_info; + +#ifndef UW_NO_SYNC + sigprocmask (SIG_SETMASK, &unwi_full_mask, &saved_mask); +#endif + ret = dl_iterate_phdr (callback, &cb_data); +#ifndef UW_NO_SYNC + sigprocmask (SIG_SETMASK, &saved_mask, NULL); +#endif + + if (ret <= 0) + { + Debug (14, "IP=0x%lx not found\n", (long) ip); + return -UNW_ENOINFO; + } + + if (cb_data.single_fde) + /* already got the result in *pi */ + return 0; + else + /* search the table: */ + return dwarf_search_unwind_table (as, ip, &cb_data.di, + pi, need_unwind_info, arg); +} + +static inline const struct table_entry * +lookup (struct table_entry *table, size_t table_size, int32_t rel_ip) +{ + unsigned long table_len = table_size / sizeof (struct table_entry); + const struct table_entry *e = 0; + unsigned long lo, hi, mid; + + /* do a binary search for right entry: */ + for (lo = 0, hi = table_len; lo < hi;) + { + mid = (lo + hi) / 2; + e = table + mid; + if (rel_ip < e->start_ip_offset) + hi = mid; + else + lo = mid + 1; + } + if (hi <= 0) + return NULL; + e = table + hi - 1; + return e; +} + +#endif /* !UNW_REMOTE_ONLY */ + +int +dwarf_search_unwind_table (unw_addr_space_t as, unw_word_t ip, + unw_dyn_info_t *di, unw_proc_info_t *pi, + int need_unwind_info, void *arg) +{ + const struct table_entry *e = NULL; + unw_word_t segbase = 0, fde_addr; + unw_accessors_t *a; + int ret; + + assert (di->format == UNW_INFO_FORMAT_REMOTE_TABLE + && (ip >= di->start_ip && ip < di->end_ip)); + + a = unw_get_accessors (as); + + segbase = di->u.rti.segbase; + e = lookup ((struct table_entry *) di->u.rti.table_data, + di->u.rti.table_len * sizeof (unw_word_t), ip - segbase); + + if (!e) + { + /* IP is inside this table's range, but there is no explicit + unwind info. */ + return -UNW_ENOINFO; + } + Debug (15, "ip=0x%lx, start_ip=0x%lx\n", + (long) ip, (long) (e->start_ip_offset + segbase)); + fde_addr = e->fde_offset + segbase; + if ((ret = dwarf_extract_proc_info_from_fde (as, a, &fde_addr, pi, + need_unwind_info, arg)) < 0) + return ret; + + if (ip < pi->start_ip || ip >= pi->end_ip) + return -UNW_ENOINFO; + + return 0; +} + +void +dwarf_put_unwind_info (unw_addr_space_t as, unw_proc_info_t *pi, void *arg) +{ + return; /* always a nop */ +} + +/*XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX*/ +/* glue */ +/*XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX*/ + +unw_addr_space_t unw_local_addr_space; +unw_accessors_t *unw_get_accessors (unw_addr_space_t unw_local_addr_space) +{ + return NULL; +} + +#ifdef OS_X + +int dl_iterate_phdr (DL_Iter_Callback callback, void *p) +{ + int i, c, j, n, size; + const struct mach_header *mh; + struct load_command *cmd; + char *data; + struct dl_phdr_info info; + Phdr *phdr; + + c = _dyld_image_count(); + + for (i = 0; i < c; i++) { + mh = _dyld_get_image_header(i); + n = mh->ncmds; + cmd = (struct load_command *)((char *)mh + sizeof(*mh)); + data = (char *)cmd + mh->sizeofcmds; + phdr = (Phdr *)malloc(sizeof(Phdr) * n); + + info.dlpi_phnum = n; + info.dlpi_addr = (long)_dyld_get_image_vmaddr_slide(i); + info.dlpi_name = _dyld_get_image_name(i); + info.dlpi_phdr = phdr; + + for (j = 0; j < n; j++) { + phdr[j].p_type = cmd->cmd; + if (cmd->cmd == LC_SEGMENT) { + struct segment_command *scmd = (struct segment_command *)cmd; + phdr[j].p_vaddr = scmd->vmaddr; + phdr[j].p_memsz = scmd->vmsize; + phdr[j].p_filesz = scmd->filesize; + } + + size = (cmd->cmdsize + sizeof(long) - 1) & ~(sizeof(long) - 1); + cmd = (struct load_command *)((char *)cmd + size); + } + + if (callback(&info, sizeof(info), p)) + return 1; + } + + return 0; +} + +#endif + +/***********************************************************************/ + +#ifdef PLAIN_X86 +static uint8_t dwarf_to_unw_regnum_map[19] = + { + UNW_X86_EAX, UNW_X86_ECX, UNW_X86_EDX, UNW_X86_EBX, + UNW_X86_ESP, UNW_X86_EBP, UNW_X86_ESI, UNW_X86_EDI, + UNW_X86_EIP, UNW_X86_EFLAGS, UNW_X86_TRAPNO, + UNW_X86_ST0, UNW_X86_ST1, UNW_X86_ST2, UNW_X86_ST3, + UNW_X86_ST4, UNW_X86_ST5, UNW_X86_ST6, UNW_X86_ST7 + }; +#else +static uint8_t dwarf_to_unw_regnum_map[17] = + { + UNW_X86_64_RAX, + UNW_X86_64_RDX, + UNW_X86_64_RCX, + UNW_X86_64_RBX, + UNW_X86_64_RSI, + UNW_X86_64_RDI, + UNW_X86_64_RBP, + UNW_X86_64_RSP, + UNW_X86_64_R8, + UNW_X86_64_R9, + UNW_X86_64_R10, + UNW_X86_64_R11, + UNW_X86_64_R12, + UNW_X86_64_R13, + UNW_X86_64_R14, + UNW_X86_64_R15, + UNW_X86_64_RIP + }; +#endif + +int +unw_get_reg (unw_cursor_t *cursor, int regnum, unw_word_t *valp) +{ + void *p; + + p = tdep_uc_addr(((struct cursor *)cursor)->dwarf.as_arg, regnum); + if (p) { + *valp = *(unw_word_t *)p; + return 1; + } else { + *valp = -1; + return 0; + } +} + +void * +tdep_uc_addr (ucontext_t *uc, int reg) +{ + void *addr; + + switch (reg) + { +#ifdef LINUX +# ifdef PLAIN_X86 + case UNW_X86_GS: addr = &uc->uc_mcontext.gregs[REG_GS]; break; + case UNW_X86_FS: addr = &uc->uc_mcontext.gregs[REG_FS]; break; + case UNW_X86_ES: addr = &uc->uc_mcontext.gregs[REG_ES]; break; + case UNW_X86_DS: addr = &uc->uc_mcontext.gregs[REG_DS]; break; + case UNW_X86_EAX: addr = &uc->uc_mcontext.gregs[REG_EAX]; break; + case UNW_X86_EBX: addr = &uc->uc_mcontext.gregs[REG_EBX]; break; + case UNW_X86_ECX: addr = &uc->uc_mcontext.gregs[REG_ECX]; break; + case UNW_X86_EDX: addr = &uc->uc_mcontext.gregs[REG_EDX]; break; + case UNW_X86_ESI: addr = &uc->uc_mcontext.gregs[REG_ESI]; break; + case UNW_X86_EDI: addr = &uc->uc_mcontext.gregs[REG_EDI]; break; + case UNW_X86_EBP: addr = &uc->uc_mcontext.gregs[REG_EBP]; break; + case UNW_X86_EIP: addr = &uc->uc_mcontext.gregs[REG_EIP]; break; + case UNW_X86_ESP: addr = &uc->uc_mcontext.gregs[REG_ESP]; break; + case UNW_X86_TRAPNO: addr = &uc->uc_mcontext.gregs[REG_TRAPNO]; break; + case UNW_X86_CS: addr = &uc->uc_mcontext.gregs[REG_CS]; break; + case UNW_X86_EFLAGS: addr = &uc->uc_mcontext.gregs[REG_EFL]; break; + case UNW_X86_SS: addr = &uc->uc_mcontext.gregs[REG_SS]; break; +# else + case UNW_X86_64_R8: addr = &uc->uc_mcontext.gregs[REG_R8]; break; + case UNW_X86_64_R9: addr = &uc->uc_mcontext.gregs[REG_R9]; break; + case UNW_X86_64_R10: addr = &uc->uc_mcontext.gregs[REG_R10]; break; + case UNW_X86_64_R11: addr = &uc->uc_mcontext.gregs[REG_R11]; break; + case UNW_X86_64_R12: addr = &uc->uc_mcontext.gregs[REG_R12]; break; + case UNW_X86_64_R13: addr = &uc->uc_mcontext.gregs[REG_R13]; break; + case UNW_X86_64_R14: addr = &uc->uc_mcontext.gregs[REG_R14]; break; + case UNW_X86_64_R15: addr = &uc->uc_mcontext.gregs[REG_R15]; break; + case UNW_X86_64_RDI: addr = &uc->uc_mcontext.gregs[REG_RDI]; break; + case UNW_X86_64_RSI: addr = &uc->uc_mcontext.gregs[REG_RSI]; break; + case UNW_X86_64_RBP: addr = &uc->uc_mcontext.gregs[REG_RBP]; break; + case UNW_X86_64_RBX: addr = &uc->uc_mcontext.gregs[REG_RBX]; break; + case UNW_X86_64_RDX: addr = &uc->uc_mcontext.gregs[REG_RDX]; break; + case UNW_X86_64_RAX: addr = &uc->uc_mcontext.gregs[REG_RAX]; break; + case UNW_X86_64_RCX: addr = &uc->uc_mcontext.gregs[REG_RCX]; break; + case UNW_X86_64_RSP: addr = &uc->uc_mcontext.gregs[REG_RSP]; break; + case UNW_X86_64_RIP: addr = &uc->uc_mcontext.gregs[REG_RIP]; break; +# endif +#endif +#ifdef OS_X + case UNW_X86_GS: addr = &uc->uc_mcontext->__ss.__gs; break; + case UNW_X86_FS: addr = &uc->uc_mcontext->__ss.__fs; break; + case UNW_X86_ES: addr = &uc->uc_mcontext->__ss.__es; break; + case UNW_X86_DS: addr = &uc->uc_mcontext->__ss.__ds; break; + case UNW_X86_EAX: addr = &uc->uc_mcontext->__ss.__eax; break; + case UNW_X86_EBX: addr = &uc->uc_mcontext->__ss.__ebx; break; + case UNW_X86_ECX: addr = &uc->uc_mcontext->__ss.__ecx; break; + case UNW_X86_EDX: addr = &uc->uc_mcontext->__ss.__edx; break; + case UNW_X86_ESI: addr = &uc->uc_mcontext->__ss.__esi; break; + case UNW_X86_EDI: addr = &uc->uc_mcontext->__ss.__edi; break; + case UNW_X86_EBP: addr = &uc->uc_mcontext->__ss.__ebp; break; + case UNW_X86_EIP: addr = &uc->uc_mcontext->__ss.__eip; break; + case UNW_X86_ESP: addr = &uc->uc_mcontext->__ss.__esp; break; + case UNW_X86_CS: addr = &uc->uc_mcontext->__ss.__cs; break; + case UNW_X86_EFLAGS: addr = &uc->uc_mcontext->__ss.__eflags; break; + case UNW_X86_SS: addr = &uc->uc_mcontext->__ss.__ss; break; +#endif + + default: + addr = NULL; + } + return addr; +} + +int dwarf_to_unw_regnum(reg) +{ + return (((reg) <= DWARF_REGNUM_MAP_LENGTH) ? dwarf_to_unw_regnum_map[reg] : 0); +} + +#ifdef PLAIN_X86 +/* DWARF column numbers: */ +#define EAX 0 +#define ECX 1 +#define EDX 2 +#define EBX 3 +#define ESP 4 +#define EBP 5 +#define ESI 6 +#define EDI 7 +#define EIP 8 +#define EFLAGS 9 +#define TRAPNO 10 +#define ST0 11 +#else +/* DWARF column numbers for x86_64: */ +#define RAX 0 +#define RDX 1 +#define RCX 2 +#define RBX 3 +#define RSI 4 +#define RDI 5 +#define RBP 6 +#define RSP 7 +#define R8 8 +#define R9 9 +#define R10 10 +#define R11 11 +#define R12 12 +#define R13 13 +#define R14 14 +#define R15 15 +#define RIP 16 +#endif + +#ifdef PLAIN_X86 +static inline int +common_init (struct cursor *c) +{ + int ret, i; + + c->dwarf.loc[EAX] = DWARF_REG_LOC (&c->dwarf, UNW_X86_EAX); + c->dwarf.loc[ECX] = DWARF_REG_LOC (&c->dwarf, UNW_X86_ECX); + c->dwarf.loc[EDX] = DWARF_REG_LOC (&c->dwarf, UNW_X86_EDX); + c->dwarf.loc[EBX] = DWARF_REG_LOC (&c->dwarf, UNW_X86_EBX); + c->dwarf.loc[ESP] = DWARF_REG_LOC (&c->dwarf, UNW_X86_ESP); + c->dwarf.loc[EBP] = DWARF_REG_LOC (&c->dwarf, UNW_X86_EBP); + c->dwarf.loc[ESI] = DWARF_REG_LOC (&c->dwarf, UNW_X86_EDI); + c->dwarf.loc[EDI] = DWARF_REG_LOC (&c->dwarf, UNW_X86_EDI); + c->dwarf.loc[EIP] = DWARF_REG_LOC (&c->dwarf, UNW_X86_EIP); + c->dwarf.loc[EFLAGS] = DWARF_REG_LOC (&c->dwarf, UNW_X86_EFLAGS); + c->dwarf.loc[TRAPNO] = DWARF_REG_LOC (&c->dwarf, UNW_X86_TRAPNO); + c->dwarf.loc[ST0] = DWARF_REG_LOC (&c->dwarf, UNW_X86_ST0); + for (i = ST0 + 1; i < DWARF_NUM_PRESERVED_REGS; ++i) + c->dwarf.loc[i] = DWARF_NULL_LOC; + + ret = dwarf_get (&c->dwarf, c->dwarf.loc[EIP], &c->dwarf.ip); + if (ret < 0) + return ret; + + ret = dwarf_get (&c->dwarf, DWARF_REG_LOC (&c->dwarf, UNW_X86_ESP), + &c->dwarf.cfa); + if (ret < 0) + return ret; + + c->sigcontext_format = X86_SCF_NONE; + c->sigcontext_addr = 0; + + c->dwarf.args_size = 0; + c->dwarf.ret_addr_column = 0; + c->dwarf.pi_valid = 0; + c->dwarf.hint = 0; + c->dwarf.prev_rs = 0; + + return 0; +} +#else +static inline int +common_init (struct cursor *c) +{ + int ret; + + c->dwarf.loc[RAX] = DWARF_REG_LOC (&c->dwarf, UNW_X86_64_RAX); + c->dwarf.loc[RDX] = DWARF_REG_LOC (&c->dwarf, UNW_X86_64_RDX); + c->dwarf.loc[RCX] = DWARF_REG_LOC (&c->dwarf, UNW_X86_64_RCX); + c->dwarf.loc[RBX] = DWARF_REG_LOC (&c->dwarf, UNW_X86_64_RBX); + c->dwarf.loc[RSI] = DWARF_REG_LOC (&c->dwarf, UNW_X86_64_RSI); + c->dwarf.loc[RDI] = DWARF_REG_LOC (&c->dwarf, UNW_X86_64_RDI); + c->dwarf.loc[RBP] = DWARF_REG_LOC (&c->dwarf, UNW_X86_64_RBP); + c->dwarf.loc[RSP] = DWARF_REG_LOC (&c->dwarf, UNW_X86_64_RSP); + c->dwarf.loc[R8] = DWARF_REG_LOC (&c->dwarf, UNW_X86_64_R8); + c->dwarf.loc[R9] = DWARF_REG_LOC (&c->dwarf, UNW_X86_64_R9); + c->dwarf.loc[R10] = DWARF_REG_LOC (&c->dwarf, UNW_X86_64_R10); + c->dwarf.loc[R11] = DWARF_REG_LOC (&c->dwarf, UNW_X86_64_R11); + c->dwarf.loc[R12] = DWARF_REG_LOC (&c->dwarf, UNW_X86_64_R12); + c->dwarf.loc[R13] = DWARF_REG_LOC (&c->dwarf, UNW_X86_64_R13); + c->dwarf.loc[R14] = DWARF_REG_LOC (&c->dwarf, UNW_X86_64_R14); + c->dwarf.loc[R15] = DWARF_REG_LOC (&c->dwarf, UNW_X86_64_R15); + c->dwarf.loc[RIP] = DWARF_REG_LOC (&c->dwarf, UNW_X86_64_RIP); + + ret = dwarf_get (&c->dwarf, c->dwarf.loc[RIP], &c->dwarf.ip); + if (ret < 0) + return ret; + + ret = dwarf_get (&c->dwarf, DWARF_REG_LOC (&c->dwarf, UNW_X86_64_RSP), + &c->dwarf.cfa); + if (ret < 0) + return ret; + + c->sigcontext_format = X86_SCF_NONE; + c->sigcontext_addr = 0; + + c->dwarf.args_size = 0; + c->dwarf.ret_addr_column = RIP; + c->dwarf.pi_valid = 0; + c->dwarf.hint = 0; + c->dwarf.prev_rs = 0; + + return 0; +} +#endif + +int unw_init_local (unw_cursor_t *cursor, ucontext_t *uc) +{ + struct cursor *c = (struct cursor *) cursor; + + Debug (1, "(cursor=%p)\n", c); + + if (!unw_local_addr_space) { + unw_local_addr_space = (unw_addr_space_t)malloc(sizeof(struct unw_addr_space)); + } + + c->dwarf.as = unw_local_addr_space; + c->dwarf.as_arg = uc; + return common_init (c); +} + +int unw_step (unw_cursor_t *c) +{ + return dwarf_step(&((struct cursor *)c)->dwarf); +} + +#if UNW_DEBUG +int unwi_debug_level = 100; +#endif + + +unw_word_t unw_get_ip(unw_cursor_t *c) +{ + return tdep_get_ip(((struct cursor *)c)); +} diff --git a/src/mzscheme/src/unwind/libunwind.h b/src/mzscheme/src/unwind/libunwind.h new file mode 100644 index 0000000000..5445a4e9e9 --- /dev/null +++ b/src/mzscheme/src/unwind/libunwind.h @@ -0,0 +1,477 @@ +/* libunwind - a platform-independent unwind library + Copyright (C) 2002-2004 Hewlett-Packard Co + Contributed by David Mosberger-Tang + +This file is part of libunwind. + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. */ + +#ifndef LIBUNWIND_H +#define LIBUNWIND_H + +#if defined(linux) +# define LINUX +#endif +#if defined(i386) +# define PLAIN_X86 +#endif + +#ifdef PLAIN_X86 +# define UNW_IP UNW_X86_EIP +#else +# define UNW_IP UNW_X86_64_RIP +#endif + +#if defined(__cplusplus) || defined(c_plusplus) +extern "C" { +#endif + +#include +#define _XOPEN_SOURCE /* needed for Mac OS X */ +#define __USE_GNU +#include +#undef __USE_GNU + + /* XXXXXXXXXXXXXXXXXXXX x86 Target XXXXXXXXXXXXXXXXXXXX */ + +#ifdef PLAIN_X86 + +#define UNW_TARGET x86 +#define UNW_TARGET_X86 1 + +/* This needs to be big enough to accommodate "struct cursor", while + leaving some slack for future expansion. Changing this value will + require recompiling all users of this library. Stack allocation is + relatively cheap and unwind-state copying is relatively rare, so we + want to err on making it rather too big than too small. */ +#define UNW_TDEP_CURSOR_LEN 127 + +typedef unsigned long unw_word_t; +typedef long unw_sword_t; + +typedef long double unw_tdep_fpreg_t; + +typedef enum + { + /* Note: general registers are expected to start with index 0. + This convention facilitates architecture-independent + implementation of the C++ exception handling ABI. See + _Unwind_SetGR() and _Unwind_GetGR() for details. + + The described register usage convention is based on "System V + Application Binary Interface, Intel386 Architecture Processor + Supplement, Fourth Edition" at + + http://www.linuxbase.org/spec/refspecs/elf/abi386-4.pdf + + It would have been nice to use the same register numbering as + DWARF, but that doesn't work because the libunwind requires + that the exception argument registers be consecutive, which the + wouldn't be with the DWARF numbering. */ + UNW_X86_EAX, /* scratch (exception argument 1) */ + UNW_X86_EDX, /* scratch (exception argument 2) */ + UNW_X86_ECX, /* scratch */ + UNW_X86_EBX, /* preserved */ + UNW_X86_ESI, /* preserved */ + UNW_X86_EDI, /* preserved */ + UNW_X86_EBP, /* (optional) frame-register */ + UNW_X86_ESP, /* (optional) frame-register */ + UNW_X86_EIP, /* frame-register */ + UNW_X86_EFLAGS, /* scratch (except for "direction", which is fixed */ + UNW_X86_TRAPNO, /* scratch */ + + /* MMX/stacked-fp registers */ + UNW_X86_ST0, /* fp return value */ + UNW_X86_ST1, /* scratch */ + UNW_X86_ST2, /* scratch */ + UNW_X86_ST3, /* scratch */ + UNW_X86_ST4, /* scratch */ + UNW_X86_ST5, /* scratch */ + UNW_X86_ST6, /* scratch */ + UNW_X86_ST7, /* scratch */ + + UNW_X86_FCW, /* scratch */ + UNW_X86_FSW, /* scratch */ + UNW_X86_FTW, /* scratch */ + UNW_X86_FOP, /* scratch */ + UNW_X86_FCS, /* scratch */ + UNW_X86_FIP, /* scratch */ + UNW_X86_FEA, /* scratch */ + UNW_X86_FDS, /* scratch */ + + /* SSE registers */ + UNW_X86_XMM0_lo, /* scratch */ + UNW_X86_XMM0_hi, /* scratch */ + UNW_X86_XMM1_lo, /* scratch */ + UNW_X86_XMM1_hi, /* scratch */ + UNW_X86_XMM2_lo, /* scratch */ + UNW_X86_XMM2_hi, /* scratch */ + UNW_X86_XMM3_lo, /* scratch */ + UNW_X86_XMM3_hi, /* scratch */ + UNW_X86_XMM4_lo, /* scratch */ + UNW_X86_XMM4_hi, /* scratch */ + UNW_X86_XMM5_lo, /* scratch */ + UNW_X86_XMM5_hi, /* scratch */ + UNW_X86_XMM6_lo, /* scratch */ + UNW_X86_XMM6_hi, /* scratch */ + UNW_X86_XMM7_lo, /* scratch */ + UNW_X86_XMM7_hi, /* scratch */ + + UNW_X86_MXCSR, /* scratch */ + + /* segment registers */ + UNW_X86_GS, /* special */ + UNW_X86_FS, /* special */ + UNW_X86_ES, /* special */ + UNW_X86_DS, /* special */ + UNW_X86_SS, /* special */ + UNW_X86_CS, /* special */ + UNW_X86_TSS, /* special */ + UNW_X86_LDT, /* special */ + + /* frame info (read-only) */ + UNW_X86_CFA, + + UNW_TDEP_LAST_REG = UNW_X86_LDT, + + UNW_TDEP_IP = UNW_X86_EIP, + UNW_TDEP_SP = UNW_X86_CFA, + UNW_TDEP_EH = UNW_X86_EAX + } +x86_regnum_t; + +#endif + + /* XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX */ + + /* XXXXXXXXXXXXXXXXXXXX x86_64 Target XXXXXXXXXXXXXXXXXXXX */ + +#ifndef PLAIN_X86 + +#define UNW_TARGET x86_64 +#define UNW_TARGET_X86_64 1 + +#define _U_TDEP_QP_TRUE 0 /* see libunwind-dynamic.h */ + +/* This needs to be big enough to accommodate "struct cursor", while + leaving some slack for future expansion. Changing this value will + require recompiling all users of this library. Stack allocation is + relatively cheap and unwind-state copying is relatively rare, so we + want to err on making it rather too big than too small. */ +#define UNW_TDEP_CURSOR_LEN 127 + +typedef uint64_t unw_word_t; +typedef int64_t unw_sword_t; + +typedef long double unw_tdep_fpreg_t; + +typedef enum + { + UNW_X86_64_RAX, + UNW_X86_64_RDX, + UNW_X86_64_RCX, + UNW_X86_64_RBX, + UNW_X86_64_RSI, + UNW_X86_64_RDI, + UNW_X86_64_RBP, + UNW_X86_64_RSP, + UNW_X86_64_R8, + UNW_X86_64_R9, + UNW_X86_64_R10, + UNW_X86_64_R11, + UNW_X86_64_R12, + UNW_X86_64_R13, + UNW_X86_64_R14, + UNW_X86_64_R15, + UNW_X86_64_RIP, + + /* XXX Add other regs here */ + + /* frame info (read-only) */ + UNW_X86_64_CFA, + + UNW_TDEP_LAST_REG = UNW_X86_64_RIP, + + UNW_TDEP_IP = UNW_X86_64_RIP, + UNW_TDEP_SP = UNW_X86_64_RSP, + UNW_TDEP_BP = UNW_X86_64_RBP, + UNW_TDEP_EH = UNW_X86_64_RAX + } +x86_64_regnum_t; + +#endif + + /* XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX */ + +#define UNW_TDEP_NUM_EH_REGS 2 /* eax and edx are exception args */ + +typedef struct unw_tdep_save_loc + { + /* Additional target-dependent info on a save location. */ + } +unw_tdep_save_loc_t; + +/* On x86, we can directly use ucontext_t as the unwind context. */ +typedef ucontext_t unw_tdep_context_t; + +/* XXX this is not ideal: an application should not be prevented from + using the "getcontext" name just because it's using libunwind. We + can't just use __getcontext() either, because that isn't exported + by glibc... */ +#define unw_tdep_getcontext(uc) (getcontext (uc), 0) + + +typedef struct unw_dyn_remote_table_info + { + unw_word_t name_ptr; /* addr. of table name (e.g., library name) */ + unw_word_t segbase; /* segment base */ + unw_word_t table_len; /* must be a multiple of sizeof(unw_word_t)! */ + unw_word_t table_data; + } +unw_dyn_remote_table_info_t; + +typedef struct unw_dyn_info + { + /* doubly-linked list of dyn-info structures: */ + struct unw_dyn_info *next; + struct unw_dyn_info *prev; + unw_word_t start_ip; /* first IP covered by this entry */ + unw_word_t end_ip; /* first IP NOT covered by this entry */ + unw_word_t gp; /* global-pointer in effect for this entry */ + int32_t format; /* real type: unw_dyn_info_format_t */ + int32_t pad; + union + { + unw_dyn_remote_table_info_t rti; + } + u; + } +unw_dyn_info_t; + +#define UNW_INFO_FORMAT_TABLE 1 +#define UNW_INFO_FORMAT_REMOTE_TABLE 2 + +typedef struct + { + /* no x86-specific auxiliary proc-info */ + } +unw_tdep_proc_info_t; + +#define UNW_VERSION_MAJOR 0 +#define UNW_VERSION_MINOR 99 +#define UNW_VERSION_EXTRA 0 + +#define UNW_VERSION_CODE(maj,min) (((maj) << 16) | (min)) +#define UNW_VERSION UNW_VERSION_CODE(UNW_VERSION_MAJOR, UNW_VERSION_MINOR) + +#define UNW_PASTE2(x,y) x##y +#define UNW_PASTE(x,y) UNW_PASTE2(x,y) +#define UNW_OBJ(fn) UNW_PASTE(UNW_PREFIX, fn) +#define UNW_ARCH_OBJ(fn) UNW_PASTE(UNW_PASTE(UNW_PASTE(_U,UNW_TARGET),_), fn) + +#define UW_NO_SYNC + +#include + +# define UNW_PREFIX UNW_PASTE(UNW_PASTE(_UL,UNW_TARGET),_) + +/* Error codes. The unwind routines return the *negated* values of + these error codes on error and a non-negative value on success. */ +typedef enum + { + UNW_ESUCCESS = 0, /* no error */ + UNW_EUNSPEC, /* unspecified (general) error */ + UNW_ENOMEM, /* out of memory */ + UNW_EBADREG, /* bad register number */ + UNW_EREADONLYREG, /* attempt to write read-only register */ + UNW_ESTOPUNWIND, /* stop unwinding */ + UNW_EINVALIDIP, /* invalid IP */ + UNW_EBADFRAME, /* bad frame */ + UNW_EINVAL, /* unsupported operation or bad value */ + UNW_EBADVERSION, /* unwind info has unsupported version */ + UNW_ENOINFO /* no unwind info found */ + } +unw_error_t; + +/* The following enum defines the indices for a couple of + (pseudo-)registers which have the same meaning across all + platforms. (RO) means read-only. (RW) means read-write. General + registers (aka "integer registers") are expected to start with + index 0. The number of such registers is architecture-dependent. + The remaining indices can be used as an architecture sees fit. The + last valid register index is given by UNW_REG_LAST. */ +typedef enum + { + UNW_REG_IP = UNW_TDEP_IP, /* (rw) instruction pointer (pc) */ + UNW_REG_SP = UNW_TDEP_SP, /* (ro) stack pointer */ + UNW_REG_EH = UNW_TDEP_EH, /* (rw) exception-handling reg base */ + UNW_REG_LAST = UNW_TDEP_LAST_REG + } +unw_frame_regnum_t; + +/* Number of exception-handler argument registers: */ +#define UNW_NUM_EH_REGS UNW_TDEP_NUM_EH_REGS + +typedef enum + { + UNW_CACHE_NONE, /* no caching */ + UNW_CACHE_GLOBAL, /* shared global cache */ + UNW_CACHE_PER_THREAD /* per-thread caching */ + } +unw_caching_policy_t; + +typedef int unw_regnum_t; + +/* The unwind cursor starts at the youngest (most deeply nested) frame + and is used to track the frame state as the unwinder steps from + frame to frame. It is safe to make (shallow) copies of variables + of this type. */ +typedef struct unw_cursor + { + unw_word_t opaque[UNW_TDEP_CURSOR_LEN]; + } +unw_cursor_t; + +/* This type encapsulates the entire (preserved) machine-state. */ +typedef unw_tdep_context_t unw_context_t; + +/* unw_getcontext() fills the unw_context_t pointed to by UC with the + machine state as it exists at the call-site. For implementation + reasons, this needs to be a target-dependent macro. It's easiest + to think of unw_getcontext() as being identical to getcontext(). */ +#define unw_getcontext(uc) unw_tdep_getcontext(uc) + +/* Return 1 if register number R is a floating-point register, zero + otherwise. + This routine is signal-safe. */ +#define unw_is_fpreg(r) unw_tdep_is_fpreg(r) + +typedef unw_tdep_fpreg_t unw_fpreg_t; + +typedef struct unw_addr_space *unw_addr_space_t; + +/* Each target may define it's own set of flags, but bits 0-15 are + reserved for general libunwind-use. */ +#define UNW_PI_FLAG_FIRST_TDEP_BIT 16 + +typedef struct unw_proc_info + { + unw_word_t start_ip; /* first IP covered by this procedure */ + unw_word_t end_ip; /* first IP NOT covered by this procedure */ + unw_word_t lsda; /* address of lang.-spec. data area (if any) */ + unw_word_t handler; /* optional personality routine */ + unw_word_t gp; /* global-pointer value for this procedure */ + unw_word_t flags; /* misc. flags */ + + int format; /* unwind-info format (arch-specific) */ + int unwind_info_size; /* size of the information (if applicable) */ + void *unwind_info; /* unwind-info (arch-specific) */ + unw_tdep_proc_info_t extra; /* target-dependent auxiliary proc-info */ + } +unw_proc_info_t; + +/* These are backend callback routines that provide access to the + state of a "remote" process. This can be used, for example, to + unwind another process through the ptrace() interface. */ +typedef struct unw_accessors + { + /* REMOVED */ + } +unw_accessors_t; + +typedef enum unw_save_loc_type + { + UNW_SLT_NONE, /* register is not saved ("not an l-value") */ + UNW_SLT_MEMORY, /* register has been saved in memory */ + UNW_SLT_REG /* register has been saved in (another) register */ + } +unw_save_loc_type_t; + +typedef struct unw_save_loc + { + unw_save_loc_type_t type; + union + { + unw_word_t addr; /* valid if type==UNW_SLT_MEMORY */ + unw_regnum_t regnum; /* valid if type==UNW_SLT_REG */ + } + u; + unw_tdep_save_loc_t extra; /* target-dependent additional information */ + } +unw_save_loc_t; + +/* These routines work both for local and remote unwinding. */ + +#define unw_local_addr_space UNW_OBJ(local_addr_space) +#define unw_create_addr_space UNW_OBJ(create_addr_space) +#define unw_destroy_addr_space UNW_OBJ(destroy_addr_space) +#define unw_get_accessors UNW_ARCH_OBJ(get_accessors) +#define unw_init_local UNW_OBJ(init_local) +#define unw_init_remote UNW_OBJ(init_remote) +#define unw_step UNW_OBJ(step) +#define unw_resume UNW_OBJ(resume) +#define unw_get_proc_info UNW_OBJ(get_proc_info) +#define unw_get_proc_info_by_ip UNW_OBJ(get_proc_info_by_ip) +#define unw_get_reg UNW_OBJ(get_reg) +#define unw_set_reg UNW_OBJ(set_reg) +#define unw_get_fpreg UNW_OBJ(get_fpreg) +#define unw_set_fpreg UNW_OBJ(set_fpreg) +#define unw_get_save_loc UNW_OBJ(get_save_loc) +#define unw_is_signal_frame UNW_OBJ(is_signal_frame) +#define unw_get_proc_name UNW_OBJ(get_proc_name) +#define unw_set_caching_policy UNW_OBJ(set_caching_policy) +#define unw_regname UNW_ARCH_OBJ(regname) +#define unw_flush_cache UNW_ARCH_OBJ(flush_cache) +#define unw_strerror UNW_ARCH_OBJ(strerror) + +extern unw_addr_space_t unw_create_addr_space (unw_accessors_t *, int); +extern void unw_destroy_addr_space (unw_addr_space_t); +extern unw_accessors_t *unw_get_accessors (unw_addr_space_t); +extern void unw_flush_cache (unw_addr_space_t, unw_word_t, unw_word_t); +extern int unw_set_caching_policy (unw_addr_space_t, unw_caching_policy_t); +extern const char *unw_regname (unw_regnum_t); + +extern int unw_init_local (unw_cursor_t *, unw_context_t *); +extern int unw_init_remote (unw_cursor_t *, unw_addr_space_t, void *); +extern int unw_step (unw_cursor_t *); +extern int unw_resume (unw_cursor_t *); +extern int unw_get_proc_info (unw_cursor_t *, unw_proc_info_t *); +extern int unw_get_proc_info_by_ip (unw_addr_space_t, unw_word_t, + unw_proc_info_t *, void *); +extern int unw_get_reg (unw_cursor_t *, int, unw_word_t *); +extern int unw_set_reg (unw_cursor_t *, int, unw_word_t); +extern int unw_get_fpreg (unw_cursor_t *, int, unw_fpreg_t *); +extern int unw_set_fpreg (unw_cursor_t *, int, unw_fpreg_t); +extern int unw_get_save_loc (unw_cursor_t *, int, unw_save_loc_t *); +extern int unw_is_signal_frame (unw_cursor_t *); +extern int unw_get_proc_name (unw_cursor_t *, char *, size_t, unw_word_t *); +extern unw_word_t unw_get_ip(unw_cursor_t *); +extern const char *unw_strerror (int); + +extern unw_addr_space_t unw_local_addr_space; + +#define unw_tdep_is_fpreg UNW_ARCH_OBJ(is_fpreg) +extern int unw_tdep_is_fpreg (int); + +#if defined(__cplusplus) || defined(c_plusplus) +} +#endif + +#endif /* LIBUNWIND_H */ diff --git a/src/mzscheme/src/unwind/libunwind_i.h b/src/mzscheme/src/unwind/libunwind_i.h new file mode 100644 index 0000000000..58e4aaa47f --- /dev/null +++ b/src/mzscheme/src/unwind/libunwind_i.h @@ -0,0 +1,1182 @@ +/* libunwind - a platform-independent unwind library + Copyright (C) 2001-2005 Hewlett-Packard Co + Contributed by David Mosberger-Tang + +This file is several parts of libunwind concatenated. + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. */ + +/* This files contains libunwind-internal definitions which are + subject to frequent change and are not to be exposed to + libunwind-users. */ + +#ifndef libunwind_i_h +#define libunwind_i_h + +#ifdef HAVE___THREAD + /* For now, turn off per-thread caching. It uses up too much TLS + memory per thread even when the thread never uses libunwind at + all. */ +# undef HAVE___THREAD +#endif + +/* Platform-independent libunwind-internal declarations. */ + +#include /* HP-UX needs this before include of pthread.h */ + +#include +#include "libunwind.h" +#include +#include +#include +#include + +/* FIXME: hard-wired */ +# define __LITTLE_ENDIAN 1234 +# define __BIG_ENDIAN 4321 +# define __BYTE_ORDER __LITTLE_ENDIAN + + +# define __BYTE_ORDER __LITTLE_ENDIAN + +#ifdef __GNUC__ +# define UNUSED __attribute__((unused)) +# define NORETURN __attribute__((noreturn)) +# define ALIAS(name) __attribute__((alias (#name))) +# if (__GNUC__ > 3) || (__GNUC__ == 3 && __GNUC_MINOR__ > 2) +# define ALWAYS_INLINE inline __attribute__((always_inline)) +# define HIDDEN __attribute__((visibility ("hidden"))) +# define PROTECTED __attribute__((visibility ("protected"))) +# else +# define ALWAYS_INLINE +# define HIDDEN +# define PROTECTED +# endif +# if (__GNUC__ >= 3) +# define likely(x) __builtin_expect ((x), 1) +# define unlikely(x) __builtin_expect ((x), 0) +# else +# define likely(x) (x) +# define unlikely(x) (x) +# endif +#else +# define ALWAYS_INLINE +# define UNUSED +# define NORETURN +# define ALIAS(name) +# define HIDDEN +# define PROTECTED +# define likely(x) (x) +# define unlikely(x) (x) +#endif + +#define ARRAY_SIZE(a) (sizeof (a) / sizeof ((a)[0])) + +/* Make it easy to write thread-safe code which may or may not be + linked against libpthread. The macros below can be used + unconditionally and if -lpthread is around, they'll call the + corresponding routines otherwise, they do nothing. */ + +#pragma weak pthread_mutex_init +#pragma weak pthread_mutex_lock +#pragma weak pthread_mutex_unlock + +#define mutex_init(l) \ + (pthread_mutex_init != 0 ? pthread_mutex_init ((l), 0) : 0) +#define mutex_lock(l) \ + (pthread_mutex_lock != 0 ? pthread_mutex_lock (l) : 0) +#define mutex_unlock(l) \ + (pthread_mutex_unlock != 0 ? pthread_mutex_unlock (l) : 0) + +#ifdef HAVE_ATOMIC_OPS_H +# include +static inline int +cmpxchg_ptr (void *addr, void *old, void *new) +{ + union + { + void *vp; + AO_t *aop; + } + u; + + u.vp = addr; + return AO_compare_and_swap(u.aop, (AO_t) old, (AO_t) new); +} +# define fetch_and_add1(_ptr) AO_fetch_and_add1(_ptr) + /* GCC 3.2.0 on HP-UX crashes on cmpxchg_ptr() */ +# if !(defined(__hpux) && __GNUC__ == 3 && __GNUC_MINOR__ == 2) +# define HAVE_CMPXCHG +# endif +# define HAVE_FETCH_AND_ADD1 +#else +# ifdef HAVE_IA64INTRIN_H +# include +static inline int +cmpxchg_ptr (void *addr, void *old, void *new) +{ + union + { + void *vp; + long *vlp; + } + u; + + u.vp = addr; + return __sync_bool_compare_and_swap(u.vlp, (long) old, (long) new); +} +# define fetch_and_add1(_ptr) __sync_fetch_and_add(_ptr, 1) +# define HAVE_CMPXCHG +# define HAVE_FETCH_AND_ADD1 +# endif +#endif +#define atomic_read(ptr) (*(ptr)) + +#define UNWI_OBJ(fn) UNW_PASTE(UNW_PREFIX,UNW_PASTE(I,fn)) +#define UNWI_ARCH_OBJ(fn) UNW_PASTE(UNW_PASTE(UNW_PASTE(_UI,UNW_TARGET),_), fn) + +#define unwi_full_mask UNWI_ARCH_OBJ(full_mask) + +/* Type of a mask that can be used to inhibit preemption. At the + userlevel, preemption is caused by signals and hence sigset_t is + appropriate. In constrast, the Linux kernel uses "unsigned long" + to hold the processor "flags" instead. */ +typedef sigset_t intrmask_t; + +extern intrmask_t unwi_full_mask; + +#define define_lock(name) \ + pthread_mutex_t name = PTHREAD_MUTEX_INITIALIZER +#define lock_init(l) mutex_init (l) +#define lock_acquire(l,m) \ +do { \ + sigprocmask (SIG_SETMASK, &unwi_full_mask, &(m)); \ + mutex_lock (l); \ +} while (0) +#define lock_release(l,m) \ +do { \ + mutex_unlock (l); \ + sigprocmask (SIG_SETMASK, &(m), NULL); \ +} while (0) + +#define GET_MEMORY(mem, size_in_bytes) \ +do { \ + /* Hopefully, mmap() goes straight through to a system call stub... */ \ + mem = mmap (0, size, PROT_READ | PROT_WRITE, MAP_PRIVATE | MAP_ANONYMOUS, \ + -1, 0); \ + if (mem == MAP_FAILED) \ + mem = NULL; \ +} while (0) + +#define UNW_DEBUG 1 +#if UNW_DEBUG +#define unwi_debug_level UNWI_ARCH_OBJ(debug_level) +extern int unwi_debug_level; + +# include +# define Debug(level,format...) \ +do { \ + if (unwi_debug_level >= level) \ + { \ + int _n = level; \ + if (_n > 16) \ + _n = 16; \ + fprintf (stderr, "%*c>%s: ", _n, ' ', __FUNCTION__); \ + fprintf (stderr, format); \ + } \ +} while (0) +# define dprintf(format...) fprintf (stderr, format) +# ifdef __GNUC__ +# undef inline +# define inline UNUSED +# endif +#else +# define Debug(level,format...) +# define dprintf(format...) +#endif + +static ALWAYS_INLINE void +print_error (const char *string) +{ + write (2, string, strlen (string)); +} + +#define mi_init UNWI_ARCH_OBJ(mi_init) + +extern void mi_init (void); /* machine-independent initializations */ +extern unw_word_t _U_dyn_info_list_addr (void); + +/* This is needed/used by ELF targets only. */ + +struct elf_image + { + void *image; /* pointer to mmap'd image */ + size_t size; /* (file-) size of the image */ + }; + +/* Target-dependent definitions that are internal to libunwind but need + to be shared with target-independent code. */ + +/*XXXXXXXXXXXXXXXXXXXXXXXXX Start unwind_dl.h XXXXXXXXXXXXXXXXXXXXXXXXXX*/ + +#ifdef OS_X + +#define elf_w(x) x +#define Elf_W(x) x + +#include +#include + +#define PT_LOAD LC_SEGMENT +#define PT_GNU_EH_FRAME -1 +#define PT_DYNAMIC -1 + +#define DT_NULL 0 +#define DT_PLTGOT 1 + +#define DW_EH_VERSION 1 + +typedef long Addr; +typedef struct { + long p_type; + Addr p_vaddr; + long p_memsz; + long p_filesz; +} Phdr; + +typedef struct { + long d_tag; + struct { long d_ptr; } d_un; +} Dyn; + +struct dl_phdr_info { + Phdr *dlpi_phdr; + Addr dlpi_addr; + long dlpi_phnum; + char *dlpi_name; +}; + +typedef int (*DL_Iter_Callback)(struct dl_phdr_info *info, size_t size, void *ptr); +int dl_iterate_phdr (DL_Iter_Callback callback, void *p); + +#else + +#define __USE_GNU +#include +#undef __USE_GNU + +#define elf_w(x) elf64_ ## x +#define Elf_W(x) ElfW(x) + +typedef int (*DL_Iter_Callback)(struct dl_phdr_info *info, size_t size, void *ptr); + +#endif + +extern int elf_w(get_proc_name) (pid_t pid, unw_word_t ip, + char *buf, size_t len, + unw_word_t *offp); + +/*XXXXXXXXXXXXXXXXXXXXXXXXX End unwind_dl.h XXXXXXXXXXXXXXXXXXXXXXXXXX*/ + +/*XXXXXXXXXXXXXXXXXXXXXXXXX Start dwarf.h XXXXXXXXXXXXXXXXXXXXXXXXXX*/ + +struct dwarf_cursor; /* forward-declaration */ + +/* This matches the value used by GCC (see + gcc/config/i386.h:DWARF_FRAME_REGISTERS), which leaves plenty of + room for expansion. */ +#define DWARF_NUM_PRESERVED_REGS 17 + +#ifdef PLAIN_X86 +#define DWARF_REGNUM_MAP_LENGTH 19 +#else +#define DWARF_REGNUM_MAP_LENGTH 17 +#endif + +/* Return TRUE if the ADDR_SPACE uses big-endian byte-order. */ +#define dwarf_is_big_endian(addr_space) 0 + +/* Convert a pointer to a dwarf_cursor structure to a pointer to + unw_cursor_t. */ +#define dwarf_to_cursor(c) ((unw_cursor_t *) (c)) + +typedef struct dwarf_loc + { + unw_word_t val; + } +dwarf_loc_t; + +/* DWARF expression opcodes. */ + +typedef enum + { + DW_OP_addr = 0x03, + DW_OP_deref = 0x06, + DW_OP_const1u = 0x08, + DW_OP_const1s = 0x09, + DW_OP_const2u = 0x0a, + DW_OP_const2s = 0x0b, + DW_OP_const4u = 0x0c, + DW_OP_const4s = 0x0d, + DW_OP_const8u = 0x0e, + DW_OP_const8s = 0x0f, + DW_OP_constu = 0x10, + DW_OP_consts = 0x11, + DW_OP_dup = 0x12, + DW_OP_drop = 0x13, + DW_OP_over = 0x14, + DW_OP_pick = 0x15, + DW_OP_swap = 0x16, + DW_OP_rot = 0x17, + DW_OP_xderef = 0x18, + DW_OP_abs = 0x19, + DW_OP_and = 0x1a, + DW_OP_div = 0x1b, + DW_OP_minus = 0x1c, + DW_OP_mod = 0x1d, + DW_OP_mul = 0x1e, + DW_OP_neg = 0x1f, + DW_OP_not = 0x20, + DW_OP_or = 0x21, + DW_OP_plus = 0x22, + DW_OP_plus_uconst = 0x23, + DW_OP_shl = 0x24, + DW_OP_shr = 0x25, + DW_OP_shra = 0x26, + DW_OP_xor = 0x27, + DW_OP_skip = 0x2f, + DW_OP_bra = 0x28, + DW_OP_eq = 0x29, + DW_OP_ge = 0x2a, + DW_OP_gt = 0x2b, + DW_OP_le = 0x2c, + DW_OP_lt = 0x2d, + DW_OP_ne = 0x2e, + DW_OP_lit0 = 0x30, + DW_OP_lit1, DW_OP_lit2, DW_OP_lit3, DW_OP_lit4, DW_OP_lit5, + DW_OP_lit6, DW_OP_lit7, DW_OP_lit8, DW_OP_lit9, DW_OP_lit10, + DW_OP_lit11, DW_OP_lit12, DW_OP_lit13, DW_OP_lit14, DW_OP_lit15, + DW_OP_lit16, DW_OP_lit17, DW_OP_lit18, DW_OP_lit19, DW_OP_lit20, + DW_OP_lit21, DW_OP_lit22, DW_OP_lit23, DW_OP_lit24, DW_OP_lit25, + DW_OP_lit26, DW_OP_lit27, DW_OP_lit28, DW_OP_lit29, DW_OP_lit30, + DW_OP_lit31, + DW_OP_reg0 = 0x50, + DW_OP_reg1, DW_OP_reg2, DW_OP_reg3, DW_OP_reg4, DW_OP_reg5, + DW_OP_reg6, DW_OP_reg7, DW_OP_reg8, DW_OP_reg9, DW_OP_reg10, + DW_OP_reg11, DW_OP_reg12, DW_OP_reg13, DW_OP_reg14, DW_OP_reg15, + DW_OP_reg16, DW_OP_reg17, DW_OP_reg18, DW_OP_reg19, DW_OP_reg20, + DW_OP_reg21, DW_OP_reg22, DW_OP_reg23, DW_OP_reg24, DW_OP_reg25, + DW_OP_reg26, DW_OP_reg27, DW_OP_reg28, DW_OP_reg29, DW_OP_reg30, + DW_OP_reg31, + DW_OP_breg0 = 0x70, + DW_OP_breg1, DW_OP_breg2, DW_OP_breg3, DW_OP_breg4, DW_OP_breg5, + DW_OP_breg6, DW_OP_breg7, DW_OP_breg8, DW_OP_breg9, DW_OP_breg10, + DW_OP_breg11, DW_OP_breg12, DW_OP_breg13, DW_OP_breg14, DW_OP_breg15, + DW_OP_breg16, DW_OP_breg17, DW_OP_breg18, DW_OP_breg19, DW_OP_breg20, + DW_OP_breg21, DW_OP_breg22, DW_OP_breg23, DW_OP_breg24, DW_OP_breg25, + DW_OP_breg26, DW_OP_breg27, DW_OP_breg28, DW_OP_breg29, DW_OP_breg30, + DW_OP_breg31, + DW_OP_regx = 0x90, + DW_OP_fbreg = 0x91, + DW_OP_bregx = 0x92, + DW_OP_piece = 0x93, + DW_OP_deref_size = 0x94, + DW_OP_xderef_size = 0x95, + DW_OP_nop = 0x96, + DW_OP_push_object_address = 0x97, + DW_OP_call2 = 0x98, + DW_OP_call4 = 0x99, + DW_OP_call_ref = 0x9a, + DW_OP_lo_user = 0xe0, + DW_OP_hi_user = 0xff + } +dwarf_expr_op_t; + +#define DWARF_CIE_VERSION 3 /* GCC emits version 1??? */ + +#define DWARF_CFA_OPCODE_MASK 0xc0 +#define DWARF_CFA_OPERAND_MASK 0x3f + +typedef enum + { + DW_CFA_advance_loc = 0x40, + DW_CFA_offset = 0x80, + DW_CFA_restore = 0xc0, + DW_CFA_nop = 0x00, + DW_CFA_set_loc = 0x01, + DW_CFA_advance_loc1 = 0x02, + DW_CFA_advance_loc2 = 0x03, + DW_CFA_advance_loc4 = 0x04, + DW_CFA_offset_extended = 0x05, + DW_CFA_restore_extended = 0x06, + DW_CFA_undefined = 0x07, + DW_CFA_same_value = 0x08, + DW_CFA_register = 0x09, + DW_CFA_remember_state = 0x0a, + DW_CFA_restore_state = 0x0b, + DW_CFA_def_cfa = 0x0c, + DW_CFA_def_cfa_register = 0x0d, + DW_CFA_def_cfa_offset = 0x0e, + DW_CFA_def_cfa_expression = 0x0f, + DW_CFA_expression = 0x10, + DW_CFA_offset_extended_sf = 0x11, + DW_CFA_def_cfa_sf = 0x12, + DW_CFA_def_cfa_offset_sf = 0x13, + DW_CFA_lo_user = 0x1c, + DW_CFA_MIPS_advance_loc8 = 0x1d, + DW_CFA_GNU_window_save = 0x2d, + DW_CFA_GNU_args_size = 0x2e, + DW_CFA_GNU_negative_offset_extended = 0x2f, + DW_CFA_hi_user = 0x3c + } +dwarf_cfa_t; + +/* DWARF Pointer-Encoding (PEs). + + Pointer-Encodings were invented for the GCC exception-handling + support for C++, but they represent a rather generic way of + describing the format in which an address/pointer is stored and + hence we include the definitions here, in the main dwarf.h file. + The Pointer-Encoding format is partially documented in Linux Base + Spec v1.3 (http://www.linuxbase.org/spec/). The rest is reverse + engineered from GCC. + +*/ +#define DW_EH_PE_FORMAT_MASK 0x0f /* format of the encoded value */ +#define DW_EH_PE_APPL_MASK 0x70 /* how the value is to be applied */ +/* Flag bit. If set, the resulting pointer is the address of the word + that contains the final address. */ +#define DW_EH_PE_indirect 0x80 + +/* Pointer-encoding formats: */ +#define DW_EH_PE_omit 0xff +#define DW_EH_PE_ptr 0x00 /* pointer-sized unsigned value */ +#define DW_EH_PE_uleb128 0x01 /* unsigned LE base-128 value */ +#define DW_EH_PE_udata2 0x02 /* unsigned 16-bit value */ +#define DW_EH_PE_udata4 0x03 /* unsigned 32-bit value */ +#define DW_EH_PE_udata8 0x04 /* unsigned 64-bit value */ +#define DW_EH_PE_sleb128 0x09 /* signed LE base-128 value */ +#define DW_EH_PE_sdata2 0x0a /* signed 16-bit value */ +#define DW_EH_PE_sdata4 0x0b /* signed 32-bit value */ +#define DW_EH_PE_sdata8 0x0c /* signed 64-bit value */ + +/* Pointer-encoding application: */ +#define DW_EH_PE_absptr 0x00 /* absolute value */ +#define DW_EH_PE_pcrel 0x10 /* rel. to addr. of encoded value */ +#define DW_EH_PE_textrel 0x20 /* text-relative (GCC-specific???) */ +#define DW_EH_PE_datarel 0x30 /* data-relative */ +/* The following are not documented by LSB v1.3, yet they are used by + GCC, presumably they aren't documented by LSB since they aren't + used on Linux: */ +#define DW_EH_PE_funcrel 0x40 /* start-of-procedure-relative */ +#define DW_EH_PE_aligned 0x50 /* aligned pointer */ + +typedef enum + { + DWARF_WHERE_UNDEF, /* register isn't saved at all */ + DWARF_WHERE_SAME, /* register has same value as in prev. frame */ + DWARF_WHERE_CFAREL, /* register saved at CFA-relative address */ + DWARF_WHERE_REG, /* register saved in another register */ + DWARF_WHERE_EXPR, /* register saved */ + } +dwarf_where_t; + +typedef struct + { + dwarf_where_t where; /* how is the register saved? */ + unw_word_t val; /* where it's saved */ + } +dwarf_save_loc_t; + +/* For uniformity, we'd like to treat the CFA save-location like any + other register save-location, but this doesn't quite work, because + the CFA can be expressed as a (REGISTER,OFFSET) pair. To handle + this, we use two dwarf_save_loc structures to describe the CFA. + The first one (CFA_REG_COLUMN), tells us where the CFA is saved. + In the case of DWARF_WHERE_EXPR, the CFA is defined by a DWARF + location expression whose address is given by member "val". In the + case of DWARF_WHERE_REG, member "val" gives the number of the + base-register and the "val" member of DWARF_CFA_OFF_COLUMN gives + the offset value. */ +#define DWARF_CFA_REG_COLUMN DWARF_NUM_PRESERVED_REGS +#define DWARF_CFA_OFF_COLUMN (DWARF_NUM_PRESERVED_REGS + 1) + +typedef struct dwarf_reg_state + { + struct dwarf_reg_state *next; /* for rs_stack */ + dwarf_save_loc_t reg[DWARF_NUM_PRESERVED_REGS + 2]; + unw_word_t ip; /* ip this rs is for */ + unw_word_t ret_addr_column; /* indicates which column in the rule table represents return address */ + unsigned short lru_chain; /* used for least-recently-used chain */ + unsigned short coll_chain; /* used for hash collisions */ + unsigned short hint; /* hint for next rs to try (or -1) */ + } +dwarf_reg_state_t; + +typedef struct dwarf_cie_info + { + unw_word_t cie_instr_start; /* start addr. of CIE "initial_instructions" */ + unw_word_t cie_instr_end; /* end addr. of CIE "initial_instructions" */ + unw_word_t fde_instr_start; /* start addr. of FDE "instructions" */ + unw_word_t fde_instr_end; /* end addr. of FDE "instructions" */ + unw_word_t code_align; /* code-alignment factor */ + unw_word_t data_align; /* data-alignment factor */ + unw_word_t ret_addr_column; /* column of return-address register */ + unw_word_t handler; /* address of personality-routine */ + uint16_t abi; + uint16_t tag; + uint8_t fde_encoding; + uint8_t lsda_encoding; + unsigned int sized_augmentation : 1; + unsigned int have_abi_marker : 1; + } +dwarf_cie_info_t; + +typedef struct dwarf_state_record + { + unsigned char fde_encoding; + unw_word_t args_size; + + dwarf_reg_state_t rs_initial; /* reg-state after CIE instructions */ + dwarf_reg_state_t rs_current; /* current reg-state */ + } +dwarf_state_record_t; + +typedef struct dwarf_cursor + { + void *as_arg; /* argument to address-space callbacks */ + unw_addr_space_t as; /* reference to per-address-space info */ + + unw_word_t cfa; /* canonical frame address; aka frame-/stack-pointer */ + unw_word_t ip; /* instruction pointer */ + unw_word_t args_size; /* size of arguments */ + unw_word_t ret_addr_column; /* column for return-address */ + unw_word_t eh_args[UNW_TDEP_NUM_EH_REGS]; + unsigned int eh_valid_mask; + + dwarf_loc_t loc[DWARF_NUM_PRESERVED_REGS]; + + unsigned int pi_valid :1; /* is proc_info valid? */ + unw_proc_info_t pi; /* info about current procedure */ + + short hint; /* faster lookup of the rs cache */ + short prev_rs; + } +dwarf_cursor_t; + +#define DWARF_LOG_UNW_CACHE_SIZE 7 +#define DWARF_UNW_CACHE_SIZE (1 << DWARF_LOG_UNW_CACHE_SIZE) + +#define DWARF_LOG_UNW_HASH_SIZE (DWARF_LOG_UNW_CACHE_SIZE + 1) +#define DWARF_UNW_HASH_SIZE (1 << DWARF_LOG_UNW_HASH_SIZE) + +typedef unsigned char unw_hash_index_t; + +struct dwarf_rs_cache + { + unsigned short lru_head; /* index of lead-recently used rs */ + unsigned short lru_tail; /* index of most-recently used rs */ + + /* hash table that maps instruction pointer to rs index: */ + unsigned short hash[DWARF_UNW_HASH_SIZE]; + + uint32_t generation; /* generation number */ + + /* rs cache: */ + dwarf_reg_state_t buckets[DWARF_UNW_CACHE_SIZE]; + }; + +/* Convenience macros: */ +#define dwarf_init UNW_ARCH_OBJ (dwarf_init) +#define dwarf_find_proc_info UNW_OBJ (dwarf_find_proc_info) +#define dwarf_search_unwind_table UNW_OBJ (dwarf_search_unwind_table) +#define dwarf_put_unwind_info UNW_OBJ (dwarf_put_unwind_info) +#define dwarf_put_unwind_info UNW_OBJ (dwarf_put_unwind_info) +#define dwarf_eval_expr UNW_OBJ (dwarf_eval_expr) +#define dwarf_extract_proc_info_from_fde \ + UNW_OBJ (dwarf_extract_proc_info_from_fde) +#define dwarf_find_save_locs UNW_OBJ (dwarf_find_save_locs) +#define dwarf_create_state_record UNW_OBJ (dwarf_create_state_record) +#define dwarf_make_proc_info UNW_OBJ (dwarf_make_proc_info) +#define dwarf_read_encoded_pointer UNW_OBJ (dwarf_read_encoded_pointer) +#define dwarf_step UNW_OBJ (dwarf_step) + +extern int dwarf_init (void); +extern int dwarf_find_proc_info (unw_addr_space_t as, unw_word_t ip, + unw_proc_info_t *pi, + int need_unwind_info, void *arg); +extern int dwarf_search_unwind_table (unw_addr_space_t as, + unw_word_t ip, + unw_dyn_info_t *di, + unw_proc_info_t *pi, + int need_unwind_info, void *arg); +extern void dwarf_put_unwind_info (unw_addr_space_t as, + unw_proc_info_t *pi, void *arg); +extern int dwarf_eval_expr (struct dwarf_cursor *c, unw_word_t *addr, + unw_word_t len, unw_word_t *valp, + int *is_register); +extern int dwarf_extract_proc_info_from_fde (unw_addr_space_t as, + unw_accessors_t *a, + unw_word_t *fde_addr, + unw_proc_info_t *pi, + int need_unwind_info, + void *arg); +extern int dwarf_find_save_locs (struct dwarf_cursor *c); +extern int dwarf_create_state_record (struct dwarf_cursor *c, + dwarf_state_record_t *sr); +extern int dwarf_make_proc_info (struct dwarf_cursor *c); +extern int dwarf_read_encoded_pointer (unw_addr_space_t as, + unw_accessors_t *a, + unw_word_t *addr, + unsigned char encoding, + const unw_proc_info_t *pi, + unw_word_t *valp, void *arg); +extern int dwarf_step (struct dwarf_cursor *c); + +/*XXXXXXXXXXXXXXXXXXXXXXXXX End dwarf.h XXXXXXXXXXXXXXXXXXXXXXXXXX*/ + +struct unw_addr_space + { + struct unw_accessors acc; + unw_caching_policy_t caching_policy; +#ifdef HAVE_ATOMIC_OPS_H + AO_t cache_generation; +#else + uint32_t cache_generation; +#endif + struct dwarf_rs_cache global_cache; + }; + +struct cursor + { + struct dwarf_cursor dwarf; /* must be first */ + + /* Format of sigcontext structure and address at which it is + stored: */ + enum + { + X86_SCF_NONE, /* no signal frame encountered */ + X86_SCF_LINUX_SIGFRAME, /* classic x86 sigcontext */ + X86_SCF_LINUX_RT_SIGFRAME /* POSIX ucontext_t */ + } + sigcontext_format; + unw_word_t sigcontext_addr; + }; + +#define DWARF_GET_LOC(l) ((l).val) + +# define DWARF_NULL_LOC DWARF_LOC (0, 0) +# define DWARF_IS_NULL_LOC(l) (DWARF_GET_LOC (l) == 0) +# define DWARF_LOC(r, t) ((dwarf_loc_t) { .val = (r) }) +# define DWARF_IS_REG_LOC(l) 0 +# define DWARF_REG_LOC(c,r) (DWARF_LOC((unw_word_t) \ + tdep_uc_addr((c)->as_arg, (r)), 0)) +# define DWARF_MEM_LOC(c,m) DWARF_LOC ((m), 0) +# define DWARF_FPREG_LOC(c,r) (DWARF_LOC((unw_word_t) \ + tdep_uc_addr((c)->as_arg, (r)), 0)) + +static inline int +dwarf_getfp (struct dwarf_cursor *c, dwarf_loc_t loc, unw_fpreg_t *val) +{ + if (!DWARF_GET_LOC (loc)) + return -1; + *val = *(unw_fpreg_t *) DWARF_GET_LOC (loc); + return 0; +} + +static inline int +dwarf_putfp (struct dwarf_cursor *c, dwarf_loc_t loc, unw_fpreg_t val) +{ + if (!DWARF_GET_LOC (loc)) + return -1; + *(unw_fpreg_t *) DWARF_GET_LOC (loc) = val; + return 0; +} + +static inline int +dwarf_get (struct dwarf_cursor *c, dwarf_loc_t loc, unw_word_t *val) +{ + if (!DWARF_GET_LOC (loc)) + return -1; + *val = *(unw_word_t *) DWARF_GET_LOC (loc); + return 0; +} + +static inline int +dwarf_put (struct dwarf_cursor *c, dwarf_loc_t loc, unw_word_t val) +{ + if (!DWARF_GET_LOC (loc)) + return -1; + *(unw_word_t *) DWARF_GET_LOC (loc) = val; + return 0; +} + +#define tdep_needs_initialization UNW_OBJ(needs_initialization) +#define tdep_init UNW_OBJ(init) +/* Platforms that support UNW_INFO_FORMAT_TABLE need to define + tdep_search_unwind_table. */ +#define tdep_search_unwind_table dwarf_search_unwind_table +#define tdep_uc_addr UNW_ARCH_OBJ(uc_addr) +#define tdep_get_elf_image UNW_ARCH_OBJ(get_elf_image) +#define tdep_access_reg UNW_OBJ(access_reg) +#define tdep_access_fpreg UNW_OBJ(access_fpreg) + +# define tdep_find_proc_info(c,ip,n) \ + dwarf_find_proc_info((c)->as, (ip), &(c)->pi, (n), \ + (c)->as_arg) +# define tdep_put_unwind_info(as,pi,arg) \ + dwarf_put_unwind_info((as), (pi), (arg)) + +#define tdep_get_as(c) ((c)->dwarf.as) +#define tdep_get_as_arg(c) ((c)->dwarf.as_arg) +#define tdep_get_ip(c) ((c)->dwarf.ip) +#define tdep_big_endian(as) 0 + +extern int tdep_needs_initialization; + +extern void tdep_init (void); +extern int tdep_search_unwind_table (unw_addr_space_t as, unw_word_t ip, + unw_dyn_info_t *di, unw_proc_info_t *pi, + int need_unwind_info, void *arg); +extern void *tdep_uc_addr (ucontext_t *uc, int reg); +extern int tdep_get_elf_image (struct elf_image *ei, pid_t pid, unw_word_t ip, + unsigned long *segbase, unsigned long *mapoff); +extern int tdep_access_reg (struct cursor *c, unw_regnum_t reg, + unw_word_t *valp, int write); +extern int tdep_access_fpreg (struct cursor *c, unw_regnum_t reg, + unw_fpreg_t *valp, int write); + + +/*XXXXXXXXXXXXXXXXXXXXXXXXX Start dwarf_i.h XXXXXXXXXXXXXXXXXXXXXXXXXX*/ + +#define dwarf_to_unw_regnum_map UNW_OBJ (dwarf_to_unw_regnum_map) + +int dwarf_to_unw_regnum(int reg); + +/* In the local-only case, we can let the compiler directly access + memory and don't need to worry about differing byte-order. */ + +typedef union + { + int8_t s8; + int16_t s16; + int32_t s32; + int64_t s64; + uint8_t u8; + uint16_t u16; + uint32_t u32; + uint64_t u64; + unw_word_t w; + void *ptr; + } + dwarf_misaligned_value_t; + +static inline int +dwarf_reads8 (unw_addr_space_t as, unw_accessors_t *a, unw_word_t *addr, + int8_t *val, void *arg) +{ + dwarf_misaligned_value_t *mvp = (void *) *addr; + + *val = mvp->s8; + *addr += sizeof (mvp->s8); + return 0; +} + +static inline int +dwarf_reads16 (unw_addr_space_t as, unw_accessors_t *a, unw_word_t *addr, + int16_t *val, void *arg) +{ + dwarf_misaligned_value_t *mvp = (void *) *addr; + + *val = mvp->s16; + *addr += sizeof (mvp->s16); + return 0; +} + +static inline int +dwarf_reads32 (unw_addr_space_t as, unw_accessors_t *a, unw_word_t *addr, + int32_t *val, void *arg) +{ + dwarf_misaligned_value_t *mvp = (void *) *addr; + + *val = mvp->s32; + *addr += sizeof (mvp->s32); + return 0; +} + +static inline int +dwarf_reads64 (unw_addr_space_t as, unw_accessors_t *a, unw_word_t *addr, + int64_t *val, void *arg) +{ + dwarf_misaligned_value_t *mvp = (void *) *addr; + + *val = mvp->s64; + *addr += sizeof (mvp->s64); + return 0; +} + +static inline int +dwarf_readu8 (unw_addr_space_t as, unw_accessors_t *a, unw_word_t *addr, + uint8_t *val, void *arg) +{ + dwarf_misaligned_value_t *mvp = (void *) *addr; + + *val = mvp->u8; + *addr += sizeof (mvp->u8); + return 0; +} + +static inline int +dwarf_readu16 (unw_addr_space_t as, unw_accessors_t *a, unw_word_t *addr, + uint16_t *val, void *arg) +{ + dwarf_misaligned_value_t *mvp = (void *) *addr; + + *val = mvp->u16; + *addr += sizeof (mvp->u16); + return 0; +} + +static inline int +dwarf_readu32 (unw_addr_space_t as, unw_accessors_t *a, unw_word_t *addr, + uint32_t *val, void *arg) +{ + dwarf_misaligned_value_t *mvp = (void *) *addr; + + *val = mvp->u32; + *addr += sizeof (mvp->u32); + return 0; +} + +static inline int +dwarf_readu64 (unw_addr_space_t as, unw_accessors_t *a, unw_word_t *addr, + uint64_t *val, void *arg) +{ + dwarf_misaligned_value_t *mvp = (void *) *addr; + + *val = mvp->u64; + *addr += sizeof (mvp->u64); + return 0; +} + +static inline int +dwarf_readw (unw_addr_space_t as, unw_accessors_t *a, unw_word_t *addr, + unw_word_t *val, void *arg) +{ + dwarf_misaligned_value_t *mvp = (void *) *addr; + + *val = mvp->w; + *addr += sizeof (mvp->w); + return 0; +} + +/* Read an unsigned "little-endian base 128" value. See Chapter 7.6 + of DWARF spec v3. */ + +static inline int +dwarf_read_uleb128 (unw_addr_space_t as, unw_accessors_t *a, unw_word_t *addr, + unw_word_t *valp, void *arg) +{ + unw_word_t val = 0, shift = 0; + unsigned char byte; + int ret; + + do + { + if ((ret = dwarf_readu8 (as, a, addr, &byte, arg)) < 0) + return ret; + + val |= ((unw_word_t) byte & 0x7f) << shift; + shift += 7; + } + while (byte & 0x80); + + *valp = val; + return 0; +} + +/* Read a signed "little-endian base 128" value. See Chapter 7.6 of + DWARF spec v3. */ + +static inline int +dwarf_read_sleb128 (unw_addr_space_t as, unw_accessors_t *a, unw_word_t *addr, + unw_word_t *valp, void *arg) +{ + unw_word_t val = 0, shift = 0; + unsigned char byte; + int ret; + + do + { + if ((ret = dwarf_readu8 (as, a, addr, &byte, arg)) < 0) + return ret; + + val |= ((unw_word_t) byte & 0x7f) << shift; + shift += 7; + } + while (byte & 0x80); + + if (shift < 8 * sizeof (unw_word_t) && (byte & 0x40) != 0) + /* sign-extend negative value */ + val |= ((unw_word_t) -1) << shift; + + *valp = val; + return 0; +} + +static ALWAYS_INLINE int +dwarf_read_encoded_pointer_inlined (unw_addr_space_t as, unw_accessors_t *a, + unw_word_t *addr, unsigned char encoding, + const unw_proc_info_t *pi, + unw_word_t *valp, void *arg) +{ + unw_word_t val, initial_addr = *addr; + uint16_t uval16; + uint32_t uval32; + uint64_t uval64; + int16_t sval16; + int32_t sval32; + int64_t sval64; + int ret; + + /* DW_EH_PE_omit and DW_EH_PE_aligned don't follow the normal + format/application encoding. Handle them first. */ + if (encoding == DW_EH_PE_omit) + { + *valp = 0; + return 0; + } + else if (encoding == DW_EH_PE_aligned) + { + *addr = (initial_addr + sizeof (unw_word_t) - 1) & -sizeof (unw_word_t); + return dwarf_readw (as, a, addr, valp, arg); + } + + switch (encoding & DW_EH_PE_FORMAT_MASK) + { + case DW_EH_PE_ptr: + if ((ret = dwarf_readw (as, a, addr, &val, arg)) < 0) + return ret; + break; + + case DW_EH_PE_uleb128: + if ((ret = dwarf_read_uleb128 (as, a, addr, &val, arg)) < 0) + return ret; + break; + + case DW_EH_PE_udata2: + if ((ret = dwarf_readu16 (as, a, addr, &uval16, arg)) < 0) + return ret; + val = uval16; + break; + + case DW_EH_PE_udata4: + if ((ret = dwarf_readu32 (as, a, addr, &uval32, arg)) < 0) + return ret; + val = uval32; + break; + + case DW_EH_PE_udata8: + if ((ret = dwarf_readu64 (as, a, addr, &uval64, arg)) < 0) + return ret; + val = uval64; + break; + + case DW_EH_PE_sleb128: + if ((ret = dwarf_read_uleb128 (as, a, addr, &val, arg)) < 0) + return ret; + break; + + case DW_EH_PE_sdata2: + if ((ret = dwarf_reads16 (as, a, addr, &sval16, arg)) < 0) + return ret; + val = sval16; + break; + + case DW_EH_PE_sdata4: + if ((ret = dwarf_reads32 (as, a, addr, &sval32, arg)) < 0) + return ret; + val = sval32; + break; + + case DW_EH_PE_sdata8: + if ((ret = dwarf_reads64 (as, a, addr, &sval64, arg)) < 0) + return ret; + val = sval64; + break; + + default: + Debug (1, "unexpected encoding format 0x%x\n", + encoding & DW_EH_PE_FORMAT_MASK); + return -UNW_EINVAL; + } + + if (val == 0) + { + /* 0 is a special value and always absolute. */ + *valp = 0; + return 0; + } + + switch (encoding & DW_EH_PE_APPL_MASK) + { + case DW_EH_PE_absptr: + break; + + case DW_EH_PE_pcrel: + val += initial_addr; + break; + + case DW_EH_PE_datarel: + /* XXX For now, assume that data-relative addresses are relative + to the global pointer. */ + val += pi->gp; + break; + + case DW_EH_PE_funcrel: + val += pi->start_ip; + break; + + case DW_EH_PE_textrel: + /* XXX For now we don't support text-rel values. If there is a + platform which needs this, we probably would have to add a + "segbase" member to unw_proc_info_t. */ + default: + Debug (1, "unexpected application type 0x%x\n", + encoding & DW_EH_PE_APPL_MASK); + return -UNW_EINVAL; + } + + if (encoding & DW_EH_PE_indirect) + { + unw_word_t indirect_addr = val; + + if ((ret = dwarf_readw (as, a, &indirect_addr, &val, arg)) < 0) + return ret; + } + + *valp = val; + return 0; +} + +/*XXXXXXXXXXXXXXXXXXXXXXXXX End dwarf_i.h XXXXXXXXXXXXXXXXXXXXXXXXXX*/ + +/*XXXXXXXXXXXXXXXXXXXXXXXXX Start dwarf-eh.h XXXXXXXXXXXXXXXXXXXXXXXXXX*/ + +/* This header file defines the format of a DWARF exception-header + section (.eh_frame_hdr, pointed to by program-header + PT_GNU_EH_FRAME). The exception-header is self-describing in the + sense that the format of the addresses contained in it is expressed + as a one-byte type-descriptor called a "pointer-encoding" (PE). + + The exception header encodes the address of the .eh_frame section + and optionally contains a binary search table for the + Frame Descriptor Entries (FDEs) in the .eh_frame. The contents of + .eh_frame has the format described by the DWARF v3 standard + (http://www.eagercon.com/dwarf/dwarf3std.htm), except that code + addresses may be encoded in different ways. Also, .eh_frame has + augmentations that allow encoding a language-specific data-area + (LSDA) pointer and a pointer to a personality-routine. + + Details: + + The Common Information Entry (CIE) associated with an FDE may + contain an augmentation string. Each character in this string has + a specific meaning and either one or two associated operands. The + operands are stored in an augmentation body which appears right + after the "return_address_register" member and before the + "initial_instructions" member. The operands appear in the order + in which the characters appear in the string. For example, if the + augmentation string is "zL", the operand for 'z' would be first in + the augmentation body and the operand for 'L' would be second. + The following characters are supported for the CIE augmentation + string: + + 'z': The operand for this character is a uleb128 value that gives the + length of the CIE augmentation body, not counting the length + of the uleb128 operand itself. If present, this code must + appear as the first character in the augmentation body. + + 'L': Indicates that the FDE's augmentation body contains an LSDA + pointer. The operand for this character is a single byte + that specifies the pointer-encoding (PE) that is used for + the LSDA pointer. + + 'R': Indicates that the code-pointers (FDE members + "initial_location" and "address_range" and the operand for + DW_CFA_set_loc) in the FDE have a non-default encoding. The + operand for this character is a single byte that specifies + the pointer-encoding (PE) that is used for the + code-pointers. Note: the "address_range" member is always + encoded as an absolute value. Apart from that, the specified + FDE pointer-encoding applies. + + 'P': Indicates the presence of a personality routine (handler). + The first operand for this character specifies the + pointer-encoding (PE) that is used for the second operand, + which specifies the address of the personality routine. + + If the augmentation string contains any other characters, the + remainder of the augmentation string should be ignored. + Furthermore, if the size of the augmentation body is unknown + (i.e., 'z' is not the first character of the augmentation string), + then the entire CIE as well all associated FDEs must be ignored. + + A Frame Descriptor Entries (FDE) may contain an augmentation body + which, if present, appears right after the "address_range" member + and before the "instructions" member. The contents of this body + is implicitly defined by the augmentation string of the associated + CIE. The meaning of the characters in the CIE's augmentation + string as far as FDEs are concerned is as follows: + + 'z': The first operand in the FDE's augmentation body specifies + the total length of the augmentation body as a uleb128 (not + counting the length of the uleb128 operand itself). + + 'L': The operand for this character is an LSDA pointer, encoded + in the format specified by the corresponding operand in the + CIE's augmentation body. + +*/ + +#define DW_EH_VERSION 1 /* The version we're implementing */ + +struct dwarf_eh_frame_hdr + { + unsigned char version; + unsigned char eh_frame_ptr_enc; + unsigned char fde_count_enc; + unsigned char table_enc; + /* The rest of the header is variable-length and consists of the + following members: + + encoded_t eh_frame_ptr; + encoded_t fde_count; + struct + { + encoded_t start_ip; // first address covered by this FDE + encoded_t fde_addr; // address of the FDE + } + binary_search_table[fde_count]; */ + }; + +/*XXXXXXXXXXXXXXXXXXXXXXXXX End dwarf-eh.h XXXXXXXXXXXXXXXXXXXXXXXXXX*/ + +#endif /* libunwind_i_h */ From 84f52ab704b2018ef743f47a0e10ce9a58532c85 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 27 Nov 2008 15:01:48 +0000 Subject: [PATCH 08/42] link unwind into mzscheme, though it's not used, yet (another step toward x86_64 backtraces) svn: r12620 --- src/mred/gc2/Makefile.in | 2 +- src/mzscheme/gc2/Makefile.in | 4 ++-- src/mzscheme/src/Makefile.in | 4 ++++ src/mzscheme/src/unwind/libunwind.c | 6 ++++++ src/mzscheme/src/unwind/libunwind_i.h | 27 +++++++++++++++------------ 5 files changed, 28 insertions(+), 15 deletions(-) diff --git a/src/mred/gc2/Makefile.in b/src/mred/gc2/Makefile.in index fa1ef5b076..617557830a 100644 --- a/src/mred/gc2/Makefile.in +++ b/src/mred/gc2/Makefile.in @@ -1348,7 +1348,7 @@ FOREIGN_USED_OBJSLIB = $(FOREIGN_OBJSLIB) FOREIGN_NOT_USED_LIB = FOREIGN_NOT_USED_OBJSLIB = -EXTRA_MZ_OBJS = ../../mzscheme/src/gmp.@LTO@ $(@FOREIGN_IF_USED@_OBJSLIB) +EXTRA_MZ_OBJS = ../../mzscheme/src/gmp.@LTO@ ../../mzscheme/src/unwind.@LTO@ $(@FOREIGN_IF_USED@_OBJSLIB) LIBMREDLIBS_a = LIBMREDLIBS_la = $(LDFLAGS) $(LDLIBS) $(@WXVARIANT@_LIBS) diff --git a/src/mzscheme/gc2/Makefile.in b/src/mzscheme/gc2/Makefile.in index 96d4ad9aac..dc7854ce39 100644 --- a/src/mzscheme/gc2/Makefile.in +++ b/src/mzscheme/gc2/Makefile.in @@ -351,8 +351,8 @@ FOREIGN_USED_OBJSLIB = $(FOREIGN_OBJSLIB) FOREIGN_NOT_USED_LIB = FOREIGN_NOT_USED_OBJSLIB = -EXTRA_OBJS_T = ../src/gmp.@LTO@ $(@FOREIGN_IF_USED@_LIB) -EXTRA_OBJS_L = ../src/gmp.@LTO@ $(@FOREIGN_IF_USED@_OBJSLIB) +EXTRA_OBJS_T = ../src/gmp.@LTO@ ../src/unwind.@LTO@ $(@FOREIGN_IF_USED@_LIB) +EXTRA_OBJS_L = ../src/gmp.@LTO@ ../src/unwind.@LTO@ $(@FOREIGN_IF_USED@_OBJSLIB) ../libmzscheme3m.@LIBSFX@: $(OBJS) $(EXTRA_OBJS_T) jit.@LTO@ gc2.@LTO@ $(AR) $(ARFLAGS) ../libmzscheme3m.@LIBSFX@ $(OBJS) $(EXTRA_OBJS_L) jit.@LTO@ gc2.@LTO@ diff --git a/src/mzscheme/src/Makefile.in b/src/mzscheme/src/Makefile.in index 2bf1127832..536da8af2e 100644 --- a/src/mzscheme/src/Makefile.in +++ b/src/mzscheme/src/Makefile.in @@ -51,6 +51,7 @@ OBJS = salloc.@LTO@ \ syntax.@LTO@ \ thread.@LTO@ \ type.@LTO@ \ + unwind.@LTO@ \ vector.@LTO@ @EXTRA_GMP_OBJ@ SRCS = $(srcdir)/salloc.c \ @@ -92,6 +93,7 @@ SRCS = $(srcdir)/salloc.c \ $(srcdir)/syntax.c \ $(srcdir)/thread.c \ $(srcdir)/type.c \ + $(srcdir)/unwind/libunwind.c \ $(srcdir)/vector.c wrong: @@ -222,6 +224,8 @@ thread.@LTO@: $(srcdir)/thread.c $(CC) $(CFLAGS) -c $(srcdir)/thread.c -o thread.@LTO@ type.@LTO@: $(srcdir)/type.c $(CC) $(CFLAGS) -c $(srcdir)/type.c -o type.@LTO@ +unwind.@LTO@: $(srcdir)/unwind/libunwind.c $(srcdir)/unwind/libunwind.h $(srcdir)/unwind/libunwind_i.h + $(CC) $(CFLAGS) -c $(srcdir)/unwind/libunwind.c -o unwind.@LTO@ vector.@LTO@: $(srcdir)/vector.c $(CC) $(CFLAGS) -c $(srcdir)/vector.c -o vector.@LTO@ diff --git a/src/mzscheme/src/unwind/libunwind.c b/src/mzscheme/src/unwind/libunwind.c index d149a1ff39..2c9add6544 100644 --- a/src/mzscheme/src/unwind/libunwind.c +++ b/src/mzscheme/src/unwind/libunwind.c @@ -23,6 +23,10 @@ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. */ +#include "../../sconfig.h" + +#ifdef USE_DWARF_LIBUNWIND + #include #include "libunwind_i.h" @@ -2467,3 +2471,5 @@ unw_word_t unw_get_ip(unw_cursor_t *c) { return tdep_get_ip(((struct cursor *)c)); } + +#endif diff --git a/src/mzscheme/src/unwind/libunwind_i.h b/src/mzscheme/src/unwind/libunwind_i.h index 58e4aaa47f..d7d98ac651 100644 --- a/src/mzscheme/src/unwind/libunwind_i.h +++ b/src/mzscheme/src/unwind/libunwind_i.h @@ -87,6 +87,9 @@ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. */ # define unlikely(x) (x) #endif +#undef HIDDEN +#define HIDDEN static + #define ARRAY_SIZE(a) (sizeof (a) / sizeof ((a)[0])) /* Make it easy to write thread-safe code which may or may not be @@ -618,37 +621,37 @@ struct dwarf_rs_cache #define dwarf_read_encoded_pointer UNW_OBJ (dwarf_read_encoded_pointer) #define dwarf_step UNW_OBJ (dwarf_step) -extern int dwarf_init (void); -extern int dwarf_find_proc_info (unw_addr_space_t as, unw_word_t ip, +HIDDEN int dwarf_init (void); +HIDDEN int dwarf_find_proc_info (unw_addr_space_t as, unw_word_t ip, unw_proc_info_t *pi, int need_unwind_info, void *arg); -extern int dwarf_search_unwind_table (unw_addr_space_t as, +HIDDEN int dwarf_search_unwind_table (unw_addr_space_t as, unw_word_t ip, unw_dyn_info_t *di, unw_proc_info_t *pi, int need_unwind_info, void *arg); -extern void dwarf_put_unwind_info (unw_addr_space_t as, +HIDDEN void dwarf_put_unwind_info (unw_addr_space_t as, unw_proc_info_t *pi, void *arg); -extern int dwarf_eval_expr (struct dwarf_cursor *c, unw_word_t *addr, +HIDDEN int dwarf_eval_expr (struct dwarf_cursor *c, unw_word_t *addr, unw_word_t len, unw_word_t *valp, int *is_register); -extern int dwarf_extract_proc_info_from_fde (unw_addr_space_t as, +HIDDEN int dwarf_extract_proc_info_from_fde (unw_addr_space_t as, unw_accessors_t *a, unw_word_t *fde_addr, unw_proc_info_t *pi, int need_unwind_info, void *arg); -extern int dwarf_find_save_locs (struct dwarf_cursor *c); -extern int dwarf_create_state_record (struct dwarf_cursor *c, +HIDDEN int dwarf_find_save_locs (struct dwarf_cursor *c); +HIDDEN int dwarf_create_state_record (struct dwarf_cursor *c, dwarf_state_record_t *sr); -extern int dwarf_make_proc_info (struct dwarf_cursor *c); -extern int dwarf_read_encoded_pointer (unw_addr_space_t as, +HIDDEN int dwarf_make_proc_info (struct dwarf_cursor *c); +HIDDEN int dwarf_read_encoded_pointer (unw_addr_space_t as, unw_accessors_t *a, unw_word_t *addr, unsigned char encoding, const unw_proc_info_t *pi, unw_word_t *valp, void *arg); -extern int dwarf_step (struct dwarf_cursor *c); +HIDDEN int dwarf_step (struct dwarf_cursor *c); /*XXXXXXXXXXXXXXXXXXXXXXXXX End dwarf.h XXXXXXXXXXXXXXXXXXXXXXXXXX*/ @@ -768,7 +771,7 @@ extern int tdep_access_fpreg (struct cursor *c, unw_regnum_t reg, #define dwarf_to_unw_regnum_map UNW_OBJ (dwarf_to_unw_regnum_map) -int dwarf_to_unw_regnum(int reg); +HIDDEN int dwarf_to_unw_regnum(int reg); /* In the local-only case, we can let the compiler directly access memory and don't need to worry about differing byte-order. */ From 8412e85b6479b8c367a782da02984a12759d0a3e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 27 Nov 2008 15:24:47 +0000 Subject: [PATCH 09/42] last bit of prep for x86_64 backtrace (might even work) svn: r12622 --- src/mzscheme/src/jit.c | 63 +++++++++++++++++++++++++++++++++++------- 1 file changed, 53 insertions(+), 10 deletions(-) diff --git a/src/mzscheme/src/jit.c b/src/mzscheme/src/jit.c index 7fc4a0f764..5092dfff56 100644 --- a/src/mzscheme/src/jit.c +++ b/src/mzscheme/src/jit.c @@ -41,6 +41,9 @@ #include "schpriv.h" #include "schmach.h" +#ifdef USE_DWARF_LIBUNWIND +# include "unwind/libunwind.h" +#endif #ifdef MZ_USE_JIT @@ -8113,6 +8116,11 @@ Scheme_Object *scheme_native_stack_trace(void) Get_Stack_Proc gs; Scheme_Object *name, *last = NULL, *first = NULL, *tail; int set_next_push = 0, prev_had_name = 0; +#ifdef USE_DWARF_LIBUNWIND + unw_context_t cx; + unw_cursor_t c; +#endif + int use_unw = 0; if (!get_stack_pointer_code) return NULL; @@ -8121,8 +8129,15 @@ Scheme_Object *scheme_native_stack_trace(void) check_stack(); #endif +#ifdef USE_DWARF_LIBUNWIND + unw_getcontext(&cx); + unw_init_local(&c, &cx); + use_unw = 1; +#else gs = (Get_Stack_Proc)get_stack_pointer_code; p = gs(); +#endif + stack_start = scheme_approx_sp(); if (stack_cache_stack_pos) { @@ -8145,9 +8160,21 @@ Scheme_Object *scheme_native_stack_trace(void) #endif } - while (STK_COMP((unsigned long)p, stack_end) - && STK_COMP(stack_start, (unsigned long)p)) { - q = ((void **)p)[RETURN_ADDRESS_OFFSET]; + while (1) { +#ifdef USE_DWARF_LIBUNWIND + if (use_unw) { + p = unw_get_frame_pointer(&c); + q = unw_get_ip(&c); + } +#endif + + if (!use_unw) { + if (!(STK_COMP((unsigned long)p, stack_end) + && STK_COMP(stack_start, (unsigned long)p))) + break; + + q = ((void **)p)[RETURN_ADDRESS_OFFSET]; + } name = find_symbol((unsigned long)q); if (SCHEME_FALSEP(name) || SCHEME_VOIDP(name)) { @@ -8223,10 +8250,28 @@ Scheme_Object *scheme_native_stack_trace(void) prev_had_name = !!name; - q = *(void **)p; - if (STK_COMP((unsigned long)q, (unsigned long)p)) - break; - p = q; +#ifdef USE_DWARF_LIBUNWIND + if (use_unw) { + if (name) { + /* A JIT-generated function, so we unwind ourselves... */ + /* For now, once we cross into JIT world, stay there. */ + use_uwn = 0; + } else { + void *prev_q = q; + unw_step(&c); + q = unw_get_ip(&c); + if (q == prev_q) + break; + } + } +#endif + + if (!use_unw) { + q = *(void **)p; + if (STK_COMP((unsigned long)q, (unsigned long)p)) + break; + p = q; + } } if (last) @@ -8256,9 +8301,7 @@ void scheme_dump_stack_trace(void) stack_end = (unsigned long)scheme_current_thread->stack_start; while (STK_COMP((unsigned long)p, stack_end) - && STK_COMP(stack_start, (unsigned long)p)) { - q = ((void **)p)[RETURN_ADDRESS_OFFSET]; - + && STK_COMP(stack_start, (unsigned long)p)) { name = find_symbol((unsigned long)q); if (SCHEME_FALSEP(name)) { /* Code uses special calling convention */ From ca45e9376305550d2fd2f612948b9bbf6e25db99 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 27 Nov 2008 16:14:31 +0000 Subject: [PATCH 10/42] support for stack traces under Linux x86_64, but the trace currently ends if working backward from JIT codes runs back into C-compiled code svn: r12623 --- src/mzscheme/sconfig.h | 1 + src/mzscheme/src/jit.c | 37 +++++++++++++++++---------- src/mzscheme/src/unwind/libunwind.c | 8 ++++-- src/mzscheme/src/unwind/libunwind.h | 1 + src/mzscheme/src/unwind/libunwind_i.h | 3 ++- 5 files changed, 34 insertions(+), 16 deletions(-) diff --git a/src/mzscheme/sconfig.h b/src/mzscheme/sconfig.h index ababb7ec7a..b49a52b272 100644 --- a/src/mzscheme/sconfig.h +++ b/src/mzscheme/sconfig.h @@ -214,6 +214,7 @@ #if defined(__x86_64__) # define MZ_USE_JIT_X86_64 # define MZ_JIT_USE_MPROTECT +# define MZ_USE_DWARF_LIBUNWIND #endif #if defined(powerpc) # define MZ_USE_JIT_PPC diff --git a/src/mzscheme/src/jit.c b/src/mzscheme/src/jit.c index 5092dfff56..1317fdc418 100644 --- a/src/mzscheme/src/jit.c +++ b/src/mzscheme/src/jit.c @@ -41,7 +41,7 @@ #include "schpriv.h" #include "schmach.h" -#ifdef USE_DWARF_LIBUNWIND +#ifdef MZ_USE_DWARF_LIBUNWIND # include "unwind/libunwind.h" #endif @@ -8113,12 +8113,13 @@ Scheme_Object *scheme_native_stack_trace(void) { void *p, *q; unsigned long stack_end, stack_start, halfway; - Get_Stack_Proc gs; Scheme_Object *name, *last = NULL, *first = NULL, *tail; int set_next_push = 0, prev_had_name = 0; -#ifdef USE_DWARF_LIBUNWIND +#ifdef MZ_USE_DWARF_LIBUNWIND unw_context_t cx; unw_cursor_t c; +#else + Get_Stack_Proc gs; #endif int use_unw = 0; @@ -8129,10 +8130,11 @@ Scheme_Object *scheme_native_stack_trace(void) check_stack(); #endif -#ifdef USE_DWARF_LIBUNWIND +#ifdef MZ_USE_DWARF_LIBUNWIND unw_getcontext(&cx); unw_init_local(&c, &cx); use_unw = 1; + p = NULL; #else gs = (Get_Stack_Proc)get_stack_pointer_code; p = gs(); @@ -8161,22 +8163,31 @@ Scheme_Object *scheme_native_stack_trace(void) } while (1) { -#ifdef USE_DWARF_LIBUNWIND +#ifdef MZ_USE_DWARF_LIBUNWIND if (use_unw) { - p = unw_get_frame_pointer(&c); - q = unw_get_ip(&c); + q = (void *)unw_get_ip(&c); + } else { + q = NULL; } #endif if (!use_unw) { if (!(STK_COMP((unsigned long)p, stack_end) - && STK_COMP(stack_start, (unsigned long)p))) - break; - + && STK_COMP(stack_start, (unsigned long)p))) + break; q = ((void **)p)[RETURN_ADDRESS_OFFSET]; } name = find_symbol((unsigned long)q); +#ifdef MZ_USE_DWARF_LIBUNWIND + if (name && use_unw) { + use_unw = 0; + p = (void *)unw_get_frame_pointer(&c); + if (!(STK_COMP((unsigned long)p, stack_end) + && STK_COMP(stack_start, (unsigned long)p))) + break; + } +#endif if (SCHEME_FALSEP(name) || SCHEME_VOIDP(name)) { /* Code uses special calling convention */ #ifdef MZ_USE_JIT_PPC @@ -8250,16 +8261,16 @@ Scheme_Object *scheme_native_stack_trace(void) prev_had_name = !!name; -#ifdef USE_DWARF_LIBUNWIND +#ifdef MZ_USE_DWARF_LIBUNWIND if (use_unw) { if (name) { /* A JIT-generated function, so we unwind ourselves... */ /* For now, once we cross into JIT world, stay there. */ - use_uwn = 0; + use_unw = 0; } else { void *prev_q = q; unw_step(&c); - q = unw_get_ip(&c); + q = (void *)unw_get_ip(&c); if (q == prev_q) break; } diff --git a/src/mzscheme/src/unwind/libunwind.c b/src/mzscheme/src/unwind/libunwind.c index 2c9add6544..0e44dc1d26 100644 --- a/src/mzscheme/src/unwind/libunwind.c +++ b/src/mzscheme/src/unwind/libunwind.c @@ -25,7 +25,7 @@ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. */ #include "../../sconfig.h" -#ifdef USE_DWARF_LIBUNWIND +#ifdef MZ_USE_DWARF_LIBUNWIND #include #include "libunwind_i.h" @@ -2466,10 +2466,14 @@ int unw_step (unw_cursor_t *c) int unwi_debug_level = 100; #endif - unw_word_t unw_get_ip(unw_cursor_t *c) { return tdep_get_ip(((struct cursor *)c)); } +unw_word_t unw_get_frame_pointer(unw_cursor_t *c) +{ + return ((struct cursor *)c)->dwarf.loc[6].val; +} + #endif diff --git a/src/mzscheme/src/unwind/libunwind.h b/src/mzscheme/src/unwind/libunwind.h index 5445a4e9e9..163814e5c1 100644 --- a/src/mzscheme/src/unwind/libunwind.h +++ b/src/mzscheme/src/unwind/libunwind.h @@ -463,6 +463,7 @@ extern int unw_get_save_loc (unw_cursor_t *, int, unw_save_loc_t *); extern int unw_is_signal_frame (unw_cursor_t *); extern int unw_get_proc_name (unw_cursor_t *, char *, size_t, unw_word_t *); extern unw_word_t unw_get_ip(unw_cursor_t *); +extern unw_word_t unw_get_frame_pointer(unw_cursor_t *); extern const char *unw_strerror (int); extern unw_addr_space_t unw_local_addr_space; diff --git a/src/mzscheme/src/unwind/libunwind_i.h b/src/mzscheme/src/unwind/libunwind_i.h index d7d98ac651..e0357716e3 100644 --- a/src/mzscheme/src/unwind/libunwind_i.h +++ b/src/mzscheme/src/unwind/libunwind_i.h @@ -188,7 +188,7 @@ do { \ mem = NULL; \ } while (0) -#define UNW_DEBUG 1 +#define UNW_DEBUG 0 #if UNW_DEBUG #define unwi_debug_level UNWI_ARCH_OBJ(debug_level) extern int unwi_debug_level; @@ -750,6 +750,7 @@ dwarf_put (struct dwarf_cursor *c, dwarf_loc_t loc, unw_word_t val) #define tdep_get_as(c) ((c)->dwarf.as) #define tdep_get_as_arg(c) ((c)->dwarf.as_arg) #define tdep_get_ip(c) ((c)->dwarf.ip) +#define tdep_get_cfa(c) ((c)->dwarf.cfa) #define tdep_big_endian(as) 0 extern int tdep_needs_initialization; From e0e672e9cab4d879608a24913426fd6824b9b6b1 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 27 Nov 2008 19:32:55 +0000 Subject: [PATCH 11/42] finish x86_64+JIT backtrace support svn: r12624 --- src/mzscheme/src/jit.c | 95 ++++++++++++++++++++--------- src/mzscheme/src/unwind/libunwind.c | 27 +++++++- src/mzscheme/src/unwind/libunwind.h | 8 +++ 3 files changed, 99 insertions(+), 31 deletions(-) diff --git a/src/mzscheme/src/jit.c b/src/mzscheme/src/jit.c index 1317fdc418..959ec4e5ae 100644 --- a/src/mzscheme/src/jit.c +++ b/src/mzscheme/src/jit.c @@ -2327,6 +2327,15 @@ static void register_sub_func(mz_jit_state *jitter, void *code, Scheme_Object *p add_symbol((unsigned long)code, (unsigned long)code_end - 1, protocol, 0); } +static void register_helper_func(mz_jit_state *jitter, void *code) +{ +#ifdef MZ_USE_DWARF_LIBUNWIND + /* Null indicates that there's no function name to report, but the + stack should be unwound manually using the JJIT-generated convention. */ + register_sub_func(jitter, code, scheme_null); +#endif +} + int do_generate_shared_call(mz_jit_state *jitter, void *_data) { Generate_Call_Data *data = (Generate_Call_Data *)_data; @@ -2336,10 +2345,19 @@ int do_generate_shared_call(mz_jit_state *jitter, void *_data) #endif if (data->is_tail) { + int ok; + void *code; + + code = jit_get_ip().ptr; + if (data->direct_prim) - return generate_direct_prim_tail_call(jitter, data->num_rands); + ok = generate_direct_prim_tail_call(jitter, data->num_rands); else - return generate_tail_call(jitter, data->num_rands, data->direct_native, 1); + ok = generate_tail_call(jitter, data->num_rands, data->direct_native, 1); + + register_helper_func(jitter, code); + + return ok; } else { int ok; void *code; @@ -6721,6 +6739,7 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) mz_pop_locals(); jit_ret(); CHECK_LIMIT(); + register_helper_func(jitter, on_demand_jit_code); /* *** app_values_tail_slow_code *** */ /* RELIES ON jit_prolog(3) FROM ABOVE */ @@ -6742,9 +6761,11 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) finish_tail_call_code = jit_get_ip().ptr; generate_finish_tail_call(jitter, 0); CHECK_LIMIT(); + register_helper_func(jitter, finish_tail_call_code); finish_tail_call_fixup_code = jit_get_ip().ptr; generate_finish_tail_call(jitter, 2); CHECK_LIMIT(); + register_helper_func(jitter, finish_tail_call_fixup_code); /* *** get_stack_pointer_code *** */ get_stack_pointer_code = jit_get_ip().ptr; @@ -7614,6 +7635,10 @@ static void on_demand_generate_lambda(Scheme_Native_Closure *nc) if (data->name) { add_symbol((unsigned long)code, (unsigned long)gdata.code_end - 1, data->name, 1); + } else { +#ifdef MZ_USE_DWARF_LIBUNWIND + add_symbol((unsigned long)code, (unsigned long)gdata.code_end - 1, scheme_null, 1); +#endif } has_rest = ((SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST) ? 1 : 0); @@ -8118,6 +8143,8 @@ Scheme_Object *scheme_native_stack_trace(void) #ifdef MZ_USE_DWARF_LIBUNWIND unw_context_t cx; unw_cursor_t c; + int manual_unw; + unw_word_t stack_addr; #else Get_Stack_Proc gs; #endif @@ -8176,18 +8203,15 @@ Scheme_Object *scheme_native_stack_trace(void) && STK_COMP(stack_start, (unsigned long)p))) break; q = ((void **)p)[RETURN_ADDRESS_OFFSET]; + /* p is the frame pointer for the function called by q, + not for q. */ } name = find_symbol((unsigned long)q); #ifdef MZ_USE_DWARF_LIBUNWIND - if (name && use_unw) { - use_unw = 0; - p = (void *)unw_get_frame_pointer(&c); - if (!(STK_COMP((unsigned long)p, stack_end) - && STK_COMP(stack_start, (unsigned long)p))) - break; - } + if (name) manual_unw = 1; #endif + if (SCHEME_FALSEP(name) || SCHEME_VOIDP(name)) { /* Code uses special calling convention */ #ifdef MZ_USE_JIT_PPC @@ -8195,30 +8219,34 @@ Scheme_Object *scheme_native_stack_trace(void) q = ((void **)p)[JIT_LOCAL2 >> JIT_LOG_WORD_SIZE]; #endif #ifdef MZ_USE_JIT_I386 - if (SCHEME_VOIDP(name)) { - /* JIT_LOCAL2 has the next return address */ - q = *(void **)p; - if (STK_COMP((unsigned long)q, stack_end) - && STK_COMP(stack_start, (unsigned long)q)) { - q = ((void **)q)[JIT_LOCAL2 >> JIT_LOG_WORD_SIZE]; - } else - q = NULL; + +# ifdef MZ_USE_DWARF_LIBUNWIND + if (use_unw) { + q = (void *)unw_get_frame_pointer(&c); + } else +# endif + q = *(void **)p; + + /* q is now the frame pointer for the former q, + so we can find the actual q */ + if (STK_COMP((unsigned long)q, stack_end) + && STK_COMP(stack_start, (unsigned long)q)) { + if (SCHEME_VOIDP(name)) { + /* JIT_LOCAL2 has the next return address */ + q = ((void **)q)[JIT_LOCAL2 >> JIT_LOG_WORD_SIZE]; + } else { + /* Push after local stack of return-address proc + has the next return address */ + q = ((void **)q)[-(3 + LOCAL_FRAME_SIZE + 1)]; + } } else { - /* Push after local stack of return-address proc - has the next return address */ - q = *(void **)p; - if (STK_COMP((unsigned long)q, stack_end) - && STK_COMP(stack_start, (unsigned long)q)) { - q = ((void **)q)[-(3 + LOCAL_FRAME_SIZE + 1)]; - } else { - q = NULL; - } + q = NULL; } #endif name = find_symbol((unsigned long)q); } - if (name) { + if (name && !SCHEME_NULLP(name)) { /* null is used to help unwind without a true name */ name = scheme_make_pair(name, scheme_null); if (last) SCHEME_CDR(last) = name; @@ -8263,10 +8291,17 @@ Scheme_Object *scheme_native_stack_trace(void) #ifdef MZ_USE_DWARF_LIBUNWIND if (use_unw) { - if (name) { + if (manual_unw) { /* A JIT-generated function, so we unwind ourselves... */ - /* For now, once we cross into JIT world, stay there. */ - use_unw = 0; + void **pp; + pp = (void **)unw_get_frame_pointer(&c); + if (!(STK_COMP((unsigned long)pp, stack_end) + && STK_COMP(stack_start, (unsigned long)pp))) + break; + stack_addr = (unw_word_t)&(pp[RETURN_ADDRESS_OFFSET+1]); + unw_manual_step(&c, &pp[RETURN_ADDRESS_OFFSET], &pp[0], + &stack_addr, &pp[-1], &pp[-2], &pp[-3]); + manual_unw = 0; } else { void *prev_q = q; unw_step(&c); diff --git a/src/mzscheme/src/unwind/libunwind.c b/src/mzscheme/src/unwind/libunwind.c index 0e44dc1d26..15dcf15a6e 100644 --- a/src/mzscheme/src/unwind/libunwind.c +++ b/src/mzscheme/src/unwind/libunwind.c @@ -2473,7 +2473,32 @@ unw_word_t unw_get_ip(unw_cursor_t *c) unw_word_t unw_get_frame_pointer(unw_cursor_t *c) { - return ((struct cursor *)c)->dwarf.loc[6].val; + return *(unw_word_t *)((struct cursor *)c)->dwarf.loc[6 /* = BP */].val; +} + +void unw_manual_step(unw_cursor_t *_c, + void *ip_addr, + void *bp_addr, + void *sp_addr, + void *bx_addr, + void *r12_addr, + void *r13_addr) +{ + struct cursor *c = (struct cursor *)_c; + + c->dwarf.loc[3].val = (unw_word_t)bx_addr; + c->dwarf.loc[6].val = (unw_word_t)bp_addr; + c->dwarf.loc[7].val = (unw_word_t)sp_addr; + c->dwarf.loc[12].val = (unw_word_t)r12_addr; + c->dwarf.loc[13].val = (unw_word_t)r13_addr; + c->dwarf.loc[16].val = (unw_word_t)ip_addr; + + c->dwarf.ip = *(unw_word_t *)ip_addr; + c->dwarf.cfa = *(unw_word_t *)sp_addr; + c->dwarf.ret_addr_column = RIP; + c->dwarf.pi_valid = 0; + c->dwarf.hint = 0; + c->dwarf.prev_rs = 0; } #endif diff --git a/src/mzscheme/src/unwind/libunwind.h b/src/mzscheme/src/unwind/libunwind.h index 163814e5c1..fbb8f52f2d 100644 --- a/src/mzscheme/src/unwind/libunwind.h +++ b/src/mzscheme/src/unwind/libunwind.h @@ -466,6 +466,14 @@ extern unw_word_t unw_get_ip(unw_cursor_t *); extern unw_word_t unw_get_frame_pointer(unw_cursor_t *); extern const char *unw_strerror (int); +void unw_manual_step(unw_cursor_t *_c, + void *ip_addr, + void *bp_addr, + void *sp_addr, + void *bx_addr, + void *r12_addr, + void *r13_addr); + extern unw_addr_space_t unw_local_addr_space; #define unw_tdep_is_fpreg UNW_ARCH_OBJ(is_fpreg) From 3ccd8059a5b985bdb223e6592918115609d7b88e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 27 Nov 2008 19:39:37 +0000 Subject: [PATCH 12/42] fix wxme exception handler svn: r12625 --- collects/wxme/wxme.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/wxme/wxme.ss b/collects/wxme/wxme.ss index 23fe02dde7..c89832d1c6 100644 --- a/collects/wxme/wxme.ss +++ b/collects/wxme/wxme.ss @@ -594,7 +594,7 @@ (call-with-parameterization plain-params (lambda () - (with-handlers ([exn:fail:read? (lambda () 'no-good)]) + (with-handlers ([exn:fail:read? (lambda (x) 'no-good)]) (read port))))) ;; ---------------------------------------- From daaab83572ee9317ec17248d9c8e4c954ddd3f7e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 27 Nov 2008 19:47:11 +0000 Subject: [PATCH 13/42] libunwind license svn: r12626 --- collects/scribblings/main/license.scrbl | 5 +++++ doc/release-notes/mzscheme/HISTORY.txt | 1 + 2 files changed, 6 insertions(+) diff --git a/collects/scribblings/main/license.scrbl b/collects/scribblings/main/license.scrbl index 7464ad64ae..8f20d584f0 100644 --- a/collects/scribblings/main/license.scrbl +++ b/collects/scribblings/main/license.scrbl @@ -128,6 +128,11 @@ PLT software includes or extends the following copyrighted material: Free Software Foundation, Inc. } +@copyright{ + libunwind + Copyright (c) 2003-2005 Hewlett-Packard Development Company, L.P. +} + @copyright{ GNU Classpath GNU Public License with special exception diff --git a/doc/release-notes/mzscheme/HISTORY.txt b/doc/release-notes/mzscheme/HISTORY.txt index bf4872339c..68435a0adb 100644 --- a/doc/release-notes/mzscheme/HISTORY.txt +++ b/doc/release-notes/mzscheme/HISTORY.txt @@ -1,5 +1,6 @@ Version 4.1.3.3 Added compile-context-preservation-enabled +Added exception-backtrace support for x86_84+JIT Added scheme/package, scheme/splicing Version 4.1.3.2 From 6d6d85a8fb0775750a64a9b19fa6230b4cc9d6db Mon Sep 17 00:00:00 2001 From: Greg Cooper Date: Fri, 28 Nov 2008 02:33:40 +0000 Subject: [PATCH 14/42] - cleaned up public version of deep-value-now - removed ft-qq (obsolete implementation of quasiquote) - removed a bunch of commented-out code svn: r12627 --- collects/frtime/frtime-lang-only.ss | 4 +- collects/frtime/frtime-opt-lang.ss | 2 +- collects/frtime/frtime.ss | 8 +- collects/frtime/ft-qq.ss | 178 ---------------------------- collects/frtime/lang-ext.ss | 52 +++++++- collects/frtime/lang.ss | 4 +- collects/frtime/mzscheme-core.ss | 149 +++-------------------- collects/frtime/mzscheme-utils.ss | 85 ++----------- collects/frtime/reactive.ss | 4 +- 9 files changed, 81 insertions(+), 405 deletions(-) delete mode 100644 collects/frtime/ft-qq.ss diff --git a/collects/frtime/frtime-lang-only.ss b/collects/frtime/frtime-lang-only.ss index f2e4515898..fea1cf5415 100644 --- a/collects/frtime/frtime-lang-only.ss +++ b/collects/frtime/frtime-lang-only.ss @@ -1,6 +1,5 @@ (module frtime-lang-only "mzscheme-utils.ss" (require frtime/lang-ext) - (require frtime/ft-qq) (require (as-is:unchecked frtime/frp-core event-set? signal-value)) @@ -18,5 +17,4 @@ (provide value-nowable? behaviorof (all-from "mzscheme-utils.ss") - (all-from-except frtime/lang-ext lift) - (all-from frtime/ft-qq))) + (all-from-except frtime/lang-ext lift))) diff --git a/collects/frtime/frtime-opt-lang.ss b/collects/frtime/frtime-opt-lang.ss index e5534f5330..2a543d6f1a 100644 --- a/collects/frtime/frtime-opt-lang.ss +++ b/collects/frtime/frtime-opt-lang.ss @@ -166,7 +166,7 @@ raise raise-exceptions raise-type-error error exit let/ec ;; no equiv because I haven't completely thought through these - lambda quote quasiquote unquote unquote-splicing make-parameter parameterize + lambda quote unquote unquote-splicing make-parameter parameterize procedure-arity-includes? dynamic-require) (provide #%app #%top #%datum require require-for-syntax provide define) diff --git a/collects/frtime/frtime.ss b/collects/frtime/frtime.ss index c76a6bc360..4db2c946bb 100644 --- a/collects/frtime/frtime.ss +++ b/collects/frtime/frtime.ss @@ -1,7 +1,6 @@ (module frtime "mzscheme-utils.ss" - (require "lang-ext.ss") + (require (all-except "lang-ext.ss" lift deep-value-now)) (require "frp-snip.ss") - (require "ft-qq.ss") (require (as-is:unchecked "frp-core.ss" event-set? signal-value)) @@ -18,7 +17,6 @@ ;(provide-for-syntax (rename frtime/mzscheme-utils syntax->list syntax->list)) (provide value-nowable? behaviorof + (all-from "lang-ext.ss") (all-from "mzscheme-utils.ss") - (all-from-except "lang-ext.ss" lift) - (all-from "frp-snip.ss") - (all-from "ft-qq.ss"))) + (all-from "frp-snip.ss"))) diff --git a/collects/frtime/ft-qq.ss b/collects/frtime/ft-qq.ss deleted file mode 100644 index aabe428d15..0000000000 --- a/collects/frtime/ft-qq.ss +++ /dev/null @@ -1,178 +0,0 @@ -(module ft-qq "mzscheme-core.ss" - (require (as-is:unchecked mzscheme define-values define-syntaxes require-for-syntax - raise-type-error quote unquote unquote-splicing)) - ;(require-for-syntax frtime/frp) - (require-for-syntax syntax/stx) - - - (define-values (frp:qq-append) - (lambda (a b) - (if (list? a) - (append a b) - (raise-type-error 'unquote-splicing "proper list" a)))) - - (define-syntaxes (frp:quasiquote) - (let ([here (quote-syntax here)] ; id with module bindings, but not lexical - [unquote-stx (quote-syntax unquote)] - [unquote-splicing-stx (quote-syntax unquote-splicing)]) - (lambda (in-form) - (if (identifier? in-form) - (raise-syntax-error #f "bad syntax" in-form)) - (let-values - (((form) (if (stx-pair? (stx-cdr in-form)) - (if (stx-null? (stx-cdr (stx-cdr in-form))) - (stx-car (stx-cdr in-form)) - (raise-syntax-error #f "bad syntax" in-form)) - (raise-syntax-error #f "bad syntax" in-form))) - ((normal) - (lambda (x old) - (if (eq? x old) - (if (stx-null? x) - (quote-syntax ()) - (list (quote-syntax quote) x)) - x))) - ((apply-cons) - (lambda (a d) - (if (stx-null? d) - (list (quote-syntax list) a) - (if (if (pair? d) - (module-identifier=? (quote-syntax list) (car d)) - #f) - (list* (quote-syntax list) a (cdr d)) - (list (quote-syntax cons) a d)))))) - (datum->syntax-object - here - (normal - (letrec-values - (((qq) - (lambda (x level) - (let-values - (((qq-list) - (lambda (x level) - (let-values - (((old-first) (stx-car x))) - (let-values - (((old-second) (stx-cdr x))) - (let-values - (((first) (qq old-first level))) - (let-values - (((second) (qq old-second level))) - (let-values - () - (if (if (eq? first old-first) - (eq? second old-second) - #f) - x - (apply-cons - (normal first old-first) - (normal second old-second))))))))))) - (if (stx-pair? x) - (let-values - (((first) (stx-car x))) - (if (if (if (identifier? first) - (module-identifier=? first unquote-stx) - #f) - (stx-list? x) - #f) - (let-values - (((rest) (stx-cdr x))) - (if (let-values - (((g35) (not (stx-pair? rest)))) - (if g35 g35 (not (stx-null? (stx-cdr rest))))) - (raise-syntax-error - 'unquote - "expects exactly one expression" - in-form - x)) - (if (zero? level) - (stx-car rest) - (qq-list x (sub1 level)))) - (if (if (if (identifier? first) - (module-identifier=? first (quote-syntax frp:quasiquote)) - #f) - (stx-list? x) - #f) - (qq-list x (add1 level)) - (if (if (if (identifier? first) - (module-identifier=? first unquote-splicing-stx) - #f) - (stx-list? x) - #f) - (raise-syntax-error - 'unquote-splicing - "invalid context within quasiquote" - in-form - x) - (if (if (stx-pair? first) - (if (identifier? (stx-car first)) - (if (module-identifier=? (stx-car first) - unquote-splicing-stx) - (stx-list? first) - #F) - #f) - #f) - (let-values - (((rest) (stx-cdr first))) - (if (let-values - (((g34) (not (stx-pair? rest)))) - (if g34 - g34 - (not (stx-null? (stx-cdr rest))))) - (raise-syntax-error - 'unquote - "expects exactly one expression" - in-form - x)) - (let-values - (((uqsd) (stx-car rest)) - ((old-l) (stx-cdr x)) - ((l) (qq (stx-cdr x) level))) - (if (zero? level) - (let-values - (((l) (normal l old-l))) - (let-values - () - (list (quote-syntax frp:qq-append) uqsd l))) - (let-values - (((restx) (qq-list rest (sub1 level)))) - (let-values - () - (if (if (eq? l old-l) - (eq? restx rest) - #f) - x - (apply-cons - (apply-cons - (quote-syntax (quote unquote-splicing)) - (normal restx rest)) - (normal l old-l)))))))) - (qq-list x level)))))) - (if (if (syntax? x) - (vector? (syntax-e x)) - #f) - (let-values - (((l) (vector->list (syntax-e x)))) - (let-values - (((l2) (qq l level))) - (let-values - () - (if (eq? l l2) - x - (list (quote-syntax list->vector) l2))))) - (if (if (syntax? x) (box? (syntax-e x)) #f) - (let-values - (((v) (unbox (syntax-e x)))) - (let-values - (((qv) (qq v level))) - (let-values - () - (if (eq? v qv) - x - (list (quote-syntax box) qv))))) - x))))))) - (qq form 0)) - form) - in-form))))) - - (provide ;(rename frp:qq-append qq-append) - (rename frp:quasiquote quasiquote))) diff --git a/collects/frtime/lang-ext.ss b/collects/frtime/lang-ext.ss index 45f4554aa6..6708e8a664 100644 --- a/collects/frtime/lang-ext.ss +++ b/collects/frtime/lang-ext.ss @@ -15,9 +15,52 @@ (define name (let ([val (parameterize ([snap? #f]) expr)]) - (lambda () (deep-value-now val))))])) + (lambda () (deep-value-now val empty))))])) - (define deep-value-now + (define (deep-value-now obj table) + (cond + [(assq obj table) => second] + [(behavior? obj) + (deep-value-now (signal-value obj) (cons (list obj (signal-value obj)) table))] + [(cons? obj) + (let* ([result (cons #f #f)] + [new-table (cons (list obj result) table)] + [car-val (deep-value-now (car obj) new-table)] + [cdr-val (deep-value-now (cdr obj) new-table)]) + (if (and (eq? car-val (car obj)) + (eq? cdr-val (cdr obj))) + obj + (cons car-val cdr-val)))] + ; won't work in the presence of super structs or immutable fields + [(struct? obj) + (let*-values ([(info skipped) (struct-info obj)] + [(name init-k auto-k acc mut! immut sup skipped?) (struct-type-info info)] + [(ctor) (struct-type-make-constructor info)] + [(indices) (build-list init-k identity)] + [(result) (apply ctor (build-list init-k (lambda (i) #f)))] + [(new-table) (cons (list obj result) table)] + [(elts) (build-list init-k (lambda (i) + (deep-value-now (acc obj i) new-table)))]) + (if (andmap (lambda (i e) (eq? (acc obj i) e)) indices elts) + obj + (begin + (for-each (lambda (i e) (mut! result i e)) indices elts) + result)))] + [(vector? obj) + (let* ([len (vector-length obj)] + [indices (build-list len identity)] + [result (build-vector len (lambda (_) #f))] + [new-table (cons (list obj result) table)] + [elts (build-list len (lambda (i) + (deep-value-now (vector-ref obj i) new-table)))]) + (if (andmap (lambda (i e) (eq? (vector-ref obj i) e)) indices elts) + obj + (begin + (for-each (lambda (i e) (vector-set! result i e)) indices elts) + result)))] + [else obj])) + + #;(define deep-value-now (case-lambda [(obj) (deep-value-now obj empty)] [(obj table) @@ -166,7 +209,7 @@ (make-events-now (if first-time empty - (list (deep-value-now bh)))) + (list (deep-value-now bh empty)))) (set! first-time #f)))) b)) @@ -389,7 +432,7 @@ [consumer (proc->signal (lambda () (let* ([now (current-inexact-milliseconds)] - [new (deep-value-now beh)] + [new (deep-value-now beh empty)] [ms (value-now ms-b)]) (when (not (equal? new (car (mcar last)))) (set-mcdr! last (mcons (cons new now) @@ -786,6 +829,7 @@ (provide raise-exceptions + deep-value-now nothing nothing? ;general-event-processor diff --git a/collects/frtime/lang.ss b/collects/frtime/lang.ss index c26a239a38..583049834e 100644 --- a/collects/frtime/lang.ss +++ b/collects/frtime/lang.ss @@ -1,6 +1,5 @@ (module lang frtime/mzscheme-utils (require frtime/lang-ext) - (require frtime/ft-qq) (require (as-is:unchecked frtime/frp-core event-set? signal-value)) @@ -18,5 +17,4 @@ (provide value-nowable? behaviorof (all-from frtime/mzscheme-utils) - (all-from-except frtime/lang-ext lift) - (all-from frtime/ft-qq))) + (all-from-except frtime/lang-ext lift))) diff --git a/collects/frtime/mzscheme-core.ss b/collects/frtime/mzscheme-core.ss index 0f88d07c23..b535b7a33e 100644 --- a/collects/frtime/mzscheme-core.ss +++ b/collects/frtime/mzscheme-core.ss @@ -1,11 +1,9 @@ (module mzscheme-core mzscheme - ;(require (all-except mzscheme provide module if require letrec null?) - ;mzlib/list) (require-for-syntax frtime/struct mzlib/list) (require mzlib/list frtime/frp-core (only srfi/43/vector-lib vector-any) - (only frtime/lang-ext lift new-cell switch ==> changes) + (only frtime/lang-ext lift new-cell switch ==> changes deep-value-now) (only mzlib/etc build-vector rec build-list opt-lambda identity)) ;;;;;;;;;;;;;;;;;;;;;;;; @@ -23,10 +21,6 @@ ... expr ...)])) - ;(define-syntax frp:match - ; (syntax-rules () - ; [(_ expr clause ...) (lift #t (match-lambda clause ...) expr)])) - (define (->boolean x) (if x #t #f)) @@ -42,7 +36,6 @@ [(_ test-exp then-exp else-exp undef-exp) (super-lift (lambda (b) - ;(printf "~n\t******\tIF CONDITION IS ~a~n" b) (cond [(undefined? b) undef-exp] [b then-exp] @@ -93,21 +86,6 @@ (map translate-clause (syntax->list #'(clause ...)))]) #'(case-lambda new-clause ...))])) - #| - (define (split-list acc lst) - (if (null? (cdr lst)) - (values acc lst) - (split-list (append acc (list (car lst))) (cdr lst)))) - - (define (frp:apply fn . args) - (let-values ([(first-args rest-args) (split-list () args)]) - (if (behavior? rest-args) - (super-lift - (lambda (rest-args) - (apply apply fn (append first-args rest-args))) - args) - (apply apply fn (append first-args rest-args))))) - |# (define any-nested-reactivity? (opt-lambda (obj [mem empty]) @@ -141,7 +119,8 @@ [(absent) (hash-table-put! deps obj 'new)] [(old) (hash-table-put! deps obj 'alive)] [(new) (void)]) - (deep-value-now/update-deps (signal-value obj) deps table)] + (deep-value-now/update-deps (signal-value obj) deps + (cons (list obj (signal-value obj)) table))] [(cons? obj) (let* ([result (cons #f #f)] [new-table (cons (list obj result) table)] @@ -178,48 +157,9 @@ result)))] [else obj])) - (define (deep-value-now obj table) - (cond - [(assq obj table) => second] - [(behavior? obj) - (deep-value-now (signal-value obj) table)] - [(cons? obj) - (let* ([result (cons #f #f)] - [new-table (cons (list obj result) table)] - [car-val (deep-value-now (car obj) new-table)] - [cdr-val (deep-value-now (cdr obj) new-table)]) - (if (and (eq? car-val (car obj)) - (eq? cdr-val (cdr obj))) - obj - (cons car-val cdr-val)))] - ; won't work in the presence of super structs or immutable fields - [(struct? obj) - (let*-values ([(info skipped) (struct-info obj)] - [(name init-k auto-k acc mut! immut sup skipped?) (struct-type-info info)] - [(ctor) (struct-type-make-constructor info)] - [(indices) (build-list init-k identity)] - [(result) (apply ctor (build-list init-k (lambda (i) #f)))] - [(new-table) (cons (list obj result) table)] - [(elts) (build-list init-k (lambda (i) - (deep-value-now (acc obj i) new-table)))]) - (if (andmap (lambda (i e) (eq? (acc obj i) e)) indices elts) - obj - (begin - (for-each (lambda (i e) (mut! result i e)) indices elts) - result)))] - [(vector? obj) - (let* ([len (vector-length obj)] - [indices (build-list len identity)] - [result (build-vector len (lambda (_) #f))] - [new-table (cons (list obj result) table)] - [elts (build-list len (lambda (i) - (deep-value-now (vector-ref obj i) new-table)))]) - (if (andmap (lambda (i e) (eq? (vector-ref obj i) e)) indices elts) - obj - (begin - (for-each (lambda (i e) (vector-set! result i e)) indices elts) - result)))] - [else obj])) + (define (public-dvn obj) + (do-in-manager-after + (deep-value-now obj empty))) (define any-spinal-reactivity? (opt-lambda (lst [mem empty]) @@ -261,8 +201,7 @@ (iq-enqueue rtn))] [(alive) (hash-table-put! deps k 'old)] [(old) (hash-table-remove! deps k) - (unregister rtn k)]))) - #;(printf "count = ~a~n" (hash-table-count deps)))))) + (unregister rtn k)]))))))) (do-in-manager (iq-enqueue rtn)) rtn) @@ -284,8 +223,7 @@ (register rtn k)] [(alive) (hash-table-put! deps k 'old)] [(old) (hash-table-remove! deps k) - (unregister rtn k)]))) - #;(printf "count = ~a~n" (hash-table-count deps)))))) + (unregister rtn k)]))))))) (do-in-manager (iq-enqueue rtn)) rtn)) @@ -299,7 +237,6 @@ (begin0 (let/ec esc (begin0 - ;;(with-handlers ([exn:fail? (lambda (exn) #f)]) (proc (lambda (obj) (if (behavior? obj) (begin @@ -320,8 +257,7 @@ (case v [(new alive) (hash-table-put! deps k 'old)] [(old) (hash-table-remove! deps k) - (unregister rtn k)]))) - #;(printf "count = ~a~n" (hash-table-count deps)))))))) + (unregister rtn k)]))))))))) (iq-enqueue rtn) rtn)) @@ -334,29 +270,14 @@ ;; CONS - (define (frp:cons f r) - (cons f r) - #;(lift #f cons f r) - #;(if (or (behavior? f) (behavior? r)) - (procs->signal:compound - cons - (lambda (p i) - (if (zero? i) - (lambda (v) (set-car! p v)) - (lambda (v) (set-cdr! p v)))) - f r) - (cons f r))) + (define frp:cons cons) (define (make-accessor acc) (lambda (v) (let loop ([v v]) (cond [(signal:compound? v) (acc (signal:compound-content v))] - [(signal? v) #;(printf "access to ~a in ~a~n" acc - (value-now/no-copy v)) - #;(lift #t acc v) - #;(switch ((changes v) . ==> . acc) (acc (value-now v))) - (super-lift acc v)] + [(signal? v) (super-lift acc v)] [(signal:switching? v) (super-lift (lambda (_) (loop (unbox (signal:switching-current v)))) @@ -390,10 +311,7 @@ [(empty? lst) (ef)] [else (error "list-match: expected a list, got ~a" lst)])) lst)) - - #;(define (frp:append . args) - (apply lift #t append args)) - + (define frp:append (case-lambda [() ()] @@ -401,18 +319,9 @@ [(lst1 lst2 . lsts) (list-match lst1 (lambda (f r) (cons f (apply frp:append r lst2 lsts))) - (lambda () (apply frp:append lst2 lsts))) - #;(frp:if (frp:empty? lst1) - (apply frp:append lst2 lsts) - (frp:cons (frp:car lst1) - (apply frp:append (frp:cdr lst1) lst2 lsts)))])) + (lambda () (apply frp:append lst2 lsts)))])) - (define frp:list list - #;(lambda elts - (frp:if (frp:empty? elts) - '() - (frp:cons (frp:car elts) - (apply frp:list (frp:cdr elts)))))) + (define frp:list list) (define frp:list* (lambda elts @@ -426,7 +335,6 @@ (define (frp:list? itm) (if (signal:compound? itm) (let ([ctnt (signal:compound-content itm)]) - ; (let ([ctnt (value-now itm)]) (if (cons? ctnt) (frp:list? (cdr ctnt)) #f)) @@ -442,23 +350,10 @@ (define frp:vector vector) - #;(define (frp:vector . args) - (if (ormap behavior? args) - (apply procs->signal:compound - vector - (lambda (vec idx) - (lambda (x) - (vector-set! vec idx x))) - args) - (apply vector args))) (define (frp:vector-ref v i) (cond - [(behavior? v) (super-lift (lambda (v) (frp:vector-ref v i)) v) - #;(switch ((changes v) . ==> . (lambda (vv) (vector-ref vv i))) - (vector-ref (value-now v) i)) ;; rewrite as super-lift - #;(lift #t vector-ref v i)] - #;[(signal:compound? v) (vector-ref (signal:compound-content v) i)] + [(behavior? v) (super-lift (lambda (v) (frp:vector-ref v i)) v)] [else (lift #t vector-ref v i)])) @@ -472,16 +367,7 @@ args)]) (values desc - #;(lambda fields - (if (ormap behavior? fields) - (apply procs->signal:compound - ctor - (lambda (strct idx) - (lambda (val) - (mut strct idx val))) - fields) - (apply ctor fields))) - ctor + ctor (lambda (v) (if (signal:compound? v) (pred (value-now/no-copy v)) (lift #t pred v))) @@ -646,14 +532,13 @@ #%top-interaction raise-reactivity raise-list-for-apply - deep-value-now + (rename public-dvn deep-value-now) any-nested-reactivity? compound-lift list-match (rename frp:if if) (rename frp:lambda lambda) (rename frp:case-lambda case-lambda) - ;(rename frp:apply apply) (rename frp:letrec letrec) (rename frp:cons cons) (rename frp:car car) diff --git a/collects/frtime/mzscheme-utils.ss b/collects/frtime/mzscheme-utils.ss index 2a68c0a0c9..02ebe00f1c 100644 --- a/collects/frtime/mzscheme-utils.ss +++ b/collects/frtime/mzscheme-utils.ss @@ -10,7 +10,6 @@ if lambda case-lambda - ;apply reverse list-ref require @@ -24,8 +23,6 @@ make-struct-field-mutator vector vector-ref - quasiquote - ;qq-append define-struct list list* @@ -33,8 +30,7 @@ append and or - cond when unless ;case - ; else => + cond when unless map ormap andmap assoc member) (rename mzscheme mzscheme:if if) (rename "lang-ext.ss" lift lift) @@ -59,11 +55,7 @@ (if (lift #t positive? idx) (list-ref (cdr lst) (lift #t sub1 idx)) (car lst))) - - ;(define (frp:eq? itm1 itm2) - ; (lift #t eq? itm1 itm2)) - - + (define-syntax cond (syntax-rules (else =>) [(_ [else result1 result2 ...]) @@ -189,14 +181,7 @@ (define (cddddr v) (cdr (cdddr v))) - - #| - (define-syntax frp:case - (syntax-rules () - [(_ expr clause ...) - (super-lift (lambda (v) (case v clause ...)) expr)])) - |# - + (define (split-list acc lst) (if (null? (cdr lst)) (values acc (car lst)) @@ -215,45 +200,7 @@ (lambda (last-args) (apply apply fn (append first-args (cons last-args empty)))) last-args)))) - - #| - ;; taken from startup.ss - (define-syntax frp:case - (lambda (x) - (syntax-case x (else) - ((_ v) - (syntax (begin v (cond)))) - ((_ v (else e1 e2 ...)) - (syntax/loc x (begin v e1 e2 ...))) - ((_ v ((k ...) e1 e2 ...)) - (syntax/loc x (if (memv v '(k ...)) (begin e1 e2 ...)))) - ((_ v ((k ...) e1 e2 ...) c1 c2 ...) - (syntax/loc x (let ((x v)) - (if (memv x '(k ...)) - (begin e1 e2 ...) - (frp:case x c1 c2 ...))))) - ((_ v (bad e1 e2 ...) . rest) - (raise-syntax-error - #f - "bad syntax (not a datum sequence)" - x - (syntax bad))) - ((_ v clause . rest) - (raise-syntax-error - #f - "bad syntax (missing expression after datum sequence)" - x - (syntax clause))) - ((_ . v) - (not (null? (syntax-e (syntax v)))) - (raise-syntax-error - #f - "bad syntax (illegal use of `.')" - x))))) - - -|# - + (define-syntax frp:case (syntax-rules () [(_ exp clause ...) @@ -274,10 +221,7 @@ (define map (case-lambda - [(f l) #;(if (pair? l) - (cons (f (car l)) (map f (cdr l))) - null) - (list-match + [(f l) (list-match l (lambda (a d) (cons (f a) (map f d))) (lambda () null))] @@ -292,10 +236,7 @@ (list-match l2 (lambda (a2 d2) (error "map expected lists of same length but got" l1 l2)) - (lambda () null)))) - #;(if (and (pair? l1) (pair? l2)) - (cons (f (car l1) (car l2)) (map f (cdr l1) (cdr l2))) - null)] + (lambda () null))))] [(f l . ls) (if (and (pair? l) (andmap pair? ls)) (cons (apply f (car l) (map car ls)) (apply map f (cdr l) (map cdr ls))) null)])) @@ -323,7 +264,6 @@ (define (dont-optimize x) x) (provide cond - ; else => and or or-undef @@ -342,7 +282,6 @@ cdddr cadddr cddddr - ;case build-path collection-path @@ -357,7 +296,7 @@ eq? equal? eqv? < > <= >= add1 cos sin tan symbol->string symbol? - number->string string->symbol eof-object? exp expt even? odd? string-append eval ; list-ref + number->string string->symbol eof-object? exp expt even? odd? string-append eval sub1 sqrt not number? string string? zero? min max modulo string->number void? rational? char? char-upcase char-ci>=? char-ci<=? string>=? char-upper-case? char-alphabetic? @@ -374,8 +313,7 @@ date-minute date-second make-date char-downcase char>=? char<=? char->integer integer->char boolean? integer? quotient remainder positive? negative? inexact->exact exact->inexact make-polar denominator truncate bitwise-not bitwise-xor bitwise-and bitwise-ior inexact? - char-whitespace? assq assv memq memv list-tail ;reverse - ;length + char-whitespace? assq assv memq memv list-tail seconds->date expand syntax-object->datum exn-message continuation-mark-set->list exn-continuation-marks exn:fail? regexp-match @@ -393,12 +331,8 @@ procedure-arity-includes? raise-type-error raise thread current-continuation-marks raise-mismatch-error require-for-syntax define-syntax define-syntaxes syntax-rules syntax-case - ; set-eventspace - ;install-errortrace-key (lifted:nonstrict format) print-struct - ;lambda - ;case-lambda define let let* @@ -409,6 +343,7 @@ begin begin0 quote + quasiquote unquote unquote-splicing @@ -442,8 +377,6 @@ dont-optimize - ; null - ; make-struct-field-mutator ) ; from core diff --git a/collects/frtime/reactive.ss b/collects/frtime/reactive.ss index c066356363..69affd2357 100644 --- a/collects/frtime/reactive.ss +++ b/collects/frtime/reactive.ss @@ -1,7 +1,6 @@ (module reactive "mzscheme-utils.ss" (require "lang-ext.ss") (require "frp-snip.ss") - (require "ft-qq.ss") (require frtime/list) (require frtime/etc) (require (as-is:unchecked "frp-core.ss" @@ -25,5 +24,4 @@ (all-from frtime/etc) (all-from "mzscheme-utils.ss") (all-from-except "lang-ext.ss" lift) - (all-from "frp-snip.ss") - (all-from "ft-qq.ss"))) + (all-from "frp-snip.ss"))) From 4ff0378fbfc5e9c6b69a2ee645c5ee3410acd108 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 28 Nov 2008 08:50:04 +0000 Subject: [PATCH 15/42] Welcome to a new PLT day. svn: r12629 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index 427f92f726..9ffe92d015 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "27nov2008") +#lang scheme/base (provide stamp) (define stamp "28nov2008") From 84ffa34efda511974bce59e594cdfc3781d7f4f9 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 28 Nov 2008 14:07:11 +0000 Subject: [PATCH 16/42] safer x86_64 backtrace svn: r12630 --- src/mzscheme/src/jit.c | 8 +++++- src/mzscheme/src/unwind/libunwind.c | 35 ++++++++++++++++++++++++--- src/mzscheme/src/unwind/libunwind.h | 3 +++ src/mzscheme/src/unwind/libunwind_i.h | 10 +++++--- 4 files changed, 48 insertions(+), 8 deletions(-) diff --git a/src/mzscheme/src/jit.c b/src/mzscheme/src/jit.c index 959ec4e5ae..127dd82e39 100644 --- a/src/mzscheme/src/jit.c +++ b/src/mzscheme/src/jit.c @@ -8178,6 +8178,11 @@ Scheme_Object *scheme_native_stack_trace(void) tail = scheme_null; } +#ifdef MZ_USE_DWARF_LIBUNWIND + unw_set_safe_pointer_range(stack_start, stack_end); + unw_reset_bad_ptr_flag(); +#endif + halfway = STK_DIFF(stack_end, (unsigned long)p) / 2; if (halfway < CACHE_STACK_MIN_TRIGGER) halfway = stack_end; @@ -8306,7 +8311,8 @@ Scheme_Object *scheme_native_stack_trace(void) void *prev_q = q; unw_step(&c); q = (void *)unw_get_ip(&c); - if (q == prev_q) + if ((q == prev_q) + || unw_reset_bad_ptr_flag()) break; } } diff --git a/src/mzscheme/src/unwind/libunwind.c b/src/mzscheme/src/unwind/libunwind.c index 15dcf15a6e..55a687bfcc 100644 --- a/src/mzscheme/src/unwind/libunwind.c +++ b/src/mzscheme/src/unwind/libunwind.c @@ -2462,6 +2462,35 @@ int unw_step (unw_cursor_t *c) return dwarf_step(&((struct cursor *)c)->dwarf); } +static int saw_bad_ptr = 0; +static char safe_space[8]; +static unw_word_t safe_start_address, safe_end_address; + +void unw_set_safe_pointer_range(unw_word_t s, unw_word_t e) +{ + safe_start_address = s; + safe_end_address = e; +} + +int unw_reset_bad_ptr_flag() +{ + int v = saw_bad_ptr; + saw_bad_ptr = 0; + return v; +} + +static void *safe_pointer(unw_word_t p) +{ + if (safe_start_address != safe_end_address) + if ((p < safe_start_address) + || (p >= safe_end_address)) { + saw_bad_ptr = 1; + return safe_space; + } + + return (void *)p; +} + #if UNW_DEBUG int unwi_debug_level = 100; #endif @@ -2473,7 +2502,7 @@ unw_word_t unw_get_ip(unw_cursor_t *c) unw_word_t unw_get_frame_pointer(unw_cursor_t *c) { - return *(unw_word_t *)((struct cursor *)c)->dwarf.loc[6 /* = BP */].val; + return *(unw_word_t *)safe_pointer(((struct cursor *)c)->dwarf.loc[6 /* = BP */].val); } void unw_manual_step(unw_cursor_t *_c, @@ -2493,8 +2522,8 @@ void unw_manual_step(unw_cursor_t *_c, c->dwarf.loc[13].val = (unw_word_t)r13_addr; c->dwarf.loc[16].val = (unw_word_t)ip_addr; - c->dwarf.ip = *(unw_word_t *)ip_addr; - c->dwarf.cfa = *(unw_word_t *)sp_addr; + c->dwarf.ip = *(unw_word_t *)safe_pointer(ip_addr); + c->dwarf.cfa = *(unw_word_t *)safe_pointer(sp_addr); c->dwarf.ret_addr_column = RIP; c->dwarf.pi_valid = 0; c->dwarf.hint = 0; diff --git a/src/mzscheme/src/unwind/libunwind.h b/src/mzscheme/src/unwind/libunwind.h index fbb8f52f2d..504b9b4b5b 100644 --- a/src/mzscheme/src/unwind/libunwind.h +++ b/src/mzscheme/src/unwind/libunwind.h @@ -476,6 +476,9 @@ void unw_manual_step(unw_cursor_t *_c, extern unw_addr_space_t unw_local_addr_space; +extern int unw_reset_bad_ptr_flag(); +extern void unw_set_safe_pointer_range(unw_word_t s, unw_word_t e); + #define unw_tdep_is_fpreg UNW_ARCH_OBJ(is_fpreg) extern int unw_tdep_is_fpreg (int); diff --git a/src/mzscheme/src/unwind/libunwind_i.h b/src/mzscheme/src/unwind/libunwind_i.h index e0357716e3..5457d6acc7 100644 --- a/src/mzscheme/src/unwind/libunwind_i.h +++ b/src/mzscheme/src/unwind/libunwind_i.h @@ -695,12 +695,14 @@ struct cursor # define DWARF_FPREG_LOC(c,r) (DWARF_LOC((unw_word_t) \ tdep_uc_addr((c)->as_arg, (r)), 0)) +static void *safe_pointer(unw_word_t); + static inline int dwarf_getfp (struct dwarf_cursor *c, dwarf_loc_t loc, unw_fpreg_t *val) { if (!DWARF_GET_LOC (loc)) return -1; - *val = *(unw_fpreg_t *) DWARF_GET_LOC (loc); + *val = *(unw_fpreg_t *) safe_pointer(DWARF_GET_LOC (loc)); return 0; } @@ -709,7 +711,7 @@ dwarf_putfp (struct dwarf_cursor *c, dwarf_loc_t loc, unw_fpreg_t val) { if (!DWARF_GET_LOC (loc)) return -1; - *(unw_fpreg_t *) DWARF_GET_LOC (loc) = val; + *(unw_fpreg_t *) safe_pointer(DWARF_GET_LOC (loc)) = val; return 0; } @@ -718,7 +720,7 @@ dwarf_get (struct dwarf_cursor *c, dwarf_loc_t loc, unw_word_t *val) { if (!DWARF_GET_LOC (loc)) return -1; - *val = *(unw_word_t *) DWARF_GET_LOC (loc); + *val = *(unw_word_t *) safe_pointer(DWARF_GET_LOC (loc)); return 0; } @@ -727,7 +729,7 @@ dwarf_put (struct dwarf_cursor *c, dwarf_loc_t loc, unw_word_t val) { if (!DWARF_GET_LOC (loc)) return -1; - *(unw_word_t *) DWARF_GET_LOC (loc) = val; + *(unw_word_t *) safe_pointer(DWARF_GET_LOC (loc)) = val; return 0; } From 9da2a8f395f0742fba696c918fc1fa7daf08adff Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 28 Nov 2008 14:58:28 +0000 Subject: [PATCH 17/42] clean up to avoid some compiler warnings svn: r12631 --- src/mzscheme/gc2/newgc.c | 2 -- src/mzscheme/src/unwind/libunwind.c | 30 ++------------------------- src/mzscheme/src/unwind/libunwind_i.h | 6 ------ 3 files changed, 2 insertions(+), 36 deletions(-) diff --git a/src/mzscheme/gc2/newgc.c b/src/mzscheme/gc2/newgc.c index 4b0ad4cb1d..d9cf19d016 100644 --- a/src/mzscheme/gc2/newgc.c +++ b/src/mzscheme/gc2/newgc.c @@ -707,8 +707,6 @@ long GC_initial_word(int sizeb) info.size = (sizeb >> gcLOG_WORD_SIZE); memcpy(&w, &info, sizeof(struct objhead)); - ((struct objhead*)&w)->size = (sizeb >> gcLOG_WORD_SIZE); - return w; } diff --git a/src/mzscheme/src/unwind/libunwind.c b/src/mzscheme/src/unwind/libunwind.c index 55a687bfcc..5cdc10b92f 100644 --- a/src/mzscheme/src/unwind/libunwind.c +++ b/src/mzscheme/src/unwind/libunwind.c @@ -1759,26 +1759,6 @@ apply: return 0; } -/* The proc-info must be valid for IP before this routine can be - called. */ -HIDDEN int -dwarf_create_state_record (struct dwarf_cursor *c, dwarf_state_record_t *sr) -{ - return create_state_record_for (c, sr, c->ip); -} - -HIDDEN int -dwarf_make_proc_info (struct dwarf_cursor *c) -{ -#if 0 - if (c->as->caching_policy == UNW_CACHE_NONE - || get_cached_proc_info (c) < 0) -#endif - /* Lookup it up the slow way... */ - return fetch_proc_info (c, c->ip, 0); - return 0; -} - HIDDEN int dwarf_step (struct dwarf_cursor *c) { @@ -2132,12 +2112,6 @@ dwarf_search_unwind_table (unw_addr_space_t as, unw_word_t ip, return 0; } -void -dwarf_put_unwind_info (unw_addr_space_t as, unw_proc_info_t *pi, void *arg) -{ - return; /* always a nop */ -} - /*XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX*/ /* glue */ /*XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX*/ @@ -2522,8 +2496,8 @@ void unw_manual_step(unw_cursor_t *_c, c->dwarf.loc[13].val = (unw_word_t)r13_addr; c->dwarf.loc[16].val = (unw_word_t)ip_addr; - c->dwarf.ip = *(unw_word_t *)safe_pointer(ip_addr); - c->dwarf.cfa = *(unw_word_t *)safe_pointer(sp_addr); + c->dwarf.ip = *(unw_word_t *)safe_pointer((unw_word_t)ip_addr); + c->dwarf.cfa = *(unw_word_t *)safe_pointer((unw_word_t)sp_addr); c->dwarf.ret_addr_column = RIP; c->dwarf.pi_valid = 0; c->dwarf.hint = 0; diff --git a/src/mzscheme/src/unwind/libunwind_i.h b/src/mzscheme/src/unwind/libunwind_i.h index 5457d6acc7..ee1cff6340 100644 --- a/src/mzscheme/src/unwind/libunwind_i.h +++ b/src/mzscheme/src/unwind/libunwind_i.h @@ -621,7 +621,6 @@ struct dwarf_rs_cache #define dwarf_read_encoded_pointer UNW_OBJ (dwarf_read_encoded_pointer) #define dwarf_step UNW_OBJ (dwarf_step) -HIDDEN int dwarf_init (void); HIDDEN int dwarf_find_proc_info (unw_addr_space_t as, unw_word_t ip, unw_proc_info_t *pi, int need_unwind_info, void *arg); @@ -630,8 +629,6 @@ HIDDEN int dwarf_search_unwind_table (unw_addr_space_t as, unw_dyn_info_t *di, unw_proc_info_t *pi, int need_unwind_info, void *arg); -HIDDEN void dwarf_put_unwind_info (unw_addr_space_t as, - unw_proc_info_t *pi, void *arg); HIDDEN int dwarf_eval_expr (struct dwarf_cursor *c, unw_word_t *addr, unw_word_t len, unw_word_t *valp, int *is_register); @@ -642,9 +639,6 @@ HIDDEN int dwarf_extract_proc_info_from_fde (unw_addr_space_t as, int need_unwind_info, void *arg); HIDDEN int dwarf_find_save_locs (struct dwarf_cursor *c); -HIDDEN int dwarf_create_state_record (struct dwarf_cursor *c, - dwarf_state_record_t *sr); -HIDDEN int dwarf_make_proc_info (struct dwarf_cursor *c); HIDDEN int dwarf_read_encoded_pointer (unw_addr_space_t as, unw_accessors_t *a, unw_word_t *addr, From 4bfb12ff3c2ed06daeb0d1f9f77f76870138aa8e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 28 Nov 2008 15:00:20 +0000 Subject: [PATCH 18/42] clean up to avoid some more compiler warnings svn: r12632 --- src/mzscheme/gc2/newgc.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/mzscheme/gc2/newgc.c b/src/mzscheme/gc2/newgc.c index d9cf19d016..985f2e6bd7 100644 --- a/src/mzscheme/gc2/newgc.c +++ b/src/mzscheme/gc2/newgc.c @@ -1245,7 +1245,7 @@ typedef struct MarkSegment { struct MarkSegment *next; void **top; void **end; - void **stop_here; /* this is only used for its address */ + void *stop_here; /* this is only used for its address */ } MarkSegment; static THREAD_LOCAL MarkSegment *mark_stack = NULL; @@ -1253,7 +1253,7 @@ static THREAD_LOCAL MarkSegment *mark_stack = NULL; inline static MarkSegment* mark_stack_create_frame() { MarkSegment *mark_frame = (MarkSegment*)ofm_malloc(STACK_PART_SIZE); mark_frame->next = NULL; - mark_frame->top = PPTR(&(mark_frame->stop_here)); + mark_frame->top = &(mark_frame->stop_here); mark_frame->end = PPTR(NUM(mark_frame) + STACK_PART_SIZE); return mark_frame; } @@ -1272,7 +1272,7 @@ inline static void push_ptr(void *ptr) if(mark_stack->next) { /* we do, so just use it */ mark_stack = mark_stack->next; - mark_stack->top = PPTR(&(mark_stack->stop_here)); + mark_stack->top = &(mark_stack->stop_here); } else { /* we don't, so we need to allocate one */ mark_stack->next = mark_stack_create_frame(); @@ -1287,7 +1287,7 @@ inline static void push_ptr(void *ptr) inline static int pop_ptr(void **ptr) { - if(mark_stack->top == PPTR(&mark_stack->stop_here)) { + if(mark_stack->top == &mark_stack->stop_here) { if(mark_stack->prev) { /* if there is a previous page, go to it */ mark_stack = mark_stack->prev; From 695bb48100f185027aafb5b04cb26518222c780c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 28 Nov 2008 15:36:37 +0000 Subject: [PATCH 19/42] fix JIT-inlined set-mc{ad}r! error reporting for PPC svn: r12633 --- src/mzscheme/src/jit.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/mzscheme/src/jit.c b/src/mzscheme/src/jit.c index 127dd82e39..371de44920 100644 --- a/src/mzscheme/src/jit.c +++ b/src/mzscheme/src/jit.c @@ -6558,7 +6558,7 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) bad_set_mcdr_code = code; break; } - mz_prolog(JIT_R1); + mz_prolog(JIT_R2); jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(2)); CHECK_RUNSTACK_OVERFLOW(); jit_str_p(JIT_RUNSTACK, JIT_R0); From 2f73042c99881a7e4b42c7713af821e59e452f99 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sat, 29 Nov 2008 05:31:23 +0000 Subject: [PATCH 20/42] Welcome to a new PLT day. svn: r12634 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index 9ffe92d015..8d86773ab6 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "28nov2008") +#lang scheme/base (provide stamp) (define stamp "29nov2008") From f9229961730f5934f26bb59edd1493d39fb46378 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 29 Nov 2008 14:18:00 +0000 Subject: [PATCH 21/42] try to avoid loop in getting x86_64 stack trace svn: r12635 --- src/mzscheme/src/unwind/libunwind.c | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/mzscheme/src/unwind/libunwind.c b/src/mzscheme/src/unwind/libunwind.c index 5cdc10b92f..5f323be419 100644 --- a/src/mzscheme/src/unwind/libunwind.c +++ b/src/mzscheme/src/unwind/libunwind.c @@ -1470,6 +1470,9 @@ rs_lookup (struct dwarf_rs_cache *cache, struct dwarf_cursor *c) } if (rs->coll_chain >= DWARF_UNW_HASH_SIZE) return 0; + if (!rs->coll_chain) + /* Something went wrong */ + return 0; rs = cache->buckets + rs->coll_chain; } } From 8bd2b94dea39d873db040caf26cbae5e98e93d1f Mon Sep 17 00:00:00 2001 From: Casey Klein Date: Sat, 29 Nov 2008 14:41:49 +0000 Subject: [PATCH 22/42] 1. Renamed `check-metafunction' to `check-metafunction-contract'. 2. Generator now eventually focuses probability on randomly chosen preferred productions. svn: r12636 --- collects/redex/private/rg-test.ss | 79 ++++++++++--------- collects/redex/private/rg.ss | 124 ++++++++++++++++++------------ 2 files changed, 114 insertions(+), 89 deletions(-) diff --git a/collects/redex/private/rg-test.ss b/collects/redex/private/rg-test.ss index c4d60d01a1..836183f185 100644 --- a/collects/redex/private/rg-test.ss +++ b/collects/redex/private/rg-test.ss @@ -65,12 +65,12 @@ (test (pick-from-list '(a b c) (make-random 1)) 'b) -(test (pick-number 3 (make-random .5)) 2) -(test (pick-number 109 (make-random 0 0 .5)) -6) -(test (pick-number 509 (make-random 0 0 1 .5 .25)) 3/7) -(test (pick-number 1009 (make-random 0 0 0 .5 1 .5)) 6.0) -(test (pick-number 2009 (make-random 0 0 0 0 2 .5 1 .5 0 0 .5)) - (make-rectangular 6.0 -6)) +(test (pick-number 24 (make-random 1/5)) 3) +(test (pick-number 224 (make-random 0 0 1/5)) -5) +(test (pick-number 524 (make-random 0 0 1 1/5 1/5)) 3/4) +(test (pick-number 1624 (make-random 0 0 0 .5 1 .5)) 3.0) +(test (pick-number 2624 (make-random 0 0 0 0 1 1 1/5 1/5 2 .5 0 .5)) + (make-rectangular 7/8 -3.0)) (let* ([lits '("bcd" "cbd")] [chars (sort (unique-chars lits) char<=?)]) @@ -101,7 +101,8 @@ (make-exn-not-raised))))])) (define (patterns . selectors) - (map (λ (selector) (λ (prods . _) (selector prods))) selectors)) + (map (λ (selector) (λ (name prods vars size) (list (selector prods)))) + selectors)) (define (iterator name items) (let ([bi (box items)]) @@ -124,13 +125,18 @@ (define-syntax decision (syntax-rules () [(_ d) (if (procedure? d) (λ () d) (iterator (quote d) d))])) - (unit (import) (export decisions^) - (define next-variable-decision (decision var)) - (define next-non-terminal-decision (decision nt)) - (define next-number-decision (decision num)) - (define next-string-decision (decision str)) - (define next-any-decision (decision any)) - (define next-sequence-decision (decision seq)))) + (λ (lang) + (unit (import) (export decisions^) + (define next-variable-decision (decision var)) + (define next-non-terminal-decision + (if (procedure? nt) + (let ([next (nt lang)]) + (λ () next)) + (iterator 'nt nt))) + (define next-number-decision (decision num)) + (define next-string-decision (decision str)) + (define next-any-decision (decision any)) + (define next-sequence-decision (decision seq))))) (let () (define-language lc @@ -152,22 +158,13 @@ (decisions #:var (list (λ _ 'x) (λ _ 'y)))) '(x x y y)) - ;; Minimum rhs is chosen with zero size - (test - (let/ec k - (generate/decisions - lc e 0 0 - (decisions #:nt (list (λ (prods . _) (k (map rhs-pattern prods))))))) - '(x)) - - ;; Size decremented - (let ([size 5]) - (test - (let/ec k - (generate/decisions - lc e size 0 - (decisions #:nt (list (λ (prods . _) (cadr prods)) (λ (p b s) (k s)))))) - (sub1 size)))) + ; After choosing (e e), size decremented forces each e to x. + (test + (generate/decisions + lc e 1 0 + (decisions #:nt (patterns first) + #:var (list (λ _ 'x) (λ _ 'y)))) + '(x y))) ;; #:binds (let () @@ -230,7 +227,7 @@ (test (generate/decisions lang d 5 0 (decisions #:seq (list (λ (_) 2)))) '(4 4 4 4 (4 4) (4 4))) (test (exn:fail-message (generate lang e 5)) - #rx"generate: unable to generate pattern \\(n_1 ..._!_1 n_2 ..._!_1 \\(n_1 n_2\\) ..._3\\)") + #rx"generate: unable to generate pattern e") (test (generate/decisions lang f 5 0 (decisions #:seq (list (λ (_) 0)))) null) (test (generate/decisions lang ((0 ..._!_1) ... (1 ..._!_1) ...) 5 0 (decisions #:seq (list (λ (_) 2) (λ (_) 3) (λ (_) 4) (λ (_) 2) (λ (_) 3) (λ (_) 4) @@ -460,6 +457,9 @@ #:var (list (λ _ 'x) (λ _ 'y)))) (term (λ (x) (hole y))))) +; preferred productions + + ;; current-error-port-output : (-> (-> any) string) (define (current-error-port-output thunk) (let ([p (open-output-string)]) @@ -484,7 +484,7 @@ (test (current-error-port-output (λ () (check lang d 2 (error 'pred-raised)))) "failed after 1 attempts:\n5\n")) -;; check-metafunction +;; check-metafunction-contract (let () (define-language empty) (define-metafunction empty @@ -504,19 +504,22 @@ [(i any ...) (any ...)]) ;; Dom(f) < Ctc(f) - (test (current-error-port-output (λ () (check-metafunction f (decisions #:num (list (λ _ 2) (λ _ 5)))))) + (test (current-error-port-output + (λ () (check-metafunction-contract f (decisions #:num (list (λ _ 2) (λ _ 5)))))) "failed after 1 attempts:\n(5)\n") ;; Rng(f) > Codom(f) - (test (current-error-port-output (λ () (check-metafunction f (decisions #:num (list (λ _ 3)))))) + (test (current-error-port-output + (λ () (check-metafunction-contract f (decisions #:num (list (λ _ 3)))))) "failed after 1 attempts:\n(3)\n") ;; LHS matches multiple ways - (test (current-error-port-output (λ () (check-metafunction g (decisions #:num (list (λ _ 1) (λ _ 1)) - #:seq (list (λ _ 2)))))) + (test (current-error-port-output + (λ () (check-metafunction-contract g (decisions #:num (list (λ _ 1) (λ _ 1)) + #:seq (list (λ _ 2)))))) "failed after 1 attempts:\n(1 1)\n") ;; OK -- generated from Dom(h) - (test (check-metafunction h) #t) + (test (check-metafunction-contract h) #t) ;; OK -- generated from pattern (any ...) - (test (check-metafunction i) #t)) + (test (check-metafunction-contract i) #t)) ;; parse/unparse-pattern (let-syntax ([test-match (syntax-rules () [(_ p x) (test (match x [p #t] [_ #f]) #t)])]) diff --git a/collects/redex/private/rg.ss b/collects/redex/private/rg.ss index f473a71d88..4131ea1eef 100644 --- a/collects/redex/private/rg.ss +++ b/collects/redex/private/rg.ss @@ -25,10 +25,12 @@ To do a better job of not generating programs with free variables, (for-syntax "reduction-semantics.ss") mrlib/tex-table) -(define random-numbers '(0 1 -1 17 8)) (define (allow-free-var? [random random]) (= 0 (random 30))) (define (exotic-choice? [random random]) (= 0 (random 5))) (define (use-lang-literal? [random random]) (= 0 (random 20))) +(define (preferred-production? attempt [random random]) + (and (>= attempt preferred-production-threshold) + (zero? (random 2)))) (define (try-to-introduce-binder?) (= 0 (random 2)) #f) ;; unique-chars : (listof string) -> (listof char) @@ -42,12 +44,13 @@ To do a better job of not generating programs with free variables, (define generation-retries 100) (define default-check-attempts 100) -(define check-growth-base 5) (define ascii-chars-threshold 50) (define tex-chars-threshold 500) (define chinese-chars-threshold 2000) +(define preferred-production-threshold 3000) + (define (pick-var lang-chars lang-lits bound-vars attempt [random random]) (if (or (null? bound-vars) (allow-free-var? random)) (let ([length (add1 (random-natural 4/5 random))]) @@ -80,11 +83,14 @@ To do a better job of not generating programs with free variables, (define (pick-string lang-chars lang-lits attempt [random random]) (random-string lang-chars lang-lits (random-natural 1/5 random) attempt random)) -(define (pick-nt prods bound-vars size) +(define ((pick-nt pref-prods) nt prods bound-vars attempt) (let* ([binders (filter (λ (x) (not (null? (rhs-var-info x)))) prods)] - [do-intro-binder? (and (not (zero? size)) (null? bound-vars) - (not (null? binders)) (try-to-introduce-binder?))]) - (pick-from-list (if do-intro-binder? binders prods)))) + [do-intro-binder? (and (null? bound-vars) + (not (null? binders)) + (try-to-introduce-binder?))]) + (cond [do-intro-binder? binders] + [(preferred-production? attempt) (list (hash-ref pref-prods nt))] + [else prods]))) (define (pick-from-list l [random random]) (list-ref l (random (length l)))) @@ -124,19 +130,24 @@ To do a better job of not generating programs with free variables, ;; E = 0 => p = 1, which breaks random-natural (/ 1 (+ (max 1 E) 1))) +; Determines a size measure for numbers, sequences, etc., using the +; attempt count. +(define (attempt->size n) + (inexact->exact (floor (/ (log (add1 n)) (log 5))))) + (define (pick-number attempt [random random]) (cond [(or (< attempt integer-threshold) (not (exotic-choice? random))) - (random-natural (expected-value->p attempt) random)] + (random-natural (expected-value->p (attempt->size attempt)) random)] [(or (< attempt rational-threshold) (not (exotic-choice? random))) - (random-integer (expected-value->p (- attempt integer-threshold)) random)] + (random-integer (expected-value->p (attempt->size (- attempt integer-threshold))) random)] [(or (< attempt real-threshold) (not (exotic-choice? random))) - (random-rational (expected-value->p (- attempt rational-threshold)) random)] + (random-rational (expected-value->p (attempt->size (- attempt rational-threshold))) random)] [(or (< attempt complex-threshold) (not (exotic-choice? random))) - (random-real (expected-value->p (- attempt real-threshold)) random)] - [else (random-complex (expected-value->p (- attempt complex-threshold)) random)])) + (random-real (expected-value->p (attempt->size (- attempt real-threshold))) random)] + [else (random-complex (expected-value->p (attempt->size (- attempt complex-threshold))) random)])) (define (pick-sequence-length attempt) - (random-natural (expected-value->p (/ (log (add1 attempt)) (log 2))))) + (random-natural (expected-value->p (attempt->size attempt)))) (define (min-prods nt base-table) (let* ([sizes (hash-ref base-table (nt-name nt))] @@ -144,11 +155,7 @@ To do a better job of not generating programs with free variables, [zip (λ (l m) (map cons l m))]) (map cdr (filter (λ (x) (equal? min-size (car x))) (zip sizes (nt-rhs nt)))))) -(define (generation-failure pat) - (error 'generate "unable to generate pattern ~s in ~s attempts" - (unparse-pattern pat) generation-retries)) - -(define (generate* lang pat [decisions@ random-decisions@]) +(define (generate* lang pat decisions@) (define-values/invoke-unit decisions@ (import) (export decisions^)) @@ -161,16 +168,17 @@ To do a better job of not generating programs with free variables, ([(nt) (findf (λ (nt) (eq? name (nt-name nt))) (append (compiled-lang-lang lang) (compiled-lang-cclang lang)))] - [(rhs) - ((next-non-terminal-decision) - (if (zero? size) (min-prods nt base-table) (nt-rhs nt)) - bound-vars size)] [(bound-vars) (append (extract-bound-vars fvt-id state) bound-vars)] - [(nt-state) (make-state (map fvt-entry (rhs-var-info rhs)) #hash())] [(term _) (generate/pred - (rhs-pattern rhs) - (λ (pat) (((generate-pat bound-vars (max 0 (sub1 size)) attempt) pat in-hole) nt-state)) + name + (λ () + (let ([rhs (pick-from-list + (if (zero? size) + (min-prods nt base-table) + ((next-non-terminal-decision) name (nt-rhs nt) bound-vars attempt)))]) + (((generate-pat bound-vars (max 0 (sub1 size)) attempt) (rhs-pattern rhs) in-hole) + (make-state (map fvt-entry (rhs-var-info rhs)) #hash())))) (λ (_ env) (mismatches-satisfied? env)))]) (values term (extend-found-vars fvt-id term state)))) @@ -199,11 +207,12 @@ To do a better job of not generating programs with free variables, (values (cons term terms) (cons (state-env state) envs) fvt))))]) (values seq (make-state fvt (merge-environments envs))))) - (define (generate/pred pat gen pred) + (define (generate/pred name gen pred) (let retry ([remaining generation-retries]) (if (zero? remaining) - (generation-failure pat) - (let-values ([(term state) (gen pat)]) + (error 'generate "unable to generate pattern ~s in ~s attempts" + name generation-retries) + (let-values ([(term state) (gen)]) (if (pred term (state-env state)) (values term state) (retry (sub1 remaining))))))) @@ -252,10 +261,14 @@ To do a better job of not generating programs with free variables, (match pat [`number (values ((next-number-decision) attempt) state)] [`(variable-except ,vars ...) - (generate/pred 'variable recur/pat (λ (var _) (not (memq var vars))))] + (generate/pred 'variable + (λ () (recur/pat 'variable)) + (λ (var _) (not (memq var vars))))] [`variable (values ((next-variable-decision) lang-chars lang-lits bound-vars attempt) state)] [`variable-not-otherwise-mentioned - (generate/pred 'variable recur/pat (λ (var _) (not (memq var (compiled-lang-literals lang)))))] + (generate/pred 'variable + (λ () (recur/pat 'variable)) + (λ (var _) (not (memq var (compiled-lang-literals lang)))))] [`(variable-prefix ,prefix) (define (symbol-append prefix suffix) (string->symbol (string-append (symbol->string prefix) (symbol->string suffix)))) @@ -263,7 +276,9 @@ To do a better job of not generating programs with free variables, (values (symbol-append prefix term) state))] [`string (values ((next-string-decision) lang-chars lang-lits attempt) state)] [`(side-condition ,pat ,(? procedure? condition)) - (generate/pred pat recur/pat (λ (_ env) (condition (bindings env))))] + (generate/pred (unparse-pattern pat) + (λ () (recur/pat pat)) + (λ (_ env) (condition (bindings env))))] [`(name ,(? symbol? id) ,p) (let-values ([(term state) (recur/pat p)]) (values term (set-env state (make-binder id) term)))] @@ -343,8 +358,8 @@ To do a better job of not generating programs with free variables, (λ (size attempt) (let-values ([(term state) (generate/pred - pat - (λ (pat) + (unparse-pattern pat) + (λ () (((generate-pat null size attempt) pat the-hole) (make-state null #hash()))) (λ (_ env) (mismatches-satisfied? env)))]) @@ -596,7 +611,7 @@ To do a better job of not generating programs with free variables, [(name/ellipses ...) names/ellipses]) (syntax/loc stx (check-property - (term-generator lang pat random-decisions@) + (term-generator lang pat random-decisions) (λ (_ bindings) (with-handlers ([exn:fail? (λ (_) #f)]) (term-let ([name/ellipses (lookup-binding bindings 'name)] ...) @@ -609,7 +624,7 @@ To do a better job of not generating programs with free variables, #t (let ([attempt (add1 (- attempts remaining))]) (let-values ([(term bindings) - (generate (floor (/ (log attempt) (log check-growth-base))) attempt)]) + (generate (attempt->size attempt) attempt)]) (if (property term bindings) (loop (sub1 remaining)) (begin @@ -621,7 +636,7 @@ To do a better job of not generating programs with free variables, (define-syntax generate (syntax-rules () [(_ lang pat size attempt) - (let-values ([(term _) ((term-generator lang pat random-decisions@) size attempt)]) + (let-values ([(term _) ((term-generator lang pat random-decisions) size attempt)]) term)] [(_ lang pat size) (generate lang pat size 0)])) @@ -633,37 +648,39 @@ To do a better job of not generating programs with free variables, (define-syntax (term-generator stx) (syntax-case stx () - [(_ lang pat decisions@) + [(_ lang pat decisions) (with-syntax ([pattern (rewrite-side-conditions/check-errs (language-id-nts #'lang 'generate) 'generate #t #'pat)]) (syntax/loc stx - (generate* - (parse-language lang) - (reassign-classes (parse-pattern `pattern lang 'top-level)) - decisions@)))])) + (let ([lang (parse-language lang)]) + (generate* + lang + (reassign-classes (parse-pattern `pattern lang 'top-level)) + (decisions lang)))))])) -(define-syntax (check-metafunction stx) +(define-syntax (check-metafunction-contract stx) (syntax-case stx () - [(_ name) (syntax/loc stx (check-metafunction name random-decisions@))] - [(_ name decisions@) + [(_ name) + (syntax/loc stx (check-metafunction-contract name random-decisions))] + [(_ name decisions) (identifier? #'name) (with-syntax ([m (let ([tf (syntax-local-value #'name (λ () #f))]) (if (term-fn? tf) (term-fn-get-id tf) (raise-syntax-error #f "not a metafunction" stx #'name)))]) - (syntax - (let ([lang (metafunc-proc-lang m)] + (syntax/loc stx + (let ([lang (parse-language (metafunc-proc-lang m))] [dom (metafunc-proc-dom-pat m)]) (check-property - (generate* (parse-language lang) + (generate* lang (reassign-classes (parse-pattern (if dom dom '(any (... ...))) lang 'top-level)) - decisions@) + (decisions lang)) (λ (t _) (with-handlers ([exn:fail:redex? (λ (_) #f)]) (begin (term (name ,@t)) #t))) - 100))))])) + default-check-attempts))))])) (define-signature decisions^ (next-variable-decision @@ -673,11 +690,16 @@ To do a better job of not generating programs with free variables, next-any-decision next-string-decision)) -(define random-decisions@ +(define (random-decisions lang) + (define preferred-productions + (make-immutable-hasheq + (map (λ (nt) (cons (nt-name nt) (pick-from-list (nt-rhs nt)))) + (append (compiled-lang-lang lang) + (compiled-lang-cclang lang))))) (unit (import) (export decisions^) (define (next-variable-decision) pick-var) (define (next-number-decision) pick-number) - (define (next-non-terminal-decision) pick-nt) + (define (next-non-terminal-decision) (pick-nt preferred-productions)) (define (next-sequence-decision) pick-sequence-length) (define (next-any-decision) pick-any) (define (next-string-decision) pick-string))) @@ -687,7 +709,7 @@ To do a better job of not generating programs with free variables, pick-nt unique-chars pick-any sexp generate parse-pattern class-reassignments reassign-classes unparse-pattern (struct-out ellipsis) (struct-out mismatch) (struct-out class) - (struct-out binder) generate/decisions check-metafunction + (struct-out binder) generate/decisions check-metafunction-contract pick-number parse-language) (provide/contract From 789e51897cb5e9f800e10a7c7306cc5f771f82a6 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 29 Nov 2008 14:43:14 +0000 Subject: [PATCH 23/42] consistently initialize libunwind local-address-space record svn: r12637 --- src/mzscheme/src/unwind/libunwind.c | 1 + 1 file changed, 1 insertion(+) diff --git a/src/mzscheme/src/unwind/libunwind.c b/src/mzscheme/src/unwind/libunwind.c index 5f323be419..4dc7276dc9 100644 --- a/src/mzscheme/src/unwind/libunwind.c +++ b/src/mzscheme/src/unwind/libunwind.c @@ -2427,6 +2427,7 @@ int unw_init_local (unw_cursor_t *cursor, ucontext_t *uc) if (!unw_local_addr_space) { unw_local_addr_space = (unw_addr_space_t)malloc(sizeof(struct unw_addr_space)); + memset(unw_local_addr_space, 0, sizeof(unw_local_addr_space)); } c->dwarf.as = unw_local_addr_space; From 7f4ddbe5fa8d9d604dccc3fe3c96450497579245 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 29 Nov 2008 18:52:25 +0000 Subject: [PATCH 24/42] better file-extension support for Mac OS X put-file dialog svn: r12638 --- collects/scribblings/gui/dialog-funcs.scrbl | 24 ++-- src/mred/gc2/Makefile.in | 6 +- src/wxmac/src/Makefile.in | 5 +- src/wxmac/src/mac/wx_dialg.cc | 119 +++++++++++++++----- src/wxmac/src/mac/wx_file_dialog.m | 43 +++++++ src/wxmac/src/mac/wx_font.m | 2 +- 6 files changed, 157 insertions(+), 42 deletions(-) create mode 100644 src/wxmac/src/mac/wx_file_dialog.m diff --git a/collects/scribblings/gui/dialog-funcs.scrbl b/collects/scribblings/gui/dialog-funcs.scrbl index 45d2636f42..8ba5ac3b25 100644 --- a/collects/scribblings/gui/dialog-funcs.scrbl +++ b/collects/scribblings/gui/dialog-funcs.scrbl @@ -118,22 +118,24 @@ Under Windows, if @scheme[extension] is not @scheme[#f], the returned path is @scheme[(string-append "*." extension)], then the result pathname is guaranteed to have an extension mapping @scheme[extension]. -Under Mac OS X, if @scheme[extension] is not @scheme[#f] - and @scheme[filters] contains the single - pattern @scheme[(string-append "*." extension)], then the result pathname is - guaranteed to have an extension mapping @scheme[extension]. Otherwise, - @scheme[extension] and @scheme[filters] are ignored. +Under Mac OS X, if @scheme[extension] is not @scheme[#f], the returned + path will get a default extension if the user does not supply one. + If @scheme[filters] contains as @scheme["*.*"] pattern, then the user + can supply any extension that is recognized by the system; otherwise, + the extension on the returned path will be either @scheme[extension] + or @scheme[_other-extension] for any @scheme[(string-append "*." + _other-extension)] pattern in @scheme[filters]. In particular, if the + only pattern in @scheme[filters] is empty or contains only + @scheme[(string-append "*." extension)], then the result pathname is + guaranteed to have an extension mapping @scheme[extension]. -The @scheme[extension] argument is ignored under X, and @scheme[filters] - can be used to specify glob-patterns. +The @scheme[extension] argument is ignored under X, and + @scheme[filters] can be used to specify glob-patterns. -The @scheme[style] list is treated as for -@scheme[get-file]. +The @scheme[style] list is treated as for @scheme[get-file]. See also @scheme[path-dialog%]. - - } @defproc[(get-directory [message (or/c string? false/c) #f] diff --git a/src/mred/gc2/Makefile.in b/src/mred/gc2/Makefile.in index 617557830a..2417f2c558 100644 --- a/src/mred/gc2/Makefile.in +++ b/src/mred/gc2/Makefile.in @@ -1333,6 +1333,8 @@ xform: $(XSRCS) xsrc/xcglue.c wx_font.o : $(srcdir)/../../wxmac/src/mac/wx_font.m $(CXX) -o wx_font.o -c $(srcdir)/../../wxmac/src/mac/wx_font.m +wx_file_dialog.o : $(srcdir)/../../wxmac/src/mac/wx_file_dialog.m + $(CXX) -o wx_file_dialog.o -c $(srcdir)/../../wxmac/src/mac/wx_file_dialog.m wx_xt_LIBS = ../../wxxt/contrib/xpm/lib/libXpm.@LTA@ @JPEG_A@ @PNG_A@ @ZLIB_A@ wx_mac_LIBS = -framework Carbon -framework Cocoa -framework QuickTime -framework AGL -framework OpenGL @JPEG_A@ @PNG_A@ -lz @LIBS@ @@ -1377,8 +1379,8 @@ MRFWRES = PLT_MrEd.framework/Versions/$(FWVERSION)_3m/Resources/PLT_MrEd.rsrc cp -r "PLT_MrEd.framework/Versions/$(FWVERSION)_3m/Resources" "../PLT_MrEd.framework/Versions/$(FWVERSION)_3m/Resources" /usr/bin/install_name_tool -change "PLT_MrEd.framework/Versions/$(FWVERSION)_3m/PLT_MrEd" "@executable_path/../../../PLT_MrEd.framework/Versions/$(FWVERSION)_3m/PLT_MrEd" "../MrEd@MMM@.app/Contents/MacOS/MrEd@MMM@" -$(MRFW) : $(XOBJS) $(@WXVARIANT@_PLAIN_OBJS) ../../mzscheme/libmzscheme3m.@LIBSFX@ wx_font.o $(MRFWRES) - $(MREDLINKER) $(LDFLAGS) -dynamiclib -o $(MRFW) -Wl,-headerpad_max_install_names $(XOBJS) $(@WXVARIANT@_PLAIN_OBJS) ../../mzscheme/libmzscheme3m.@LIBSFX@ $(@WXVARIANT@_LIBS) @X_EXTRA_LIBS@ wx_font.o +$(MRFW) : $(XOBJS) $(@WXVARIANT@_PLAIN_OBJS) ../../mzscheme/libmzscheme3m.@LIBSFX@ wx_font.o wx_file_dialog.o $(MRFWRES) + $(MREDLINKER) $(LDFLAGS) -dynamiclib -o $(MRFW) -Wl,-headerpad_max_install_names $(XOBJS) $(@WXVARIANT@_PLAIN_OBJS) ../../mzscheme/libmzscheme3m.@LIBSFX@ $(@WXVARIANT@_LIBS) @X_EXTRA_LIBS@ wx_font.o wx_file_dialog.o $(MRFWRES): $(srcdir)/../../mac/osx_appl.ss $(srcdir)/../../mac/cw/MrEd.r rm -rf PLT_MrEd.framework/Resources PLT_MrEd.framework/PLT_MrEd diff --git a/src/wxmac/src/Makefile.in b/src/wxmac/src/Makefile.in index c4942a8ab2..23617eb21e 100644 --- a/src/wxmac/src/Makefile.in +++ b/src/wxmac/src/Makefile.in @@ -146,6 +146,7 @@ OBJS = \ wx_xbm.o \ \ wx_font.o \ + wx_file_dialog.o \ \ $(MIN_OBJS) @@ -385,9 +386,11 @@ ALSelectors.o : $(ALISTDEPS) $(ALISTDIR)/ALSelectors.c $(CC) $(ALISTCCFLAGS) -o ALSelectors.o -c $(ALISTDIR)/ALSelectors.c ######################################## -# Cocoa fonts # +# Cocoa # ######################################## +wx_file_dialog.o : $(srcdir)/mac/wx_file_dialog.m + $(CXX) -o wx_file_dialog.o -c $(srcdir)/mac/wx_file_dialog.m wx_font.o : $(srcdir)/mac/wx_font.m $(CXX) -o wx_font.o -c $(srcdir)/mac/wx_font.m diff --git a/src/wxmac/src/mac/wx_dialg.cc b/src/wxmac/src/mac/wx_dialg.cc index 7f9d7be7b5..33fa5b20ea 100644 --- a/src/wxmac/src/mac/wx_dialg.cc +++ b/src/wxmac/src/mac/wx_dialg.cc @@ -585,7 +585,8 @@ static void ExtensionCallback(NavEventCallbackMessage callBackSelector, } break; case kNavCBStart: - { + if (0) { + /* No longer needed */ EventTypeSpec spec[1]; spec[0].eventClass = kEventClassKeyboard; spec[0].eventKind = kEventRawKeyDown; @@ -638,6 +639,40 @@ static char *GetNthPath(NavReplyRecord *reply, int index) static NavEventUPP extProc = NewNavEventUPP((NavEventProcPtr)ExtensionCallback); + +static WindowPtr extract_sheet_parent(wxWindow *parent) +{ + if (parent) { + wxFrame *f; + + if (wxSubType(parent->__type, wxTYPE_FRAME)) { + f = (wxFrame *)parent; + } else if (wxSubType(parent->__type, wxTYPE_DIALOG_BOX)) { + f = (wxFrame *)parent->GetParent(); + } else + f = NULL; + + if (f) + f = f->GetSheetParent(); + + if (f) { + CGrafPtr graf; + wxMacDC *mdc; + WindowPtr win; + mdc = f->MacDC(); + graf = mdc->macGrafPort(); + win = GetWindowFromPort(graf); + if (IsWindowVisible(win)) + return win; + } + } + + return NULL; +} + + +extern "C" void wx_set_nav_file_types(NavDialogRef dlg, int cnt, char **exts, char *def_ext); + char *wxFileSelector(char *message, char *default_path, char *default_filename, char *default_extension, char *wildcard, int flags, @@ -652,6 +687,8 @@ char *wxFileSelector(char *message, char *default_path, NavUserAction action; NavReplyRecord *reply; char *temp; + char **acceptable_extensions = NULL; + int num_acceptable = 0, single_type = 0; if (!navinited) { if (!NavLoad()) { @@ -691,10 +728,14 @@ char *wxFileSelector(char *message, char *default_path, if (s2) { int len, flen; len = strlen(default_extension); - if ((s1[0] == '*') + if ((s1[0] == '*') && (s1[1] == '.') && ((s2 - s1) == (len + 2)) - && !strncmp(default_extension, s1+2, len)) { + && !strncmp(default_extension, s1+2, len) + && (!s1[len+2] + || ((s1[len+2] == '|') + && !s1[len+3]))) { + single_type = 1; dialogOptions.optionFlags |= kNavPreserveSaveFileExtension; /* Make sure initial name has specified extension: */ if (!default_filename) @@ -714,6 +755,44 @@ char *wxFileSelector(char *message, char *default_path, } } } + + if (!single_type) { + /* Extract defaults */ + int cnt = 0; + char **a, *ext; + s1 = wildcard; + while (s1) { + s1 = strchr(s1, '|'); + if (s1) { + if ((s1[1] == '*') + && (s1[2] == '.')) { + cnt++; + s1 = strchr(s1 + 1, '|'); + if (s1) s1++; + } else + s1 = 0; + } + } + if (cnt) { + int i; + a = new WXGC_PTRS char*[cnt]; + s1 = wildcard; + for (i = 0; i < cnt; i++) { + s1 = strchr(s1, '|'); + s1 += 3; + s2 = strchr(s1, '|'); + if (!s2) + s2 = s1 + strlen(s1); + ext = new WXGC_ATOMIC char[s2 - s1 + 1]; + memcpy(ext, s1, s2 - s1); + ext[s2 - s1] = 0; + a[i] = ext; + s1 = s2 + 1; + } + acceptable_extensions = a; + num_acceptable = cnt; + } + } } if (default_filename) { @@ -723,30 +802,13 @@ char *wxFileSelector(char *message, char *default_path, cbi->has_parent = 1; if (parent) { - wxFrame *f; - - if (wxSubType(parent->__type, wxTYPE_FRAME)) { - f = (wxFrame *)parent; - } else if (wxSubType(parent->__type, wxTYPE_DIALOG_BOX)) { - f = (wxFrame *)parent->GetParent(); - } else - f = NULL; - - if (f) - f = f->GetSheetParent(); - - if (f) { - CGrafPtr graf; - wxMacDC *mdc; - WindowPtr win; - mdc = f->MacDC(); - graf = mdc->macGrafPort(); - win = GetWindowFromPort(graf); - if (IsWindowVisible(win)) { - dialogOptions.parentWindow = win; - dialogOptions.modality = kWindowModalityWindowModal; - cbi->has_parent = 1; - } + WindowPtr win; + win = extract_sheet_parent(parent); + + if (win) { + dialogOptions.parentWindow = win; + dialogOptions.modality = kWindowModalityWindowModal; + cbi->has_parent = 1; } } @@ -767,6 +829,9 @@ char *wxFileSelector(char *message, char *default_path, extProc, cbi_sr, &outDialog); cbi->is_put = 1; + if (derr == noErr) + wx_set_nav_file_types(outDialog, num_acceptable, acceptable_extensions, + default_extension); } cbi->dialog = outDialog; diff --git a/src/wxmac/src/mac/wx_file_dialog.m b/src/wxmac/src/mac/wx_file_dialog.m new file mode 100644 index 0000000000..35e3a7057b --- /dev/null +++ b/src/wxmac/src/mac/wx_file_dialog.m @@ -0,0 +1,43 @@ + +/* Set options for the Cocoa file dialog */ + +#import +#include + +void wx_set_nav_file_types(NavDialogRef dlg, int cnt, char **exts, char *def_ext) +{ + if (cnt) { + id pool = [[NSAutoreleasePool alloc] init]; + id *objs; + int i, j, allow_others = 0; + NSArray *a; + NSSavePanel *sp = (NSSavePanel *)dlg; + + for (i = 0; i < cnt; i++) { + if (!strcmp(exts[i], "*")) + allow_others = 1; + } + + objs = (id *)malloc(sizeof(id) * (1 + (cnt - allow_others))); + j = 0; + objs[j++] = [[NSString alloc] initWithUTF8String: def_ext]; + for (i = 0; i < cnt; i++) { + if (strcmp(exts[i], "*")) + objs[j++] = [[NSString alloc] initWithUTF8String: exts[i]]; + } + + a = [NSArray arrayWithObjects:objs count:j]; + + [sp setAllowedFileTypes:a]; + sp.canSelectHiddenExtension = TRUE; + if (!allow_others) + sp.allowsOtherFileTypes = FALSE; + + for (i = 0; i < j; i++) { + [objs[i] release]; + } + free(objs); + + [pool release]; + } +} diff --git a/src/wxmac/src/mac/wx_font.m b/src/wxmac/src/mac/wx_font.m index a92c55e827..88efcbd710 100644 --- a/src/wxmac/src/mac/wx_font.m +++ b/src/wxmac/src/mac/wx_font.m @@ -1,6 +1,6 @@ /* The easiest way to find out whether a font is fixed-width is to - jump over the to Coacao world. The ATS and Cocoa worlds are + jump over the to Cocao world. The ATS and Cocoa worlds are connected through the PostScript name of a font. */ #import From 333e0702c99c88738bf6a90f15b9ee43a8971ad4 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 29 Nov 2008 21:08:18 +0000 Subject: [PATCH 25/42] handles filename extensions better now, using new stuff matthew added svn: r12639 --- collects/framework/private/scheme.ss | 5 ++--- collects/profj/tool.ss | 7 +++++++ doc/release-notes/drscheme/HISTORY.txt | 10 ++++++++-- 3 files changed, 17 insertions(+), 5 deletions(-) diff --git a/collects/framework/private/scheme.ss b/collects/framework/private/scheme.ss index f3e8c76557..30920fb9bd 100644 --- a/collects/framework/private/scheme.ss +++ b/collects/framework/private/scheme.ss @@ -1182,7 +1182,8 @@ (values lexeme type paren start end))))) (define/override (put-file text sup directory default-name) - (parameterize ([finder:default-extension "ss"]) + (parameterize ([finder:default-extension "ss"] + [finder:default-filters '(("SCM" "*.scm") ("Any" "*.*"))]) ;; don't call the surrogate's super, since it sets the default extension (sup directory default-name))) @@ -1224,8 +1225,6 @@ (define text-mode% (text-mode-mixin color:text-mode%)) - - (define (setup-keymap keymap) (let ([add-pos-function (λ (name call-method) diff --git a/collects/profj/tool.ss b/collects/profj/tool.ss index 710fdd8970..cd96ba7833 100644 --- a/collects/profj/tool.ss +++ b/collects/profj/tool.ss @@ -116,6 +116,13 @@ (define mode-surrogate% (class color:text-mode% + + (define/override (put-file text sup directory default-name) + (parameterize ([finder:default-extension "java"] + [finder:default-filters '(("Any" "*.*"))]) + ;; don't call the surrogate's super, since it sets the default extension + (sup directory default-name))) + (define/override (on-disable-surrogate text) (keymap:remove-chained-keymap text java-keymap) (super on-disable-surrogate text)) diff --git a/doc/release-notes/drscheme/HISTORY.txt b/doc/release-notes/drscheme/HISTORY.txt index 6421c44f94..362a7791f3 100644 --- a/doc/release-notes/drscheme/HISTORY.txt +++ b/doc/release-notes/drscheme/HISTORY.txt @@ -1,11 +1,17 @@ ------------------------------ - Version 4.3 + Version 4.1.4 +------------------------------ + + . improved the way extensions are handled when saving files. + +------------------------------ + Version 4.1.3 ------------------------------ . minor bug fixes ------------------------------ - Version 4.2 + Version 4.1.2 ------------------------------ . contract library's function contract From 1e67e2fda7789384ed21c36865cc3448fc790790 Mon Sep 17 00:00:00 2001 From: Greg Cooper Date: Sat, 29 Nov 2008 21:47:37 +0000 Subject: [PATCH 26/42] workaround for duplicate text-field% events svn: r12640 --- collects/frtime/gui/mixin-macros.ss | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/collects/frtime/gui/mixin-macros.ss b/collects/frtime/gui/mixin-macros.ss index e3223df4e6..11e2bf77b6 100644 --- a/collects/frtime/gui/mixin-macros.ss +++ b/collects/frtime/gui/mixin-macros.ss @@ -1,6 +1,5 @@ (module mixin-macros frtime - (require mzlib/class) - + (require mzlib/class) (define-syntax events->callbacks (lambda (stx) @@ -47,10 +46,14 @@ (define name-e (event-receiver)) (define processed-events (processor name-e)) (super-new) + (define ft-last-evt #f) ;what about when the super call returns an error? (define/override method-name (lambda args - (send-event name-e args) + (when (or (< (length args) 2) + (and (not (eq? (cadr args) ft-last-evt)) + (set! ft-last-evt (cadr args)))) + (send-event name-e args)) (super method-name . args))) (define/public (g-name) processed-events))))]))) From 119b5bf0fafb14d89ee0d863bc55b3122e477a5a Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 30 Nov 2008 04:47:23 +0000 Subject: [PATCH 27/42] added the usual menus to the test window; also 'open' on the mac and drag and drop now work properly svn: r12642 --- collects/test-engine/test-display.scm | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/collects/test-engine/test-display.scm b/collects/test-engine/test-display.scm index d8b4006170..28c6632601 100644 --- a/collects/test-engine/test-display.scm +++ b/collects/test-engine/test-display.scm @@ -225,7 +225,7 @@ (super-instantiate ()))) (define test-window% - (class* frame% () + (class* frame:standard-menus% () (super-instantiate ((string-constant test-engine-window-title) #f 400 350)) @@ -234,11 +234,13 @@ (define disable-func void) (define close-cleanup void) + (inherit get-area-container) + (define content - (make-object editor-canvas% this #f '(auto-vscroll))) + (make-object editor-canvas% (get-area-container) #f '(auto-vscroll))) (define button-panel - (make-object horizontal-panel% this + (make-object horizontal-panel% (get-area-container) '() #t 0 0 0 0 '(right bottom) 0 0 #t #f)) (define buttons @@ -260,6 +262,8 @@ (switch-func)))) (make-object grow-box-spacer-pane% button-panel))) + (define/override (edit-menu:between-select-all-and-find menu) (void)) + (define/public (update-editor e) (send content set-editor e)) From 96651516e85ea5639f6511bb4b2beef8c79fb15a Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 30 Nov 2008 04:57:03 +0000 Subject: [PATCH 28/42] made close-current-tab be public svn: r12643 --- collects/drscheme/private/unit.ss | 5 ++++- collects/scribblings/tools/unit.scrbl | 5 +++++ 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/collects/drscheme/private/unit.ss b/collects/drscheme/private/unit.ss index 6bb941b46d..b523730f1f 100644 --- a/collects/drscheme/private/unit.ss +++ b/collects/drscheme/private/unit.ss @@ -1334,6 +1334,7 @@ module browser threading seems wrong. execute-callback get-current-tab open-in-new-tab + close-current-tab on-tab-change enable-evaluation disable-evaluation @@ -1344,6 +1345,7 @@ module browser threading seems wrong. ensure-rep-hidden ensure-defs-shown + get-language-menu register-toolbar-button get-tabs)) @@ -2505,7 +2507,7 @@ module browser threading seems wrong. (define/private (change-to-delta-tab dt) (change-to-nth-tab (modulo (+ (send current-tab get-i) dt) (length tabs)))) - (define/private (close-current-tab) + (define/public-final (close-current-tab) (cond [(null? tabs) (void)] [(null? (cdr tabs)) (void)] @@ -2528,6 +2530,7 @@ module browser threading seems wrong. [else (last tabs)]))) (loop (cdr l-tabs))))]))])) + ;; a helper private method for close-current-tab -- doesn't close an arbitrary tab. (define/private (close-tab tab) (cond [(send tab can-close?) diff --git a/collects/scribblings/tools/unit.scrbl b/collects/scribblings/tools/unit.scrbl index 7188b0f139..1ff27056bc 100644 --- a/collects/scribblings/tools/unit.scrbl +++ b/collects/scribblings/tools/unit.scrbl @@ -575,6 +575,11 @@ Returns the currently active tab. } +@defmethod[#:mode public-final (close-current-tab) void?]{ + Closes the current tab, making some other tab visible. + If there is only one tab open, this method does nothing. +} + @defmethod[(get-definitions-canvas) (is-a?/c drscheme:unit:definitions-canvas%)]{ From d351d796ee80b00288ba3caddd3a530693db0b2f Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 30 Nov 2008 08:50:16 +0000 Subject: [PATCH 29/42] Welcome to a new PLT day. svn: r12644 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index 8d86773ab6..19669ca910 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "29nov2008") +#lang scheme/base (provide stamp) (define stamp "30nov2008") From 0f43e934a73220e111521fcadc3b3f79a93f1719 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 30 Nov 2008 12:49:08 +0000 Subject: [PATCH 30/42] use method call instead of propert set on NSSavePanel svn: r12645 --- src/wxmac/src/mac/wx_file_dialog.m | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/wxmac/src/mac/wx_file_dialog.m b/src/wxmac/src/mac/wx_file_dialog.m index 35e3a7057b..eff772ea8f 100644 --- a/src/wxmac/src/mac/wx_file_dialog.m +++ b/src/wxmac/src/mac/wx_file_dialog.m @@ -29,7 +29,7 @@ void wx_set_nav_file_types(NavDialogRef dlg, int cnt, char **exts, char *def_ext a = [NSArray arrayWithObjects:objs count:j]; [sp setAllowedFileTypes:a]; - sp.canSelectHiddenExtension = TRUE; + [sp setCanSelectHiddenExtension:TRUE]; if (!allow_others) sp.allowsOtherFileTypes = FALSE; From 382a650b74b0dc1907da20079f2e75be507ae4ae Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 30 Nov 2008 12:57:46 +0000 Subject: [PATCH 31/42] change another property to a method call svn: r12646 --- src/wxmac/src/mac/wx_file_dialog.m | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/wxmac/src/mac/wx_file_dialog.m b/src/wxmac/src/mac/wx_file_dialog.m index eff772ea8f..f398b62fc4 100644 --- a/src/wxmac/src/mac/wx_file_dialog.m +++ b/src/wxmac/src/mac/wx_file_dialog.m @@ -31,7 +31,7 @@ void wx_set_nav_file_types(NavDialogRef dlg, int cnt, char **exts, char *def_ext [sp setAllowedFileTypes:a]; [sp setCanSelectHiddenExtension:TRUE]; if (!allow_others) - sp.allowsOtherFileTypes = FALSE; + [sp setAllowsOtherFileTypes:FALSE]; for (i = 0; i < j; i++) { [objs[i] release]; From 88b0e558c3d0fc72cc7962ad29cc2142ceb81637 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 30 Nov 2008 13:25:10 +0000 Subject: [PATCH 32/42] better syntax checking for scribble defform #:literals svn: r12647 --- collects/scribble/private/manual-form.ss | 29 ++++++++++++++++++------ 1 file changed, 22 insertions(+), 7 deletions(-) diff --git a/collects/scribble/private/manual-form.ss b/collects/scribble/private/manual-form.ss index 08810891d3..76ffc10389 100644 --- a/collects/scribble/private/manual-form.ss +++ b/collects/scribble/private/manual-form.ss @@ -45,6 +45,13 @@ spec spec)] [_ spec])))]) + (for-each (lambda (id) + (unless (identifier? id) + (raise-syntax-error #f + "expected an identifier for a literal" + stx + id))) + (syntax->list #'(lit ...))) #'(with-togetherable-scheme-variables (lit ...) ([form spec] [form spec1] ... @@ -109,13 +116,21 @@ (define-syntax (defform/none stx) (syntax-case stx () [(_ #:literals (lit ...) spec desc ...) - #'(with-togetherable-scheme-variables - (lit ...) - ([form spec]) - (*defforms #f - '(spec) (list (lambda (ignored) (schemeblock0/form spec))) - null null - (lambda () (list desc ...))))] + (begin + (for-each (lambda (id) + (unless (identifier? id) + (raise-syntax-error #f + "expected an identifier for a literal" + stx + id))) + (syntax->list #'(lit ...))) + #'(with-togetherable-scheme-variables + (lit ...) + ([form spec]) + (*defforms #f + '(spec) (list (lambda (ignored) (schemeblock0/form spec))) + null null + (lambda () (list desc ...)))))] [(_ spec desc ...) #'(defform/none #:literals () spec desc ...)])) From 35599a89550b7658318fae70d68d7d06a9bd33b9 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 30 Nov 2008 13:34:12 +0000 Subject: [PATCH 33/42] avoid duplicate subwindow callbacks in a text-field% svn: r12648 --- collects/mred/private/wxtextfield.ss | 3 ++ collects/mred/private/wxwindow.ss | 49 +++++++++++++++++----------- 2 files changed, 33 insertions(+), 19 deletions(-) diff --git a/collects/mred/private/wxtextfield.ss b/collects/mred/private/wxtextfield.ss index 990e6b6950..4ecd803007 100644 --- a/collects/mred/private/wxtextfield.ss +++ b/collects/mred/private/wxtextfield.ss @@ -142,6 +142,7 @@ [p (if horiz? this (let ([p (make-object wx-vertical-pane% #f proxy this null)]) + (send p skip-subwindow-events? #t) (send (send p area-parent) add-child p) p))]) (sequence @@ -166,7 +167,9 @@ '(hide-hscroll)) '(hide-vscroll hide-hscroll))))]) (sequence + (send c skip-subwindow-events? #t) (when l + (send l skip-subwindow-events? #t) (send l x-margin 0)) (send c set-x-margin 2) (send c set-y-margin 2) diff --git a/collects/mred/private/wxwindow.ss b/collects/mred/private/wxwindow.ss index a05e0c471e..8e708a7863 100644 --- a/collects/mred/private/wxwindow.ss +++ b/collects/mred/private/wxwindow.ss @@ -18,29 +18,36 @@ [focus? #f] [container this] [visible? #f] - [active? #f]) + [active? #f] + [skip-sub-events? #f]) (public [on-visible (lambda () (let ([vis? (is-shown-to-root?)]) (unless (eq? vis? visible?) (set! visible? vis?) - (as-exit - (lambda () - (send (wx->proxy this) on-superwindow-show vis?))))))] + (unless skip-sub-events? + (as-exit + (lambda () + (send (wx->proxy this) on-superwindow-show vis?)))))))] [queue-visible (lambda () (parameterize ([wx:current-eventspace (send (get-top-level) get-eventspace)]) - (wx:queue-callback (entry-point (lambda () (on-visible))) wx:middle-queue-key)))]) + (wx:queue-callback (entry-point (lambda () (on-visible))) wx:middle-queue-key)))] + [skip-subwindow-events? + (case-lambda + [() skip-sub-events?] + [(skip?) (set! skip-sub-events? skip?)])]) (public [on-active (lambda () (let ([act? (is-enabled-to-root?)]) (unless (eq? act? active?) (set! active? act?) - (as-exit - (lambda () - (send (wx->proxy this) on-superwindow-enable act?))))))] + (unless skip-sub-events? + (as-exit + (lambda () + (send (wx->proxy this) on-superwindow-enable act?)))))))] [queue-active (lambda () (parameterize ([wx:current-eventspace (send (get-top-level) get-eventspace)]) @@ -127,7 +134,7 @@ (define (make-window-glue% %) ; implies make-glue% (class100 (make-glue% %) (mred proxy . args) - (inherit get-x get-y get-width get-height area-parent get-mred get-proxy) + (inherit get-x get-y get-width get-height area-parent get-mred get-proxy skip-subwindow-events?) (private-field [pre-wx->proxy (lambda (orig-w e k) ;; MacOS: w may not be something the user knows @@ -211,16 +218,20 @@ (as-exit (lambda () (super on-kill-focus)))))] [pre-on-char (lambda (w e) (or (super pre-on-char w e) - (as-entry - (lambda () - (pre-wx->proxy w e - (lambda (m e) - (as-exit (lambda () - (send (get-proxy) on-subwindow-char m e)))))))))] + (if (skip-subwindow-events?) + #f + (as-entry + (lambda () + (pre-wx->proxy w e + (lambda (m e) + (as-exit (lambda () + (send (get-proxy) on-subwindow-char m e))))))))))] [pre-on-event (entry-point (lambda (w e) - (pre-wx->proxy w e - (lambda (m e) - (as-exit (lambda () - (send (get-proxy) on-subwindow-event m e)))))))]) + (if (skip-subwindow-events?) + #f + (pre-wx->proxy w e + (lambda (m e) + (as-exit (lambda () + (send (get-proxy) on-subwindow-event m e))))))))]) (sequence (apply super-init mred proxy args))))) From 1fa53fc4bf6690643092d87f855bf30b30e2e05f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 30 Nov 2008 14:22:28 +0000 Subject: [PATCH 34/42] Dave's patch to avoid out.xref warnings (a hack around the handin-server doc problem) svn: r12649 --- collects/setup/xref.ss | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/collects/setup/xref.ss b/collects/setup/xref.ss index be7e60819f..a9f60d3edf 100644 --- a/collects/setup/xref.ss +++ b/collects/setup/xref.ss @@ -23,8 +23,9 @@ (path-replace-suffix (file-name-from-path (car d)) #"")))]) (and (not (and (len . >= . 3) (memq 'omit (caddr d)))) - (let ([d (doc-path dir name flags 'false-if-missing)]) - (and d (build-path d "out.sxref"))))))) + (let* ([d (doc-path dir name flags 'false-if-missing)] + [p (and d (build-path d "out.sxref"))]) + (and p (file-exists? p) p)))))) (define (get-reader-thunks) (map (lambda (dest) From 67f29daee539833c6f99406baba7fc3726da4981 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 30 Nov 2008 14:32:58 +0000 Subject: [PATCH 35/42] reference doc corrections svn: r12650 --- .../reference/module-reflect.scrbl | 44 ++++++++++--------- .../scribblings/reference/stx-trans.scrbl | 22 +++++----- 2 files changed, 36 insertions(+), 30 deletions(-) diff --git a/collects/scribblings/reference/module-reflect.scrbl b/collects/scribblings/reference/module-reflect.scrbl index fc3d875c28..40bad5d696 100644 --- a/collects/scribblings/reference/module-reflect.scrbl +++ b/collects/scribblings/reference/module-reflect.scrbl @@ -51,9 +51,7 @@ the grammar for @scheme[_module-path] for @scheme[require], @defparam[current-module-name-resolver proc (case-> - (resolved-module-path? - . -> . - any) + (resolved-module-path? . -> . any) ((or/c module-path? path?) (or/c #f resolved-module-path?) (or/c #f syntax?) @@ -316,35 +314,41 @@ See also @scheme[module->language-info].} @;------------------------------------------------------------------------ @section[#:tag "dynreq"]{Dynamic Module Access} -@defproc[(dynamic-require [mod module-path?][provided (or/c symbol? #f void?)]) +@defproc[(dynamic-require [mod module-path?] + [provided (or/c symbol? #f void?)] + [fail-thunk (-> any) (lambda () ....)]) any]{ Dynamically instantiates the module specified by @scheme[mod] for @tech{phase} 0 in the current namespace's registry, if it is not yet -@tech{instantiate}d. If @scheme[mod] is not a symbol, the current -@tech{module name resolver} may load a module declaration to resolve -it (see @scheme[current-module-name-resolver]); the path is resolved -relative to @scheme[current-load-relative-directory] and/or +@tech{instantiate}d. The current @tech{module name resolver} may load +a module declaration to resolve @scheme[mod] (see +@scheme[current-module-name-resolver]); the path is resolved relative +to @scheme[current-load-relative-directory] and/or @scheme[current-directory]. If @scheme[provided] is @scheme[#f], then the result is @|void-const|, -and the module is not @tech{visit}ed (see -@secref["mod-parse"]). Otherwise, when @scheme[provided] is a symbol, -the value of the module's export with the given name is returned, and -still the module is not @tech{visit}ed. If the module exports -@scheme[provide] as syntax, then a use of the binding is expanded and -evaluated in a fresh namespace to which the module is attached, which -means that the module is @tech{visit}ed. If the module has no such -exported variable or syntax, or if the variable is protected (see -@secref["modprotect"]), the @exnraise[exn:fail:contract]. +and the module is not @tech{visit}ed (see @secref["mod-parse"]). + +When @scheme[provided] is a symbol, the value of the module's export +with the given name is returned, and still the module is not +@tech{visit}ed. If the module exports @scheme[provide] as syntax, then +a use of the binding is expanded and evaluated in a fresh namespace to +which the module is attached, which means that the module is +@tech{visit}ed. If the module has no such exported variable or syntax, +then @scheme[fail-thunk] is called; the default @scheme[fail-thunk] +raises @scheme[exn:fail:contract]. If the variable named by +@scheme[provided] is exported protected (see @secref["modprotect"]), +then the @exnraise[exn:fail:contract]. If @scheme[provided] is @|void-const|, then the module is -@tech{visit}ed but not @tech{instantiate}d (see -@secref["mod-parse"]). The result is @|void-const|.} +@tech{visit}ed but not @tech{instantiate}d (see @secref["mod-parse"]), +and the result is @|void-const|.} @defproc[(dynamic-require-for-syntax [mod module-path?] - [provided (or/c symbol? #f)]) + [provided (or/c symbol? #f)] + [fail-thunk (-> any) (lambda () ....)]) any]{ Like @scheme[dynamic-require], but in @tech{phase} 1.} diff --git a/collects/scribblings/reference/stx-trans.scrbl b/collects/scribblings/reference/stx-trans.scrbl index f05aad24f3..a7183c2278 100644 --- a/collects/scribblings/reference/stx-trans.scrbl +++ b/collects/scribblings/reference/stx-trans.scrbl @@ -396,14 +396,16 @@ exports of the module. @defproc[(syntax-local-get-shadower [id-stx identifier?]) identifier?]{ Returns @scheme[id-stx] if no binding in the current expansion context -shadows @scheme[id-stx], if @scheme[id-stx] has no module bindings in -its lexical information, and if the current expansion context is not a +shadows @scheme[id-stx] (ignoring unsealed @tech{internal-definition +contexts}), if @scheme[id-stx] has no module bindings in its lexical +information, and if the current expansion context is not a @tech{module context}. If a binding of @scheme[inner-identifier] shadows @scheme[id-stx], the -result is the same as -@scheme[(syntax-local-get-shadower inner-identifier)], except that it -has the location and properties of @scheme[id-stx]. +result is the same as @scheme[(syntax-local-get-shadower +inner-identifier)], except that it has the location and properties of +@scheme[id-stx]. When searching for a shadowing binding, bindings from +unsealed @tech{internal-definition contexts} are ignored. Otherwise, the result is the same as @scheme[id-stx] with its module bindings (if any) removed from its lexical information, and the @@ -473,7 +475,7 @@ mark}. Multiple applications of the same and different result procedures use distinct marks.} @defproc[(make-syntax-delta-introducer [ext-stx syntax?] - [base-stx syntax?] + [base-stx (or/c syntax? #f)] [phase-level (or/c #f exact-integer?) (syntax-local-phase-level)]) (syntax? . -> . syntax?)]{ @@ -482,10 +484,10 @@ Produces a procedure that behaves like @scheme[syntax-local-introduce], but using the @tech{syntax marks} of @scheme[ext-stx] that are not shared with @scheme[base-stx]. If @scheme[ext-stx] does not extend the set of marks in @scheme[base-stx] -but @scheme[ext-stx] has a module binding in the @tech{phase level} -indicated by @scheme[phase-level], then any marks of @scheme[ext-stx] -that would be needed to preserve its binding are not transferred in an -introduction. +or if @scheme[base-stx] is @scheme[#f], and if @scheme[ext-stx] has a +module binding in the @tech{phase level} indicated by +@scheme[phase-level], then any marks of @scheme[ext-stx] that would be +needed to preserve its binding are not transferred in an introduction. This procedure is potentially useful when @scheme[_m-id] has a transformer binding that records some @scheme[_orig-id], and a use of From 3b89976e377248fce12b788b6ec52dfe14e138d4 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 30 Nov 2008 18:26:25 +0000 Subject: [PATCH 36/42] new Mac file-dialog support only for 10.5 and up svn: r12652 --- src/wxmac/src/mac/wx_file_dialog.m | 66 +++++++++++++++++------------- 1 file changed, 37 insertions(+), 29 deletions(-) diff --git a/src/wxmac/src/mac/wx_file_dialog.m b/src/wxmac/src/mac/wx_file_dialog.m index f398b62fc4..9f7be5da6d 100644 --- a/src/wxmac/src/mac/wx_file_dialog.m +++ b/src/wxmac/src/mac/wx_file_dialog.m @@ -6,38 +6,46 @@ void wx_set_nav_file_types(NavDialogRef dlg, int cnt, char **exts, char *def_ext) { - if (cnt) { - id pool = [[NSAutoreleasePool alloc] init]; - id *objs; - int i, j, allow_others = 0; - NSArray *a; - NSSavePanel *sp = (NSSavePanel *)dlg; + SInt32 versionMajor, versionMinor; - for (i = 0; i < cnt; i++) { - if (!strcmp(exts[i], "*")) - allow_others = 1; - } - - objs = (id *)malloc(sizeof(id) * (1 + (cnt - allow_others))); - j = 0; - objs[j++] = [[NSString alloc] initWithUTF8String: def_ext]; - for (i = 0; i < cnt; i++) { - if (strcmp(exts[i], "*")) - objs[j++] = [[NSString alloc] initWithUTF8String: exts[i]]; - } - - a = [NSArray arrayWithObjects:objs count:j]; + Gestalt(gestaltSystemVersionMajor, &versionMajor); + Gestalt(gestaltSystemVersionMinor, &versionMinor); + + if ((versionMajor >= 10) + && (versionMinor >= 5)) { + if (cnt) { + id pool = [[NSAutoreleasePool alloc] init]; + id *objs; + int i, j, allow_others = 0; + NSArray *a; + NSSavePanel *sp = (NSSavePanel *)dlg; - [sp setAllowedFileTypes:a]; - [sp setCanSelectHiddenExtension:TRUE]; - if (!allow_others) - [sp setAllowsOtherFileTypes:FALSE]; + for (i = 0; i < cnt; i++) { + if (!strcmp(exts[i], "*")) + allow_others = 1; + } - for (i = 0; i < j; i++) { - [objs[i] release]; - } - free(objs); + objs = (id *)malloc(sizeof(id) * (1 + (cnt - allow_others))); + j = 0; + objs[j++] = [[NSString alloc] initWithUTF8String: def_ext]; + for (i = 0; i < cnt; i++) { + if (strcmp(exts[i], "*")) + objs[j++] = [[NSString alloc] initWithUTF8String: exts[i]]; + } + + a = [NSArray arrayWithObjects:objs count:j]; - [pool release]; + [sp setAllowedFileTypes:a]; + [sp setCanSelectHiddenExtension:TRUE]; + if (!allow_others) + [sp setAllowsOtherFileTypes:FALSE]; + + for (i = 0; i < j; i++) { + [objs[i] release]; + } + free(objs); + + [pool release]; + } } } From 224462a3f596f79b6ae3c6a30f202e0d6ab6928e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 30 Nov 2008 18:36:27 +0000 Subject: [PATCH 37/42] doc put-file behavior for 10.4 vs 10.5 svn: r12653 --- collects/scribblings/gui/dialog-funcs.scrbl | 26 +++++++++++++-------- 1 file changed, 16 insertions(+), 10 deletions(-) diff --git a/collects/scribblings/gui/dialog-funcs.scrbl b/collects/scribblings/gui/dialog-funcs.scrbl index 8ba5ac3b25..b5e60df5c5 100644 --- a/collects/scribblings/gui/dialog-funcs.scrbl +++ b/collects/scribblings/gui/dialog-funcs.scrbl @@ -118,16 +118,22 @@ Under Windows, if @scheme[extension] is not @scheme[#f], the returned path is @scheme[(string-append "*." extension)], then the result pathname is guaranteed to have an extension mapping @scheme[extension]. -Under Mac OS X, if @scheme[extension] is not @scheme[#f], the returned - path will get a default extension if the user does not supply one. - If @scheme[filters] contains as @scheme["*.*"] pattern, then the user - can supply any extension that is recognized by the system; otherwise, - the extension on the returned path will be either @scheme[extension] - or @scheme[_other-extension] for any @scheme[(string-append "*." - _other-extension)] pattern in @scheme[filters]. In particular, if the - only pattern in @scheme[filters] is empty or contains only - @scheme[(string-append "*." extension)], then the result pathname is - guaranteed to have an extension mapping @scheme[extension]. +Under Mac OS X 10.5 and later, if @scheme[extension] is not + @scheme[#f], the returned path will get a default extension if the + user does not supply one. If @scheme[filters] contains as + @scheme["*.*"] pattern, then the user can supply any extension that + is recognized by the system; otherwise, the extension on the returned + path will be either @scheme[extension] or @scheme[_other-extension] + for any @scheme[(string-append "*." _other-extension)] pattern in + @scheme[filters]. In particular, if the only pattern in + @scheme[filters] is empty or contains only @scheme[(string-append + "*." extension)], then the result pathname is guaranteed to have an + extension mapping @scheme[extension]. + +Under Mac OS X versions before 10.5, the returned path will get a + default extension only if @scheme[extension] is not @scheme[#f] and + @scheme[filters] contains only @scheme[(string-append "*." + extension)]. The @scheme[extension] argument is ignored under X, and @scheme[filters] can be used to specify glob-patterns. From 8905cc86e543bd2e1d5d39636892739552c01f70 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 30 Nov 2008 21:44:47 +0000 Subject: [PATCH 38/42] Added `sandbox-exit-handler' to control the exit handler svn: r12654 --- collects/scheme/sandbox.ss | 10 ++++++++-- collects/scribblings/reference/sandbox.scrbl | 6 ++++++ 2 files changed, 14 insertions(+), 2 deletions(-) diff --git a/collects/scheme/sandbox.ss b/collects/scheme/sandbox.ss index 048a8d0234..c1199582be 100644 --- a/collects/scheme/sandbox.ss +++ b/collects/scheme/sandbox.ss @@ -15,8 +15,9 @@ sandbox-coverage-enabled sandbox-namespace-specs sandbox-override-collection-paths - sandbox-security-guard sandbox-path-permissions + sandbox-security-guard + sandbox-exit-handler sandbox-network-guard sandbox-make-inspector sandbox-make-logger @@ -138,6 +139,11 @@ (define sandbox-security-guard (make-parameter default-sandbox-guard)) +(define (default-sandbox-exit-handler _) + (error 'exit "sandboxed code cannot exit")) + +(define sandbox-exit-handler (make-parameter default-sandbox-exit-handler)) + (define sandbox-make-inspector (make-parameter make-inspector)) (define sandbox-make-logger (make-parameter current-logger)) @@ -594,7 +600,7 @@ [current-command-line-arguments '#()] ;; restrict the sandbox context from this point [current-security-guard (sandbox-security-guard)] - [exit-handler (lambda x (error 'exit "user code cannot exit"))] + [exit-handler (sandbox-exit-handler)] [current-inspector ((sandbox-make-inspector))] [current-logger ((sandbox-make-logger))] ;; This breaks because we need to load some libraries that are trusted diff --git a/collects/scribblings/reference/sandbox.scrbl b/collects/scribblings/reference/sandbox.scrbl index d208e6c895..3db9ae43ee 100644 --- a/collects/scribblings/reference/sandbox.scrbl +++ b/collects/scribblings/reference/sandbox.scrbl @@ -448,6 +448,12 @@ collection libraries (including @scheme[make-evalautor] for more information.} +@defparam[sandbox-exit-handler handler (any/c . -> . any)]{ + +A parameter that determines the initial @scheme[(exit-handler)] for +sandboxed evaluations. The default handler simply throws an error.} + + @defparam[sandbox-network-guard proc (symbol? (or/c (and/c string? immutable?) #f) From 7ea8ab6592e4ea96121d24c3b3fa4ed355e653cd Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 1 Dec 2008 03:21:46 +0000 Subject: [PATCH 39/42] switch to #lang, reformat svn: r12655 --- collects/mzlib/sandbox.ss | 232 +++++++++++++++++++------------------- 1 file changed, 113 insertions(+), 119 deletions(-) diff --git a/collects/mzlib/sandbox.ss b/collects/mzlib/sandbox.ss index 582d1fd7f7..3ab4e60d50 100644 --- a/collects/mzlib/sandbox.ss +++ b/collects/mzlib/sandbox.ss @@ -1,124 +1,118 @@ -(module sandbox scheme/base - (require scheme/sandbox - (prefix-in mz: (only-in mzscheme make-namespace))) - (provide sandbox-init-hook - sandbox-reader - sandbox-input - sandbox-output - sandbox-error-output - sandbox-propagate-breaks - sandbox-coverage-enabled - sandbox-namespace-specs - sandbox-override-collection-paths - sandbox-security-guard - sandbox-path-permissions - sandbox-network-guard - sandbox-make-inspector - sandbox-eval-limits - kill-evaluator - break-evaluator - set-eval-limits - put-input - get-output - get-error-output - get-uncovered-expressions - call-with-limits - with-limits - exn:fail:resource? - exn:fail:resource-resource - (rename-out [*make-evaluator make-evaluator] - [gui? mred?])) +#lang scheme/base - (define-namespace-anchor anchor) +(require scheme/sandbox + (prefix-in mz: (only-in mzscheme make-namespace))) - ;; Compatbility: - ;; * recognize 'r5rs, etc, and wrap them as a list. - ;; * 'begin form of reqs - ;; * more agressively extract requires from lang and reqs - (define *make-evaluator - (case-lambda - [(lang reqs . progs) - (with-ns-params - (lambda () - (let ([beg-req? (and (list? reqs) - (pair? reqs) - (eq? 'begin (car reqs)))] - [reqs (or reqs '())] - [lang (or lang '(begin))]) - (keyword-apply - make-evaluator - '(#:allow-read #:requires) - (list (extract-requires lang reqs) - (if beg-req? null reqs)) - (case lang - [(r5rs beginner beginner-abbr intermediate intermediate-lambda advanced) - (list 'special lang)] - [else lang]) - (append - (if beg-req? (cdr reqs) null) - progs)))))] - [(mod) - (with-ns-params - (lambda () - (make-module-evaluator mod)))])) +(provide sandbox-init-hook + sandbox-reader + sandbox-input + sandbox-output + sandbox-error-output + sandbox-propagate-breaks + sandbox-coverage-enabled + sandbox-namespace-specs + sandbox-override-collection-paths + sandbox-security-guard + sandbox-path-permissions + sandbox-network-guard + sandbox-make-inspector + sandbox-eval-limits + kill-evaluator + break-evaluator + set-eval-limits + put-input + get-output + get-error-output + get-uncovered-expressions + call-with-limits + with-limits + exn:fail:resource? + exn:fail:resource-resource + (rename-out [*make-evaluator make-evaluator] + [gui? mred?])) - (define (make-mz-namespace) - (let ([ns (mz:make-namespace)]) - ;; Because scheme/sandbox needs scheme/base: - (namespace-attach-module (namespace-anchor->namespace anchor) - 'scheme/base - ns) - ns)) +(define-namespace-anchor anchor) - (define (with-ns-params thunk) - (let ([v (sandbox-namespace-specs)]) - (cond - [(and (not gui?) - (eq? (car v) make-base-namespace)) - (parameterize ([sandbox-namespace-specs - (cons make-mz-namespace - (cdr v))]) - (thunk))] - [(and gui? - (eq? (car v) (dynamic-require 'mred 'make-gui-namespace))) - (parameterize ([sandbox-namespace-specs - ;; Simulate the old make-namespace-with-mred: - (cons (lambda () - (let ([ns (make-mz-namespace)] - [ns2 ((dynamic-require 'mred 'make-gui-namespace))]) - (namespace-attach-module ns2 'mred ns) - (namespace-attach-module ns2 'scheme/class ns) - (parameterize ([current-namespace ns]) - (namespace-require 'mred) - (namespace-require 'scheme/class)) - ns)) - (cdr v))]) - (thunk))] - [else (thunk)]))) - - (define (literal-identifier=? x y) - (or (free-identifier=? x y) - (eq? (syntax-e x) (syntax-e y)))) +;; Compatbility: +;; * recognize 'r5rs, etc, and wrap them as a list. +;; * 'begin form of reqs +;; * more agressively extract requires from lang and reqs +(define *make-evaluator + (case-lambda + [(lang reqs . progs) + (with-ns-params + (lambda () + (let ([beg-req? (and (list? reqs) + (pair? reqs) + (eq? 'begin (car reqs)))] + [reqs (or reqs '())] + [lang (or lang '(begin))]) + (keyword-apply + make-evaluator + '(#:allow-read #:requires) + (list (extract-requires lang reqs) + (if beg-req? null reqs)) + (case lang + [(r5rs beginner beginner-abbr intermediate intermediate-lambda + advanced) + (list 'special lang)] + [else lang]) + (append (if beg-req? (cdr reqs) null) progs)))))] + [(mod) (with-ns-params (lambda () (make-module-evaluator mod)))])) - (define (extract-requires language requires) - (define (find-requires forms) - (let loop ([forms (reverse forms)] [reqs '()]) - (if (null? forms) - reqs - (loop (cdr forms) - (syntax-case* (car forms) (require) literal-identifier=? - [(require specs ...) - (append (syntax->datum #'(specs ...)) reqs)] - [_else reqs]))))) - (let* ([requires (if (and (pair? requires) (eq? 'begin (car requires))) - (find-requires (cdr requires)) - null)] - [requires (cond [(string? language) requires] - [(not (pair? language)) requires] - [(memq (car language) '(lib file planet quote)) - requires] - [(eq? (car language) 'begin) - (append (find-requires (cdr language)) requires)] - [else (error 'extract-requires - "bad language spec: ~e" language)])]) - requires))) +(define (make-mz-namespace) + (let ([ns (mz:make-namespace)]) + ;; Because scheme/sandbox needs scheme/base: + (namespace-attach-module (namespace-anchor->namespace anchor) + 'scheme/base ns) + ns)) + +(define (with-ns-params thunk) + (let ([v (sandbox-namespace-specs)]) + (cond [(and (not gui?) (eq? (car v) make-base-namespace)) + (parameterize ([sandbox-namespace-specs + (cons make-mz-namespace (cdr v))]) + (thunk))] + [(and gui? (eq? (car v) (dynamic-require 'mred 'make-gui-namespace))) + (parameterize + ([sandbox-namespace-specs + ;; Simulate the old make-namespace-with-mred: + (cons (lambda () + (let ([ns (make-mz-namespace)] + [ns2 ((dynamic-require + 'mred 'make-gui-namespace))]) + (namespace-attach-module ns2 'mred ns) + (namespace-attach-module ns2 'scheme/class ns) + (parameterize ([current-namespace ns]) + (namespace-require 'mred) + (namespace-require 'scheme/class)) + ns)) + (cdr v))]) + (thunk))] + [else (thunk)]))) + +(define (literal-identifier=? x y) + (or (free-identifier=? x y) (eq? (syntax-e x) (syntax-e y)))) + +(define (extract-requires language requires) + (define (find-requires forms) + (let loop ([forms (reverse forms)] [reqs '()]) + (if (null? forms) + reqs + (loop (cdr forms) + (syntax-case* (car forms) (require) literal-identifier=? + [(require specs ...) + (append (syntax->datum #'(specs ...)) reqs)] + [_else reqs]))))) + (let* ([requires (if (and (pair? requires) (eq? 'begin (car requires))) + (find-requires (cdr requires)) + null)] + [requires (cond [(string? language) requires] + [(not (pair? language)) requires] + [(memq (car language) '(lib file planet quote)) + requires] + [(eq? (car language) 'begin) + (append (find-requires (cdr language)) requires)] + [else (error 'extract-requires + "bad language spec: ~e" language)])]) + requires)) From 30adf7980a52411bac37a67f7eff7d68e6a58fa6 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 1 Dec 2008 03:37:02 +0000 Subject: [PATCH 40/42] switch to scheme/base for the sandbox interface and for use in tests svn: r12656 --- collects/tests/mzscheme/sandbox.ss | 66 +++++++++++++++--------------- 1 file changed, 34 insertions(+), 32 deletions(-) diff --git a/collects/tests/mzscheme/sandbox.ss b/collects/tests/mzscheme/sandbox.ss index f290c4ed86..cacbb51478 100644 --- a/collects/tests/mzscheme/sandbox.ss +++ b/collects/tests/mzscheme/sandbox.ss @@ -3,7 +3,7 @@ (Section 'sandbox) -(require mzlib/sandbox) +(require scheme/sandbox) (let ([ev void]) (define (run thunk) @@ -44,7 +44,7 @@ ;; basic stuff, limits --top-- - (set! ev (make-evaluator 'mzscheme '() + (set! ev (make-evaluator 'scheme/base (make-prog "(define x 1)" "(define (id x) x)" "(define (plus1 x) x)" @@ -112,7 +112,7 @@ (set! ev (parameterize ([sandbox-input "3\n"] [sandbox-output 'string] [sandbox-error-output current-output-port]) - (make-evaluator 'mzscheme '() '(define x 123)))) + (make-evaluator 'scheme/base '(define x 123)))) --eval-- (printf "x = ~s\n" x) => (void) --top-- (get-output ev) => "x = 123\n" --eval-- (printf "x = ~s\n" x) => (void) @@ -128,7 +128,7 @@ --top-- (set! ev (parameterize ([sandbox-output 'string] [sandbox-error-output 'string]) - (make-evaluator 'mzscheme '()))) + (make-evaluator 'scheme/base))) --eval-- (begin (printf "a\n") (fprintf (current-error-port) "b\n")) --top-- (get-output ev) => "a\n" (get-error-output ev) => "b\n" @@ -137,7 +137,7 @@ [sandbox-output 'bytes] [sandbox-error-output current-output-port] [sandbox-eval-limits '(0.25 10)]) - (make-evaluator 'mzscheme '() '(define x 123)))) + (make-evaluator 'scheme/base '(define x 123)))) --eval-- (begin (printf "x = ~s\n" x) (fprintf (current-error-port) "err\n")) --top-- (get-output ev) => #"x = 123\nerr\n" @@ -163,7 +163,7 @@ (let-values ([(i1 o1) (make-pipe)] [(i2 o2) (make-pipe)]) ;; o1 -> i1 -ev-> o2 -> i2 (set! ev (parameterize ([sandbox-input i1] [sandbox-output o2]) - (make-evaluator 'mzscheme '() '(define x 123)))) + (make-evaluator 'scheme/base '(define x 123)))) (t --eval-- (printf "x = ~s\n" x) => (void) --top-- (read-line i2) => "x = 123" --eval-- (printf "x = ~s\n" x) => (void) @@ -179,62 +179,63 @@ ;; sexprs as a program --top-- - (set! ev (make-evaluator 'mzscheme '() '(define id (lambda (x) x)))) + (set! ev (make-evaluator 'scheme/base '(define id (lambda (x) x)))) --eval-- (id 123) => 123 --top-- - (set! ev (make-evaluator 'mzscheme '() '(define id (lambda (x) x)) - '(define fooo 999))) + (set! ev (make-evaluator 'scheme/base '(define id (lambda (x) x)) + '(define fooo 999))) --eval-- (id fooo) => 999 ;; test source locations too --top-- - (make-evaluator 'mzscheme '() 0 1 2 '(define foo)) + (make-evaluator 'scheme/base 0 1 2 '(define foo)) =err> "program:4:0: define" ;; empty program for clean repls --top-- - (set! ev (make-evaluator '(begin) '())) + (set! ev (make-evaluator '(begin))) --eval-- (define x (+ 1 2 3)) => (void) x => 6 (define x (+ x 10)) => (void) x => 16 --top-- - (set! ev (make-evaluator 'mzscheme '())) + (set! ev (make-evaluator 'scheme/base)) --eval-- (define x (+ 1 2 3)) => (void) x => 6 (define x (+ x 10)) => (void) x => 16 --top-- - (set! ev (make-evaluator 'mzscheme '() '(define x (+ 1 2 3)))) + (set! ev (make-evaluator 'scheme/base '(define x (+ 1 2 3)))) --eval-- (define x (+ x 10)) =err> "cannot re-define a constant" ;; whole program argument --top-- - (set! ev (make-evaluator '(module foo mzscheme (define x 1)))) + (set! ev (make-module-evaluator '(module foo scheme/base (define x 1)))) --eval-- x => 1 --top-- - (set! ev (make-evaluator '(module foo mzscheme (provide x) (define x 1)))) + (set! ev (make-module-evaluator + '(module foo scheme/base (provide x) (define x 1)))) --eval-- x => 1 (define x 2) =err> "cannot re-define a constant" ;; limited FS access, allowed for requires --top-- - (let* ([tmp (find-system-path 'temp-dir)] - [mzlib (path->string (collection-path "mzlib"))] - [list-lib (path->string (build-path mzlib "list.ss"))] - [test-lib (path->string (build-path tmp "sandbox-test.ss"))]) + (let* ([tmp (find-system-path 'temp-dir)] + [schemelib (path->string (collection-path "scheme"))] + [list-lib (path->string (build-path schemelib "list.ss"))] + [test-lib (path->string (build-path tmp "sandbox-test.ss"))]) (t --top-- - (set! ev (make-evaluator 'mzscheme '())) + (set! ev (make-evaluator 'scheme/base)) --eval-- ;; reading from collects is allowed - (list (directory-list ,mzlib)) + (list (directory-list ,schemelib)) (file-exists? ,list-lib) => #t (input-port? (open-input-file ,list-lib)) => #t ;; writing is forbidden @@ -242,15 +243,16 @@ ;; reading from other places is forbidden (directory-list ,tmp) =err> "`read' access denied" ;; no network too + (require scheme/tcp) (tcp-listen 12345) =err> "network access denied" --top-- ;; reading from a specified require is fine (with-output-to-file test-lib (lambda () - (printf "~s\n" '(module sandbox-test mzscheme + (printf "~s\n" '(module sandbox-test scheme/base (define x 123) (provide x)))) #:exists 'replace) - (set! ev (make-evaluator 'mzscheme `(,test-lib))) + (set! ev (make-evaluator 'scheme/base #:requires `(,test-lib))) --eval-- x => 123 (length (with-input-from-file ,test-lib read)) => 5 @@ -259,7 +261,7 @@ --top-- ;; should work also for module evaluators ;; --> NO! Shouldn't make user code require whatever it wants - ;; (set! ev (make-evaluator `(module foo mzscheme + ;; (set! ev (make-evaluator `(module foo scheme/base ;; (require (file ,test-lib))))) ;; --eval-- ;; x => 123 @@ -271,7 +273,7 @@ (set! ev (parameterize ([sandbox-path-permissions `((read ,tmp) ,@(sandbox-path-permissions))]) - (make-evaluator 'mzscheme '()))) + (make-evaluator 'scheme/base))) --eval-- (length (with-input-from-file ,test-lib read)) => 5 (list? (directory-list ,tmp)) @@ -281,24 +283,24 @@ ;; languages and requires --top-- - (set! ev (make-evaluator 'r5rs '() "(define x (eq? 'x 'X))")) + (set! ev (make-evaluator '(special r5rs) "(define x (eq? 'x 'X))")) --eval-- x => #t --top-- - (set! ev (make-evaluator 'mzscheme '() "(define l null)")) + (set! ev (make-evaluator 'scheme/base "(define l null)")) --eval-- (cond [null? l 0]) => 0 (last-pair l) =err> "reference to an identifier" --top-- - (set! ev (make-evaluator 'beginner '() (make-prog "(define l null)" - "(define x 3.5)"))) + (set! ev (make-evaluator '(special beginner) + (make-prog "(define l null)" "(define x 3.5)"))) --eval-- (cond [null? l 0]) =err> "expected an open parenthesis" --top-- (eq? (ev "6") (ev "(sub1 (* 2 3.5))")) (eq? (ev "6") (ev "(sub1 (* 2 x))")) --top-- - (set! ev (make-evaluator 'mzscheme '(mzlib/list) '())) + (set! ev (make-evaluator 'scheme/base #:requires '(scheme/list))) --eval-- (last-pair '(1 2 3)) => '(3) (last-pair null) =err> "expected argument of type" @@ -306,7 +308,7 @@ ;; coverage --top-- (set! ev (parameterize ([sandbox-coverage-enabled #t]) - (make-evaluator 'mzscheme '() + (make-evaluator 'scheme/base (make-prog "(define (foo x) (+ x 1))" "(define (bar x) (+ x 2))" "(equal? (foo 3) 4)")))) @@ -327,7 +329,7 @@ (old) (compile-enforce-module-constants #f) (compile-allow-set!-undefined #t)))]) - (make-evaluator 'mzscheme '() '(define x 123)))) + (make-evaluator 'scheme/base '(define x 123)))) --eval-- (set! x 456) ; would be an error without the `enforce' parameter x => 456 From df62fbad7910b120196b5c9ccb5a3b2ec1488dc2 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 1 Dec 2008 11:27:35 +0000 Subject: [PATCH 41/42] fix typo (PR 9955) svn: r12658 --- collects/scribblings/reference/filesystem.scrbl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scribblings/reference/filesystem.scrbl b/collects/scribblings/reference/filesystem.scrbl index 20c6fba204..06f2f72270 100644 --- a/collects/scribblings/reference/filesystem.scrbl +++ b/collects/scribblings/reference/filesystem.scrbl @@ -225,7 +225,7 @@ exception.} @defproc[(delete-file [path path-string?]) void?]{ -Feletes the file with path @scheme[path] if it exists, otherwise the +Deletes the file with path @scheme[path] if it exists, otherwise the @exnraise[exn:fail:filesystem]. If @scheme[path] is a link, the link is deleted rather than the destination of the link.} From 6e9ccd3f4398e13b9d9bf9e0581819b673795a36 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 1 Dec 2008 12:54:16 +0000 Subject: [PATCH 42/42] better checking of case where a local name is used before it is defined (in an int-def context) svn: r12659 --- collects/scheme/private/class-internal.ss | 14 ++++++++++++++ collects/scheme/private/classidmap.ss | 12 +++++++----- 2 files changed, 21 insertions(+), 5 deletions(-) diff --git a/collects/scheme/private/class-internal.ss b/collects/scheme/private/class-internal.ss index 37006a569d..d98c6625bf 100644 --- a/collects/scheme/private/class-internal.ss +++ b/collects/scheme/private/class-internal.ss @@ -173,6 +173,20 @@ [super-instantiate super-instantiate-param] [super-new super-new-param]) + ;;-------------------------------------------------------------------- + ;; local member name lookup + ;;-------------------------------------------------------------------- + + (define-for-syntax (localize orig-id) + (do-localize orig-id #'validate-local-member)) + + (define (validate-local-member orig s) + (if (symbol? s) + s + (error 'local-member-name + "used before its definition: ~a" + orig))) + ;;-------------------------------------------------------------------- ;; class macros ;;-------------------------------------------------------------------- diff --git a/collects/scheme/private/classidmap.ss b/collects/scheme/private/classidmap.ss index f46886cf2f..b88fb8b098 100644 --- a/collects/scheme/private/classidmap.ss +++ b/collects/scheme/private/classidmap.ss @@ -293,15 +293,17 @@ (define-struct private-name (orig-id gen-id)) - (define (localize orig-id) + (define (do-localize orig-id validate-local-member-stx) (let loop ([id orig-id]) (let ([v (syntax-local-value id (lambda () #f))]) (cond [(and v (private-name? v)) (list 'unquote - (binding (private-name-orig-id v) - id - (private-name-gen-id v)))] + (list validate-local-member-stx + (list 'quote orig-id) + (binding (private-name-orig-id v) + id + (private-name-gen-id v))))] [(and (set!-transformer? v) (s!t? (set!-transformer-procedure v))) (s!t-ref (set!-transformer-procedure v) 1)] @@ -353,6 +355,6 @@ make-init-error-map make-init-redirect super-error-map make-with-method-map flatten-args make-method-call - make-private-name localize + do-localize make-private-name generate-super-call generate-inner-call generate-class-expand-context class-top-level-context?)))