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/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/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/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))))]))) 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"))) 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 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))))) 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" "⊒") 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)) 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/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 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 diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index 56c75225ef..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 "26nov2008") +#lang scheme/base (provide stamp) (define stamp "30nov2008") 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?))) 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/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 ...)])) diff --git a/collects/scribblings/gui/dialog-funcs.scrbl b/collects/scribblings/gui/dialog-funcs.scrbl index 45d2636f42..b5e60df5c5 100644 --- a/collects/scribblings/gui/dialog-funcs.scrbl +++ b/collects/scribblings/gui/dialog-funcs.scrbl @@ -118,22 +118,30 @@ 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 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]. -The @scheme[extension] argument is ignored under X, and @scheme[filters] - can be used to specify glob-patterns. +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[style] list is treated as for -@scheme[get-file]. +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]. See also @scheme[path-dialog%]. - - } @defproc[(get-directory [message (or/c string? false/c) #f] 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/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.} 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/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) 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 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%)]{ 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) 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)) 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 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))))) ;; ---------------------------------------- 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 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 diff --git a/src/mred/gc2/Makefile.in b/src/mred/gc2/Makefile.in index fa1ef5b076..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@ @@ -1348,7 +1350,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) @@ -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/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/gc2/newgc.c b/src/mzscheme/gc2/newgc.c index 4b0ad4cb1d..985f2e6bd7 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; } @@ -1247,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; @@ -1255,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; } @@ -1274,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(); @@ -1289,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; 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/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/jit.c b/src/mzscheme/src/jit.c index 89b9481b09..371de44920 100644 --- a/src/mzscheme/src/jit.c +++ b/src/mzscheme/src/jit.c @@ -41,6 +41,9 @@ #include "schpriv.h" #include "schmach.h" +#ifdef MZ_USE_DWARF_LIBUNWIND +# include "unwind/libunwind.h" +#endif #ifdef MZ_USE_JIT @@ -2315,6 +2318,24 @@ 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); +} + +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; @@ -2324,13 +2345,22 @@ 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, *code_end; + void *code; code = jit_get_ip().ptr; @@ -2339,9 +2369,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 +3951,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 +4008,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 +4043,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 +4073,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 +4580,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 +6471,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 +6541,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_R2); jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(2)); CHECK_RUNSTACK_OVERFLOW(); jit_str_p(JIT_RUNSTACK, JIT_R0); @@ -6541,29 +6578,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 +6667,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); } } @@ -6699,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 */ @@ -6720,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; @@ -7592,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); @@ -8091,9 +8138,17 @@ 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 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 + int use_unw = 0; if (!get_stack_pointer_code) return NULL; @@ -8102,8 +8157,16 @@ Scheme_Object *scheme_native_stack_trace(void) check_stack(); #endif +#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(); +#endif + stack_start = scheme_approx_sp(); if (stack_cache_stack_pos) { @@ -8115,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; @@ -8126,11 +8194,29 @@ 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 MZ_USE_DWARF_LIBUNWIND + if (use_unw) { + 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; + 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) manual_unw = 1; +#endif + if (SCHEME_FALSEP(name) || SCHEME_VOIDP(name)) { /* Code uses special calling convention */ #ifdef MZ_USE_JIT_PPC @@ -8138,30 +8224,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; @@ -8204,10 +8294,36 @@ 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 MZ_USE_DWARF_LIBUNWIND + if (use_unw) { + if (manual_unw) { + /* A JIT-generated function, so we unwind ourselves... */ + 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); + q = (void *)unw_get_ip(&c); + if ((q == prev_q) + || unw_reset_bad_ptr_flag()) + break; + } + } +#endif + + if (!use_unw) { + q = *(void **)p; + if (STK_COMP((unsigned long)q, (unsigned long)p)) + break; + p = q; + } } if (last) @@ -8237,9 +8353,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 */ diff --git a/src/mzscheme/src/unwind/libunwind.c b/src/mzscheme/src/unwind/libunwind.c new file mode 100644 index 0000000000..4dc7276dc9 --- /dev/null +++ b/src/mzscheme/src/unwind/libunwind.c @@ -0,0 +1,2511 @@ +/* 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 "../../sconfig.h" + +#ifdef MZ_USE_DWARF_LIBUNWIND + +#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; + if (!rs->coll_chain) + /* Something went wrong */ + 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; +} + +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; +} + +/*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)); + memset(unw_local_addr_space, 0, sizeof(unw_local_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); +} + +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 + +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 *(unw_word_t *)safe_pointer(((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 *)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; + c->dwarf.prev_rs = 0; +} + +#endif diff --git a/src/mzscheme/src/unwind/libunwind.h b/src/mzscheme/src/unwind/libunwind.h new file mode 100644 index 0000000000..504b9b4b5b --- /dev/null +++ b/src/mzscheme/src/unwind/libunwind.h @@ -0,0 +1,489 @@ +/* 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 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; + +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); + +#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..ee1cff6340 --- /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 + +#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 + 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 0 +#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) + +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); +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); +HIDDEN int dwarf_eval_expr (struct dwarf_cursor *c, unw_word_t *addr, + unw_word_t len, unw_word_t *valp, + int *is_register); +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); +HIDDEN int dwarf_find_save_locs (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); +HIDDEN 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 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 *) safe_pointer(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 *) safe_pointer(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 *) safe_pointer(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 *) safe_pointer(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_get_cfa(c) ((c)->dwarf.cfa) +#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) + +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. */ + +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 */ 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 @@ __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..9f7be5da6d --- /dev/null +++ b/src/wxmac/src/mac/wx_file_dialog.m @@ -0,0 +1,51 @@ + +/* Set options for the Cocoa file dialog */ + +#import +#include + +void wx_set_nav_file_types(NavDialogRef dlg, int cnt, char **exts, char *def_ext) +{ + SInt32 versionMajor, versionMinor; + + 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; + + 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 setCanSelectHiddenExtension:TRUE]; + if (!allow_others) + [sp setAllowsOtherFileTypes: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