1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
|
; Copyright (c) 1993-2008 by Richard Kelsey. See file COPYING.
; Types and nodes together
; Instantiate TYPE and replace the types in NODE with their corresponding
; value. LOCATION is where NODE will be applied, and is used to get the actual
; types of the arguments.
(define (instantiate-type&value type node location)
(let ((has (instantiate-type-scheme type
-1
(lambda () (fix-types node))))
(wants (call->proc-type (node-parent location))))
(identity (unify! has wants 'simplifying))))
; (format #t "~%Reconstructing ")
; (pp-cps call)
; (format #t " has ~S~% wants ~S~%"
; (instantiate has)
; (instantiate wants))
; (breakpoint "reconstructing ~S" call)
; (unify! has wants 'simplifying)
; This is used to replace all references in NODE to polymorphic type variables
; with the current value of the type variable.
; Youch! Very inefficient - may make many copies of the same type.
(define (fix-types node)
(let label ((node node))
(case (node-variant node)
((lambda)
(for-each fix-variable (lambda-variables node))
(label (lambda-body node)))
((call)
(walk-vector label (call-args node)))
((literal)
(let ((value (literal-value node)))
(if (or (uvar? value)
(other-type? value))
(set-literal-value! node (copy-type value))))))))
(define (fix-variable var)
(set-variable-type! var (copy-type (variable-type var))))
(define (call->proc-type call)
(let ((end (if (or (calls-this-primop? call 'call)
(calls-this-primop? call 'tail-call))
2 ; no protocol to ignore
3))) ; protocol to ignore
(make-arrow-type (do ((i (- (vector-length (call-args call)) 1) (- i 1))
(ts '() (cons (maybe-instantiate
(node-type (call-arg call i)))
ts)))
((< i end)
ts))
(let ((cont (call-arg call 0)))
(if (reference-node? cont)
(variable-type (reference-variable cont))
(make-tuple-type (map variable-type
(lambda-variables cont))))))))
(define (maybe-instantiate type)
(if (type-scheme? type)
(instantiate-type-scheme type -1)
type))
(define (make-monomorphic! var)
(let ((type (type-scheme-type (variable-type var))))
(for-each (lambda (ref)
(if (not (called-node? ref))
(error
"polymorphic procedure ~S used as value, cannot be made monomorphic"
(variable-name var))
(unify! type
(call->proc-type (node-parent ref))
'make-monomorphic!)))
(variable-refs var))
(set-variable-type! var type)))
|
