163 lines
5.9 KiB
Scheme
163 lines
5.9 KiB
Scheme
(module contract-opt-guts mzscheme
|
|
(require (lib "private/boundmap.ss" "syntax")
|
|
(lib "list.ss")
|
|
"contract-guts.ss")
|
|
(require-for-template mzscheme)
|
|
|
|
(provide get-opter reg-opter! opter
|
|
interleave-lifts
|
|
|
|
make-opt/info
|
|
opt/info-contract
|
|
opt/info-val
|
|
opt/info-pos
|
|
opt/info-neg
|
|
opt/info-src-info
|
|
opt/info-orig-str
|
|
opt/info-free-vars
|
|
opt/info-recf
|
|
opt/info-base-pred
|
|
opt/info-this
|
|
opt/info-that
|
|
|
|
opt/info-swap-blame
|
|
opt/info-change-val)
|
|
|
|
;; a hash table of opters
|
|
(define opters-table
|
|
(make-module-identifier-mapping))
|
|
|
|
;; get-opter : syntax -> opter
|
|
(define (get-opter ctc)
|
|
(module-identifier-mapping-get opters-table ctc (λ () #f)))
|
|
|
|
;; opter : (union symbol identifier) -> opter
|
|
(define (opter ctc)
|
|
(if (identifier? ctc)
|
|
(get-opter ctc)
|
|
(error 'opter "the argument must be a bound identifier, got ~e" ctc)))
|
|
|
|
;; reg-opter! : symbol opter ->
|
|
(define (reg-opter! ctc opter)
|
|
(module-identifier-mapping-put! opters-table ctc opter))
|
|
|
|
;; interleave-lifts : list list -> list
|
|
;; interleaves a list of variables names and a list of sexps into a list of
|
|
;; (var sexp) pairs.
|
|
(define (interleave-lifts vars sexps)
|
|
(if (= (length vars) (length sexps))
|
|
(if (null? vars) null
|
|
(cons (cons (car vars) (car sexps))
|
|
(interleave-lifts (cdr vars) (cdr sexps))))
|
|
(error 'interleave-lifts "expected lists of equal length, got ~e and ~e" vars sexps)))
|
|
|
|
|
|
;; struct for color-keeping across opters
|
|
(define-struct opt/info (contract val pos neg src-info orig-str free-vars recf base-pred this that))
|
|
|
|
;; opt/info-swap-blame : opt/info -> opt/info
|
|
;; swaps pos and neg
|
|
(define (opt/info-swap-blame info)
|
|
(let ((ctc (opt/info-contract info))
|
|
(val (opt/info-val info))
|
|
(pos (opt/info-neg info))
|
|
(neg (opt/info-pos info))
|
|
(src-info (opt/info-src-info info))
|
|
(orig-str (opt/info-orig-str info))
|
|
(free-vars (opt/info-free-vars info))
|
|
(recf (opt/info-recf info))
|
|
(base-pred (opt/info-base-pred info))
|
|
(this (opt/info-this info))
|
|
(that (opt/info-that info)))
|
|
(make-opt/info ctc val pos neg src-info orig-str free-vars recf base-pred this that)))
|
|
|
|
;; opt/info-change-val : identifier opt/info -> opt/info
|
|
;; changes the name of the variable that the value-to-be-contracted is bound to
|
|
(define (opt/info-change-val val info)
|
|
(let ((ctc (opt/info-contract info))
|
|
(pos (opt/info-neg info))
|
|
(neg (opt/info-pos info))
|
|
(src-info (opt/info-src-info info))
|
|
(orig-str (opt/info-orig-str info))
|
|
(free-vars (opt/info-free-vars info))
|
|
(recf (opt/info-recf info))
|
|
(base-pred (opt/info-base-pred info))
|
|
(this (opt/info-this info))
|
|
(that (opt/info-that info)))
|
|
(make-opt/info ctc val neg pos src-info orig-str free-vars recf base-pred this that)))
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; stronger helper functions
|
|
;;
|
|
|
|
;; new-stronger-var : identifier (identifier identifier -> exp) -> stronger-rib
|
|
;; the second identifier should be bound (in a lift) to an expression whose value has to be saved.
|
|
;; The ids passed to cogen are expected to be bound to two contracts' values of that expression, when
|
|
;; those contracts are being compared for strongerness
|
|
(define (new-stronger-var id cogen)
|
|
(with-syntax ([(var-this var-that) (generate-temporaries (list id id))])
|
|
(make-stronger-rib (syntax var-this)
|
|
(syntax var-that)
|
|
id
|
|
(cogen (syntax var-this)
|
|
(syntax var-that)))))
|
|
|
|
(define empty-stronger '())
|
|
|
|
(define-struct stronger-rib (this-var that-var save-id stronger-exp))
|
|
|
|
(provide new-stronger-var
|
|
(struct stronger-rib (this-var that-var save-id stronger-exp)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; lifting helper functions
|
|
;;
|
|
(provide lift/binding lift/effect empty-lifts bind-lifts bind-superlifts lifts-to-save)
|
|
|
|
;; lift/binding : syntax[expression] identifier lifts -> (values syntax lifts)
|
|
;; adds a new id to `lifts' that is bound to `e'. Returns the
|
|
;; variable that was bound
|
|
;; values that are lifted are also saved in the wrapper to make sure that the rhs's are evaluated at the right time.
|
|
(define (lift/binding e id-hint lifts)
|
|
(syntax-case e ()
|
|
[x
|
|
(or (identifier? e)
|
|
(number? (syntax-e e))
|
|
(boolean? (syntax-e e)))
|
|
(values e lifts)]
|
|
[else
|
|
(let ([x (car (generate-temporaries (list id-hint)))])
|
|
(values x
|
|
(snoc (cons x e) lifts)))]))
|
|
|
|
;; lift/effect : syntax[expression] lifts -> lifts
|
|
;; adds a new lift to `lifts' that is evaluated for effect. no variable returned
|
|
(define (lift/effect e lifts)
|
|
(let ([x (car (generate-temporaries '(lift/effect)))])
|
|
(snoc (cons #f e) lifts)))
|
|
|
|
(define (snoc x l) (append l (list x)))
|
|
|
|
;; empty-lifts : lifts
|
|
;; the initial lifts
|
|
(define empty-lifts '())
|
|
|
|
(define (bind-lifts lifts stx) (do-bind-lifts lifts stx #'let*))
|
|
(define (bind-superlifts lifts stx) (do-bind-lifts lifts stx #'letrec))
|
|
|
|
(define (do-bind-lifts lifts stx binding-form)
|
|
(if (null? lifts)
|
|
stx
|
|
(with-syntax ([((lifts-x . lift-e) ...) lifts])
|
|
(with-syntax ([(lifts-x ...) (map (λ (x) (if (identifier? x) x (car (generate-temporaries '(junk)))))
|
|
(syntax->list (syntax (lifts-x ...))))]
|
|
[binding-form binding-form])
|
|
#`(binding-form ([lifts-x lift-e] ...)
|
|
#,stx)))))
|
|
|
|
(define (lifts-to-save lifts) (filter values (map car lifts)))
|
|
|
|
) |