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

checkpointing progress toward applicable structs instead of hash table

Browse Source
This commit is contained in:
John Clements 2010-12-04 21:57:46 -08:00
parent 6ac65c3907
commit 6f84a1c143
4 changed files with 269 additions and 179 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

165
collects/stepper/private/annotate.rkt
View File

@ -1,4 +1,4 @@
#lang scheme/base #lang racket/base
(require (prefix-in kernel: syntax/kerncase) (require (prefix-in kernel: syntax/kerncase)
mzlib/contract mzlib/contract
@ -9,7 +9,6 @@
"shared.ss" "shared.ss"
"my-macros.ss" "my-macros.ss"
#;"xml-box.ss" #;"xml-box.ss"
#;(file "/Users/clements/clements/scheme-scraps/eli-debug.ss")
(prefix-in beginner-defined: "beginner-defined.ss") (prefix-in beginner-defined: "beginner-defined.ss")
(for-syntax scheme/base)) (for-syntax scheme/base))
@ -103,11 +102,14 @@
; top-level-rewrite : (SYNTAX-OBJECT -> SYNTAX-OBJECT) ; top-level-rewrite : (SYNTAX-OBJECT -> SYNTAX-OBJECT)
; top-level-rewrite performs several tasks; it labels variables with their types (let-bound, lambda-bound, or non-lexical), ; top-level-rewrite performs several tasks; it labels variables with their types
; it flags if's which could come from cond's, it labels the begins in conds with 'stepper-skip annotations ; (let-bound, lambda-bound, or non-lexical), it flags if's which could come from
; cond's, it labels the begins in conds with 'stepper-skip annotations
; label-var-types returns a syntax object which is identical to the original except that the variable references are labeled ; label-var-types returns a syntax object which is identical to the original except
; with the stepper-syntax-property 'stepper-binding-type, which is set to either let-bound, lambda-bound, or non-lexical. ; that the variable references are labeled with the stepper-syntax-property
; 'stepper-binding-type, which is set to either let-bound, lambda-bound, or
; non-lexical.
(define (top-level-rewrite stx) (define (top-level-rewrite stx)
(let loop ([stx stx] (let loop ([stx stx]
@ -128,16 +130,30 @@
[do-let/rec [do-let/rec
(lambda (stx rec?) (lambda (stx rec?)
(with-syntax ([(label ((vars rhs) ...) . bodies) stx]) (with-syntax ([(label ((vars rhs) ...) . bodies) stx])
(let* ([vars-list (apply append (map syntax->list (syntax->list (syntax (vars ...)))))] (let* ([vars-list
[labelled-vars-list (map (lambda (var-list) (map (lambda (exp) (recur-with-bindings exp vars-list)) (apply append
(syntax->list var-list))) (map syntax->list
(syntax->list (syntax (vars ...))))] (syntax->list (syntax (vars ...)))))]
[rhs-list (if rec? [labelled-vars-list
(map (lambda (exp) (recur-with-bindings exp vars-list)) (syntax->list #'(rhs ...))) (map (lambda (var-list)
(map recur-regular (syntax->list #'(rhs ...))))] (map (lambda (exp)
[new-bodies (map (lambda (exp) (recur-with-bindings exp vars-list)) (syntax->list #'bodies))] (recur-with-bindings exp vars-list))
(syntax->list var-list)))
(syntax->list (syntax (vars ...))))]
[rhs-list
(if rec?
(map (lambda (exp)
(recur-with-bindings exp vars-list))
(syntax->list #'(rhs ...)))
(map recur-regular (syntax->list #'(rhs ...))))]
[new-bodies
(map (lambda (exp)
(recur-with-bindings exp vars-list))
(syntax->list #'bodies))]
[new-bindings (map list labelled-vars-list rhs-list)]) [new-bindings (map list labelled-vars-list rhs-list)])
(datum->syntax stx `(,#'label ,new-bindings ,@new-bodies) stx stx))))] (datum->syntax
stx
`(,#'label ,new-bindings ,@new-bodies) stx stx))))]
; evaluated at runtime, using 3D code: ; evaluated at runtime, using 3D code:
[put-into-xml-table (lambda (val) [put-into-xml-table (lambda (val)
@ -476,48 +492,78 @@
[lambda-clause-abstraction [lambda-clause-abstraction
(lambda (clause) (lambda (clause)
(with-syntax ([(args-stx . bodies) clause]) (with-syntax ([(args-stx . bodies) clause])
(let*-2vals ([(annotated-body free-varrefs) (match-let*
; wrap bodies in explicit begin if more than 1 user-introduced (non-skipped) bodies ([(vector annotated-body free-varrefs)
; NB: CAN'T HAPPEN in beginner up through int/lambda ; wrap bodies in explicit begin if more than 1
(if (> (length (filter (lambda (clause) ; user-introduced (non-skipped) bodies
(not (stepper-syntax-property clause 'stepper-skip-completely))) ; NB: CAN'T HAPPEN in beginner up through int/lambda
(syntax->list (syntax bodies)))) 1) (let ([non-skipped-bodies
(lambda-body-recur (syntax (begin . bodies))) (filter
(let*-2vals ([(annotated-bodies free-var-sets) (lambda (clause)
(2vals-map lambda-body-recur (syntax->list #`bodies))]) (not (skipped? clause)))
(2vals #`(begin . #,annotated-bodies) (varref-set-union free-var-sets))))] (syntax->list (syntax bodies)))])
[new-free-varrefs (varref-set-remove-bindings free-varrefs (if (> (length non-skipped-bodies) 1)
(arglist-flatten #'args-stx))]) (lambda-body-recur (syntax (begin . bodies)))
(2vals (datum->syntax #'here `(,#'args-stx ,annotated-body) #'clause) new-free-varrefs))))] (match-let*
([(vector annotated-bodies free-var-sets)
(2vals-map lambda-body-recur
(syntax->list #`bodies))])
(vector #`(begin . #,annotated-bodies)
(varref-set-union free-var-sets)))))]
[new-free-varrefs
(varref-set-remove-bindings
free-varrefs
(arglist-flatten #'args-stx))])
(vector (datum->syntax
#'here
`(,#'args-stx ,annotated-body) #'clause)
new-free-varrefs))))]
[outer-lambda-abstraction [outer-lambda-abstraction
(lambda (annotated-lambda free-varrefs) (lambda (annotated-lambda free-varrefs)
(let*-2vals (match-let*
([closure-info (make-debug-info-app 'all free-varrefs 'none)] ([ap-struct-maker
;; if we manually disable the storage of names, lambdas get rendered as lambdas. #`(#,annotated-proc #,annotated-lambda #f)]
[closure-name (if show-lambdas-as-lambdas? [closure-info (make-debug-info-app 'all free-varrefs 'none)]
#f ;; if we manually disable the storage of
(cond [(syntax? procedure-name-info) procedure-name-info] ;; names, lambdas get rendered as lambdas.
[(pair? procedure-name-info) (car procedure-name-info)] [closure-name
[else #f]))] (if show-lambdas-as-lambdas?
#f
(cond [(syntax? procedure-name-info) procedure-name-info]
[(pair? procedure-name-info)
(car procedure-name-info)]
[else #f]))]
[closure-storing-proc [closure-storing-proc
(opt-lambda (closure debug-info [lifted-index #f]) (opt-lambda (closure debug-info [lifted-index #f])
(closure-table-put! closure (make-closure-record (closure-table-put! closure
closure-name (make-closure-record
debug-info closure-name
#f debug-info
lifted-index)) #f
lifted-index))
closure)] closure)]
;; gnarr! I can't find a test case
;; that depends on the attachment of the inferred name...
[inferred-name-lambda [inferred-name-lambda
(if closure-name (if closure-name
(syntax-property annotated-lambda 'inferred-name (syntax-e closure-name)) (syntax-property
annotated-lambda
'inferred-name
(syntax-e closure-name))
annotated-lambda)] annotated-lambda)]
[captured [captured
(cond [(pair? procedure-name-info) (cond [(pair? procedure-name-info)
#`(#%plain-app #,closure-storing-proc #,inferred-name-lambda #,closure-info #`(#%plain-app
#,(cadr procedure-name-info))] #,closure-storing-proc
#,inferred-name-lambda
#,closure-info
#,(cadr procedure-name-info))]
[else [else
#`(#%plain-app #,closure-storing-proc #,inferred-name-lambda #,closure-info)])]) #`(#%plain-app
#,closure-storing-proc
#,inferred-name-lambda
#,closure-info)])])
(normal-bundle free-varrefs captured)))] (normal-bundle free-varrefs captured)))]
@ -803,19 +849,24 @@
(kernel:kernel-syntax-case exp #f (kernel:kernel-syntax-case exp #f
[(#%plain-lambda . clause) [(#%plain-lambda . clause)
(let*-2vals ([(annotated-clause free-varrefs) (match-let*
(lambda-clause-abstraction (syntax clause))] ([(vector annotated-clause free-varrefs)
[annotated-lambda (lambda-clause-abstraction #'clause)]
(with-syntax ([annotated-clause annotated-clause]) [annotated-lambda
(syntax/loc exp (#%plain-lambda . annotated-clause)))]) (with-syntax ([annotated-clause annotated-clause])
(syntax/loc exp
(#%plain-lambda . annotated-clause)))])
(outer-lambda-abstraction annotated-lambda free-varrefs))] (outer-lambda-abstraction annotated-lambda free-varrefs))]
[(case-lambda . clauses) [(case-lambda . clauses)
(let*-2vals ([(annotated-cases free-varrefs-cases) (match-let*
(2vals-map lambda-clause-abstraction (syntax->list (syntax clauses)))] ([(vector annotated-cases free-varrefs-cases)
[annotated-case-lambda (with-syntax ([annotated-cases annotated-cases]) (2vals-map lambda-clause-abstraction
(syntax/loc exp (case-lambda . annotated-cases)))] (syntax->list (syntax clauses)))]
[free-varrefs (varref-set-union free-varrefs-cases)]) [annotated-case-lambda
(with-syntax ([annotated-cases annotated-cases])
(syntax/loc exp (case-lambda . annotated-cases)))]
[free-varrefs (varref-set-union free-varrefs-cases)])
(outer-lambda-abstraction annotated-case-lambda free-varrefs))] (outer-lambda-abstraction annotated-case-lambda free-varrefs))]
@ -1225,3 +1276,7 @@
(define (stepper-recertify new-stx old-stx) (define (stepper-recertify new-stx old-stx)
(syntax-recertify new-stx old-stx saved-code-inspector #f)) (syntax-recertify new-stx old-stx saved-code-inspector #f))
;; does this stx have the 'stepper-skip-completely property?
(define (skipped? stx)
(stepper-syntax-property stx 'stepper-skip-completely))

125
collects/stepper/private/my-macros.rkt
View File

@ -1,89 +1,88 @@
(module my-macros mzscheme #lang racket
(require-for-syntax mzlib/list)
;;;;;;;;;; ;;;;;;;;;;
;; ;;
;; paul graham's [ _ ] macro ;; paul graham's [ _ ] macro
;; ;;
;;;;;;;;;; ;;;;;;;;;;
(provide lx) (provide lx)
(define-syntax (lx stx) (define-syntax (lx stx)
(syntax-case stx () (syntax-case stx ()
[(lx term) [(lx term)
(with-syntax ([binder (datum->syntax-object (syntax term) `_)]) (with-syntax ([binder (datum->syntax (syntax term) `_)])
(syntax (lambda (binder) term)))])) (syntax (lambda (binder) term)))]))
;;;;;;;;;; ;;;;;;;;;;
;; ;;
;; ccond implementation ;; ccond implementation
;; ;;
;;;;;;;;;; ;;;;;;;;;;
(provide ccond) (provide ccond)
(define-syntax (ccond stx) (define-syntax (ccond stx)
(syntax-case stx () (syntax-case stx ()
[(_ (question answer) ...) [(_ (question answer) ...)
(syntax (syntax
(cond (cond
(question answer) ... (question answer) ...
(else (error 'ccond "fell off end of cond expression"))))])) (else (error 'ccond "fell off end of cond expression"))))]))
;;;;;;;;;; ;;;;;;;;;;
;; ;;
;; 2vals implementation ;; 2vals implementation
;; ;;
;;;;;;;;;; ;;;;;;;;;;
;; honestly, match-let* supersedes all of this, if I ever have time to redo it... ;; honestly, match-let* supersedes all of this, if I ever have time to redo it...
(provide 2vals let*-2vals 2vals-first 2vals-second 2vals-map apply-to-first-of-2vals) (provide 2vals let*-2vals 2vals-first 2vals-second 2vals-map apply-to-first-of-2vals)
(define 2vals vector) (define 2vals vector)
(define-syntax (let*-2vals stx) (define-syntax (let*-2vals stx)
(syntax-case stx (let*-2vals) (syntax-case stx (let*-2vals)
[(let*-2vals () . bodies) [(let*-2vals () . bodies)
(syntax/loc stx (begin . bodies))] (syntax/loc stx (begin . bodies))]
[(let*-2vals ([(id-a id-b) rhs] binding ...) . bodies) ; 2 values in a vector [(let*-2vals ([(id-a id-b) rhs] binding ...) . bodies) ; 2 values in a vector
(syntax/loc stx (let* ([_a rhs] [id-a (vector-ref _a 0)] [id-b (vector-ref _a 1)]) (syntax/loc stx (let* ([_a rhs] [id-a (vector-ref _a 0)] [id-b (vector-ref _a 1)])
(let*-2vals (binding ...) . bodies)))] (let*-2vals (binding ...) . bodies)))]
[(let*-2vals ([id-a rhs] binding ...) . bodies) ; just 1 value [(let*-2vals ([id-a rhs] binding ...) . bodies) ; just 1 value
(quasisyntax/loc stx (let* ([id-a rhs]) (quasisyntax/loc stx (let* ([id-a rhs])
#,(syntax/loc stx (let*-2vals (binding ...) . bodies))))])) #,(syntax/loc stx (let*-2vals (binding ...) . bodies))))]))
(define-syntax (2vals-first stx) (define-syntax (2vals-first stx)
(syntax-case stx (2vals-first) (syntax-case stx (2vals-first)
[(2vals-first a) [(2vals-first a)
(syntax (vector-ref a 0))])) (syntax (vector-ref a 0))]))
(define-syntax (2vals-second stx) (define-syntax (2vals-second stx)
(syntax-case stx (2vals-second) (syntax-case stx (2vals-second)
[(2vals-second a) [(2vals-second a)
(syntax (vector-ref a 1))])) (syntax (vector-ref a 1))]))
(define (apply-to-first-of-2vals proc 2vals) (define (apply-to-first-of-2vals proc 2vals)
(vector (proc (vector-ref 2vals 0)) (vector (proc (vector-ref 2vals 0))
(vector-ref 2vals 1))) (vector-ref 2vals 1)))
; 2vals-map : (('a -> (2vals 'b 'c)) ('a list)) -> (2vals ('b list) ('c list)) ; 2vals-map : (('a -> (2vals 'b 'c)) ('a list)) -> (2vals ('b list) ('c list))
; dual-map is like map, only for a procedure that returns (values a b), and its ; dual-map is like map, only for a procedure that returns (values a b), and its
; result is (values a-list b-list)... the contract specifies this more clearly. ; result is (values a-list b-list)... the contract specifies this more clearly.
(define (2vals-map f . lsts) (define (2vals-map f . lsts)
(if (null? (car lsts)) (if (null? (car lsts))
(2vals null null) (2vals null null)
(let*-2vals ([(a b) (apply f (map car lsts))] (let*-2vals ([(a b) (apply f (map car lsts))]
[(a-rest b-rest) (apply 2vals-map f (map cdr lsts))]) [(a-rest b-rest) (apply 2vals-map f (map cdr lsts))])
(2vals (cons a a-rest) (cons b b-rest)))))) (2vals (cons a a-rest) (cons b b-rest)))))
; test cases ; test cases
; (require my-macros) ; (require my-macros)

83
collects/stepper/private/shared.rkt
View File

@ -1,30 +1,32 @@
#lang scheme #lang racket
(require "my-macros.ss" (require "my-macros.rkt"
srfi/26 srfi/26
scheme/class) scheme/class)
#;(require (for-syntax mzlib/list))
; CONTRACTS ; CONTRACTS
(define varref-set? (listof identifier?)) (define varref-set? (listof identifier?))
(define binding-set? (or/c varref-set? (symbols 'all))) (define binding-set? (or/c varref-set? (symbols 'all)))
(define (arglist? v) (define (arglist? v)
(or (null? v) (or (null? v)
(identifier? v) (identifier? v)
(and (pair? v) (and (pair? v)
((flat-contract-predicate (cons/c identifier? arglist?)) v)) ((flat-contract-predicate (cons/c identifier? arglist?)) v))
(and (syntax? v) (null? (syntax-e v))) (and (syntax? v) (null? (syntax-e v)))
(and (syntax? v) (and (syntax? v)
((flat-contract-predicate (cons/c identifier? arglist?)) (syntax-e v))))) ((flat-contract-predicate (cons/c identifier? arglist?)) (syntax-e v)))))
#;(provide/contract #;(provide/contract
[varref-set-remove-bindings (-> varref-set? varref-set? varref-set?)] [varref-set-remove-bindings (-> varref-set? varref-set? varref-set?)]
[binding-set-varref-set-intersect (-> binding-set? varref-set? binding-set?)] [binding-set-varref-set-intersect (-> binding-set? varref-set? binding-set?)]
[binding-set-union (-> (listof binding-set?) binding-set?)] [binding-set-union (-> (listof binding-set?) binding-set?)]
[varref-set-union (-> (listof varref-set?) varref-set?)] [varref-set-union (-> (listof varref-set?) varref-set?)]
[skipto/auto (syntax? (symbols 'rebuild 'discard) (syntax? . -> . syntax?) . -> . syntax?)] [skipto/auto (syntax? (symbols 'rebuild 'discard)
(syntax? . -> . syntax?)
. -> .
syntax?)]
[in-closure-table (-> any/c boolean?)] [in-closure-table (-> any/c boolean?)]
[sublist (-> number? number? list? list?)] [sublist (-> number? number? list? list?)]
[attach-info (-> syntax? syntax? syntax?)] [attach-info (-> syntax? syntax? syntax?)]
@ -98,25 +100,29 @@
skipto/fourth skipto/fourth
skipto/firstarg skipto/firstarg
(struct-out annotated-proc)
view-controller^ view-controller^
stepper-frame^ stepper-frame^
) )
;; stepper-syntax-property : like syntax property, but adds properties to an association ;; stepper-syntax-property : like syntax property, but adds properties to an association
;; list associated with the syntax property 'stepper-properties ;; list associated with the syntax property 'stepper-properties
(define stepper-syntax-property ;; 2010-12-05: I no longer see any reason not just to use the regular
(case-lambda ;; syntax-property for this...
[(stx tag) (let ([stepper-props (syntax-property stx 'stepper-properties)]) (define stepper-syntax-property
(if stepper-props (case-lambda
(let ([table-lookup (assq tag stepper-props)]) [(stx tag) (let ([stepper-props (syntax-property stx 'stepper-properties)])
(if table-lookup (if stepper-props
(cadr table-lookup) (let ([table-lookup (assq tag stepper-props)])
#f)) (if table-lookup
#f))] (cadr table-lookup)
[(stx tag new-val) (syntax-property stx 'stepper-properties #f))
(cons (list tag new-val) #f))]
(or (syntax-property stx 'stepper-properties) [(stx tag new-val) (syntax-property stx 'stepper-properties
null)))])) (cons (list tag new-val)
(or (syntax-property stx 'stepper-properties)
null)))]))
;; with-stepper-syntax-properties : like stepper-syntax-property, but in a "let"-like form ;; with-stepper-syntax-properties : like stepper-syntax-property, but in a "let"-like form
(define-syntax (with-stepper-syntax-properties stx) (define-syntax (with-stepper-syntax-properties stx)
@ -678,8 +684,8 @@
stx)])) stx)]))
;; the xml-snip-creation@ unit accepts the xml-snip% and scheme-snip% classes and provides ;; the xml-snip-creation@ unit accepts the xml-snip% and scheme-snip% classes and
;; functions which map a "spec" to an xml-snip. ;; provides functions which map a "spec" to an xml-snip.
;; An xml-spec is (listof xml-spec-elt) ;; An xml-spec is (listof xml-spec-elt)
;; An xml-spec-elt is either ;; An xml-spec-elt is either
;; - a string, ;; - a string,
@ -720,12 +726,23 @@
(car (last-pair (send language get-language-position)))) (car (last-pair (send language get-language-position))))
;; per Robby's suggestion: rather than using a hash table for
;; lambdas, just use an applicable structure instead.
;; An annotated procedure is represented at runtime by
;; an applicable structure that stores stepper information.
(struct annotated-proc (base info)
#:property prop:procedure
(struct-field-index base))
(define-signature view-controller^ (go)) (define-signature view-controller^ (go))
(define-signature stepper-frame^ (stepper-frame%)) (define-signature stepper-frame^ (stepper-frame%))
; test cases ; test cases
;(require shared) ;(require shared)
;(write (collection-path "tests" "mzscheme")) ;(write (collection-path "tests" "mzscheme"))

27
collects/tests/stepper/through-tests.rkt
View File

@ -213,6 +213,15 @@
-> ,@defs {(+ 12 9)} -> ,@defs {(+ 12 9)}
-> ,@defs {21})) -> ,@defs {21}))
;;intermediate/lambda hof
(let ([defs `((define (a x)
(lambda (y) (+ x y)))
(define b (a 9)))])
(t 'intermediate-lambda-hof m:intermediate-lambda
,@defs (b 5)
:: ,@defs {(b 5)}
-> @defs {'zoofrenzy}))
;;;;;;;;;;;; ;;;;;;;;;;;;
;; ;;
;; OR / AND ;; OR / AND
@ -604,9 +613,16 @@
(t1 'let-deriv (t1 'let-deriv
m:intermediate "(define (f g) (let ([gp (lambda (x) (/ (- (g (+ x 0.1)) (g x)) 0.001))]) gp)) (define gprime (f cos))" m:intermediate "(define (f g) (let ([gp (lambda (x) (/ (- (g (+ x 0.1)) (g x)) 0.001))]) gp)) (define gprime (f cos))"
(let ([defs `((define (f g) (let ([gp (lambda (x) (/ (- (g (+ x 0.1)) (g x)) 0.001))]) gp)))]) (let ([defs `((define (f g)
`((before-after (,@defs (define gprime (hilite (f cos)))) (let ([gp (lambda (x) (/ (- (g (+ x 0.1)) (g x)) 0.001))])
(,@defs (define gprime (hilite (let ([gp (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001))]) gp))))) gp)))])
`((before-after (,@defs (define gprime
(hilite (f cos))))
(,@defs (define gprime
(hilite (let ([gp (lambda (x)
(/ (- (cos (+ x 0.1)) (cos x))
0.001))])
gp)))))
(before-after (,@defs (define gprime (hilite (let ([gp (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001))]) gp)))) (before-after (,@defs (define gprime (hilite (let ([gp (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001))]) gp))))
(,@defs (hilite (define gp_0 (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001)))) (define gprime (hilite gp_0)))) (,@defs (hilite (define gp_0 (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001)))) (define gprime (hilite gp_0))))
(finished-stepping)))) (finished-stepping))))
@ -625,6 +641,8 @@
((define f_0 (lambda (x) (+ x 13))) (define a (hilite (lambda (x) (+ x 13)))))) ((define f_0 (lambda (x) (+ x 13))) (define a (hilite (lambda (x) (+ x 13))))))
(finished-stepping))) (finished-stepping)))
;;;;;;;;;;;;; ;;;;;;;;;;;;;
;; ;;
;; LET* ;; LET*
@ -1486,4 +1504,5 @@
check-error check-error-bad)) check-error check-error-bad))
#;(run-tests '(teachpack-universe)) #;(run-tests '(teachpack-universe))
#;(run-all-tests) #;(run-all-tests)
(run-tests '(check-expect)))) (run-tests '(intermediate-lambda-hof))
))