-
Notifications
You must be signed in to change notification settings - Fork 70
/
debug.lisp
193 lines (172 loc) · 8.82 KB
/
debug.lisp
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
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
(defpackage #:coalton-impl/debug
(:use #:cl)
(:local-nicknames
(#:settings #:coalton-impl/settings)
(#:algo #:coalton-impl/algorithm)
(#:tc #:coalton-impl/typechecker)
(#:entry #:coalton-impl/entry)))
(in-package #:coalton-impl/debug)
(defun coalton:print-value-db (&optional package)
"Print the global value environment"
(let ((env entry:*global-environment*)
(sorted-by-package (make-hash-table)))
;; Sort the entires by package
(fset:do-map (sym entry (algo:immutable-map-data (tc:environment-value-environment env)))
(push (cons sym entry) (gethash (symbol-package sym) sorted-by-package)))
;; Print out the entries for each package
(labels ((print-package (package entries)
(format t "[package ~A]~%~%" (package-name package))
;; Remove qualifications from package symbols
(let ((*package* package))
(loop :for (name . type) :in entries :do
(format t " ~A :: ~A~%"
name
type)))
(format t "~%")))
(if package
(let ((p (find-package package)))
(unless p
(error "Invalid package ~A" package))
(print-package p (gethash p sorted-by-package)))
(maphash #'print-package sorted-by-package)))))
(defun coalton:print-type-db (&optional package)
"Print the global type environment"
(let ((env entry:*global-environment*)
(sorted-by-package (make-hash-table)))
;; Sort the entires by package
(fset:do-map (sym entry (algo:immutable-map-data (tc:environment-type-environment env)))
(push (cons sym entry) (gethash (symbol-package sym) sorted-by-package)))
;; Print out the entries for each package
(labels ((print-package (package entries)
(format t "[package ~A]~%~%" (package-name package))
(loop :for (name . entry) :in entries :do
(format t " ~A :: ~A~%"
name
(tc:kind-of entry)))
(format t "~%")))
(if package
(let ((p (find-package package)))
(unless p
(error "Invalid package ~A" package))
(print-package p (gethash p sorted-by-package)))
(maphash #'print-package sorted-by-package)))))
(defun coalton:print-class-db (&optional package)
"Print the global class environment"
(let ((env entry:*global-environment*)
(sorted-by-package (make-hash-table)))
;; Sort the entires by package
(fset:do-map (sym entry (algo:immutable-map-data (tc:environment-class-environment env)))
(push (cons sym entry) (gethash (symbol-package sym) sorted-by-package)))
;; Print out the entries for each package
(labels ((print-package (package entries)
(format t "[package ~A]~%~%" (package-name package))
(let ((*package* package))
(loop :for (name . entry) :in entries :do
(tc:with-pprint-variable-context ()
(let ((class-pred (tc:ty-class-predicate entry)))
(format t " [~S (~A :: ~A)]~%"
(tc:ty-predicate-class class-pred)
(tc:ty-predicate-types class-pred)
(mapcar #'tc:kind-of (tc:ty-predicate-types class-pred))))
(loop :for method :in (tc:ty-class-unqualified-methods entry) :do
(format t " ~S :: ~A~%"
(tc:ty-class-method-name method)
(tc:ty-class-method-type method))))
(format t "~%")))
(format t "~%")))
(if package
(let ((p (find-package package)))
(unless p
(error "Invalid package ~A" package))
(print-package p (gethash p sorted-by-package)))
(maphash #'print-package sorted-by-package)))))
(defun coalton:print-instance-db (&optional package)
"Print the global instance environment"
(let ((env entry:*global-environment*)
(sorted-by-package (make-hash-table)))
;; Sort the entires by package
(fset:do-map (sym entry (algo:immutable-map-data (tc:environment-class-environment env)))
(push (cons entry (tc:lookup-class-instances env sym :no-error t))
(gethash (symbol-package sym) sorted-by-package)))
;; Print out the entries for each package
(labels ((print-package (package entries)
(format t "[package ~A]~%~%" (package-name package))
(let ((*package* package))
(loop
:for (entry . instances) :in entries
:when (not (null instances))
;; Generate substitutions for class
:do (tc:with-pprint-variable-context ()
(let* ((class-pred (tc:ty-class-predicate entry)))
(format t " [~S (~A :: ~A)]~%"
(tc:ty-predicate-class class-pred)
(tc:ty-predicate-types class-pred)
(mapcar #'tc:kind-of (tc:ty-predicate-types class-pred)))))
(fset:do-seq (instance instances)
(format t " ")
;; Generate type variable substitutions from instance constraints
(tc:with-pprint-variable-context ()
(let* ((instance-constraints (tc:ty-class-instance-constraints instance))
(instance-predicate (tc:ty-class-instance-predicate instance)))
(cond
((= 0 (length instance-constraints))
(format t "~A~%" instance-predicate))
((= 1 (length instance-constraints))
(format t "~A ~A ~A~%"
(first instance-constraints)
(if settings:*coalton-print-unicode* "⇒" "=>")
instance-predicate))
(t
(format t "~A ~A ~A~%"
instance-constraints
(if settings:*coalton-print-unicode* "⇒" "=>")
instance-predicate))))))
(format t "~%")))
(format t "~%")))
(if package
(let ((p (find-package package)))
(unless p
(error "Invalid package ~A" package))
(print-package p (gethash p sorted-by-package)))
(maphash #'print-package sorted-by-package)))))
(defun coalton:print-specializations (&optional package)
"Print all specializations"
(let ((env entry:*global-environment*)
(sorted-by-package (make-hash-table)))
(fset:do-map (sym entry (algo:immutable-listmap-data (tc:environment-specialization-environment env)))
(push (cons sym entry) (gethash (symbol-package sym) sorted-by-package)))
(labels ((print-package (package entries)
(format t "[package ~A]~%~%" (package-name package))
(loop :for (name . specs) :in entries
:do (progn
(format t " ~A :: ~A~%" name (tc:lookup-value-type env name))
(fset:do-seq (spec specs)
(format t " ~A :: ~A~%"
(tc:specialization-entry-to spec)
(tc:specialization-entry-to-ty spec)))
(format t "~%")))
(format t "~%")))
(if package
(let ((p (find-package package)))
(unless p
(error "Invalid package ~A" package))
(print-package p (gethash p sorted-by-package)))
(maphash #'print-package sorted-by-package)))))
(defun coalton:type-of (symbol)
"Lookup the type of value SYMBOL in the global environment"
(tc:lookup-value-type entry:*global-environment* symbol))
(defun coalton:kind-of (symbol)
"Lookup the kind of type SYMBOL in the global environment"
(tc:kind-of (coalton-impl/typechecker::type-entry-type (tc:lookup-type entry:*global-environment* symbol))))
(defun coalton:lookup-code (name)
"Lookup the compiled code of a given definition"
(declare (type symbol name))
(tc:lookup-code entry:*global-environment* name))
(defun coalton:lookup-class (name)
"Lookup a given class"
(declare (type symbol name))
(tc:lookup-class entry:*global-environment* name))
(defun coalton:lookup-fundeps (name)
"Lookup the fundep structure for a given class"
(declare (type symbol name))
(tc:lookup-fundep-environment entry:*global-environment* name))