You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
786 lines
26 KiB
Scheme
786 lines
26 KiB
Scheme
;; kernel.ss
|
|
; ----------------------------------------------------------------------
|
|
; Copyright (C) 1995-97 Cormac Flanagan
|
|
;
|
|
; This program is free software; you can redistribute it and/or
|
|
; modify it under the terms of the GNU General Public License
|
|
; version 2 as published by the Free Software Foundation.
|
|
;
|
|
; This program is distributed in the hope that it will be useful,
|
|
; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
; GNU General Public License for more details.
|
|
;
|
|
; You should have received a copy of the GNU General Public License
|
|
; along with this program; if not, write to the Free Software
|
|
; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
|
; ----------------------------------------------------------------------
|
|
;; ----------------------------------------------------------------------=
|
|
;; FlowType == value flow graph node
|
|
|
|
(define-const-typed-structure
|
|
FlowType
|
|
( (: num num)
|
|
(! expr (union zodiac:parsed string false symbol))
|
|
(! arrowto (listof FlowType))
|
|
(! arrowfrom (listof FlowType))
|
|
(! type-annotation any) ;; type-annotation% or file.ss (if from .za file)
|
|
(! proplist (listof (cons sym any)))
|
|
(! values-ftype (union false FlowType))
|
|
))
|
|
|
|
(define num-ftype 0)
|
|
(define list-ftype '())
|
|
(define num-edge 0)
|
|
|
|
(define (init-FlowType!)
|
|
(set! num-ftype 0)
|
|
(set! list-ftype '())
|
|
(set! num-edge 0))
|
|
|
|
;;------------------------------------------------------------
|
|
;; Extension functions
|
|
|
|
(define (add-FlowType-arrow! from to)
|
|
(set-FlowType-arrowto! from (cons to (FlowType-arrowto from)))
|
|
(set-FlowType-arrowfrom! to (cons from (FlowType-arrowfrom to))))
|
|
|
|
(define (add-FlowType! ftype)
|
|
(set! num-ftype (add1 num-ftype))
|
|
(set! list-ftype (cons ftype list-ftype))
|
|
ftype)
|
|
|
|
;;------------------------------------------------------------
|
|
;; Property list stuff
|
|
|
|
(define (add-FlowType-prop! ftype prop val)
|
|
(set-FlowType-proplist! ftype
|
|
(cons (cons prop val) (FlowType-proplist ftype))))
|
|
|
|
(define (get-FlowType-prop ftype prop default)
|
|
(recur loop ([l (FlowType-proplist ftype)])
|
|
(match l
|
|
[() default]
|
|
[((a . d) . rest)
|
|
(if (eq? a prop)
|
|
d
|
|
(loop rest))]
|
|
[_ default])))
|
|
|
|
(define (FlowType-name ftype)
|
|
(symbol-append (get-FlowType-prop ftype 'symbol 'anon)
|
|
':
|
|
(FlowType-num ftype)))
|
|
|
|
;; ======================================================================
|
|
;; ======================================================================
|
|
|
|
(define-typed-structure (Tvar struct:FlowType)
|
|
( (: objs (listof AV))
|
|
(: orig-objs (listof AV))
|
|
(: constraints (listof (union con con-filter)))
|
|
(: leq-top-s bool)
|
|
(: edgeto (listof Tvar))
|
|
(: edgefrom (listof Tvar))
|
|
(: L NT)
|
|
(: U NT)
|
|
(: PL NT)
|
|
(: PU NT)
|
|
))
|
|
|
|
(define-const-typed-structure AV
|
|
((: num num)
|
|
(: template template)
|
|
misc
|
|
(: fields+ (vec Tvar))
|
|
(: fields- (vec Tvar))
|
|
(! U NT)
|
|
(! PU any)
|
|
wb
|
|
))
|
|
|
|
(define-const-typed-structure template
|
|
( (: type sym)
|
|
(: num+ int)
|
|
(: num- int)
|
|
(: ref (vec num))
|
|
(: assign (vec num))
|
|
(! super-templates (listof template))
|
|
(: misc-eq? (any -> any))))
|
|
|
|
;; ref and assign are for constructors
|
|
;; ref maps a constructor-field to the AV-field+ to get value from
|
|
;; assign maps a constructor-field to the AV-field- to add value to,
|
|
;; or #f if immutable
|
|
;; super-templates field records that eg num is a supertype of apply+
|
|
;; misc-eq? is an equality function on the misc field of AVs
|
|
;; sym-ndx maps symbols to the index for that symbol
|
|
;; eg. map ivar names
|
|
|
|
|
|
;; Each elem of AV-fields is an Tvar
|
|
|
|
(define-const-typed-structure con
|
|
( (: num num)
|
|
(: template template)
|
|
(: field-no num)
|
|
(: tvar Tvar)
|
|
(: sign bool)
|
|
misc))
|
|
|
|
(define-const-typed-structure con-filter
|
|
((: num num)
|
|
(: filter filter)
|
|
(: tvar Tvar)))
|
|
|
|
(define-const-typed-structure filter
|
|
((: sign bool)
|
|
(: templates (listof template))))
|
|
|
|
(define (create-filter sign templates)
|
|
(assert (and (boolean? sign)
|
|
(list? templates)
|
|
(andmap template? templates))
|
|
'create-filter sign templates)
|
|
(make-filter sign templates))
|
|
|
|
;; Says whether to include or exclude certain templates
|
|
|
|
(define-const-typed-structure con-top-s
|
|
())
|
|
|
|
(define con-top-s (make-con-top-s))
|
|
|
|
(define mt-vector (vector))
|
|
;----------------------------------------------------------------------
|
|
|
|
(define num-con 0)
|
|
(define num-AV 0)
|
|
(define num-AV-in-Tvar 0)
|
|
(define max-constraint-system-size 0)
|
|
(define (constraint-system-size) (+ num-edge num-con num-AV-in-Tvar))
|
|
|
|
(define (SBA-entry->hash entry)
|
|
(hash-fn (FlowType-num (car entry))
|
|
(let ([d (cdr entry)])
|
|
(if (Tvar? d)
|
|
(FlowType-num d)
|
|
(AV-num d)))))
|
|
|
|
(define (init-kernel!)
|
|
(init-FlowType!)
|
|
(set! num-con 0)
|
|
(set! num-AV 0)
|
|
(set! num-AV-in-Tvar 0)
|
|
(set! max-constraint-system-size 0)
|
|
(init-hash-table SBA-entry->hash 0)
|
|
)
|
|
|
|
;;------------------------------------------------------------
|
|
;; Creation functions
|
|
|
|
(define (create-AV template misc fields+ fields-)
|
|
(assert (and
|
|
(template? template)
|
|
(vector? fields+)
|
|
(vector? fields-)
|
|
(vector-andmap Tvar? fields+)
|
|
(vector-andmap Tvar? fields-))
|
|
`(create-AV ,template ,misc ,fields+ ,fields-))
|
|
(let ([AV (make-AV num-AV template misc fields+ fields- #f #f (make-weak-box 1))])
|
|
(set! num-AV (add1 num-AV))
|
|
AV))
|
|
|
|
(define mk-Tvar-nolist
|
|
(lambda (sym)
|
|
(let ([tvar (make-Tvar
|
|
;; FlowType fields
|
|
num-ftype #f '() '() #f `((symbol . ,sym)) #f
|
|
;; Tvar fields
|
|
'() '() '() #f '() '()
|
|
#f #f #f #f
|
|
)])
|
|
(set! num-ftype (add1 num-ftype))
|
|
tvar)))
|
|
|
|
(define mk-Tvar
|
|
(lambda (sym)
|
|
(let ([tvar (mk-Tvar-nolist sym)])
|
|
(set! list-ftype (cons tvar list-ftype))
|
|
tvar)))
|
|
|
|
(define (create-con template field-no tvar sign)
|
|
(create-con-misc template field-no tvar sign '()))
|
|
|
|
(define (create-con-misc template field-no tvar sign misc)
|
|
(make-con num-con template field-no tvar sign misc))
|
|
|
|
(define (create-con-filter filter tvar)
|
|
(assert (filter? filter))
|
|
(make-con-filter num-con filter tvar))
|
|
|
|
;; ----------------------------------------------------------------------
|
|
;; Functions for extending graph
|
|
;; the add-* functions extend the data structures, but don't propogate
|
|
;; the check-add-* only adds if item not in data structure, but don't propogate
|
|
;; the extend-* functions also propogate values & constraints appropriately
|
|
;; the new-* functions are normally bound to extend-*, but sometines add-*
|
|
;; ----------------------------------------------------------------------
|
|
|
|
(define add-edge!
|
|
(lambda (from to)
|
|
(assert (and (Tvar? from) (Tvar? to)) 'add-edge! from to)
|
|
(set-Tvar-edgeto! from (cons to (Tvar-edgeto from)))
|
|
(set-Tvar-edgefrom! to (cons from (Tvar-edgefrom to)))
|
|
(set! num-edge (add1 num-edge))
|
|
(add-entry (hash-fn (FlowType-num from) (FlowType-num to))
|
|
(cons from to))))
|
|
|
|
(define add-AV!
|
|
(lambda (tvar AV)
|
|
(set! num-AV-in-Tvar (add1 num-AV-in-Tvar))
|
|
(set-Tvar-objs! tvar (cons AV (Tvar-objs tvar)))
|
|
(add-entry (hash-fn (FlowType-num tvar) (AV-num AV))
|
|
(cons tvar AV))))
|
|
|
|
(define add-con!
|
|
(lambda (tvar con)
|
|
(set! num-con (add1 num-con))
|
|
(set-Tvar-constraints! tvar (cons con (Tvar-constraints tvar)))))
|
|
|
|
'(define add-nohash-con! add-con!)
|
|
|
|
;; ----------------------------------------------------------------------
|
|
;; the check-add-* functions check if a constraint is present,
|
|
;; and if not, add it, but do not propogate
|
|
|
|
(define check-add-edge!
|
|
(lambda (from to)
|
|
(assert (and (Tvar? from) (Tvar? to)) 'extend-edge! from to)
|
|
(unless
|
|
(or (Tvar-edge? from to) (eq? from to))
|
|
(add-edge! from to))))
|
|
|
|
(define check-add-AV!
|
|
(lambda (tvar AV)
|
|
(assert (AV? AV) `(extend-AV! ,tvar ,AV))
|
|
(set-Tvar-orig-objs! tvar (cons AV (Tvar-orig-objs tvar)))))
|
|
|
|
(define check-add-con!
|
|
(lambda (tvar con)
|
|
(set! num-con (add1 num-con))
|
|
(set-Tvar-constraints! tvar (cons con (Tvar-constraints tvar)))
|
|
(match con
|
|
[($ con-filter _ _ dest)
|
|
(set-Tvar-edgefrom! dest (cons tvar (Tvar-edgefrom dest)))]
|
|
[_ (void)])))
|
|
|
|
;; ----------------------------------------------------------------------
|
|
;; the extend-* functions also propogate values & constraints appropriately
|
|
|
|
(define extend-edge!
|
|
(lambda (from to)
|
|
(assert (and (Tvar? from) (Tvar? to)) 'extend-edge! from to)
|
|
(unless
|
|
(or (Tvar-edge? from to) (eq? from to))
|
|
(add-edge! from to)
|
|
;; Propogate all AV's
|
|
(for-each (lambda (AV) (prop-AV! to AV))
|
|
(Tvar-objs from)))))
|
|
|
|
(define extend-AV!
|
|
(lambda (tvar AV)
|
|
(assert (AV? AV) `(extend-AV! ,tvar ,AV))
|
|
(set-Tvar-orig-objs! tvar (cons AV (Tvar-orig-objs tvar)))
|
|
(prop-AV! tvar AV)))
|
|
|
|
(define prop-AV!
|
|
(lambda (tvar AV)
|
|
(assert (and (Tvar? tvar) (AV? AV)) `(prop-AV! ,tvar ,AV))
|
|
(unless (Tvar-AV-mem? tvar AV)
|
|
(add-AV! tvar AV)
|
|
;; Apply all constraints
|
|
(for-each
|
|
(lambda (con) (SBA-constraint tvar con AV))
|
|
(Tvar-constraints tvar))
|
|
;; Propogate
|
|
(for-each
|
|
(lambda (to) (prop-AV! to AV))
|
|
(Tvar-edgeto tvar)))))
|
|
|
|
(define extend-con!
|
|
(lambda (tvar con)
|
|
(set! num-con (add1 num-con))
|
|
(set-Tvar-constraints! tvar (cons con (Tvar-constraints tvar)))
|
|
(match con
|
|
[($ con-filter _ _ dest)
|
|
(set-Tvar-edgefrom! dest (cons tvar (Tvar-edgefrom dest)))]
|
|
[_ (void)])
|
|
;; Apply to all AV's
|
|
(for-each (lambda (AV) (SBA-constraint tvar con AV))
|
|
(get-Tvar-objs tvar))))
|
|
|
|
;; ----------------------------------------------------------------------
|
|
;; the new-* functions are normally equiv to extend-*,
|
|
;; but can be set to add-* via a parameter
|
|
|
|
(define new-edge! extend-edge!)
|
|
(define new-AV! extend-AV!)
|
|
(define new-con! extend-con!)
|
|
|
|
(define (new-leq-top-s! tvar)
|
|
;; tvar <= top-s, is constraint
|
|
(unless (Tvar-leq-top-s tvar)
|
|
(set-Tvar-leq-top-s! tvar #t)
|
|
(new-con! tvar con-top-s)))
|
|
|
|
(define (new-geq-top-s! tvar)
|
|
;; top-s <= tvar, is AV
|
|
(new-AV! tvar AV-top-s))
|
|
|
|
;; ----------------------------------------------------------------------
|
|
|
|
(define keep-S-closed
|
|
(let ([closed #t])
|
|
(case-lambda
|
|
[() closed]
|
|
[(x)
|
|
(set! closed x)
|
|
(if x
|
|
(begin
|
|
(set! new-edge! extend-edge!)
|
|
(set! new-AV! extend-AV!)
|
|
(set! new-con! extend-con!))
|
|
(begin
|
|
(set! new-edge! check-add-edge!)
|
|
(set! new-AV! check-add-AV!)
|
|
(set! new-con! check-add-con!)))])))
|
|
|
|
(define new-create-AV!
|
|
(lambda (tvar template misc fields)
|
|
(new-AV! tvar (create-AV template misc fields))))
|
|
|
|
(define new-bidir-edge!
|
|
(lambda (from to)
|
|
(new-edge! from to)
|
|
(new-edge! to from)))
|
|
|
|
(define new-edge-para
|
|
(case-lambda
|
|
[() new-edge!]
|
|
[(x) (set! new-edge! x)]))
|
|
|
|
(define (close-constraints tvars)
|
|
(pretty-debug `(close-constraints ,(map Tvar-name tvars)))
|
|
(for-each
|
|
(lambda (tvar)
|
|
(for-each
|
|
(lambda (AV)
|
|
(for-each
|
|
(lambda (to) (prop-AV! to AV))
|
|
(Tvar-edgeto tvar))
|
|
(for-each
|
|
(lambda (con) (SBA-constraint tvar con AV))
|
|
(Tvar-constraints tvar)))
|
|
(get-Tvar-objs tvar)))
|
|
tvars))
|
|
|
|
;;------------------------------------------------------------
|
|
;; Handling constraints
|
|
|
|
(define gSBA-constraint (void))
|
|
|
|
(define SBA-constraint
|
|
(lambda (tvar con AV)
|
|
(set! gSBA-constraint (list tvar con AV))
|
|
(match con
|
|
;; Regular constraints
|
|
[($ con _ template field-no tvar-con sign)
|
|
(match AV
|
|
[($ AV _ template2 misc fields+ fields-)
|
|
(when (or
|
|
(eq? template template2)
|
|
(memq template (template-super-templates template2)))
|
|
;;(pretty-print `(,con ,AV))
|
|
(if sign
|
|
(when (< field-no (vector-length fields+))
|
|
;; Propogate field from AV into tvar-con
|
|
(new-edge! (vector-ref fields+ field-no) tvar-con))
|
|
(when (< field-no (vector-length fields-))
|
|
;; Propogate field from tvar-con into AV
|
|
(new-edge! tvar-con (vector-ref fields- field-no)))))
|
|
(when (eq? template2 template-top-s)
|
|
(if sign
|
|
(new-geq-top-s! tvar-con)
|
|
(new-leq-top-s! tvar-con)))])]
|
|
|
|
;; Filter constraints
|
|
[($ con-filter _ ($ filter bool templates) tvar-con)
|
|
'(printf "template ~s templates ~s memq ~s bool ~s add ~s~n"
|
|
(template-type (AV-template AV))
|
|
(map template-type templates)
|
|
(memq (AV-template AV) templates)
|
|
bool
|
|
(case (memq (AV-template AV) templates)
|
|
[#f (not bool)]
|
|
[else bool]))
|
|
(let* ( [AV-t (AV-template AV)]
|
|
[found (ormap
|
|
(lambda (t2)
|
|
(or
|
|
(eq? AV-t t2)
|
|
(memq t2 (template-super-templates AV-t))))
|
|
templates)])
|
|
'(pretty-print-debug
|
|
`(con-filter found ,found
|
|
memq ,(memq AV-t templates)
|
|
AV-t ,(template-type AV-t)
|
|
,(map template-type templates)))
|
|
(when (or (case found
|
|
[(#f) (not bool)]
|
|
[else bool])
|
|
(eq? AV-t template-top-s))
|
|
;; Add AV to tvar-con
|
|
(prop-AV! tvar-con AV)))]
|
|
[($ con-top-s)
|
|
(match AV
|
|
[($ AV _ template2 misc fields+ fields-)
|
|
(vector-for-each new-leq-top-s! fields+)
|
|
(vector-for-each new-geq-top-s! fields-)])])))
|
|
|
|
;;------------------------------------------------------------
|
|
;; Functions/predicates for examining the graph
|
|
|
|
(define (Tvar-AV-mem? tvar AV)
|
|
(hash-find (hash-fn (FlowType-num tvar) (AV-num AV))
|
|
(lambda (entry)
|
|
(and (eq? (car entry) tvar)
|
|
(eq? (cdr entry) AV)))))
|
|
|
|
(define (Tvar-edge? from to)
|
|
(hash-find (hash-fn (FlowType-num from) (FlowType-num to))
|
|
(lambda (entry)
|
|
(and (eq? (car entry) from)
|
|
(eq? (cdr entry) to)))))
|
|
|
|
(define get-Tvar-objs Tvar-objs)
|
|
|
|
;; ------------------------------------------------------------
|
|
|
|
(define (really-check-kernel-ok)
|
|
(dynamic-let
|
|
([st:check-kernel #t])
|
|
(check-kernel-ok)))
|
|
|
|
(define check-kernel-ok:tvar #f)
|
|
|
|
(define (check-kernel-ok)
|
|
;; Sanity check
|
|
(when (st:check-kernel)
|
|
(assert (= num-ftype (length list-ftype)))
|
|
(let ([Tvar-edge?
|
|
(lambda (a b)
|
|
(or (eq? a b)
|
|
(Tvar-edge? a b)))])
|
|
|
|
(printf "check-kernel-ok: Consistency tests~n")
|
|
(for-each
|
|
(lambda (tvar)
|
|
(when (Tvar? tvar)
|
|
(assert (= (length (Tvar-objs tvar))
|
|
(length (list->set (Tvar-objs tvar)))))
|
|
(assert (= (length (Tvar-edgeto tvar))
|
|
(length (list->set (Tvar-edgeto tvar)))))
|
|
(assert (= (length (Tvar-constraints tvar))
|
|
(length (list->set (Tvar-constraints tvar)))))
|
|
(for-each (lambda (AV) (assert (Tvar-AV-mem? tvar AV) (Tvar-name tvar)))
|
|
(Tvar-objs tvar))
|
|
(for-each (lambda (to) (assert (Tvar-edge? tvar to)))
|
|
(Tvar-edgeto tvar))))
|
|
list-ftype)
|
|
|
|
;; Now check kernel is closed under S
|
|
(printf "check-kernel-ok: Closure tests~n")
|
|
(for-each
|
|
(lambda (tvar)
|
|
(when (Tvar? tvar)
|
|
(for-each
|
|
(lambda (AV)
|
|
;; First check AV prop'd
|
|
(for-each
|
|
(lambda (to)
|
|
(when (Tvar? to)
|
|
(assert (Tvar-AV-mem? to AV)
|
|
(Tvar-name tvar) (Tvar-name to)
|
|
(template-type (AV-template AV)))))
|
|
(Tvar-edgeto tvar))
|
|
;; Check AV applied to all constraints
|
|
(for-each
|
|
(match-lambda
|
|
[($ con _ template field-no tvar-con sign)
|
|
(match AV
|
|
[($ AV _ template2 misc fields+ fields-)
|
|
(when
|
|
(or
|
|
(eq? template template2)
|
|
(memq template (template-super-templates template2)))
|
|
(if sign
|
|
(when (< field-no (vector-length fields+))
|
|
;; Propogate field from AV into tvar-con
|
|
(assert
|
|
(Tvar-edge?
|
|
(vector-ref fields+ field-no) tvar-con)
|
|
`(Tvar-edge?
|
|
,(Tvar-name (vector-ref fields+ field-no))
|
|
,(Tvar-name tvar-con))
|
|
(Tvar-name tvar) field-no
|
|
(template-type template)))
|
|
(when (< field-no (vector-length fields-))
|
|
;; Propogate field from tvar-con into AV
|
|
(assert
|
|
(Tvar-edge?
|
|
tvar-con (vector-ref fields- field-no))
|
|
(Tvar-name tvar)
|
|
field-no
|
|
(Tvar-name tvar-con)
|
|
sign
|
|
(template-type template)))))]
|
|
|
|
[_
|
|
;; Constraint does not apply to this AV
|
|
(void)])]
|
|
[($ con-filter _ ($ filter bool templates) tvar-con)
|
|
;; ignore for now
|
|
(void)])
|
|
(Tvar-constraints tvar)))
|
|
(get-Tvar-objs tvar))))
|
|
(reverse list-ftype))
|
|
|
|
;; Now check all reachable tvars are in list-ftype
|
|
(printf "check-kernel-ok: list-ftype tests~n")
|
|
(let*-vals
|
|
( [(get set) (alloc-Tvar-field (lambda () #f))]
|
|
[ok-tvar? (lambda (tvar)
|
|
(unless (get tvar)
|
|
(printf
|
|
"Tvar ~s reachable from ~s but not in list-ftype ~s~n"
|
|
(FlowType-num tvar)
|
|
(FlowType-num check-kernel-ok:tvar)
|
|
(memq tvar list-ftype))))]
|
|
[ok-AV?
|
|
(match-lambda
|
|
[($ AV _ _ _ fields+ fields-)
|
|
(vector-for-each ok-tvar? fields+)
|
|
(vector-for-each ok-tvar? fields-)])])
|
|
|
|
(for-each
|
|
(lambda (ftype)
|
|
(when (Tvar? ftype) (set ftype #t)))
|
|
list-ftype)
|
|
|
|
(for-each
|
|
(lambda (ftype)
|
|
(when (Tvar? ftype)
|
|
(set! check-kernel-ok:tvar ftype)
|
|
(for-each ok-tvar? (Tvar-edgeto ftype))
|
|
(for-each ok-tvar? (Tvar-edgefrom ftype))
|
|
(for-each ok-AV? (Tvar-objs ftype))
|
|
(for-each ok-AV? (Tvar-orig-objs ftype))
|
|
(for-each
|
|
(match-lambda
|
|
[($ con _ _ _ tvar) (ok-tvar? tvar)]
|
|
[($ con-filter _ _ tvar) (ok-tvar? tvar)])
|
|
(Tvar-constraints ftype))))
|
|
list-ftype))
|
|
|
|
)))
|
|
|
|
(define (check-unreachable ftypes unreachable)
|
|
(let* ( [check-ok
|
|
(lambda (ftype)
|
|
(when (memq ftype unreachable)
|
|
(error 'check-unreachable "Ftype ~s in old ~s"
|
|
(FlowType-name ftype)
|
|
(map FlowType-name unreachable))))])
|
|
(for-each
|
|
(lambda (ftype)
|
|
(when (Tvar? ftype)
|
|
(for-each check-ok (Tvar-edgeto ftype))
|
|
(for-each check-ok (Tvar-edgefrom ftype))
|
|
(for-each
|
|
(match-lambda
|
|
[($ AV _ _ _ fields+ fields-)
|
|
(vector-for-each check-ok fields+)
|
|
(vector-for-each check-ok fields-)])
|
|
(Tvar-objs ftype))
|
|
(for-each
|
|
(match-lambda
|
|
[($ con _ _ _ tvar) (check-ok tvar)]
|
|
[($ con-filter _ _ tvar) (check-ok tvar)])
|
|
(Tvar-constraints ftype))))
|
|
ftypes)))
|
|
|
|
;; ------------------------------------------------------------
|
|
|
|
(define-structure (kernel-state
|
|
num-ftype list-ftype num-edge
|
|
num-con num-AV num-AV-in-Tvar
|
|
closed? new-edge! hash-table-state))
|
|
|
|
(define (save-kernel-state)
|
|
(make-kernel-state
|
|
num-ftype list-ftype num-edge
|
|
num-con num-AV num-AV-in-Tvar
|
|
(keep-S-closed) new-edge!
|
|
(capture-hash-table-state)))
|
|
|
|
(define restore-kernel-state!
|
|
(match-lambda
|
|
[($ kernel-state
|
|
saved-num-ftype saved-list-ftype saved-num-edge
|
|
saved-num-con saved-num-AV saved-num-AV-in-Tvar
|
|
closed? saved-new-edge!
|
|
hash-table-state)
|
|
(let ([old-size (constraint-system-size)])
|
|
(set! num-ftype saved-num-ftype)
|
|
(set! list-ftype saved-list-ftype)
|
|
(set! num-edge saved-num-edge)
|
|
(set! num-con saved-num-con)
|
|
(set! num-AV saved-num-AV)
|
|
(set! num-AV-in-Tvar saved-num-AV-in-Tvar)
|
|
(keep-S-closed closed?)
|
|
(set! new-edge! saved-new-edge!)
|
|
(restore-hash-table-state! hash-table-state)
|
|
|
|
(set! max-constraint-system-size
|
|
(max max-constraint-system-size
|
|
(+ (constraint-system-size) old-size)))
|
|
)]))
|
|
|
|
(define free-kernel-state!
|
|
(match-lambda
|
|
[($ kernel-state
|
|
saved-num-ftype saved-list-ftype saved-num-edge
|
|
saved-num-con saved-num-AV saved-num-AV-in-Tvar
|
|
closed? saved-new-edge!
|
|
hash-table-state)
|
|
|
|
(free-hash-table-state! hash-table-state)
|
|
(for-each
|
|
(lambda (ftype)
|
|
(set-FlowType-expr! ftype 'zerod1!)
|
|
(set-FlowType-arrowto! ftype 'zerod2!)
|
|
(set-FlowType-arrowfrom! ftype 'zerod3!)
|
|
(set-FlowType-type-annotation! ftype 'zerod4!)
|
|
(set-FlowType-proplist! ftype 'zerod5!)
|
|
(set-FlowType-values-ftype! ftype 'zerod6!)
|
|
(when (Tvar? ftype)
|
|
(set-Tvar-objs! ftype 'zerod7!)
|
|
(set-Tvar-orig-objs! ftype 'zerod8!)
|
|
(set-Tvar-constraints! ftype 'zerod9!)
|
|
(set-Tvar-edgeto! ftype 'zeroda!)
|
|
(set-Tvar-edgefrom! ftype 'zerodb!)
|
|
(set-Tvar-L! ftype 'zerodc!)
|
|
(set-Tvar-U! ftype 'zerodd!)
|
|
(set-Tvar-PL! ftype 'zerode!)
|
|
(set-Tvar-PU! ftype 'zerodf!)))
|
|
saved-list-ftype)]))
|
|
|
|
;; ----------------------------------------------------------------------
|
|
|
|
(define-structure (prompt-kernel-state saved-state prompt-hash-state ftypes))
|
|
|
|
(define (prompt-kernel-state)
|
|
(make-prompt-kernel-state
|
|
(save-kernel-state)
|
|
(prompt-hash-table-state)
|
|
(map
|
|
(lambda (ftype)
|
|
(list
|
|
ftype
|
|
(match ftype
|
|
[($ FlowType _ _ arrowto arrowfrom _ _ values-ftype)
|
|
(list arrowto arrowfrom values-ftype)])
|
|
(match ftype
|
|
[($ Tvar _ _ _ _ _ _ _
|
|
objs orig-objs con edgeto edgefrom)
|
|
(list objs orig-objs con edgeto edgefrom)]
|
|
[_ #f])))
|
|
list-ftype)))
|
|
|
|
(define unprompt-kernel-state!
|
|
(match-lambda
|
|
[($ prompt-kernel-state saved-state prompt-hash-state ftypes)
|
|
(restore-kernel-state! saved-state)
|
|
(unprompt-hash-table-state! prompt-hash-state)
|
|
(for-each
|
|
(match-lambda
|
|
[(ftype (arrowto arrowfrom values-ftype) tvar-info)
|
|
(set-FlowType-arrowto! ftype arrowto)
|
|
(set-FlowType-arrowfrom! ftype arrowfrom)
|
|
(set-FlowType-values-ftype! ftype values-ftype)
|
|
(match tvar-info
|
|
[#f (void)]
|
|
[(objs orig-objs con edgeto edgefrom)
|
|
(set-Tvar-objs! ftype objs)
|
|
(set-Tvar-orig-objs! ftype orig-objs)
|
|
(set-Tvar-constraints! ftype con)
|
|
(set-Tvar-edgeto! ftype edgeto)
|
|
(set-Tvar-edgefrom! ftype edgefrom)])])
|
|
ftypes)]))
|
|
|
|
;; ------------------------------------------------------------
|
|
;; Auxiliary info on Tvars
|
|
|
|
(define alloc-Tvar-field
|
|
(case-lambda
|
|
[(default-fn)
|
|
(let* ( [table (make-hash-table)]
|
|
[get-info
|
|
(lambda (tvar)
|
|
(assert (FlowType? tvar) tvar 'get-info)
|
|
(hash-table-get table tvar default-fn))]
|
|
[set-info!
|
|
(lambda (tvar v)
|
|
(assert (FlowType? tvar) tvar 'set-info!)
|
|
(hash-table-put! table tvar v))])
|
|
(values get-info set-info!))]
|
|
[() (alloc-Tvar-field (lambda () #f))]))
|
|
|
|
(define alloc-AV-field
|
|
(case-lambda
|
|
[(default-fn)
|
|
(let* ( [table (make-hash-table)]
|
|
[get-info
|
|
(lambda (AV)
|
|
(hash-table-get table AV default-fn))]
|
|
[set-info!
|
|
(lambda (AV v)
|
|
(hash-table-put! table AV v))])
|
|
(values get-info set-info!))]
|
|
[() (alloc-AV-field (lambda () #f))]))
|
|
|
|
(define (field->set alloc-field)
|
|
(let*-vals ( [(get-info set-info!) (alloc-field)]
|
|
[list-obj '()]
|
|
[in? (lambda (obj) (get-info obj))]
|
|
[add! (lambda (obj)
|
|
(unless (in? obj)
|
|
(set-info! obj #t)
|
|
(set! list-obj (cons obj list-obj))))]
|
|
[get-list (lambda () list-obj)])
|
|
(values in? add! get-list)))
|
|
|
|
;; ----------------------------------------------------------------------
|
|
|
|
(define mk-Tvar-init-AV
|
|
(lambda (sym AV)
|
|
(let ([r (mk-Tvar sym)])
|
|
(new-AV! r AV)
|
|
r)))
|
|
|
|
(define (Tvar-name tvar) (FlowType-name tvar))
|
|
|
|
;; ======================================================================
|
|
|