![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to vector.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSDReno / pgrm / lisp / liszt|
Return to vector.l CVS log | Up to [CSRG BSD Unix] / 43BSDReno / pgrm / lisp / liszt |
1.1 root 1: (include-if (null (get 'chead 'version)) "../chead.l")
2: (Liszt-file vector
3: "$Header: vector.l,v 1.12 87/12/15 17:10:04 sklower Exp $")
4:
5: ;;; ---- v e c t o r vector referencing
6: ;;;
7: ;;; -[Fri Nov 11 22:35:50 1983 by jkf]-
8:
9:
10: (defun cc-vset ()
11: ;; Set a vector created via 'vector'.
12: (d-vset 'lisp))
13:
14: (defun cc-vref ()
15: ;; Reference a vector created via 'vector'.
16: (d-vref 'lisp))
17:
18: (defun cc-vseti-byte ()
19: ;; Set a vector created via 'vectori-byte'.
20: (d-vset 'byte))
21:
22: (defun cc-vrefi-byte ()
23: ;; Reference a vector created via 'vectori-byte'.
24: (d-vref 'byte))
25:
26: (defun cc-vseti-word ()
27: ;; Set a vector created via 'vectori-word'.
28: (d-vset 'word))
29:
30: (defun cc-vrefi-word ()
31: ;; Reference a vector created via 'vectori-word'.
32: (d-vref 'word))
33:
34: (defun cc-vseti-long ()
35: ;; Set a vector created via 'vectori-long'.
36: (d-vset 'long))
37:
38: (defun cc-vrefi-long ()
39: ;; Reference a vector created via 'vectori-long'.
40: (d-vref 'long))
41:
42: ;--- d-vset :: handle all types of vset's
43: (defun d-vset (type)
44: ;; Generic vector store. Type is either 'lisp', 'byte', 'word',
45: ;; or 'long'.
46: (let ((vect (cadr v-form))
47: (index (caddr v-form))
48: (val (cadddr v-form))
49: (vect-addr) (index-addr)
50: (vect-val) (fetchval)
51: (temp) (size)
52: (vec-reg #+(or for-vax for-tahoe) 'r0 #+for-68k 'a0)
53: (val-reg #+(or for-vax for-tahoe) 'r1 #+for-68k 'd1)
54: (index-reg '#.fixnum-reg)
55: (temp-reg #+(or for-vax for-tahoe) 'r4 #+for-68k 'd0)
56: (temp-areg #+(or for-vax for-tahoe) 'bogus! #+for-68k 'a1)
57: (oklab (d-genlab))
58: (needlowcheck t)) ; t if must check lower index bounds
59:
60: #+for-68k (d-regused '#.fixnum-reg)
61: (makecomment `(doing vec set type ,type))
62: (if (fixp index)
63: then (if (<& index 0)
64: then (comp-err "vector index less than 0 " v-form))
65: (setq needlowcheck nil))
66:
67: ; Compute the value to be stored...
68: ;
69: ; If we are doing an immediate vector, then get the value
70: ; instead of the boxed fixnum (in the case of byte), or
71: ; word/long.
72: (if (null (eq 'lisp type)) then (setq val `(cdr ,val)))
73:
74: (if (null (setq vect-val (d-simple val)))
75: then (let ((g-loc val-reg) g-cc g-ret)
76: (d-exp val))
77: (setq vect-val val-reg)
78: else (setq vect-val (e-cvt vect-val)))
79:
80: ; make sure that we are not going to clobber val-reg...
81: (if (not (and (d-simple vect) (d-simple index)))
82: then ; val-reg could be clobbered when we do the
83: ; fetching of the vector or index values
84: (setq fetchval t)
85: (e-move vect-val (e-cvt 'stack)))
86:
87: ; Compute the index...
88: ;
89: (if (setq index-addr (d-simple index))
90: then (let ((g-loc vec-reg) g-cc g-ret)
91: (d-exp vect))
92: (setq vect-addr vec-reg) ; the vector op is in vec-reg
93: ; we really want the cdr of index (the actual number).
94: ; if we can do that simply, great. otherwise we
95: ; bring the index into index-reg and then do the cdr ourselves
96: (if (setq temp (d-simple `(cdr ,index)))
97: then (d-move temp index-reg)
98: else (d-move index-addr index-reg)
99: #+(or for-vax for-tahoe)
100: (e-move `(0 ,index-reg) index-reg)
101: #+for-68k
102: (progn
103: (e-move index-reg 'a5)
104: (e-move '(0 a5) index-reg)))
105: (setq index-addr index-reg)
106: else ; the index isn't computable simply, so we must
107: ; stack the vector location to keep it safe
108: (let ((g-loc 'stack) g-cc g-ret)
109: (d-exp vect))
110: (push nil g-locs)
111: (incr g-loccnt)
112: ; compute index's value into index-reg
113: (d-fixnumexp index)
114: ; now put vector address into vec-reg
115: (d-move 'unstack vec-reg)
116: (decr g-loccnt)
117: (pop g-locs)
118: (setq vect-addr vec-reg
119: index-addr index-reg)
120: ; must be sure that the cc's reflect the value of index-reg
121: (e-tst index-reg))
122:
123: ; At this point, vect-addr (always vec-reg) contains the location of
124: ; the start of the vector, index-addr (always index-reg) contains
125: ; the index value.
126: ; The condition codes reflect the value of the index.
127: ; First we insure that the index is non negative
128: ; test must use a jmp in case the object file is large
129: ;
130: (if needlowcheck
131: then (e-write2 #+(or for-vax for-tahoe) 'jgeq #+for-68k 'jpl oklab)
132: (e-write2 'jmp 'vecindexerr)
133: (e-label oklab)
134: (setq oklab (d-genlab)))
135: ;; now, we compare against the size of the vector
136: ;; the size of the vector is in bytes, we may want to shift this
137: ;; to reflect the size in words or longwords, depending on the
138: ;; type of reference
139: (if (eq type 'byte)
140: then ; can compare right away
141: (e-cmp index-addr `(-8 ,vect-addr))
142: else ; shift size into temp-reg
143: (setq size (if (eq type 'word) then 1 else 2))
144: #+for-vax
145: (e-write4 'ashl (concat '$- size)
146: `(-8 ,vect-addr) temp-reg)
147: #+for-tahoe
148: (e-write4 'shar (concat '$ size)
149: `(-8 ,vect-addr) temp-reg)
150: #+for-68k
151: (progn
152: (e-move `(-8 ,vect-addr) temp-reg)
153: (e-write3 'asrl `($ ,size) temp-reg))
154: (e-cmp index-addr temp-reg)
155: (d-clearreg temp-reg))
156: ;; size is the number of objects, the index is 0 based so
157: ;; it must be less than the vector size
158: (e-write2 #+(or for-vax for-tahoe) 'jlss #+for-68k 'jmi oklab)
159: (e-write2 'jmp 'vecindexerr)
160: (e-label oklab)
161:
162: (if fetchval
163: then ; unstack the value to store...
164: (e-move (e-cvt 'unstack) val-reg)
165: (setq vect-val val-reg))
166:
167: ;; if we get here then the access is in bounds
168: (if (eq type 'lisp)
169: then #+(or for-vax for-tahoe)
170: (e-move vect-val `(0 ,vect-addr ,index-addr))
171: #+for-68k
172: (progn
173: (e-move index-addr temp-reg)
174: (e-write3 'asll '($ 2) temp-reg)
175: (e-add vect-addr temp-reg)
176: (e-move temp-reg temp-areg)
177: (e-move vect-val `(0 ,temp-areg)))
178: (if g-loc (e-move vect-val (e-cvt g-loc)))
179: (if g-cc then (d-handlecc))
180: else (setq temp (cadr (assq type '((byte movb)
181: (word movw)
182: (long movl)))))
183: #+(or for-vax for-tahoe)
184: (e-write3 temp vect-val `(0 ,vect-addr ,index-addr))
185: #+for-68k
186: (progn
187: (e-move index-addr temp-reg)
188: (caseq type
189: (word (e-write3 'asll '($ 1) temp-reg))
190: (long (e-write3 'asll '($ 2) temp-reg)))
191: (e-write3 'lea `(% 0 ,vec-reg ,temp-reg) temp-areg)
192: (if (eq type 'long)
193: then (e-write3 temp vect-val `(0 ,temp-areg))
194: else (e-move vect-val 'd1)
195: (e-write3 temp 'd1 `(0 ,temp-areg))))
196: (if g-loc
197: then (if (eq type 'byte)
198: then ; all bytes values are within the fixnum
199: ; range, we convert them to immediate
200: ; fixum with ease.
201: #+for-vax
202: (progn
203: (e-write4 'ashl '($ 2)
204: index-reg index-reg)
205: (e-write3 'movab
206: `(5120 ,index-reg)
207: (e-cvt g-loc)))
208: #+for-tahoe
209: (progn
210: (e-write4 'shal '($ 2)
211: index-reg index-reg)
212: (e-write3 'movab
213: `(5120 ,index-reg)
214: (e-cvt g-loc)))
215: #+for-68k
216: (progn
217: (e-move index-reg temp-reg)
218: (e-write3 'asll '($ 2) temp-reg)
219: (e-move temp-reg temp-areg)
220: (e-move
221: (e-cvt '(fixnum 0))
222: temp-reg)
223: (e-write3 'lea
224: `(% 0 ,temp-areg ,temp-reg)
225: temp-areg)
226: (e-move
227: temp-areg
228: (e-cvt g-loc)))
229: else ; must convert the hard way
230: (e-call-qnewint)
231: (d-clearreg)
232: (if (not (eq g-loc 'reg))
233: then (d-move 'reg g-loc)))
234: ; result is always non nil
235: (if (car g-cc) then (e-goto (car g-cc)))
236: elseif (car g-cc) then (e-goto (car g-cc))))
237: (d-vectorindexcode)))
238:
239: ;--- d-vref :: handle all types of vref's
240: (defun d-vref (type)
241: ;; Generic vector reference. Type is either 'lisp', 'byte', 'word',
242: ;; or 'long'.
243: (let ((vect (cadr v-form))
244: (index (caddr v-form))
245: (vect-addr) (index-addr) (temp) (size)
246: (vec-reg #+(or for-vax for-tahoe) 'r0 #+for-68k 'a0)
247: (index-reg '#.fixnum-reg)
248: (temp-reg #+(or for-vax for-tahoe) 'r4 #+for-68k 'd0)
249: (temp-areg #+(or for-vax for-tahoe) 'rX #+for-68k 'a1)
250: (oklab (d-genlab))
251: (needlowcheck t)) ; t if must check lower index bounds
252:
253: #+for-68k (d-regused '#.fixnum-reg)
254: (makecomment `(doing vec ref type ,type))
255: (if (fixp index)
256: then (if (<& index 0)
257: then (comp-err "vector index less than 0 " v-form))
258: (setq needlowcheck nil))
259:
260: (if (setq index-addr (d-simple index))
261: then (let ((g-loc vec-reg) g-cc g-ret)
262: (d-exp vect))
263: (setq vect-addr vec-reg) ; the vector op is in vec-reg
264: ; we really want the cdr of index (the actual number).
265: ; if we can do that simply, great. otherwise we
266: ; bring the index into index-reg and then do the cdr ourselves
267: (if (setq temp (d-simple `(cdr ,index)))
268: then (d-move temp index-reg)
269: else (d-move index-addr index-reg)
270: #+(or for-vax for-tahoe)
271: (e-move `(0 ,index-reg) index-reg)
272: #+for-68k
273: (progn
274: (e-move index-reg 'a5)
275: (e-move '(0 a5) index-reg)))
276: (setq index-addr index-reg)
277: else ; the index isn't computable simply, so we must
278: ; stack the vector location to keep it safe
279: (let ((g-loc 'stack) g-cc g-ret)
280: (d-exp vect))
281: (push nil g-locs)
282: (incr g-loccnt)
283: ; compute index's value into index-reg
284: (d-fixnumexp index)
285: ; now put vector address into vec-reg
286: (d-move 'unstack vec-reg)
287: (decr g-loccnt)
288: (pop g-locs)
289: (setq vect-addr vec-reg
290: index-addr index-reg)
291: ; must be sure that the cc's reflect the value of index-reg
292: (e-tst index-reg))
293:
294: ; at this point, vect-addr (always vec-reg) contains the location of
295: ; the start of the vector, index-addr (always index-reg) contains
296: ; the index value. the condition codes reflect the value of
297: ; the index
298: ; First we insure that the index is non negative
299: ; test must use a jmp in case the object file is large
300: (if needlowcheck
301: then (e-write2 #+(or for-vax for-tahoe) 'jgeq #+for-68k 'jpl oklab)
302: (e-write2 'jmp 'vecindexerr)
303: (e-label oklab)
304: (setq oklab (d-genlab)))
305:
306: ; now, we compare against the size of the vector
307: ; the size of the vector is in bytes, we may want to shift this
308: ; to reflect the size in words or longwords, depending on the
309: ; type of reference
310: (if (eq type 'byte)
311: then ; can compare right away
312: (e-cmp index-addr `(-8 ,vect-addr))
313: else ; shift size into temp-reg
314: (setq size (if (eq type 'word) then 1 else 2))
315: #+for-vax
316: (e-write4 'ashl (concat '$- size) `(-8 ,vect-addr) temp-reg)
317: #+for-tahoe
318: (e-write4 'shar (concat '$ size) `(-8 ,vect-addr) temp-reg)
319: #+for-68k
320: (progn
321: (e-move `(-8 ,vect-addr) temp-reg)
322: (e-write3 'asrl `($ ,size) temp-reg))
323: (e-cmp index-addr temp-reg)
324: (d-clearreg temp-reg))
325: ; size is the number of objects, the index is 0 based so
326: ; it must be less than the vector size
327: (e-write2 #+(or for-vax for-tahoe) 'jlss #+for-68k 'jmi oklab)
328: (e-write2 'jmp 'vecindexerr)
329: (e-label oklab)
330:
331: ;; if we get here then the access is in bounds
332: (if g-loc
333: then ; we care about the value.
334: ; if the value is one of the fixnum types, then we
335: ; move the value to index-reg so it can be fixnum converted
336: (if (eq type 'lisp)
337: then #+(or for-vax for-tahoe)
338: (e-move `(0 ,vect-addr ,index-addr)
339: (e-cvt g-loc))
340: #+for-68k
341: (progn
342: (e-move index-addr temp-reg)
343: (e-write3 'asll '($ 2) temp-reg)
344: (e-add vect-addr temp-reg)
345: (e-move temp-reg temp-areg)
346: (e-move `(0 ,temp-areg) (e-cvt g-loc)))
347: (if g-cc then (d-handlecc))
348: else #+(or for-vax for-tahoe)
349: (progn
350: (setq temp (cadr (assq type '((byte cvtbl)
351: (word cvtwl)
352: (long movl)))))
353: (e-write3 temp
354: `(0 ,vect-addr ,index-addr)
355: index-reg))
356: #+for-68k
357: (progn
358: (setq temp
359: (cadr (assq type '((byte movb)
360: (word movw)
361: (long movl)))))
362: (caseq type
363: (word (e-write3 'asll '($ 1) index-reg))
364: (long (e-write3 'asll '($ 2) index-reg)))
365: (e-write3 'lea `(% 0 ,vec-reg ,index-reg)
366: temp-areg)
367: (if (memq type '(byte word))
368: then (e-write2 'clrl index-reg))
369: (e-write3 temp `(0 ,temp-areg) index-reg))
370: (if (eq type 'byte)
371: then ; all bytes values are within the fixnum
372: ; range, we convert them to immediate
373: ; fixum with ease.
374: #+for-vax
375: (progn
376: (e-write4 'ashl '($ 2)
377: index-reg index-reg)
378: (e-write3 'movab
379: `(5120 ,index-reg)
380: (e-cvt g-loc)))
381: #+for-tahoe
382: (progn
383: (e-write4 'shal '($ 2)
384: index-reg index-reg)
385: (e-write3 'movab
386: `(5120 ,index-reg)
387: (e-cvt g-loc)))
388: #+for-68k
389: (progn
390: (e-write3 'asll '($ 2) index-reg)
391: (e-move index-reg temp-areg)
392: (e-move
393: '($ _nilatom+0x1400)
394: temp-reg)
395: (e-write3 'lea
396: `(% 0 ,temp-areg ,temp-reg)
397: temp-areg)
398: (e-move
399: temp-areg
400: (e-cvt g-loc)))
401: else ; must convert the hard way
402: (e-call-qnewint)
403: (d-clearreg)
404: (if (not (eq g-loc 'reg))
405: then (d-move 'reg g-loc)))
406: ; result is always non nil
407: (if (car g-cc) then (e-goto (car g-cc))))
408: elseif g-cc
409: ; we dont care about the value, just whether it nil
410: then (if (eq type 'lisp)
411: then #+(or for-vax for-tahoe)
412: (e-tst `(0 ,vect-addr ,index-addr))
413: #+for-68k
414: (progn
415: (e-move index-addr temp-reg)
416: (e-write3 'asll '($ 2) temp-reg)
417: (e-add vect-addr temp-reg)
418: (e-move temp-reg temp-areg)
419: (e-cmpnil `(0 ,temp-areg)))
420: (d-handlecc)
421: else ; if fixnum, then it is always true
422: (if (car g-cc) then (e-goto (car g-cc)))))
423: (d-vectorindexcode)))
424:
425: ;--- d-vectorindexcode :: put out code to call the vector range error.
426: ; At this point the vector is in r0, the index an immediate fixnum in r5
427: ; we call the function int:vector-range-error with two arguments, the
428: ; vector and the index.
429: ;
430: (defun d-vectorindexcode ()
431: (if (null g-didvectorcode)
432: then (let ((afterlab (d-genlab)))
433: (e-goto afterlab)
434: (e-label 'vecindexerr)
435: (d-move #+(or for-vax for-tahoe) 'r0 #+for-68k 'a0 'stack)
436: (e-call-qnewint)
437: (d-move 'reg 'stack)
438: (d-calltran 'int:vector-range-error 2)
439: ; never returns
440: (e-label afterlab))
441: (setq g-didvectorcode t)))
442:
443:
444: ;------------------------ vector access functions
445:
446: ;--- cc-vectorp :: check for vectorness
447: ;
448: (defun cc-vectorp nil
449: (d-typesimp (cadr v-form) #.(immed-const 18)))
450:
451: ;--- cc-vectorip :: check for vectoriness
452: ;
453: (defun cc-vectorip nil
454: (d-typesimp (cadr v-form) #.(immed-const 19)))
455:
456: ;--- c-vsize :: extract vsize
457: ;
458: (defun c-vsize nil
459: (d-vectorsize (cadr v-form) '2))
460:
461: (defun c-vsize-byte nil
462: (d-vectorsize (cadr v-form) '0))
463:
464: (defun c-vsize-word nil
465: (d-vectorsize (cadr v-form) '1))
466:
467: (defun d-vectorsize (form shift)
468: (let ((g-loc #+(or for-vax for-tahoe) 'reg #+for-68k 'a0)
469: g-cc
470: g-ret)
471: (d-exp form))
472: ; get size into `fixnum-reg' for fixnum boxing
473: (if (zerop shift)
474: then (e-move '(-8 #+(or for-vax for-tahoe) r0 #+for-68k a0) '#.fixnum-reg)
475: else #+for-vax
476: (e-write4 'ashl (concat '$- shift) '(-8 r0) '#.fixnum-reg)
477: #+for-tahoe
478: (e-write4 'shar (concat '$ shift) '(-8 r0) '#.fixnum-reg)
479: #+for-68k
480: (progn
481: (e-move '(-8 a0) '#.fixnum-reg)
482: (e-write3 'asrl `($ ,shift) '#.fixnum-reg)))
483: (e-call-qnewint))
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.