![[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] / 42BSD / ucb / lisp / liszt|
Return to vector.l CVS log | Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / liszt |
1.1 root 1: (include-if (null (get 'chead 'version)) "../chead.l")
2: (Liszt-file vector
3: "$Header: vector.l,v 1.9 83/09/01 12:06:02 sklower Exp $")
4:
5: ;;; ---- v e c t o r vector referencing
6: ;;;
7: ;;; -[Thu Aug 11 18:29:32 1983 by layer]-
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 #+for-vax 'r0 #+for-68k 'a0)
53: (val-reg #+for-vax 'r1 #+for-68k 'd1)
54: (index-reg '#.fixnum-reg)
55: (temp-reg #+for-vax 'r4 #+for-68k 'd0)
56: (temp-areg #+for-vax '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: #+for-vax
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 #+for-vax '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-68k
148: (progn
149: (e-move `(-8 ,vect-addr) temp-reg)
150: (e-write3 'asrl `($ ,size) temp-reg))
151: (e-cmp index-addr temp-reg)
152: (d-clearreg temp-reg))
153: ;; size is the number of objects, the index is 0 based so
154: ;; it must be less than the vector size
155: (e-write2 #+for-vax 'jlss #+for-68k 'jmi oklab)
156: (e-write2 'jmp 'vecindexerr)
157: (e-label oklab)
158:
159: (if fetchval
160: then ; unstack the value to store...
161: (e-move (e-cvt 'unstack) val-reg)
162: (setq vect-val val-reg))
163:
164: ;; if we get here then the access is in bounds
165: (if (eq type 'lisp)
166: then #+for-vax
167: (e-move vect-val `(0 ,vect-addr ,index-addr))
168: #+for-68k
169: (progn
170: (e-move index-addr temp-reg)
171: (e-write3 'asll '($ 2) temp-reg)
172: (e-add vect-addr temp-reg)
173: (e-move temp-reg temp-areg)
174: (e-move vect-val `(0 ,temp-areg)))
175: (if g-loc (e-move vect-val (e-cvt g-loc)))
176: (if g-cc then (d-handlecc))
177: else (setq temp (cadr (assq type '((byte movb)
178: (word movw)
179: (long movl)))))
180: #+for-vax
181: (e-write3 temp vect-val `(0 ,vect-addr ,index-addr))
182: #+for-68k
183: (progn
184: (e-move index-addr temp-reg)
185: (caseq type
186: (word (e-write3 'asll '($ 1) temp-reg))
187: (long (e-write3 'asll '($ 2) temp-reg)))
188: (e-write3 'lea `(% 0 ,vec-reg ,temp-reg) temp-areg)
189: (if (eq type 'long)
190: then (e-write3 temp vect-val `(0 ,temp-areg))
191: else (e-move vect-val 'd1)
192: (e-write3 temp 'd1 `(0 ,temp-areg))))
193: (if g-loc
194: then (if (eq type 'byte)
195: then ; all bytes values are within the fixnum
196: ; range, we convert them to immediate
197: ; fixum with ease.
198: #+for-vax
199: (progn
200: (e-write4 'ashl '($ 2)
201: index-reg index-reg)
202: (e-write3 'movab
203: `(5120 ,index-reg)
204: (e-cvt g-loc)))
205: #+for-68k
206: (progn
207: (e-move index-reg temp-reg)
208: (e-write3 'asll '($ 2) temp-reg)
209: (e-move temp-reg temp-areg)
210: (e-move
211: (e-cvt '(fixnum 0))
212: temp-reg)
213: (e-write3 'lea
214: `(% 0 ,temp-areg ,temp-reg)
215: temp-areg)
216: (e-move
217: temp-areg
218: (e-cvt g-loc)))
219: else ; must convert the hard way
220: (e-call-qnewint)
221: (d-clearreg)
222: (if (not (eq g-loc 'reg))
223: then (d-move 'reg g-loc)))
224: ; result is always non nil
225: (if (car g-cc) then (e-goto (car g-cc)))
226: elseif (car g-cc) then (e-goto (car g-cc))))
227: (d-vectorindexcode)))
228:
229: ;--- d-vref :: handle all types of vref's
230: (defun d-vref (type)
231: ;; Generic vector reference. Type is either 'lisp', 'byte', 'word',
232: ;; or 'long'.
233: (let ((vect (cadr v-form))
234: (index (caddr v-form))
235: (vect-addr) (index-addr) (temp) (size)
236: (vec-reg #+for-vax 'r0 #+for-68k 'a0)
237: (index-reg '#.fixnum-reg)
238: (temp-reg #+for-vax 'r4 #+for-68k 'd0)
239: (temp-areg #+for-vax 'rX #+for-68k 'a1)
240: (oklab (d-genlab))
241: (needlowcheck t)) ; t if must check lower index bounds
242:
243: #+for-68k (d-regused '#.fixnum-reg)
244: (makecomment `(doing vec ref type ,type))
245: (if (fixp index)
246: then (if (<& index 0)
247: then (comp-err "vector index less than 0 " v-form))
248: (setq needlowcheck nil))
249:
250: (if (setq index-addr (d-simple index))
251: then (let ((g-loc vec-reg) g-cc g-ret)
252: (d-exp vect))
253: (setq vect-addr vec-reg) ; the vector op is in vec-reg
254: ; we really want the cdr of index (the actual number).
255: ; if we can do that simply, great. otherwise we
256: ; bring the index into index-reg and then do the cdr ourselves
257: (if (setq temp (d-simple `(cdr ,index)))
258: then (d-move temp index-reg)
259: else (d-move index-addr index-reg)
260: #+for-vax
261: (e-move `(0 ,index-reg) index-reg)
262: #+for-68k
263: (progn
264: (e-move index-reg 'a5)
265: (e-move '(0 a5) index-reg)))
266: (setq index-addr index-reg)
267: else ; the index isn't computable simply, so we must
268: ; stack the vector location to keep it safe
269: (let ((g-loc 'stack) g-cc g-ret)
270: (d-exp vect))
271: (push nil g-locs)
272: (incr g-loccnt)
273: ; compute index's value into index-reg
274: (d-fixnumexp index)
275: ; now put vector address into vec-reg
276: (d-move 'unstack vec-reg)
277: (decr g-loccnt)
278: (pop g-locs)
279: (setq vect-addr vec-reg
280: index-addr index-reg)
281: ; must be sure that the cc's reflect the value of index-reg
282: (e-tst index-reg))
283:
284: ; at this point, vect-addr (always vec-reg) contains the location of
285: ; the start of the vector, index-addr (always index-reg) contains
286: ; the index value. the condition codes reflect the value of
287: ; the index
288: ; First we insure that the index is non negative
289: ; test must use a jmp in case the object file is large
290: (if needlowcheck
291: then (e-write2 #+for-vax 'jgeq #+for-68k 'jpl oklab)
292: (e-write2 'jmp 'vecindexerr)
293: (e-label oklab)
294: (setq oklab (d-genlab)))
295:
296: ; now, we compare against the size of the vector
297: ; the size of the vector is in bytes, we may want to shift this
298: ; to reflect the size in words or longwords, depending on the
299: ; type of reference
300: (if (eq type 'byte)
301: then ; can compare right away
302: (e-cmp index-addr `(-8 ,vect-addr))
303: else ; shift size into temp-reg
304: (setq size (if (eq type 'word) then 1 else 2))
305: #+for-vax
306: (e-write4 'ashl (concat '$- size) `(-8 ,vect-addr) temp-reg)
307: #+for-68k
308: (progn
309: (e-move `(-8 ,vect-addr) temp-reg)
310: (e-write3 'asrl `($ ,size) temp-reg))
311: (e-cmp index-addr temp-reg)
312: (d-clearreg temp-reg))
313: ; size is the number of objects, the index is 0 based so
314: ; it must be less than the vector size
315: (e-write2 #+for-vax 'jlss #+for-68k 'jmi oklab)
316: (e-write2 'jmp 'vecindexerr)
317: (e-label oklab)
318:
319: ;; if we get here then the access is in bounds
320: (if g-loc
321: then ; we care about the value.
322: ; if the value is one of the fixnum types, then we
323: ; move the value to index-reg so it can be fixnum converted
324: (if (eq type 'lisp)
325: then #+for-vax
326: (e-move `(0 ,vect-addr ,index-addr)
327: (e-cvt g-loc))
328: #+for-68k
329: (progn
330: (e-move index-addr temp-reg)
331: (e-write3 'asll '($ 2) temp-reg)
332: (e-add vect-addr temp-reg)
333: (e-move temp-reg temp-areg)
334: (e-move `(0 ,temp-areg) (e-cvt g-loc)))
335: (if g-cc then (d-handlecc))
336: else #+for-vax
337: (progn
338: (setq temp (cadr (assq type '((byte cvtbl)
339: (word cvtwl)
340: (long movl)))))
341: (e-write3 temp
342: `(0 ,vect-addr ,index-addr)
343: index-reg))
344: #+for-68k
345: (progn
346: (setq temp
347: (cadr (assq type '((byte movb)
348: (word movw)
349: (long movl)))))
350: (caseq type
351: (word (e-write3 'asll '($ 1) index-reg))
352: (long (e-write3 'asll '($ 2) index-reg)))
353: (e-write3 'lea `(% 0 ,vec-reg ,index-reg)
354: temp-areg)
355: (if (memq type '(byte word))
356: then (e-write2 'clrl index-reg))
357: (e-write3 temp `(0 ,temp-areg) index-reg))
358: (if (eq type 'byte)
359: then ; all bytes values are within the fixnum
360: ; range, we convert them to immediate
361: ; fixum with ease.
362: #+for-vax
363: (progn
364: (e-write4 'ashl '($ 2)
365: index-reg index-reg)
366: (e-write3 'movab
367: `(5120 ,index-reg)
368: (e-cvt g-loc)))
369: #+for-68k
370: (progn
371: (e-write3 'asll '($ 2) index-reg)
372: (e-move index-reg temp-areg)
373: (e-move
374: '($ _nilatom+0x1400)
375: temp-reg)
376: (e-write3 'lea
377: `(% 0 ,temp-areg ,temp-reg)
378: temp-areg)
379: (e-move
380: temp-areg
381: (e-cvt g-loc)))
382: else ; must convert the hard way
383: (e-call-qnewint)
384: (d-clearreg)
385: (if (not (eq g-loc 'reg))
386: then (d-move 'reg g-loc)))
387: ; result is always non nil
388: (if (car g-cc) then (e-goto (car g-cc))))
389: elseif g-cc
390: ; we dont care about the value, just whether it nil
391: then (if (eq type 'lisp)
392: then #+for-vax
393: (e-tst `(0 ,vect-addr ,index-addr))
394: #+for-68k
395: (progn
396: (e-move index-addr temp-reg)
397: (e-write3 'asll '($ 2) temp-reg)
398: (e-add vect-addr temp-reg)
399: (e-move temp-reg temp-areg)
400: (e-tst `(0 ,temp-areg)))
401: (d-handlecc)
402: else ; if fixnum, then it is always true
403: (if (car g-cc) then (e-goto (car g-cc)))))
404: (d-vectorindexcode)))
405:
406: ;--- d-vectorindexcode :: put out code to call the vector range error.
407: ; At this point the vector is in r0, the index an immediate fixnum in r5
408: ; we call the function int:vector-range-error with two arguments, the
409: ; vector and the index.
410: ;
411: (defun d-vectorindexcode ()
412: (if (null g-didvectorcode)
413: then (let ((afterlab (d-genlab)))
414: (e-goto afterlab)
415: (e-label 'vecindexerr)
416: (d-move #+for-vax 'r0 #+for-68k 'a0 'stack)
417: (e-call-qnewint)
418: (d-move 'reg 'stack)
419: (d-calltran 'int:vector-range-error 2)
420: ; never returns
421: (e-label afterlab))
422: (setq g-didvectorcode t)))
423:
424:
425: ;------------------------ vector access functions
426:
427: ;--- cc-vectorp :: check for vectorness
428: ;
429: (defun cc-vectorp nil
430: (d-typesimp (cadr v-form) #.(immed-const 18)))
431:
432: ;--- cc-vectorip :: check for vectoriness
433: ;
434: (defun cc-vectorip nil
435: (d-typesimp (cadr v-form) #.(immed-const 19)))
436:
437: ;--- c-vsize :: extract vsize
438: ;
439: (defun c-vsize nil
440: (d-vectorsize (cadr v-form) '2))
441:
442: (defun c-vsize-byte nil
443: (d-vectorsize (cadr v-form) '0))
444:
445: (defun c-vsize-word nil
446: (d-vectorsize (cadr v-form) '1))
447:
448: (defun d-vectorsize (form shift)
449: (let ((g-loc 'reg)
450: g-cc
451: g-ret)
452: (d-exp form))
453: ; get size into `fixnum-reg' for fixnum boxing
454: (if (zerop shift)
455: then (e-move '(-8 #+for-vax r0 #+for-68k a0) '#.fixnum-reg)
456: else #+for-vax
457: (e-write4 'ashl (concat '$- shift) '(-8 r0) '#.fixnum-reg)
458: #+for-68k
459: (progn
460: (e-move '(-8 a0) '#.fixnum-reg)
461: (e-write3 'asrl `($ ,shift) '#.fixnum-reg)))
462: (e-call-qnewint))
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.