File: theme-d-stripping.scm

package info (click to toggle)
theme-d 1.4.0-1
  • links: PTS, VCS
  • area: main
  • in suites: bullseye, sid
  • size: 12,784 kB
  • sloc: lisp: 47,684; sh: 4,200; makefile: 455; ansic: 319
file content (254 lines) | stat: -rw-r--r-- 9,056 bytes parent folder | download
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
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
;; Copyright (C) 2008-2013 Tommi Höynälänmaa
;; Distributed under GNU General Public License version 3,
;; see file doc/GPL-3.


;; *** Stripping unused code in the linker output ***


(import (rnrs exceptions)
	(srfi srfi-1)
	(th-scheme-utilities stdutils)
	(th-scheme-utilities hrecord))


(define gl-i-var-def-table-size 20000)


(define gl-debug4 '())


(define (var-ref-addr var-ref)
  (hfield-ref (hfield-ref var-ref 'variable) 'address))


(define (mark-repr-used! repr)
  (hfield-set! repr 'include? #t))


(define (determine-address-coverage linker address lst-new-visited)
  (let ((old-indent gl-indent))
    (set! gl-indent (+ gl-indent 1))
    (let ((ht-var-defs (hfield-ref linker 'ht-var-defs))
	  (ht-method-decls (hfield-ref linker 'ht-method-decls))
	  (ht-used-decls (hfield-ref linker 'ht-used-decls))
	  (ht-used (hfield-ref linker 'ht-used)))
      ;; There is no need to check a variable
      ;; that has already been checked.
      (if (not (address-hash-ref ht-used address))
	  (let ((var-def (address-hash-ref ht-var-defs address)))
	    (if (not (eq? var-def #f))
		(determine-coverage linker var-def lst-new-visited))
	    (let ((method-def (address-hash-ref ht-method-decls
						address)))
	      (if method-def
		  (begin
		    (address-hash-set! ht-used-decls address
				       method-def)
		    (determine-coverage 
		     linker
		     (hfield-ref method-def 'procexpr)
		     lst-new-visited)))))))
    (set! gl-indent old-indent)))


;; (define (address-to-string address)
;;   (let ((source-name (hfield-ref address 'source-name)))
;;     (string-append
;;      (if (not-null? source-name)
;; 	 (symbol->string (hfield-ref address 'source-name))
;; 	 "()")
;;      "["
;;      (number->string (hfield-ref address 'number))
;;      "]")))


(define (determine-coverage linker repr lst-visited)
  (let ((ht-var-defs (hfield-ref linker 'ht-var-defs))
	(ht-method-decls (hfield-ref linker 'ht-method-decls))
	(ht-used-decls (hfield-ref linker 'ht-used-decls))
	(ht-used (hfield-ref linker 'ht-used)))
    (let ((old-indent gl-indent))
      (set! gl-indent (+ gl-indent 1))
      (cond
       ((null? repr)
	'())
       ((memq repr lst-visited)
	'())
       ;; The following test is an optimization.
       ((and (hrecord-is-instance? repr <variable-definition>)
	     (or (hfield-ref repr 'include?)
		 (address-hash-ref (hfield-ref linker 'ht-used)
				   (hfield-ref (hfield-ref repr 'variable)
					       'address))))
	'())
       ((pair? repr)
	(let ((lst-new-visited (cons repr lst-visited)))
	  (determine-coverage linker (car repr) lst-new-visited)
	  (determine-coverage linker (cdr repr) lst-new-visited)))
       ;; We have to check subclasses of <variable-definition> before that.
       ((hrecord-is-instance? repr <generic-procedure-definition>)
	(let ((address (hfield-ref (hfield-ref repr 'variable) 'address)))
	  (if (not (address-hash-ref ht-used address))
	      (begin
		(mark-repr-used! repr)
		(address-hash-set! ht-used address repr)
		(let ((lst-new-visited (cons repr lst-visited)))
		  (mark-methods-for-coverage linker lst-new-visited))))))
       ((or (hrecord-is-instance? repr <class-definition>)
	    (hrecord-is-instance? repr <param-class-definition>)
	    (hrecord-is-instance? repr <param-logical-type-def>)
	    (hrecord-is-instance? repr <param-class-definition>)
	    (hrecord-is-instance? repr <generic-procedure-definition>))
	(let ((address (hfield-ref (hfield-ref repr 'variable) 'address)))
	  (mark-repr-used! repr)
	  (address-hash-set! ht-used address repr)
	  (let ((lst-subreprs (get-subexpressions repr))
		(lst-new-visited (cons repr lst-visited)))
	    (for-each (lambda (repr1)
			(determine-coverage linker repr1 lst-new-visited))
		      lst-subreprs))))
       ((hrecord-is-instance? repr <prim-class-def>)
	(let ((address (hfield-ref (hfield-ref repr 'variable) 'address)))
	  (address-hash-set! ht-used address repr))
	(mark-repr-used! repr)
	(let ((var-superclass (hfield-ref repr 'superclass))
	      (lst-new-visited (cons repr lst-visited)))
	  (determine-coverage linker var-superclass lst-new-visited)))
       ((hrecord-is-instance? repr <variable-definition>)
	(let ((address (hfield-ref (hfield-ref repr 'variable) 'address))
	      (lst-new-visited (cons repr lst-visited)))
	  (mark-repr-used! repr)
	  (address-hash-set! ht-used address repr)
	  (determine-coverage linker (hfield-ref repr 'value-expr)
			      lst-new-visited)))
       ((hrecord-is-instance? repr <variable-reference>)
	(let ((var (hfield-ref repr 'variable)))
	  ;; Variables without a toplevel definition
	  ;; need not be checked for coverage.
	  ;; Builtin variables and local variable don't
	  ;; have a variable definition.
	  (if (is-normal-variable? var)
	      (let ((lst-new-visited (cons repr lst-visited)))
		(determine-coverage linker var lst-new-visited)))))
       ((hrecord-is-instance? repr <normal-variable>)
	(let ((address (hfield-ref repr 'address))
	      (lst-new-visited (cons repr lst-visited)))
	  (determine-address-coverage linker address lst-new-visited)))
       ((is-entity? repr)
	(let ((lst-subreprs (get-subexpressions repr))
	      (lst-new-visited (cons repr lst-visited))
	      (address (hfield-ref repr 'address)))
	  (if (not-null? address)
	      (determine-address-coverage linker address lst-new-visited))
	  (for-each (lambda (repr1)
		      (determine-coverage linker repr1 lst-new-visited))
		    lst-subreprs)))
       (else
	(dvar1-set! repr)
	(raise 'determine-coverage:invalid-object)))
      (set! gl-indent old-indent))))


(define (mark-method-for-coverage linker repr def? lst-visited)
  (let ((gen-proc (hfield-ref repr 'gen-proc)))
    (assert (is-target-object? gen-proc))
    ;; We may have to check globals-by-address here.
    (let ((address (hfield-ref gen-proc 'address))
	  (ht-used (hfield-ref linker 'ht-used)))
      (assert (is-address? address))
      (if (address-hash-ref ht-used address)
	  (begin
	    (mark-repr-used! repr)
	    (if def?
		(determine-coverage
		 linker (hfield-ref repr 'procexpr) lst-visited)))))))


(define (mark-methods-for-coverage linker lst-visited)
  (for-each
   (lambda (repr)
     (cond
      ((hrecord-is-instance? repr <method-definition>)
       (mark-method-for-coverage linker repr #t lst-visited))
      ((hrecord-is-instance? repr <method-declaration>)
       (mark-method-for-coverage linker repr #f lst-visited))
      (else '())))
   (hfield-ref linker 'repr-list)))


(define (do-prevent-stripping linker)
  (let ((lst-reprs (hfield-ref linker 'repr-list)))
    (for-each
     (lambda (repr)
       (if (hrecord-is-instance? repr <prevent-stripping-expr>)
	   (let ((address (hfield-ref repr 'target-address)))
	     (if (null? address)
		 (begin
		   ;; This is an error situation.
		   (raise 'error-with-prevent-stripping-expr)))
	     (determine-address-coverage linker address '()))))
     lst-reprs)))


(define (make-var-def-hash-table lst-reprs)
  (let ((ht (make-hash-table gl-i-var-def-table-size)))
    (for-each (lambda (repr)
		(if (hrecord-is-instance? repr <variable-definition>)
		    (address-hash-set!
		     ht
		     (hfield-ref (hfield-ref repr 'variable) 'address)
		     repr)))
	      lst-reprs)
    ht))


(define (decl-is-used? linker repr)
  (assert (is-linker? linker))
  (assert (hrecord-is-instance? repr <forward-declaration>))
  (let ((address (hfield-ref (hfield-ref repr 'variable) 'address))
	(ht-used (hfield-ref linker 'ht-used)))
    (if (address-hash-ref ht-used address) #t #f)))


(define (var-def-is-used? linker repr)
  (or (not (hfield-ref linker 'strip?))
      (hfield-ref repr 'include?)
      (hashq-ref (hfield-ref linker 'ht-rebound) repr)))


(define (is-my-main-address? address)
  (and
   (eqv? (hfield-ref address 'number) address-number-target)
   (eqv? (hfield-ref address 'source-name) '_main)))


(define (include-in-stripping? expr)
  (not (or
	(and (hrecord-is-instance? expr <variable-definition>)
	     (let ((expr-value (hfield-ref expr 'value-expr)))
	       (or (null? expr-value)
		   (is-target-object? expr-value)
		   (hrecord-is-instance? expr-value <procedure-expression>)
		   (hrecord-is-instance? expr-value <param-proc-expr>)
		   (hrecord-is-instance? expr-value <prim-proc-ref>)
		   (hrecord-is-instance? expr-value <checked-prim-proc>)))
	     (not (is-my-main-address? (hfield-ref (hfield-ref expr 'variable)
						   'address))))
	(hrecord-is-instance? expr <forward-declaration>)
	(hrecord-is-instance? expr <method-definition>)
	(hrecord-is-instance? expr <method-declaration>)
	(hrecord-is-instance? expr <zero-setting-expr>)
	(hrecord-is-instance? expr <prevent-stripping-expr>)
	(hrecord-is-instance? expr <expr-define-syntax>)
	(hrecord-is-instance? expr <debug-output-expr>))))


(define (determine-total-coverage linker)
  (assert (is-linker? linker))
  ;; Reversion is not necessary here.
  (let ((l-reprs (reverse (hfield-ref linker 'repr-list))))
    (for-each (lambda (repr)
		(if (include-in-stripping? repr)
		    (determine-coverage linker repr '())))
	      l-reprs)))