suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix problems in lex-rename simplification; other tiny improvements and doc repairs

Browse Source 
svn: r12380
This commit is contained in:
Matthew Flatt 2008-11-10 22:50:54 +00:00
parent 15ad16f28d
commit ad75c8aa58
6 changed files with 142 additions and 76 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
collects/mzlib/pretty.ss
View File

@ -1089,12 +1089,13 @@
(define max-call-head-width 5)
(define (no-sharing? expr count apair? acdr)
(if (and found
(apair? expr)
(hash-table-get found (acdr expr) #f))
#f
(or (zero? count)
(no-sharing? (acdr expr) (sub1 count) apair? acdr))))
(if (apair? expr)
(if (and found
(hash-table-get found (acdr expr) #f))
#f
(or (zero? count)
(no-sharing? (acdr expr) (sub1 count) apair? acdr)))
#f))
(define (style head expr apair? acar acdr)
(case (look-in-style-table head)

57
collects/mzlib/private/shared-body.ss
View File

@ -56,6 +56,7 @@
(and (cadr decl)
(andmap values (list-ref decl 4))
decl)))))))))]
[append-ids null]
[same-special-id? (lambda (a b)
;; Almost module-or-top-identifier=?,
;; but handle the-cons specially
@ -84,7 +85,7 @@
ph))
names placeholder-ids ph-used?s))
(loop expr)))
(syntax-case* expr (the-cons mcons list box box-immutable vector vector-immutable) same-special-id?
(syntax-case* expr (the-cons mcons append box box-immutable vector vector-immutable) same-special-id?
[(the-cons a d)
(with-syntax ([a (cons-elem #'a)]
[d (cons-elem #'d)])
@ -95,13 +96,28 @@
(syntax (mcons undefined undefined))]
[(mcons . _)
(bad "mcons")]
[(list e ...)
[(lst e ...)
(ormap (lambda (x) (free-identifier=? x #'lst))
(syntax->list #'(list list*)))
(with-syntax ([(e ...)
(map (lambda (x) (cons-elem x))
(syntax->list (syntax (e ...))))])
(syntax/loc expr (list e ...)))]
[(list . _)
(bad "list")]
(syntax/loc expr (lst e ...)))]
[(lst . _)
(ormap (lambda (x) (free-identifier=? x #'lst))
(syntax->list #'(list list*)))
(bad (syntax-e #'lst))]
[(append e0 ... e)
(let ([len-id (car (generate-temporaries '(len)))])
(set! append-ids (cons len-id append-ids))
(with-syntax ([e (cons-elem #'e)]
[len-id len-id])
(syntax/loc expr (let ([ph (make-placeholder e)]
[others (append e0 ... null)])
(set! len-id (length others))
(append others ph)))))]
[(append . _)
(bad "append")]
[(box v)
(syntax (box undefined))]
[(box . _)
@ -143,10 +159,12 @@
[(init-expr ...)
(map (lambda (expr temp-id used?)
(let ([init-id
(syntax-case* expr (the-cons mcons list box box-immutable vector vector-immutable) same-special-id?
(syntax-case* expr (the-cons mcons list list* append box box-immutable vector vector-immutable) same-special-id?
[(the-cons . _) temp-id]
[(mcons . _) temp-id]
[(list . _) temp-id]
[(list* . _) temp-id]
[(append . _) temp-id]
[(box . _) temp-id]
[(box-immutable . _) temp-id]
[(vector . _) temp-id]
@ -170,11 +188,13 @@
(if (null? l)
null
(cons (datum->syntax (quote-syntax here) n #f)
(loop (cdr l) (add1 n))))))])
(loop (cdr l) (add1 n))))))]
[append-ids (reverse append-ids)])
(map (lambda (name expr)
(let loop ([name name] [expr expr])
(with-syntax ([name name])
(syntax-case* expr (the-cons mcons list box box-immutable vector vector-immutable) same-special-id?
(syntax-case* expr (the-cons mcons list list* append box box-immutable vector vector-immutable)
same-special-id?
[(the-cons a d)
#`(begin #,(loop #`(car name) #'a)
#,(loop #`(cdr name) #'d))]
@ -189,6 +209,23 @@
(loop #`(list-ref name #,n) e))
(gen-n es)
es)))]
[(list* e ...)
(let* ([es (syntax->list #'(e ...))]
[last-n (sub1 (length es))])
#`(begin
#,@(map (lambda (n e)
(loop #`(#,(if (= (syntax-e n) last-n)
#'list-tail
#'list-ref)
name
#,n)
e))
(gen-n es)
es)))]
[(append e0 ... e)
(with-syntax ([len-id (car append-ids)])
(set! append-ids (cdr append-ids))
(loop #`(list-tail name len-id) #'e))]
[(box v)
(syntax (set-box! name v))]
[(box-immutable v)
@ -241,9 +278,11 @@
(and (unbox ph-used?)
#`(placeholder-set! #,ph #,graph-expr)))
placeholder-ids ph-used?s
(syntax->list #'(graph-expr ...))))])
(syntax->list #'(graph-expr ...))))]
[(append-id ...) append-ids])
(syntax/loc stx
(letrec-values ([(used-ph-id) (make-placeholder #f)] ...
[(append-id) #f] ...
[(temp-id ...)
(begin
ph-init ...

105
collects/scheme/private/class-internal.ss
View File

@ -69,20 +69,22 @@
;; keyword setup
;;--------------------------------------------------------------------
(define-for-syntax (do-class-keyword stx)
(if (identifier? stx)
(raise-syntax-error
#f
"illegal (unparenthesized) use of a class keyword"
stx)
(raise-syntax-error
#f
"use of a class keyword is not in a class top-level"
stx)))
(define-syntax provide-class-keyword
(syntax-rules ()
[(_ id ...)
(begin
(define-syntax (id stx)
(if (identifier? stx)
(raise-syntax-error
#f
"illegal (unparenthesized) use of a class keyword"
stx)
(raise-syntax-error
#f
"use of a class keyword is not in a class top-level"
stx)))
(define-syntax (id stx) (do-class-keyword stx))
...
(provide id ...))]))
@ -94,43 +96,47 @@
inspect
init-rest)
(define-for-syntax (do-define-like-internal stx)
(syntax-case stx ()
[(_ orig . __)
(raise-syntax-error
#f
"use of a class keyword is not in a class top-level"
#'orig)]))
(define-for-syntax (do-define-like stx internal-id)
(syntax-case stx ()
[(_ elem ...)
(syntax-property
#`(#,internal-id #,stx
#,@(map (lambda (e)
(if (identifier? e)
e
(syntax-property
(syntax-case e ()
[((n1 n2) . expr)
(quasisyntax/loc e
(#,(syntax-property
#'(n1 n2)
'certify-mode 'transparent)
. expr))]
[_else e])
'certify-mode 'transparent)))
(syntax-e #'(elem ...))))
'certify-mode
'transparent)]
[(_ . elems)
#`(#,internal-id #,stx . elems)]
[_else
(raise-syntax-error #f "illegal (unparenthesized) use of class keyword" stx)]))
(define-syntax provide-class-define-like-keyword
(syntax-rules ()
[(_ [internal-id id] ...)
(begin
(define-syntax (internal-id stx)
(syntax-case stx ()
[(_ orig . __)
(raise-syntax-error
#f
"use of a class keyword is not in a class top-level"
#'orig)]))
(define-syntax (internal-id stx) (do-define-like-internal stx))
...
(define-syntax (id stx)
(syntax-case stx ()
[(_ elem (... ...))
(syntax-property
#`(internal-id #,stx
#,@(map (lambda (e)
(if (identifier? e)
e
(syntax-property
(syntax-case e ()
[((n1 n2) . expr)
(quasisyntax/loc e
(#,(syntax-property
#'(n1 n2)
'certify-mode 'transparent)
. expr))]
[_else e])
'certify-mode 'transparent)))
(syntax-e #'(elem (... ...)))))
'certify-mode
'transparent)]
[(_ . elems)
#`(internal-id #,stx . elems)]
[_else
(raise-syntax-error #f "illegal (unparenthesized) use of class keyword" stx)]))
(define-syntax (id stx) (do-define-like stx #'internal-id))
...
(provide id ...))]))
@ -139,6 +145,14 @@
[-init init]
[-init-field init-field])
(define-for-syntax not-in-a-class
(lambda (stx)
(raise-syntax-error
#f
"use of a class keyword is not in a class"
stx)))
(define-syntax define/provide-context-keyword
(syntax-rules ()
[(_ (id param-id) ...)
@ -146,12 +160,7 @@
(begin
(provide id)
(define-syntax-parameter param-id
(make-set!-transformer
(lambda (stx)
(raise-syntax-error
#f
"use of a class keyword is not in a class"
stx))))
(make-set!-transformer not-in-a-class))
(define-syntax id
(make-parameter-rename-transformer #'param-id)))
...)]))

10
collects/scribblings/reference/shared.scrbl
View File

@ -38,14 +38,16 @@ following @scheme[_shared-expr] grammar, where earlier variants in a
production take precedence over later variants:
@schemegrammar*[
#:literals (cons list vector-immutable box-immutable mcons vector box)
#:literals (cons list list* append vector-immutable box-immutable mcons vector box)
[shared-expr shell-expr
plain-expr]
[shell-expr (cons in-immutable-expr in-immutable-expr)
(list in-immutable-expr ...)
(list* in-immutable-expr ...)
(append early-expr ... in-immutable-expr)
(vector-immutable in-immutable-expr ...)
(box-immutable in-immutable-expr)
(mcons patchable-expr)
(mcons patchable-expr patchable-expr)
(vector patchable-expr ...)
(box patchable-expr ...)
(#, @|maker| patchable-expr ...)]
@ -67,7 +69,7 @@ be one of the @scheme[id]s bound by the @scheme[shared] form to a
When the @scheme[expr]s of the @scheme[shared] form are parsed via
@scheme[_shared-expr] (taking into account the order of the variants
for precedence), and sub-expression that parses via
for precedence), and sub-expressions that parse via
@scheme[_early-expr] will be evaluated first when the @scheme[shared]
form is evaluated. Among such expressions, they are evaluated in the
order as they appear within the @scheme[shared] form. However, any
@ -90,7 +92,7 @@ where a reference to an @scheme[id] produces @|undefined-const| if it
is evaluated before the right-hand side of the @scheme[id] binding.
Finally, the @scheme[_patchable-expr]s are evaluated. At this point,
all @scheme[id]s are bound, so @scheme[_patchable-expr]s also created
all @scheme[id]s are bound, so @scheme[_patchable-expr]s also creates
data cycles (but only with cycles that can be created via mutation).
@examples[

2
src/mzscheme/gc2/newgc.c
View File

@ -1317,7 +1317,7 @@ void GC_register_new_thread(void *t, void *c)
/* administration / initialization */
/*****************************************************************************/
int designate_modified(void *p)
static int designate_modified(void *p)
{
NewGC *gc = GC_get_GC();
struct mpage *page = pagemap_find_page(gc->page_maps, p);

29
src/mzscheme/src/stxobj.c
View File

@ -4494,14 +4494,14 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca
(But don't mutate the wrap list, because that will stomp on
tables that might be needed by a propoagation.)
In addition to depending on the rest of the wraps, a
simplifciation can depend on preceding wraps due to rib
skipping. So the lex_cache maps a wrap to another hash table that
maps a skip list to a simplified rename.
A lex_cache maps wrap starts w to simplified tables. A lex_cache
is modified by this function, only, but it's also read in
datum_to_wraps. */
datum_to_wraps.
In addition to depending on the rest of the wraps, a
simplification can depend on preceding wraps due to rib
skipping. So the lex_cache maps a wrap to another hash table that
maps a skip list to a simplified rename. */
WRAP_POS_INIT(w, wraps);
WRAP_POS_INIT_END(prev);
@ -4548,7 +4548,7 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca
if (add) {
/* Need to simplify, but do deepest first: */
if (SCHEME_NULLP(stack) || !SAME_OBJ(SCHEME_CAR(stack), key)) {
if (SCHEME_NULLP(stack) || !SAME_OBJ(SCHEME_CAR(SCHEME_CAR(stack)), key)) {
stack = CONS(CONS(key, orig_skip_ribs), stack);
}
} else {
@ -4734,6 +4734,21 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca
SCHEME_VEC_ELS(v2)[0] = scheme_false;
SCHEME_VEC_ELS(v2)[1] = scheme_false;
{
/* Sometimes we generate the same simplified lex table, so
look for an equivalent one in the cache. */
v = scheme_hash_get(lex_cache, scheme_true);
if (!v) {
v = (Scheme_Object *)scheme_make_hash_table_equal();
scheme_hash_set(lex_cache, scheme_true, v);
}
svl = scheme_hash_get((Scheme_Hash_Table *)v, v2);
if (svl)
v2 = svl;
else
scheme_hash_set((Scheme_Hash_Table *)v, v2, v2);
}
v2l = CONS(v2, v2l);
}