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

all necessary changes to check references to uninitialized letrec variables

Browse Source 
includes a new pass, letrec_check, two new primitives, and
changes to packages that grabbed the letrec undefined value
This commit is contained in:
Claire Alvis 2013-05-07 09:36:47 -04:00 committed by Matthew Flatt
parent 800641e11a
commit 72c958df62
42 changed files with 3225 additions and 1150 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/algol60/runtime.rkt
View File

@ -1,4 +1,5 @@
(module runtime mzscheme
(require racket/undefined)
(provide (struct a60:array (vec dimens))
(struct a60:switch (choices))
@ -17,7 +18,6 @@
(define-struct a60:array (vec dimens))
(define-struct a60:switch (choices))
(define undefined (letrec ([x x]) x))
(define (check-boolean b) b)
(define (goto f) (f))
(define (get-value v) (v))

3
pkgs/compatibility-pkgs/compatibility-lib/mzlib/unit200.rkt
View File

@ -7,14 +7,13 @@
syntax/name
syntax/context
racket/syntax
racket/undefined
(only racket/base filter)
"private/unitidmap.rkt")
;; ----------------------------------------------------------------------
;; Structures and helpers
(define undefined (letrec ([x x]) x)) ; initial value
(define insp (current-inspector)) ; for named structures
(define-struct unit (num-imports exports go)) ; unit value

20
pkgs/htdp-pkgs/htdp-lib/lang/private/teach.rkt
View File

@ -38,6 +38,7 @@
mzlib/math
mzlib/pconvert-prop
scheme/match
racket/undefined
"set-result.rkt"
(only racket/base define-struct)
racket/struct-info
@ -87,15 +88,14 @@
(current-continuation-marks)))))
;; Wrapped around uses of local-bound variables:
(define (check-not-undefined name val)
(if (eq? val undefined)
(define (teach-check-not-undefined name val)
(if (undefined? val)
(raise
(make-exn:fail:contract:variable
(format "local variable used before its definition: ~a" name)
(current-continuation-marks)
name))
val))
(define undefined (letrec ([x x]) x))
(define (identifier-is-bound? id)
(or (identifier-binding id)
@ -1147,11 +1147,11 @@
;; For intermediate:
;; This application form disallows rator expressions that aren't
;; top-level identifiers or of the form `(check-not-undefined ...)'.
;; top-level identifiers or of the form `(teach-check-not-undefined ...)'.
;; The latter is probably surprising. It turns out that every use of
;; a `local'-bound identifier gets converted to an undefined check,
;; and the call to `check-not-undefined' can't be forged by the
;; and the call to `teach-check-not-undefined' can't be forged by the
;; programmer. So the pattern-match effectively recognizes uses of
;; `local'-bound identifiers, which are legal as rator
;; expressions. (`let' and `letrec' get converted to `local'.)
@ -1163,8 +1163,8 @@
(syntax-case stx ()
[(_ rator rand ...)
(let* ([fun (syntax rator)]
[undef-check? (syntax-case fun (check-not-undefined)
[(check-not-undefined id)
[undef-check? (syntax-case fun (teach-check-not-undefined)
[(teach-check-not-undefined id)
#t]
[_else #f])]
[binding (and (identifier? fun)
@ -1749,7 +1749,7 @@
((define-syntaxes (def-id/prop ...)
(values
(make-undefined-check
(quote-syntax check-not-undefined)
(quote-syntax teach-check-not-undefined)
(quote-syntax tmp-id))
...))
...)))])
@ -1818,7 +1818,7 @@
(quasisyntax/loc stx
(#%stratified-body
(define-syntaxes (name) (make-undefined-check
(quote-syntax check-not-undefined)
(quote-syntax teach-check-not-undefined)
(quote-syntax tmp-id)))
...
(define-values (tmp-id) rhs-expr)
@ -1853,7 +1853,7 @@
(let-values ([(tmp-id) rhs-expr] ...)
#,(stepper-syntax-property
#`(let-syntaxes ([(name) (make-undefined-check
(quote-syntax check-not-undefined)
(quote-syntax teach-check-not-undefined)
(quote-syntax tmp-id))]
...)
expr)

9
pkgs/pconvert-lib/mzlib/pconvert.rkt
View File

@ -4,7 +4,8 @@
(require (only racket/base sort)
compatibility/mlist
"pconvert-prop.rkt"
racket/class)
racket/class
racket/undefined)
(provide show-sharing
constructor-style-printing
@ -27,8 +28,6 @@
current-build-share-hook
current-print-convert-hook)
(define undefined-val (letrec ([x x]) x))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; the value stored in the hash table. Contains the name
;; <which is a number unless we are in donkey and it already has a name>
@ -123,7 +122,9 @@
(boolean? expr)
(char? expr) (void? expr)
(null? expr)
(eq? expr undefined-val) ; #<undefined> test - yuck
;; #<undefined> test - yuck, and maybe not worth checking
;; anymore, since undefined generally shouldn't escape
(undefined? expr)
)
'atomic]
[(and (not (struct? expr)) ;; struct names are the wrong thing, here

8
pkgs/plai/datatype.rkt
View File

@ -2,7 +2,8 @@
(require (for-syntax racket/base
racket/list)
racket/list
racket/contract)
racket/contract
racket/undefined)
(provide define-type type-case)
@ -86,11 +87,6 @@
stx)]
[_ (transfer-srcloc orig stx)]))))
(define the-undefined
(letrec ([x x]) x))
(define (undefined? x)
(eq? the-undefined x))
(define-syntax (define-type stx)
(syntax-parse
stx

2
pkgs/r5rs-pkgs/r5rs-lib/r5rs/main.rkt
View File

@ -1,5 +1,6 @@
(module main scheme/base
(require scheme/mpair
racket/undefined
(for-syntax scheme/base syntax/kerncase
"private/r5rs-trans.rkt")
(only-in mzscheme transcript-on transcript-off))
@ -243,7 +244,6 @@
;; Copied from R5rS, but with an added `let' around body,
;; and with optimization for precedure letrecs
(define undefined (letrec ([u u]) u))
(define-for-syntax (immediate-value? stx)
(let ([v (syntax-e stx)])
(or (number? v)

28
pkgs/racket-pkgs/racket-doc/scribblings/reference/data.scrbl
View File

@ -174,15 +174,27 @@ The @|void-const| value is always @racket[eq?] to itself.
@; ----------------------------------------------------------------------
@section[#:tag "undefined"]{Undefined}
The constant @|undefined-const| is used as the initial value for
@racket[letrec] bindings and in other places where a placeholder value
is needed before a specific value can be assigned. Use
@racket[undefined] (which is bound to @|undefined-const|) as a last resort.
@note-lib[racket/undefined]
The @|undefined-const| value is always @racket[eq?] to itself.
The constant @racket[undefined] is conceptually used as a placeholder
value for a binding, so that a reference to a binding before its
definition can be detected. Such references are normally protected
implicitly via @racket[check-not-undefined], so that an expression does
not normally produce an @racket[undefined] value.
@note-lib-only[racket/undefined]
The @racket[undefined] value is always @racket[eq?] to itself.
@defthing[undefined any/c]{The @|undefined-const| constant.}
@defproc[(undefined? [v any/c]) boolean?]{Returns @racket[#t] if @racket[v] is the
constant @racket[undefined], @racket[#f] otherwise.}
@history[#:added "6.0.0.6"]
@defthing[undefined undefined?]{The ``undefined'' constant.}
@defproc[(check-not-undefined [v any/c] [sym symbol?]) (and/c any/c (not/c undefined?))]{
Checks whether @racket[v] is @racket[undefined], and raises
@racket[exn:fail:contract:variable] in that case with an error message
along the lines of ``@racket[sym]: variable used before its definition.''
If @racket[v] is not @racket[undefined], then it is returned.
}

3
pkgs/racket-pkgs/racket-test/tests/racket/optimize.rktl
View File

@ -918,6 +918,9 @@
(test-comp '(let ([x 8][y 9]) (lambda () (+ x y)))
'(let ([x 8][y 9]) (lambda () (if #f y (+ x y)))))
;; Don't optimize away use before definition:
(test-comp '(letrec ([x (begin x 5)]) x) '5 #f)
(test-comp '(let ([x 5]) (set! x 2)) '(let ([x 5]) (set! x x) (set! x 2)))
(test-comp '(let* () (f 5))

14
pkgs/racket-pkgs/racket-test/tests/racket/syntax.rktl
View File

@ -87,8 +87,8 @@
(let ((x 4))
(lambda (y) (+ x y))))
(test 10 add4 6)
(test (letrec([x x]) x) 'lambda (let ([x (lambda () (define d d) d)]) (x)))
(test (letrec([x x]) x) 'lambda ((lambda () (define d d) d)))
(err/rt-test (let ([x (lambda () (define d d) d)]) (x)) exn:fail:contract:variable?)
(err/rt-test ((lambda () (define d d) d)) exn:fail:contract:variable?)
(test '(3 4 5 6) (lambda x x) 3 4 5 6)
(test '(5 6) (lambda (x y . z) z) 3 4 5 6)
(test 'second (lambda () (cons 'first 2) 'second))
@ -643,8 +643,8 @@
(test 'twox 'let*-values (let*-values ([() (values)][() (values)]) 'twox))
(test 'threex 'letrec-values (letrec-values ([() (values)][() (values)]) 'threex))
(letrec ([undef undef])
(test (list 1 undef undef) 'no-split-letrec (letrec-values ([(a b c) (values 1 a b)]) (list a b c))))
(err/rt-test (letrec-values ([(a b c) (values 1 a b)]) (list a b c))
exn:fail:contract:variable?)
(test '(10 11) 'letrec-values (letrec-values ([(names kps)
(letrec ([oloop 10])
@ -1642,13 +1642,15 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; check that the compiler is not too agressive with `letrec' -> `let*'
(test "#<undefined>\nready\n"
(test "<undefined>\nready\n"
get-output-string
(let ([p (open-output-string)])
(parameterize ([current-output-port p])
(let ([restart void])
(letrec ([dummy1 (let/cc k (set! restart k))]
[dummy2 (displayln maybe-ready)]
[dummy2 (displayln (with-handlers ([exn:fail:contract:variable?
(lambda (exn) '<undefined>)])
maybe-ready))]
[maybe-ready 'ready])
(let ([rs restart])
(set! restart void)

5
pkgs/swindle/tiny-clos.rkt
View File

@ -116,7 +116,8 @@
;;; OK, now let's get going. But, as usual, before we can do anything
;;; interesting, we have to muck around for a bit first. First, we need to
;;; load the support library. [-- replaced with a module.]
(require swindle/misc)
(require swindle/misc
racket/undefined)
;; This is a convenient function for raising exceptions
(define (raise* exn-maker fmt . args)
@ -219,7 +220,7 @@
;;> This is Racket's `unspecified' value which is used as the default
;;> value for unbound slots. It is provided so you can check if a slot is
;;> unbound.
(define* ??? (letrec ([x x]) x)) ; this is Racket's #<undefined> value
(define* ??? undefined)
(define unspecified-initializer (lambda args ???))
(define false-func (lambda args #f))

5
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/abbrev.rkt
View File

@ -8,6 +8,7 @@
racket/list
racket/match
racket/function
racket/undefined
unstable/function
(prefix-in c: (contract-req))
@ -91,8 +92,8 @@
(define/decl -Boolean (Un -False -True))
(define/decl -Undefined
(make-Base 'Undefined
#'(lambda (x) (equal? (letrec ([y y]) y) x)) ; initial value of letrec bindings
(lambda (x) (equal? (letrec ([y y]) y) x))))
#'undefined? ; initial value of letrec bindings
undefined?))
(define/decl -Bytes (make-Base 'Bytes #'bytes? bytes?))
(define/decl -Base-Regexp (make-Base 'Base-Regexp
#'(and/c regexp? (not/c pregexp?))

5
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/any-wrap.rkt
View File

@ -3,15 +3,14 @@
(require racket/match racket/contract/combinator
racket/fixnum racket/flonum
racket/set
racket/undefined
(only-in (combine-in racket/private/promise)
promise?
prop:force promise-forcer))
(define undef (letrec ([x x]) x))
(define (base-val? e)
(or (number? e) (string? e) (char? e) (symbol? e)
(null? e) (regexp? e) (eq? undef e) (path? e)
(null? e) (regexp? e) (undefined? e) (path? e)
(regexp? e) (keyword? e) (bytes? e) (boolean? e) (void? e)
;; Base values because you can only store flonums/fixnums in these
;; and not any higher-order values. This isn't sound if we ever

13
racket/collects/racket/contract/private/misc.rkt
View File

@ -557,26 +557,23 @@
(apply or/c ss))
(define atomic-value?
(let ([undefined (letrec ([x x]) x)])
(λ (x)
(or (char? x) (symbol? x) (boolean? x)
(null? x) (keyword? x) (number? x)
(void? x) (eq? x undefined)))))
(λ (x)
(or (char? x) (symbol? x) (boolean? x)
(null? x) (keyword? x) (number? x)
(void? x))))
(define/final-prop (one-of/c . elems)
(for ([arg (in-list elems)]
[i (in-naturals)])
(unless (atomic-value? arg)
(raise-argument-error 'one-of/c
"char, symbol, boolean, null, keyword, number, void, or undefined"
"char, symbol, boolean, null, keyword, number, or void"
i
elems)))
(define (undefined? x) (eq? x (letrec ([x x]) x)))
(define or/c-args
(map (λ (x)
(cond
[(void? x) void?]
[(undefined? x) undefined?]
[else x]))
elems))
(apply or/c or/c-args))

3
racket/collects/racket/private/class-c-old.rkt
View File

@ -3,6 +3,7 @@
racket/stxparam
syntax/parse)
racket/stxparam
racket/undefined
"class-wrapped.rkt"
"class-internal.rkt"
"../contract/base.rkt"
@ -20,8 +21,6 @@
build-internal-class/c internal-class/c-proj
class/c-internal-name-clauses)
(define undefined (letrec ([x x]) x))
;; Shorthand contracts that treat the implicit object argument as if it were
;; contracted with any/c.
(define-syntax-rule (->m . stx)

3
racket/collects/racket/private/class-internal.rkt
View File

@ -9,6 +9,7 @@
(only-in "../contract/region.rkt" current-contract-region)
"../contract/base.rkt"
"../contract/combinator.rkt"
racket/undefined
(for-syntax racket/stxparam
syntax/kerncase
syntax/stx
@ -4375,8 +4376,6 @@ An example
;; misc utils
;;--------------------------------------------------------------------
(define undefined (letrec ([x x]) x))
(define-struct (exn:fail:object exn:fail) () #:inspector insp)
(struct as-write (content))

5
racket/collects/racket/private/classidmap.rkt
View File

@ -3,6 +3,7 @@
(require syntax/stx
(for-syntax racket/base)
(for-template racket/base
racket/undefined
"class-wrapped.rkt"))
(define insp (variable-reference->module-declaration-inspector
@ -83,12 +84,12 @@
[(id . args)
(with-syntax ([bindings (syntax/loc stx ([obj obj-expr]))]
[call (quasisyntax/loc stx
(((unsyntax field-accessor) obj) . args))])
((check-not-undefined ((unsyntax field-accessor) obj) 'id) . args))])
(syntax/loc stx (let* bindings call)))]
[id
(with-syntax ([bindings (syntax/loc stx ([obj obj-expr]))]
[get (quasisyntax/loc stx
((unsyntax field-accessor) obj))])
(check-not-undefined ((unsyntax field-accessor) obj) 'id))])
(syntax/loc stx (let* bindings get)))])))))))
(define (make-method-map the-finder the-obj the-binder the-binder-localized method-accessor)

3
racket/collects/racket/private/pre-base.rkt
View File

@ -179,7 +179,8 @@
procedure->method procedure-rename
chaperone-procedure impersonate-procedure
assq assv assoc
prop:incomplete-arity prop:method-arity-error)
prop:incomplete-arity prop:method-arity-error
check-not-undefined undefined)
(all-from "reqprov.rkt")
(all-from-except "for.rkt"
define-in-vector-like

5
racket/collects/racket/private/unit-runtime.rkt
View File

@ -2,7 +2,7 @@
(require (for-syntax "unit-syntax.rkt" racket/base))
(provide define-syntax/err-param
undefined (rename-out [make-a-unit make-unit]) unit-import-sigs unit-export-sigs unit-go unit? unit-deps
(rename-out [make-a-unit make-unit]) unit-import-sigs unit-export-sigs unit-go unit? unit-deps
check-unit check-no-imports check-sigs check-deps check-helper)
(define-syntax define-syntax/err-param
@ -12,9 +12,6 @@
(parameterize ((error-syntax arg))
body)))))
;; initial value
(define undefined (letrec ([x x]) x))
;; for named structures
(define insp (current-inspector))

4
racket/collects/racket/shared.rkt
View File

@ -3,14 +3,14 @@
syntax/kerncase
syntax/struct
racket/struct-info
racket/include))
racket/include)
racket/undefined)
(provide shared)
(define-for-syntax code-insp (variable-reference->module-declaration-inspector
(#%variable-reference)))
(define undefined (letrec ([x x]) x))
(require (only-in racket/base [cons the-cons]))
(define-syntax shared

10
racket/collects/racket/undefined.rkt
View File

@ -1,8 +1,8 @@
#lang racket/base
(require '#%kernel)
(provide undefined)
(provide check-not-undefined
undefined
undefined?)
;; In a future version of Racket, this `letrec` pattern
;; will not work, but the `racket/undefined` library will
;; still export an `undefined`:
(define undefined (letrec ([x x]) x))
(define (undefined? v) (eq? v undefined))

4
racket/collects/racket/unit.rkt
View File

@ -17,6 +17,7 @@
"private/unit-syntax.rkt"))
(require racket/block
racket/undefined
racket/contract/base
racket/contract/region
racket/stxparam
@ -1186,7 +1187,8 @@
(lambda (int/ext-name index ctc)
(bound-identifier-mapping-put! def-table
(car int/ext-name)
#`(vector-ref #,v #,index))
#`(check-not-undefined (vector-ref #,v #,index)
'#,(car int/ext-name)))
(bound-identifier-mapping-put! ctc-table
(car int/ext-name)
ctc)

6
racket/collects/syntax/toplevel.rkt
View File

@ -1,5 +1,6 @@
(module toplevel racket/base
(require "kerncase.rkt")
(require "kerncase.rkt"
racket/undefined)
(provide eval-compile-time-part-of-top-level
eval-compile-time-part-of-top-level/compile
@ -74,8 +75,7 @@
(begin0
(when compile? (compile-syntax stx))
(for-each (lambda (id)
(with-syntax ([id id]
[undefined (letrec ([x x]) x)])
(with-syntax ([id id])
(eval-syntax (syntax (define-values (id) undefined)))))
(syntax->list (syntax (id ...)))))]
[_else

6
racket/src/racket/gc2/Makefile.in
View File

@ -76,6 +76,7 @@ OBJS = salloc.@LTO@ \
jitprep.@LTO@ \
jitstack.@LTO@ \
jitstate.@LTO@ \
letrec_check.@LTO@ \
list.@LTO@ \
marshal.@LTO@ \
module.@LTO@ \
@ -135,6 +136,7 @@ XSRCS = $(XSRCDIR)/salloc.c \
$(XSRCDIR)/jitprep.c \
$(XSRCDIR)/jitstack.c \
$(XSRCDIR)/jitstate.c \
$(XSRCDIR)/letrec_check.c \
$(XSRCDIR)/list.c \
$(XSRCDIR)/marshal.c \
$(XSRCDIR)/module.c \
@ -253,6 +255,8 @@ $(XSRCDIR)/marshal.c: ../src/marshal.@LTO@ $(XFORMDEP) $(SRCDIR)/mzrt.h
$(XFORM) $(XSRCDIR)/marshal.c $(SRCDIR)/marshal.c
$(XSRCDIR)/module.c: ../src/module.@LTO@ $(XFORMDEP) $(SRCDIR)/mzrt.h
$(XFORM) $(XSRCDIR)/module.c $(SRCDIR)/module.c
$(XSRCDIR)/letrec_check.c: ../src/letrec_check.@LTO@ $(XFORMDEP)
$(XFORM) $(XSRCDIR)/letrec_check.c $(SRCDIR)/letrec_check.c
$(XSRCDIR)/list.c: ../src/list.@LTO@ $(XFORMDEP)
$(XFORM) $(XSRCDIR)/list.c $(SRCDIR)/list.c
$(XSRCDIR)/network.c: ../src/network.@LTO@ $(XFORMDEP)
@ -360,6 +364,8 @@ jitstack.@LTO@: $(XSRCDIR)/jitstack.c
$(CC) $(ALL_CFLAGS) -c $(XSRCDIR)/jitstack.c -o jitstack.@LTO@
jitstate.@LTO@: $(XSRCDIR)/jitstate.c
$(CC) $(ALL_CFLAGS) -c $(XSRCDIR)/jitstate.c -o jitstate.@LTO@
letrec_check.@LTO@: $(XSRCDIR)/letrec_check.c
$(CC) $(ALL_CFLAGS) -c $(XSRCDIR)/letrec_check.c -o letrec_check.@LTO@
list.@LTO@: $(XSRCDIR)/list.c
$(CC) $(ALL_CFLAGS) -c $(XSRCDIR)/list.c -o list.@LTO@
marshal.@LTO@: $(XSRCDIR)/marshal.c

6
racket/src/racket/src/Makefile.in
View File

@ -39,6 +39,7 @@ OBJS = salloc.@LTO@ \
jitprep.@LTO@ \
jitstack.@LTO@ \
jitstate.@LTO@ \
letrec_check.@LTO@ \
list.@LTO@ \
marshal.@LTO@ \
module.@LTO@ \
@ -96,6 +97,7 @@ SRCS = $(srcdir)/salloc.c \
$(srcdir)/jitprep.c \
$(srcdir)/jitstack.c \
$(srcdir)/jitstate.c \
$(srcdir)/letrec_check.c \
$(srcdir)/list.c \
$(srcdir)/marshal.c \
$(srcdir)/module.c \
@ -226,6 +228,8 @@ jitstack.@LTO@: $(srcdir)/jitstack.c
$(CC) $(ALL_CFLAGS) -c $(srcdir)/jitstack.c -o jitstack.@LTO@
jitstate.@LTO@: $(srcdir)/jitstate.c
$(CC) $(ALL_CFLAGS) -c $(srcdir)/jitstate.c -o jitstate.@LTO@
letrec_check.@LTO@: $(srcdir)/letrec_check.c
$(CC) $(ALL_CFLAGS) -c $(srcdir)/letrec_check.c -o letrec_check.@LTO@
list.@LTO@: $(srcdir)/list.c
$(CC) $(ALL_CFLAGS) -c $(srcdir)/list.c -o list.@LTO@
marshal.@LTO@: $(srcdir)/marshal.c
@ -362,6 +366,8 @@ jitprep.@LTO@: $(COMMON_HEADERS) \
jitstack.@LTO@: $(COMMON_HEADERS) $(JIT_HEADERS) $(srcdir)/codetab.inc \
$(srcdir)/unwind/libunwind.h
jitstate.@LTO@: $(COMMON_HEADERS) $(JIT_HEADERS)
letrec_check.@LTO@: $(COMMON_HEADERS) \
$(srcdir)/stypes.h
list.@LTO@: $(COMMON_HEADERS) \
$(srcdir)/stypes.h
marshal.@LTO@: $(COMMON_HEADERS) \

11
racket/src/racket/src/compenv.c
View File

@ -28,6 +28,10 @@
#define TABLE_CACHE_MAX_SIZE 2048
/* Pre-allocate local variable reference objects.
first dimension: position in the current stack frame
second dimension: 0 for local variables, 1 for unboxed local variables
third dimension: flags. TODO has to do with whether something is an unboxed fixnum, flonum, or extnum */
READ_ONLY static Scheme_Object *scheme_local[MAX_CONST_LOCAL_POS][MAX_CONST_LOCAL_TYPES][MAX_CONST_LOCAL_FLAG_VAL + 1];
READ_ONLY static Scheme_Object *toplevels[MAX_CONST_TOPLEVEL_DEPTH][MAX_CONST_TOPLEVEL_POS][SCHEME_TOPLEVEL_FLAGS_MASK + 1];
@ -853,11 +857,14 @@ static Scheme_Object *alloc_local(short type, int pos)
return (Scheme_Object *)v;
}
/* type should be either scheme_local_type or scheme_local_unbox_type
TODO: double check that */
Scheme_Object *scheme_make_local(Scheme_Type type, int pos, int flags)
{
int k;
Scheme_Object *v, *key;
/* k is 0 if type is scheme_local_type and 1 if type is scheme_local_unbox_type */
k = type - scheme_local_type;
/* Helper for reading bytecode: make sure flags is a valid value */
@ -899,7 +906,9 @@ static Scheme_Local *get_frame_loc(Scheme_Comp_Env *frame,
int cnt, u;
u = COMPILE_DATA(frame)->use[i];
// flags -= (flags & SCHEME_APP_POS);
u |= (((flags & (SCHEME_APP_POS | SCHEME_SETTING))
? CONSTRAINED_USE
: ((u & (ARBITRARY_USE | ONE_ARBITRARY_USE)) ? ARBITRARY_USE : ONE_ARBITRARY_USE))

39
racket/src/racket/src/compile.c
View File

@ -1210,18 +1210,6 @@ set_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec,
rec[drec].value_name = SCHEME_STX_SYM(name);
val = scheme_compile_expr(body, scheme_no_defines(env), rec, drec);
/* check for (set! x x) */
if (SAME_TYPE(SCHEME_TYPE(var), SCHEME_TYPE(val))) {
if (SAME_TYPE(SCHEME_TYPE(var), scheme_local_type)
|| SAME_TYPE(SCHEME_TYPE(var), scheme_local_unbox_type)) {
/* local */
if (SCHEME_LOCAL_POS(var) == SCHEME_LOCAL_POS(val))
return scheme_compiled_void();
} else {
/* global; can't do anything b/c var might be undefined or constant */
}
}
set_undef = (rec[drec].comp_flags & COMP_ALLOW_SET_UNDEFINED);
@ -2073,7 +2061,7 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname,
int star, int recursive, int multi, Scheme_Compile_Info *rec, int drec,
Scheme_Comp_Env *frame_already)
{
Scheme_Object *bindings, *l, *binding, *name, **names, *forms, *defname;
Scheme_Object *bindings, *l, *binding, *name, **names, **clv_names, *forms, *defname;
int num_clauses, num_bindings, i, j, k, m, pre_k;
Scheme_Comp_Env *frame, *env, *rhs_env;
Scheme_Compile_Info *recs;
@ -2110,6 +2098,7 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname,
post_bind = !recursive && !star;
rev_bind_order = recursive;
/* forms ends up being the let body */
forms = SCHEME_STX_CDR(form);
forms = SCHEME_STX_CDR(forms);
forms = scheme_datum_to_syntax(forms, form, form, 0, 0);
@ -2266,6 +2255,16 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname,
lv->count = (k - pre_k);
lv->position = pre_k;
if (recursive) {
/* The names are only used for recursive bindings (in letrec_check),
currently. It would be ok if we record extra names, though. */
clv_names = MALLOC_N(Scheme_Object*, lv->count);
for (m = pre_k; m < k; m++) {
clv_names[m - pre_k] = SCHEME_STX_SYM(names[m]);
}
lv->names = clv_names;
}
if (lv->count == 1)
recs[i].value_name = SCHEME_STX_SYM(names[pre_k]);
@ -2827,6 +2826,8 @@ do_begin_syntax(char *name,
if (zero)
env = scheme_no_defines(env);
/* if the begin has only one expression inside, drop the begin
TODO: is this right */
if (SCHEME_STX_NULLP(SCHEME_STX_CDR(forms))) {
forms = SCHEME_STX_CAR(forms);
return scheme_compile_expr(forms, env, rec, drec);
@ -2924,9 +2925,9 @@ Scheme_Object *scheme_make_sequence_compilation(Scheme_Object *seq, int opt)
/* "Inline" nested begins */
count += ((Scheme_Sequence *)v)->count;
total++;
} else if (opt
&& (((opt > 0) && !last) || ((opt < 0) && !first))
&& scheme_omittable_expr(v, -1, -1, 0, NULL, NULL, -1, 0)) {
} else if (opt
&& (((opt > 0) && !last) || ((opt < 0) && !first))
&& scheme_omittable_expr(v, -1, -1, 0, NULL, NULL, -1, 1)) {
/* A value that is not the result. We'll drop it. */
total++;
} else {
@ -2954,7 +2955,7 @@ Scheme_Object *scheme_make_sequence_compilation(Scheme_Object *seq, int opt)
/* can't optimize away a begin0 at read time; it's too late, since the
return is combined with EXPD_BEGIN0 */
addconst = 1;
} else if ((opt < 0) && !scheme_omittable_expr(SCHEME_CAR(seq), 1, -1, 0, NULL, NULL, -1, 0)) {
} else if ((opt < 0) && !scheme_omittable_expr(SCHEME_CAR(seq), 1, -1, 0, NULL, NULL, -1, 1)) {
/* We can't optimize (begin0 expr cont) to expr because
exp is not in tail position in the original (so we'd mess
up continuation marks). */
@ -2986,7 +2987,7 @@ Scheme_Object *scheme_make_sequence_compilation(Scheme_Object *seq, int opt)
} else if (opt
&& (((opt > 0) && (k < total))
|| ((opt < 0) && k))
&& scheme_omittable_expr(v, -1, -1, 0, NULL, NULL, -1, 0)) {
&& scheme_omittable_expr(v, -1, -1, 0, NULL, NULL, -1, 1)) {
/* Value not the result. Do nothing. */
} else
o->array[i++] = v;
@ -3574,6 +3575,8 @@ void scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object
a = scheme_compile_expr_lift_to_let(a, eenv, &mrec, 0);
a = scheme_letrec_check_expr(a);
oi = scheme_optimize_info_create(eenv->prefix, 1);
if (!(rec[drec].comp_flags & COMP_CAN_INLINE))
scheme_optimize_info_never_inline(oi);

2096
racket/src/racket/src/cstartup.inc
View File

File diff suppressed because it is too large Load Diff

1
racket/src/racket/src/env.c
View File

@ -249,6 +249,7 @@ Scheme_Env *scheme_engine_instance_init()
scheme_init_portable_case();
scheme_init_compenv();
scheme_init_letrec_check();
scheme_init_optimize();
scheme_init_resolve();
scheme_init_sfs();

2
racket/src/racket/src/eval.c
View File

@ -4061,6 +4061,8 @@ static void *compile_k(void)
break;
}
o = scheme_letrec_check_expr(o);
oi = scheme_optimize_info_create(cenv->prefix, 1);
scheme_optimize_info_enforce_const(oi, enforce_consts);
if (!(comp_flags & COMP_CAN_INLINE))

27
racket/src/racket/src/fun.c
View File

@ -86,6 +86,7 @@ READ_ONLY Scheme_Object *scheme_values_func; /* the function bound to `values' *
READ_ONLY Scheme_Object *scheme_procedure_p_proc;
READ_ONLY Scheme_Object *scheme_procedure_arity_includes_proc;
READ_ONLY Scheme_Object *scheme_void_proc;
READ_ONLY Scheme_Object *scheme_check_not_undefined;
READ_ONLY Scheme_Object *scheme_apply_proc;
READ_ONLY Scheme_Object *scheme_call_with_values_proc; /* the function bound to `call-with-values' */
READ_ONLY Scheme_Object *scheme_reduced_procedure_struct;
@ -160,6 +161,7 @@ static Scheme_Object *extract_one_cc_mark (int argc, Scheme_Object *argv[]);
static Scheme_Object *call_with_immediate_cc_mark (int argc, Scheme_Object *argv[]);
static Scheme_Object *void_func (int argc, Scheme_Object *argv[]);
static Scheme_Object *void_p (int argc, Scheme_Object *argv[]);
static Scheme_Object *check_not_undefined (int argc, Scheme_Object *argv[]);
static Scheme_Object *dynamic_wind (int argc, Scheme_Object *argv[]);
#ifdef TIME_SYNTAX
static Scheme_Object *time_apply(int argc, Scheme_Object *argv[]);
@ -490,6 +492,14 @@ scheme_init_fun (Scheme_Env *env)
| SCHEME_PRIM_IS_OMITABLE);
scheme_add_global_constant("void?", o, env);
/* adds the new primitive check-undefined to the kernel langauge
check-undefined has an arity of 1 and no flags */
REGISTER_SO(scheme_check_not_undefined);
scheme_check_not_undefined = scheme_make_prim_w_arity(check_not_undefined, "check-not-undefined", 2, 2);
scheme_add_global_constant("check-not-undefined", scheme_check_not_undefined, env);
scheme_add_global_constant("undefined", scheme_undefined, env);
#ifdef TIME_SYNTAX
scheme_add_global_constant("time-apply",
scheme_make_prim_w_arity2(time_apply,
@ -2523,6 +2533,23 @@ void_p (int argc, Scheme_Object *argv[])
return SAME_OBJ(argv[0], scheme_void) ? scheme_true : scheme_false;
}
static Scheme_Object *
check_not_undefined (int argc, Scheme_Object *argv[])
{
if (!SCHEME_SYMBOLP(argv[1]))
scheme_wrong_contract("check-not-undefined", "symbol?", 1, argc, argv);
if (SAME_OBJ(argv[0], scheme_undefined)) {
scheme_raise_exn(MZEXN_FAIL_CONTRACT_VARIABLE,
argv[1],
"%S: variable used before its definition",
argv[1]);
}
return argv[0];
}
static Scheme_Object *
procedure_p (int argc, Scheme_Object *argv[])
{

1854
racket/src/racket/src/letrec_check.c Normal file
View File

File diff suppressed because it is too large Load Diff

6
racket/src/racket/src/mkmark.rkt
View File

@ -1,7 +1,7 @@
#lang racket/base
(define re:start "^START ([a-z]+);")
(define re:end "^END ([a-z]+);")
(define re:start "^START ([a-z_]+);")
(define re:end "^END ([a-z_]+);")
(define re:form "^([a-zA-Z0-9_]+) [{]")
@ -39,7 +39,7 @@
(loop (cdr l) (not skip?))]
[skip?
(loop (cdr l) #t)]
[(regexp-match? #rx"(START|END)_[A-Z]+_ONLY;" (car l))
[(regexp-match? #rx"(START|END)_[A-Z_]+_ONLY;" (car l))
(loop (cdr l) skip?)]
[else
(printf "~a\n" (car l))

6
racket/src/racket/src/module.c
View File

@ -8404,11 +8404,13 @@ static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env
/* Note: don't use MZCONFIG_USE_JIT for module bodies */
use_jit = scheme_startup_use_jit;
o = scheme_letrec_check_expr((Scheme_Object *)env->genv->module);
oi = scheme_optimize_info_create(env->prefix, 1);
scheme_optimize_info_enforce_const(oi, rec[drec].comp_flags & COMP_ENFORCE_CONSTS);
if (!(rec[drec].comp_flags & COMP_CAN_INLINE))
scheme_optimize_info_never_inline(oi);
o = scheme_optimize_expr((Scheme_Object *)env->genv->module, oi, 0);
o = scheme_optimize_expr(o, oi, 0);
rp = scheme_resolve_prefix(0, env->prefix, 1);
ri = scheme_resolve_info_create(rp);
@ -9014,6 +9016,8 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_
if (!for_stx)
lifted_reqs = scheme_append(scheme_frame_get_require_lifts(eenv), lifted_reqs);
m = scheme_letrec_check_expr(m);
oi = scheme_optimize_info_create(eenv->prefix, 1);
scheme_optimize_info_set_context(oi, (Scheme_Object *)env->genv->module);
if (!(rec[drec].comp_flags & COMP_CAN_INLINE))

78
racket/src/racket/src/mzmark_letrec_check.inc Normal file
View File

@ -0,0 +1,78 @@
/* >>>> Generated by mkmark.rkt from mzmarksrc.c <<<< */
static int mark_letrec_check_frame_SIZE(void *p, struct NewGC *gc) {
return
gcBYTES_TO_WORDS(sizeof(Letrec_Check_Frame));
}
static int mark_letrec_check_frame_MARK(void *p, struct NewGC *gc) {
Letrec_Check_Frame *frame = (Letrec_Check_Frame *)p;
gcMARK2(frame->def, gc);
gcMARK2(frame->next, gc);
gcMARK2(frame->ref, gc);
gcMARK2(frame->checked, gc);
gcMARK2(frame->head, gc);
gcMARK2(frame->deferred_with_rhs_ref, gc);
gcMARK2(frame->deferred_with_body_ref, gc);
gcMARK2(frame->deferred_with_no_ref, gc);
return
gcBYTES_TO_WORDS(sizeof(Letrec_Check_Frame));
}
static int mark_letrec_check_frame_FIXUP(void *p, struct NewGC *gc) {
Letrec_Check_Frame *frame = (Letrec_Check_Frame *)p;
gcFIXUP2(frame->def, gc);
gcFIXUP2(frame->next, gc);
gcFIXUP2(frame->ref, gc);
gcFIXUP2(frame->checked, gc);
gcFIXUP2(frame->head, gc);
gcFIXUP2(frame->deferred_with_rhs_ref, gc);
gcFIXUP2(frame->deferred_with_body_ref, gc);
gcFIXUP2(frame->deferred_with_no_ref, gc);
return
gcBYTES_TO_WORDS(sizeof(Letrec_Check_Frame));
}
#define mark_letrec_check_frame_IS_ATOMIC 0
#define mark_letrec_check_frame_IS_CONST_SIZE 1
static int mark_scheme_deferred_expr_SIZE(void *p, struct NewGC *gc) {
return
gcBYTES_TO_WORDS(sizeof(Scheme_Deferred_Expr));
}
static int mark_scheme_deferred_expr_MARK(void *p, struct NewGC *gc) {
Scheme_Deferred_Expr *clos = (Scheme_Deferred_Expr *)p;
gcMARK2(clos->expr, gc);
gcMARK2(clos->frame, gc);
gcMARK2(clos->uvars, gc);
gcMARK2(clos->pvars, gc);
gcMARK2(clos->subexpr_ls, gc);
return
gcBYTES_TO_WORDS(sizeof(Scheme_Deferred_Expr));
}
static int mark_scheme_deferred_expr_FIXUP(void *p, struct NewGC *gc) {
Scheme_Deferred_Expr *clos = (Scheme_Deferred_Expr *)p;
gcFIXUP2(clos->expr, gc);
gcFIXUP2(clos->frame, gc);
gcFIXUP2(clos->uvars, gc);
gcFIXUP2(clos->pvars, gc);
gcFIXUP2(clos->subexpr_ls, gc);
return
gcBYTES_TO_WORDS(sizeof(Scheme_Deferred_Expr));
}
#define mark_scheme_deferred_expr_IS_ATOMIC 0
#define mark_scheme_deferred_expr_IS_CONST_SIZE 1

8
racket/src/racket/src/mzmark_type.inc
View File

@ -628,6 +628,7 @@ static int comp_let_value_MARK(void *p, struct NewGC *gc) {
gcMARK2(c->flags, gc);
gcMARK2(c->value, gc);
gcMARK2(c->body, gc);
gcMARK2(c->names, gc);
return
gcBYTES_TO_WORDS(sizeof(Scheme_Compiled_Let_Value));
@ -639,6 +640,7 @@ static int comp_let_value_FIXUP(void *p, struct NewGC *gc) {
gcFIXUP2(c->flags, gc);
gcFIXUP2(c->value, gc);
gcFIXUP2(c->body, gc);
gcFIXUP2(c->names, gc);
return
gcBYTES_TO_WORDS(sizeof(Scheme_Compiled_Let_Value));
@ -1660,6 +1662,9 @@ static int input_port_MARK(void *p, struct NewGC *gc) {
gcMARK2(ip->input_extras_ready, gc);
gcMARK2(ip->unless, gc);
gcMARK2(ip->unless_cache, gc);
#ifdef WINDOWS_FILE_HANDLES
gcMARK2(ip->bufwidths, gc);
#endif
return
gcBYTES_TO_WORDS(sizeof(Scheme_Input_Port));
@ -1687,6 +1692,9 @@ static int input_port_FIXUP(void *p, struct NewGC *gc) {
gcFIXUP2(ip->input_extras_ready, gc);
gcFIXUP2(ip->unless, gc);
gcFIXUP2(ip->unless_cache, gc);
#ifdef WINDOWS_FILE_HANDLES
gcFIXUP2(ip->bufwidths, gc);
#endif
return
gcBYTES_TO_WORDS(sizeof(Scheme_Input_Port));

38
racket/src/racket/src/mzmarksrc.c
View File

@ -235,6 +235,7 @@ comp_let_value {
gcMARK2(c->flags, gc);
gcMARK2(c->value, gc);
gcMARK2(c->body, gc);
gcMARK2(c->names, gc);
size:
gcBYTES_TO_WORDS(sizeof(Scheme_Compiled_Let_Value));
@ -1327,6 +1328,43 @@ END sfs;
/**********************************************************************/
START letrec_check;
mark_letrec_check_frame {
mark:
Letrec_Check_Frame *frame = (Letrec_Check_Frame *)p;
gcMARK2(frame->def, gc);
gcMARK2(frame->next, gc);
gcMARK2(frame->ref, gc);
gcMARK2(frame->checked, gc);
gcMARK2(frame->head, gc);
gcMARK2(frame->deferred_with_rhs_ref, gc);
gcMARK2(frame->deferred_with_body_ref, gc);
gcMARK2(frame->deferred_with_no_ref, gc);
size:
gcBYTES_TO_WORDS(sizeof(Letrec_Check_Frame));
}
mark_scheme_deferred_expr {
mark:
Scheme_Deferred_Expr *clos = (Scheme_Deferred_Expr *)p;
gcMARK2(clos->expr, gc);
gcMARK2(clos->frame, gc);
gcMARK2(clos->uvars, gc);
gcMARK2(clos->pvars, gc);
gcMARK2(clos->subexpr_ls, gc);
size:
gcBYTES_TO_WORDS(sizeof(Scheme_Deferred_Expr));
}
END letrec_check;
/**********************************************************************/
START optimize;
mark_optimize_info {

21
racket/src/racket/src/optimize.c
View File

@ -250,7 +250,7 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved,
If warn_info is supplied, complain when a mismatch is detected.
If no_id is 1, then an identifier doesn't count as omittable,
unless the identifier is a consistent top-level; currently, this
is used to imply the absece of a continuation-mark impersonator. */
is used to imply the absence of a continuation-mark impersonator. */
{
Scheme_Type vtype;
@ -439,6 +439,15 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved,
return 0;
}
/* check for (set! x x) */
if (vtype == scheme_set_bang_type) {
Scheme_Set_Bang *sb = (Scheme_Set_Bang *)o;
if (SAME_TYPE(scheme_local_type, SCHEME_TYPE(sb->var))
&& SAME_TYPE(scheme_local_type, SCHEME_TYPE(sb->val))
&& (SCHEME_LOCAL_POS(sb->var) == SCHEME_LOCAL_POS(sb->val)))
return 1;
}
/* check for struct-type declaration: */
{
Scheme_Object *auto_e;
@ -2568,6 +2577,16 @@ static Scheme_Object *optimize_application3(Scheme_Object *o, Optimize_Info *inf
app = (Scheme_App3_Rec *)o;
if (SAME_OBJ(app->rator, scheme_check_not_undefined)
&& SCHEME_SYMBOLP(app->rand2)) {
scheme_log(info->logger,
SCHEME_LOG_WARNING,
0,
"warning%s: use-before-definition check inserted on variable: %S",
scheme_optimize_context_to_string(info->context),
app->rand2);
}
/* Check for (apply ... (list ...)) early: */
le = direct_apply((Scheme_Object *)app, app->rator, app->rand2, info);
if (le) return scheme_optimize_expr(le, info, context);

1
racket/src/racket/src/print.c
View File

@ -2028,6 +2028,7 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
if (compact && (SCHEME_PROCP(obj)
|| SCHEME_STRUCT_TYPEP(obj)
|| SCHEME_EOFP(obj)
|| SAME_OBJ(scheme_undefined, obj)
|| SAME_TYPE(scheme_always_evt_type, SCHEME_TYPE(obj))
|| SAME_TYPE(scheme_never_evt_type, SCHEME_TYPE(obj))
|| SAME_TYPE(scheme_struct_property_type, SCHEME_TYPE(obj))

2
racket/src/racket/src/schminc.h
View File

@ -14,7 +14,7 @@
#define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 1116
#define EXPECTED_PRIM_COUNT 1118
#define EXPECTED_UNSAFE_COUNT 101
#define EXPECTED_FLFXNUM_COUNT 69
#define EXPECTED_EXTFL_COUNT 45

7
racket/src/racket/src/schpriv.h
View File

@ -18,6 +18,8 @@
#ifndef __mzscheme_private__
#define __mzscheme_private__
// #define MZ_GC_STRESS_TESTING 1
#include "scheme.h"
#include "longdouble/longdouble.h"
@ -263,6 +265,7 @@ void scheme_init_type();
void scheme_init_custodian_extractors();
void scheme_init_bignum();
void scheme_init_compenv();
void scheme_init_letrec_check();
void scheme_init_optimize();
void scheme_init_resolve();
void scheme_init_sfs();
@ -432,6 +435,7 @@ extern Scheme_Object *scheme_values_func;
extern Scheme_Object *scheme_procedure_p_proc;
extern Scheme_Object *scheme_procedure_arity_includes_proc;
extern Scheme_Object *scheme_void_proc;
extern Scheme_Object *scheme_check_not_undefined;
extern Scheme_Object *scheme_pair_p_proc;
extern Scheme_Object *scheme_mpair_p_proc;
extern Scheme_Object *scheme_unsafe_cons_list_proc;
@ -1346,6 +1350,7 @@ typedef struct Scheme_Compiled_Let_Value {
int *flags;
Scheme_Object *value;
Scheme_Object *body;
Scheme_Object **names; /* NULL after letrec_check phase */
} Scheme_Compiled_Let_Value;
#define SCHEME_CLV_FLAGS(clv) MZ_OPT_HASH_KEY(&(clv)->iso)
@ -2856,6 +2861,8 @@ typedef struct Scheme_Set_Bang {
Scheme_Object *scheme_protect_quote(Scheme_Object *expr);
Scheme_Object *scheme_letrec_check_expr(Scheme_Object *);
Scheme_Object *scheme_optimize_expr(Scheme_Object *, Optimize_Info *, int context);
Scheme_Object *scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, int context);

4
racket/src/racket/src/schvers.h
View File

@ -13,12 +13,12 @@
consistently.)
*/
#define MZSCHEME_VERSION "6.0.1.1"
#define MZSCHEME_VERSION "6.0.1.2"
#define MZSCHEME_VERSION_X 6
#define MZSCHEME_VERSION_Y 0
#define MZSCHEME_VERSION_Z 1
#define MZSCHEME_VERSION_W 1
#define MZSCHEME_VERSION_W 2
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

2
racket/src/racket/src/stypes.h
View File

@ -288,7 +288,9 @@ enum {
scheme_rt_lightweight_cont, /* 260 */
scheme_rt_export_info, /* 261 */
scheme_rt_cont_jmp, /* 262 */
scheme_rt_letrec_check_frame, /* 263 */
#endif
scheme_deferred_expr_type, /* 264 */
_scheme_last_type_
};