1;; Records used by "cpnanopass.ss" and "cpprim.ss"
2
3(define-record-type ctci ; compile-time version of code-info
4  (nongenerative #{ctci bcpkdd2y9yyv643zicd4jbe3y-0})
5  (sealed #t)
6  (fields (mutable live) (mutable rpi*) (mutable closure-fv-names))
7  (protocol
8    (lambda (new)
9      (lambda ()
10        (new #f '() #f)))))
11
12(define-record-type ctrpi ; compile-time version of rp-info
13  (nongenerative #{ctrpi bcpkdd2y9yyv643zicd4jbe3y-1})
14  (sealed #t)
15  (fields label src sexpr mask))
16
17(define-record-type info-lambda
18  (nongenerative #{info-lambda bcpkdd2y9yyv643zicd4jbe3y-2})
19  (parent info)
20  (sealed #t)
21  (fields src sexpr libspec (mutable interface*) (mutable dcl*) (mutable flags) (mutable fv*) (mutable name)
22    (mutable well-known?) (mutable closure-rep) ctci (mutable pinfo*) seqno)
23  (protocol
24    (lambda (pargs->new)
25      (rec cons-info-lambda
26        (case-lambda
27          [(src sexpr libspec interface*) (cons-info-lambda src sexpr libspec interface* #f 0)]
28          [(src sexpr libspec interface* name) (cons-info-lambda src sexpr libspec interface* name 0)]
29          [(src sexpr libspec interface* name flags)
30           ((pargs->new) src sexpr libspec interface*
31            (map (lambda (iface) (make-direct-call-label 'dcl)) interface*)
32            (if (eq? (subset-mode) 'system) (fxlogor flags (constant code-flag-system)) flags)
33            '() name #f 'closure (and (generate-inspector-information) (make-ctci)) '() ($np-next-lambda-seqno))])))))
34
35(define-record-type info-call
36  (nongenerative #{info-call bcpkdd2y9yyv643zicd4jbe3y-3})
37  (parent info)
38  (sealed #t)
39  (fields src sexpr (mutable check?) pariah? error? shift-attachment? shift-consumer-attachment?*)
40  (protocol
41    (lambda (pargs->new)
42      (case-lambda
43       [(src sexpr check? pariah? error? shift-attachment? shift-consumer-attachment?*)
44        ((pargs->new) src sexpr check? pariah? error? shift-attachment? shift-consumer-attachment?*)]
45       [(src sexpr check? pariah? error?)
46        ((pargs->new) src sexpr check? pariah? error? #f '())]))))
47
48(define-record-type info-newframe
49  (nongenerative #{info-newframe bcpkdd2y9yyv643zicd4jbe3y-4})
50  (parent info)
51  (sealed #t)
52  (fields
53    src
54    sexpr
55    cnfv*
56    nfv*
57    nfv**
58    (mutable weight)
59    (mutable call-live*)
60    (mutable frame-words)
61    (mutable local-save*))
62  (protocol
63    (lambda (pargs->new)
64      (lambda (src sexpr cnfv* nfv* nfv**)
65        ((pargs->new) src sexpr cnfv* nfv* nfv** 0 #f #f #f)))))
66
67(define-record-type info-kill*
68  (nongenerative #{info-kill* bcpkdd2y9yyv643zicd4jbe3y-5})
69  (parent info)
70  (fields kill*))
71
72(define-record-type info-kill*-live*
73  (nongenerative #{info-kill*-live* bcpkdd2y9yyv643zicd4jbe3y-6})
74  (parent info-kill*)
75  (fields live*)
76  (protocol
77    (lambda (new)
78      (case-lambda
79        [(kill* live*)
80          ((new kill*) live*)]
81        [(kill*)
82          ((new kill*) (reg-list))]))))
83
84(define-record-type info-asmlib
85  (nongenerative #{info-asmlib bcpkdd2y9yyv643zicd4jbe3y-7})
86  (parent info-kill*-live*)
87  (sealed #t)
88  (fields libspec save-ra?)
89  (protocol
90    (lambda (new)
91      (case-lambda
92        [(kill* libspec save-ra? live*)
93         ((new kill* live*) libspec save-ra?)]
94        [(kill* libspec save-ra?)
95         ((new kill*) libspec save-ra?)]))))
96
97(module (intrinsic-info-asmlib intrinsic-return-live* intrinsic-entry-live* intrinsic-modify-reg* dorest-intrinsics)
98  (define-record-type intrinsic
99    (nongenerative #{intrinsic bcpkdd2y9yyv643zicd4jbe3y-A})
100    (sealed #t)
101    (fields libspec kill* live* rv*))
102  (define intrinsic-info-asmlib
103    (lambda (intrinsic save-ra?)
104      (make-info-asmlib (intrinsic-kill* intrinsic)
105        (intrinsic-libspec intrinsic)
106        save-ra?
107        (intrinsic-live* intrinsic))))
108  (define intrinsic-return-live*
109    ; used a handful of times, just while compiling library.ss...don't bother optimizing
110    (lambda (intrinsic)
111      (fold-left (lambda (live* kill) (remq kill live*))
112        (vector->list regvec) (intrinsic-kill* intrinsic))))
113  (define intrinsic-entry-live*
114    ; used a handful of times, just while compiling library.ss...don't bother optimizing
115    (lambda (intrinsic) ; return-live* - rv + live*
116      (fold-left (lambda (live* live) (if (memq live live*) live* (cons live live*)))
117        (fold-left (lambda (live* rv) (remq rv live*))
118          (intrinsic-return-live* intrinsic)
119          (intrinsic-rv* intrinsic))
120        (intrinsic-live* intrinsic))))
121  (define intrinsic-modify-reg*
122    (lambda (intrinsic)
123      (append (intrinsic-rv* intrinsic)
124              (intrinsic-kill* intrinsic))))
125  (define-syntax declare-intrinsic
126    (syntax-rules (unquote)
127      [(_ name entry-name (kill ...) (live ...) (rv ...))
128       (begin
129         (define name
130           (make-intrinsic
131             (lookup-libspec entry-name)
132             (reg-list kill ...)
133             (reg-list live ...)
134             (reg-list rv ...)))
135         (export name))]))
136  ; must include in kill ... any register explicitly assigned by the intrinsic
137  ; plus additional registers as needed to avoid spilled unspillables.  the
138  ; list could be machine-dependent but at this point it doesn't matter.
139  (declare-intrinsic dofargint32 dofargint32 (%ts %td %xp) (%ac0) (%ac0))
140  (constant-case ptr-bits
141    [(32) (declare-intrinsic dofargint64 dofargint64 (%ts %td %xp) (%ac0) (%ac0 %ac1))]
142    [(64) (declare-intrinsic dofargint64 dofargint64 (%ts %td %xp) (%ac0) (%ac0))])
143  (declare-intrinsic dofretint32 dofretint32 (%ts %td %xp) (%ac0) (%ac0))
144  (constant-case ptr-bits
145    [(32) (declare-intrinsic dofretint64 dofretint64 (%ts %td %xp) (%ac0 %ac1) (%ac0))]
146    [(64) (declare-intrinsic dofretint64 dofretint64 (%ts %td %xp) (%ac0) (%ac0))])
147  (declare-intrinsic dofretuns32 dofretuns32 (%ts %td %xp) (%ac0) (%ac0))
148  (constant-case ptr-bits
149    [(32) (declare-intrinsic dofretuns64 dofretuns64 (%ts %td %xp) (%ac0 %ac1) (%ac0))]
150    [(64) (declare-intrinsic dofretuns64 dofretuns64 (%ts %td %xp) (%ac0) (%ac0))])
151  (declare-intrinsic dofretu8* dofretu8* (%ac0 %ts %td %cp %ac1) (%ac0) (%xp))
152  (declare-intrinsic dofretu16* dofretu16* (%ac0 %ts %td %cp %ac1) (%ac0) (%xp))
153  (declare-intrinsic dofretu32* dofretu32* (%ac0 %ts %td %cp %ac1) (%ac0) (%xp))
154  (declare-intrinsic get-room get-room () (%xp) (%xp))
155  (declare-intrinsic scan-remembered-set scan-remembered-set () () ())
156  (declare-intrinsic reify-1cc reify-1cc (%xp %ac0 %ts %reify1 %reify2) () (%td)) ; %reify1 & %reify2 are defined as needed per machine...
157  (declare-intrinsic maybe-reify-cc maybe-reify-cc (%xp %ac0 %ts %reify1 %reify2) () (%td)) ; ... to have enough registers to allocate
158  (declare-intrinsic dooverflow dooverflow () () ())
159  (declare-intrinsic dooverflood dooverflood () (%xp) ())
160  ; a dorest routine takes all of the register and frame arguments from the rest
161  ; argument forward and also modifies the rest argument.  for the rest argument,
162  ; this is a wash (it's live both before and after).  the others should also be
163  ; listed as live.  it's inconvenient and currently unnecessary to do so.
164  ; (actually currently impossible to list the infinite set of frame arguments)
165  (define-syntax dorest-intrinsic-max (identifier-syntax 5))
166  (export dorest-intrinsic-max)
167  (define (list-xtail ls n)
168    (if (or (null? ls) (fx= n 0))
169        ls
170        (list-xtail (cdr ls) (fx1- n))))
171  (define dorest-intrinsics
172    (let ()
173      (define-syntax dorests
174        (lambda (x)
175          #`(vector #,@
176              (let f ([i 0])
177                (if (fx> i dorest-intrinsic-max)
178                    '()
179                    (cons #`(make-intrinsic
180                              (lookup-libspec #,(construct-name #'k "dorest" i))
181                              (reg-list %ac0 %xp %ts %td)
182                              (reg-cons* %ac0 (list-xtail arg-registers #,i))
183                              (let ([ls (list-xtail arg-registers #,i)]) (if (null? ls) '() (list (car ls)))))
184                      (f (fx+ i 1))))))))
185      dorests)))
186
187(define-record-type info-alloc
188  (nongenerative #{info-alloc bcpkdd2y9yyv643zicd4jbe3y-9})
189  (parent info)
190  (sealed #t)
191  (fields tag save-flrv? save-ra?))
192
193(define-record-type info-foreign
194  (nongenerative #{info-foreign bcpkdd2y9yyv643zicd4jbe3y-10})
195  (parent info)
196  (sealed #t)
197  (fields conv* arg-type* result-type unboxed? (mutable name))
198  (protocol
199    (lambda (pargs->new)
200      (lambda (conv* arg-type* result-type unboxed?)
201        ((pargs->new) conv* arg-type* result-type unboxed? #f)))))
202
203(define-record-type info-literal
204  (nongenerative #{info-literal bcpkdd2y9yyv643zicd4jbe3y-11})
205  (parent info)
206  (sealed #t)
207  (fields indirect? type addr offset))
208
209(define-record-type info-lea
210  (nongenerative #{info-lea bcpkdd2y9yyv643zicd4jbe3y-12})
211  (parent info)
212  (sealed #t)
213  (fields offset))
214
215(define-record-type info-load
216  (nongenerative #{info-load bcpkdd2y9yyv643zicd4jbe3y-13})
217  (parent info)
218  (sealed #t)
219  (fields type swapped?))
220
221(define-record-type info-condition-code
222  (nongenerative #{info-condition-code bcpkdd2y9yyv643zicd4jbe3y-14})
223  (parent info)
224  (sealed #t)
225  (fields type reversed? invertible?))
226
227(define-record-type info-c-simple-call
228  (nongenerative #{info-c-simple-call bcpkdd2y9yyv643zicd4jbe3y-15})
229  (parent info-kill*-live*)
230  (sealed #t)
231  (fields save-ra? entry)
232  (protocol
233   (lambda (new)
234     (case-lambda
235      [(save-ra? entry) ((new '() '()) save-ra? entry)]
236      [(live* save-ra? entry) ((new '() live*) save-ra? entry)]))))
237
238(define-record-type info-c-return
239  (nongenerative #{info-c-return bcpkdd2y9yyv643zicd4jbe3y-16})
240  (parent info)
241  (sealed #t)
242  (fields offset))
243
244(define-record-type info-inline
245  (nongenerative #{info-inline bcpkdd2y9yyv643zicd4jbe3y-17})
246  (parent info)
247  (sealed #t)
248  (fields))
249
250(define-record-type info-unboxed-args
251  (nongenerative #{info-unboxed-args bcpkdd2y9yyv643zicd4jbe3y-18})
252  (parent info)
253  (fields unboxed?*))
254