![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to funa.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 funa.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 funa
3: "$Header: funa.l,v 1.12 87/12/15 17:02:01 sklower Exp $")
4:
5: ;;; ---- f u n a function compilation
6: ;;;
7: ;;; -[Mon Aug 22 22:01:01 1983 by layer]-
8:
9:
10: ;--- cc-and :: compile an and expression
11: ; We evaluate forms from left to right as long as they evaluate to
12: ; a non nil value. We only have to worry about storing the value of
13: ; the last expression in g-loc.
14: ;
15: (defun cc-and nil
16: (let ((finlab (d-genlab))
17: (finlab2)
18: (exps (if (cdr v-form) thenret else '(t)))) ; (and) ==> t
19: (if (null (cdr g-cc))
20: then (d-exp (do ((g-cc (cons nil finlab))
21: (g-loc)
22: (g-ret)
23: (ll exps (cdr ll)))
24: ((null (cdr ll)) (car ll))
25: (d-exp (car ll))))
26: (if g-loc
27: then (setq finlab2 (d-genlab))
28: (e-goto finlab2)
29: (e-label finlab)
30: (d-move 'Nil g-loc)
31: (e-label finlab2)
32: else (e-label finlab))
33: else ;--- cdr g-cc is non nil, thus there is
34: ; a quick escape possible if one of the
35: ; expressions evals to nil
36:
37: (if (null g-loc) then (setq finlab (cdr g-cc)))
38: (d-exp (do ((g-cc (cons nil finlab))
39: (g-loc)
40: (g-ret)
41: (ll exps (cdr ll)))
42: ((null (cdr ll)) (car ll))
43: (d-exp (car ll))))
44: ; if g-loc is non nil, then we have evaled the and
45: ; expression to yield nil, which we must store in
46: ; g-loc and then jump to where the cdr of g-cc takes us
47: (if g-loc
48: then (setq finlab2 (d-genlab))
49: (e-goto finlab2)
50: (e-label finlab)
51: (d-move 'Nil g-loc)
52: (e-goto (cdr g-cc))
53: (e-label finlab2))))
54: (d-clearreg)) ; we cannot predict the state of the registers
55:
56: ;--- cc-arg :: get the nth arg from the current lexpr
57: ;
58: ; the syntax for Franz lisp is (arg i)
59: ; for interlisp the syntax is (arg x i) where x is not evaluated and is
60: ; the name of the variable bound to the number of args. We can only handle
61: ; the case of x being the variable for the current lexpr we are compiling
62: ;
63: (defun cc-arg nil
64: (prog (nillab finlab)
65: (setq nillab (d-genlab)
66: finlab (d-genlab))
67: (if (not (eq 'lexpr g-ftype))
68: then (comp-err " arg only allowed in lexprs"))
69: (if (and (eq (length (cdr v-form)) 2) fl-inter)
70: then (if (not (eq (car g-args) (cadr v-form)))
71: then (comp-err " arg expression is for non local lexpr "
72: v-form)
73: else (setq v-form (cdr v-form))))
74: (if (and (null g-loc) (null g-cc))
75: then ;bye bye, wouldn't do anything
76: (return nil))
77: (if (and (fixp (cadr v-form)) (>& (cadr v-form) 0))
78: then ; simple case (arg n) for positive n
79: (d-move `(fixnum ,(cadr v-form)) 'reg)
80: #+for-68k
81: (progn
82: (e-sub `(-4 #.olbot-reg) 'd0)
83: (if g-loc
84: then (e-move '(% -8 #.olbot-reg d0) (e-cvt g-loc)))
85: (if g-cc then (e-cmpnil '(% -8 #.olbot-reg d0))))
86: #+(or for-vax for-tahoe)
87: (progn
88: (e-sub3 '(* -4 #.olbot-reg) '(0 r0) 'r0)
89: (if g-loc
90: then (e-move '(-8 #.olbot-reg r0) (e-cvt g-loc))
91: elseif g-cc
92: then (e-tst '(-8 #.olbot-reg r0))))
93: (d-handlecc)
94: elseif (or (null (cadr v-form))
95: (and (fixp (cadr v-form)) (=& 0 (cadr v-form))))
96: then ;---the form is: (arg nil) or (arg) or (arg 0).
97: ; We have a private copy of the number of args right
98: ; above the arguments on the name stack, so that
99: ; the user can't clobber it... (0 olbot) points
100: ; to the user setable copy, and (-4 olbot) to our
101: ; copy.
102: (if g-loc then (e-move '(-4 #.olbot-reg) (e-cvt g-loc)))
103: ; Will always return a non nil value, so
104: ; don't even test it.
105: (if (car g-cc) then (e-goto (car g-cc)))
106: else ; general (arg <form>)
107: (let ((g-loc 'reg)
108: (g-cc (cons nil nillab))
109: (g-ret))
110: (d-exp (cadr v-form))) ;boxed fixnum or nil
111: ; (arg 0) returns nargs (compiler only!)
112: (d-cmp 'reg '(fixnum 0))
113: (e-gotonil nillab)
114:
115: ; ... here we are doing (arg <number>), <number> != 0
116: #+for-68k
117: (progn
118: (e-sub '(-4 #.olbot-reg) 'd0)
119: (if g-loc
120: then (e-move '(% -8 #.olbot-reg d0) (e-cvt g-loc)))
121: (if g-cc then (e-cmpnil '(% -8 #.olbot-reg d0))))
122: #+(or for-vax for-tahoe)
123: (progn
124: (e-sub3 `(* -4 #.olbot-reg) '(0 r0) 'r0)
125: (if g-loc
126: then (e-move '(-8 #.olbot-reg r0) (e-cvt g-loc))
127: elseif g-cc
128: then (e-tst '(-8 #.olbot-reg r0))))
129: (d-handlecc)
130: (e-goto finlab)
131: (e-label nillab)
132: ; here we are doing (arg nil) which
133: ; returns the number of args
134: ; which is always true if anyone is testing
135: (if g-loc
136: then (e-move '(-4 #.olbot-reg) (e-cvt g-loc))
137: #+for-68k (if g-cc then (e-cmpnil '(-4 #.olbot-reg)))
138: (d-handlecc)
139: elseif (car g-cc)
140: then (e-goto (car g-cc))) ;always true
141: (e-label finlab))))
142:
143: ;--- c-assembler-code
144: ; the args to assembler-code are a list of assembler language
145: ; statements. This statements are put directly in the code
146: ; stream produced by the compiler. Beware: The interpreter cannot
147: ; interpret the assembler-code function.
148: ;
149: (defun c-assembler-code nil
150: (setq g-skipcode nil) ; turn off code skipping
151: (makecomment '(assembler code start))
152: (do ((xx (cdr v-form) (cdr xx)))
153: ((null xx))
154: (e-write1 (car xx)))
155: (makecomment '(assembler code end)))
156:
157: ;--- cm-assq :: assoc with eq for testing
158: ;
159: ; form: (assq val list)
160: ;
161: (defun cm-assq nil
162: `(do ((xx-val ,(cadr v-form))
163: (xx-lis ,(caddr v-form) (cdr xx-lis)))
164: ((null xx-lis))
165: (cond ((eq xx-val (caar xx-lis)) (return (car xx-lis))))))
166:
167: ;--- cc-atom :: test for atomness
168: ;
169: (defun cc-atom nil
170: (d-typecmplx (cadr v-form)
171: #.(immed-const (plus 1_0 1_1 1_2 1_4 1_5 1_6 1_7 1_9 1_10))))
172:
173: ;--- c-bcdcall :: do a bcd call
174: ;
175: ; a bcdcall is the franz equivalent of the maclisp subrcall.
176: ; it is called with
177: ; (bcdcall 'b_obj 'arg1 ...)
178: ; where b_obj must be a binary object. no type checking is done.
179: ;
180: (defun c-bcdcall nil
181: (d-callbig 1 (cdr v-form) t))
182:
183: ;--- cc-bcdp :: check for bcdpness
184: ;
185: (defun cc-bcdp nil
186: (d-typesimp (cadr v-form) #.(immed-const 5)))
187:
188: ;--- cc-bigp :: check for bignumness
189: ;
190: (defun cc-bigp nil
191: (d-typesimp (cadr v-form) #.(immed-const 9)))
192:
193: ;--- c-boole :: compile
194: ;
195: #+(or for-vax for-tahoe)
196: (progn 'compile
197: (defun c-boole nil
198: (cond ((fixp (cadr v-form))
199: (setq v-form (d-boolexlate (d-booleexpand v-form)))))
200: (cond ((eq 'boole (car v-form)) ;; avoid recursive calls to d-exp
201: (d-callbig 'boole (cdr v-form) nil))
202: (t (let ((g-loc 'reg) (g-cc nil) (g-ret nil)) ; eval answer
203: (d-exp v-form)))))
204:
205: ;--- d-booleexpand :: make sure boole only has three args
206: ; we use the identity (boole k x y z) == (boole k (boole k x y) z)
207: ; to make sure that there are exactly three args to a call to boole
208: ;
209: (defun d-booleexpand (form)
210: (if (and (dtpr form) (eq 'boole (car form)))
211: then (if (< (length form) 4)
212: then (comp-err "Too few args to boole : " form)
213: elseif (= (length form) 4)
214: then form
215: else (d-booleexpand
216: `(boole ,(cadr form)
217: (boole ,(cadr form)
218: ,(caddr form)
219: ,(cadddr form))
220: ,@(cddddr form))))
221: else form))
222:
223: (declare (special x y))
224: (defun d-boolexlate (form)
225: (if (atom form)
226: then form
227: elseif (and (eq 'boole (car form))
228: (fixp (cadr form)))
229: then (let ((key (cadr form))
230: (x (d-boolexlate (caddr form)))
231: (y (d-boolexlate (cadddr form)))
232: (res))
233: (makecomment `(boole key = ,key))
234: (if (eq key 0) ;; 0
235: then `(progn ,x ,y 0)
236: elseif (eq key 1) ;; x * y
237: then #+for-vax `(fixnum-BitAndNot ,x (fixnum-BitXor ,y -1))
238: #+for-tahoe `(fixnum-BitAnd ,x ,y)
239: elseif (eq key 2) ;; !x * y
240: then #+for-vax `(fixnum-BitAndNot (fixnum-BitXor ,x -1)
241: (fixnum-BitXor ,y -1))
242: #+for-tahoe `(fixnum-BitAnd (fixnum-BitXor ,x -1) ,y)
243: elseif (eq key 3) ;; y
244: then `(progn ,x ,y)
245: elseif (eq key 4) ;; x * !y
246: then #+for-vax `(fixnum-BitAndNot ,x ,y)
247: #+for-tahoe `(fixnum-BitAnd ,x (fixnum-BitXor ,y -1))
248: elseif (eq key 5) ;; x
249: then `(prog1 ,x ,y)
250: elseif (eq key 6) ;; x xor y
251: then `(fixnum-BitXor ,x ,y)
252: elseif (eq key 7) ;; x + y
253: then `(fixnum-BitOr ,x ,y)
254: elseif (eq key 8) ;; !(x xor y)
255: then `(fixnum-BitXor (fixnum-BitOr ,x ,y) -1)
256: elseif (eq key 9) ;; !(x xor y)
257: then `(fixnum-BitXor (fixnum-BitXor ,x ,y) -1)
258: elseif (eq key 10) ;; !x
259: then `(prog1 (fixnum-BitXor ,x -1) ,y)
260: elseif (eq key 11) ;; !x + y
261: then `(fixnum-BitOr (fixnum-BitXor ,x -1) ,y)
262: elseif (eq key 12) ;; !y
263: then `(progn ,x (fixnum-BitXor ,y -1))
264: elseif (eq key 13) ;; x + !y
265: then `(fixnum-BitOr ,x (fixnum-BitXor ,y -1))
266: elseif (eq key 14) ;; !x + !y
267: then `(fixnum-BitOr (fixnum-BitXor ,x -1)
268: (fixnum-BitXor ,y -1))
269: elseif (eq key 15) ;; -1
270: then `(progn ,x ,y -1)
271: else form))
272: else form))
273:
274: (declare (unspecial x y))
275: ) ;; end for-vax
276:
277:
278: ;--- c-*catch :: compile a *catch expression
279: ;
280: ; the form of *catch is (*catch 'tag 'val)
281: ; we evaluate 'tag and set up a catch frame, and then eval 'val
282: ;
283: (defun c-*catch nil
284: (let ((g-loc 'reg)
285: (g-cc nil)
286: (g-ret nil)
287: (finlab (d-genlab))
288: (beglab (d-genlab)))
289: (d-exp (cadr v-form)) ; calculate tag into 'reg
290: (d-pushframe #.F_CATCH 'reg 'Nil) ; the Nil is a don't care
291: (push nil g-labs) ; disallow labels
292: ; retval will be non 0 if we were thrown to, in which case the value
293: ; thrown is in _lispretval.
294: ; If we weren't thrown-to the value should be calculated in r0.
295: (e-tst '_retval)
296: (e-write2 #+(or for-vax for-tahoe) 'jeql #+for-68k 'jeq beglab)
297: (e-move '_lispretval (e-cvt 'reg))
298: (e-write2 #+(or for-vax for-tahoe) 'jbr #+for-68k 'jra finlab)
299: (e-label beglab)
300: (d-exp (caddr v-form))
301: (e-label finlab)
302: (d-popframe) ; remove catch frame from stack
303: (unpush g-locs) ; remove (catcherrset . 0)
304: (unpush g-labs) ; allow labels again
305: (d-clearreg)))
306:
307: ;--- d-pushframe :: put an evaluation frame on the stack
308: ;
309: ; This is equivalant in the C system to 'errp = Pushframe(class,arg1,arg2);'
310: ; We stack a frame which describes the class (will always be F_CATCH)
311: ; and the other option args.
312: ; 2/10/82 - it is a bad idea to stack a variable number of arguments, since
313: ; this makes it more complicated to unstack frames. Thus we will always
314: ; stack the maximum --jkf
315: (defun d-pushframe (class arg1 arg2)
316: (C-push (e-cvt arg2))
317: (C-push (e-cvt arg1))
318: (C-push `($ ,class))
319: (if (null $global-reg$)
320: then (e-move '#.np-reg '#.np-sym)
321: (e-move '#.np-reg '#.lbot-sym))
322: (e-quick-call '_qpushframe)
323: (e-move (e-cvt 'reg) '_errp)
324: (push '(catcherrset . 0) g-locs))
325:
326: ;--- d-popframe :: remove an evaluation frame from the stack
327: ;
328: ; This is equivalent in the C system to 'errp = Popframe();'
329: ; n is the number of arguments given to the pushframe which
330: ; created this frame. We have to totally remove this frame from
331: ; the stack only if we are in a local function, but for now, we just
332: ; do it all the time.
333: ;
334: (defun d-popframe ()
335: (let ((treg #+(or for-vax for-tahoe) 'r1 #+for-68k 'a5))
336: (e-move '_errp treg)
337: (e-move `(#.OF_olderrp ,treg) '_errp)
338: ; there are always 3 arguments pushed, and the frame contains 5
339: ; longwords. We should make these parameters into manifest
340: ; constants --jkf
341: (e-add3 `($ ,(+ (* 3 4) (* 5 4))) treg 'sp)))
342:
343: ;--- c-cond :: compile a "cond" expression
344: ;
345: ; not that this version of cond is a 'c' rather than a 'cc' .
346: ; this was done to make coding this routine easier and because
347: ; it is believed that it wont harm things much if at all
348: ;
349: (defun c-cond nil
350: (makecomment '(beginning cond))
351: (do ((clau (cdr v-form) (cdr clau))
352: (finlab (d-genlab))
353: (nxtlab)
354: (save-reguse)
355: (seent))
356: ((or (null clau) seent)
357: ; end of cond
358: ; if haven't seen a t must store a nil in `reg'
359: (if (null seent) then (d-move 'Nil 'reg))
360: (e-label finlab))
361:
362: ; case 1 - expr
363: (if (atom (car clau))
364: then (comp-err "bad cond clause " (car clau))
365: ; case 2 - (expr)
366: elseif (null (cdar clau))
367: then (let ((g-loc (if (or g-cc g-loc) then 'reg))
368: (g-cc (cons finlab nil))
369: (g-ret (and g-ret (null (cdr clau)))))
370: (d-exp (caar clau)))
371: ; case 3 - (t expr1 expr2 ...)
372: elseif (or (eq t (caar clau))
373: (equal ''t (caar clau)))
374: then (let ((g-loc (if (or g-cc g-loc) then 'reg))
375: g-cc)
376: (d-exps (cdar clau)))
377: (setq seent t)
378: ; case 4 - (expr1 expr2 ...)
379: else (let ((g-loc nil)
380: (g-cc (cons nil (setq nxtlab (d-genlab))))
381: (g-ret nil))
382: (d-exp (caar clau)))
383: (setq save-reguse (copy g-reguse))
384: (let ((g-loc (if (or g-cc g-loc) then 'reg))
385: g-cc)
386: (d-exps (cdar clau)))
387: (if (or (cdr clau) (null seent)) then (e-goto finlab))
388: (e-label nxtlab)
389: (setq g-reguse save-reguse)))
390:
391: (d-clearreg))
392:
393: ;--- c-cons :: do a cons instruction quickly
394: ;
395: (defun c-cons nil
396: (d-pushargs (cdr v-form)) ; there better be 2 args
397: (e-quick-call '_qcons)
398: (setq g-locs (cddr g-locs))
399: (setq g-loccnt (- g-loccnt 2))
400: (d-clearreg))
401:
402: ;--- c-cxr :: compile a cxr instruction
403: ;
404: ;
405: (defun cc-cxr nil
406: (d-supercxr t nil))
407:
408: ;--- d-supercxr :: do a general struture reference
409: ; type - one of fixnum-block,flonum-block,<other-symbol>
410: ; the type is that of an array, so <other-symbol> could be t, nil
411: ; or anything else, since anything except *-block is treated the same
412: ;
413: ; the form of a cxr is (cxr index hunk) but supercxr will handle
414: ; arrays too, so hunk could be (getdata (getd 'arrayname))
415: ;
416: ; offsetonly is t if we only care about the offset of this element from
417: ; the beginning of the data structure. If offsetonly is t then type
418: ; will be nil.
419: ;
420: ; Note: this takes care of g-loc and g-cc
421:
422: #+(or for-vax for-tahoe)
423: (defun d-supercxr (type offsetonly)
424: (let ((arg1 (cadr v-form))
425: (arg2 (caddr v-form))
426: lop rop semisimple)
427:
428: (if (fixp arg1) then (setq lop `(immed ,arg1))
429: else (d-fixnumexp arg1) ; calculate index into r5
430: (setq lop 'r5)) ; and remember that it is there
431:
432: ; before we calculate the second expression, we may have to save
433: ; the value just calculated into r5. To be safe we stack away
434: ; r5 if the expression is not simple or semisimple.
435: (if (not (setq rop (d-simple arg2)))
436: then (if (and (eq lop 'r5)
437: (not (setq semisimple (d-semisimple arg2))))
438: then (C-push (e-cvt lop)))
439: (let ((g-loc 'reg) g-cc)
440: (d-exp arg2))
441: (setq rop 'r0)
442:
443: (if (and (eq lop 'r5) (not semisimple))
444: then (C-pop (e-cvt lop))))
445:
446: (if (eq type 'flonum-block)
447: then (setq lop (d-structgen lop rop 8))
448: (e-write3 'movq lop 'r4)
449: (e-quick-call '_qnewdoub) ; box number
450: (d-clearreg) ; clobbers all regs
451: (if (and g-loc (not (eq g-loc 'reg)))
452: then (d-move 'reg g-loc))
453: (if (car g-cc) then (e-goto (car g-cc)))
454: else (setq lop (d-structgen lop rop 4)
455: rop (if g-loc then
456: (if (eq type 'fixnum-block) then 'r5
457: else (e-cvt g-loc))))
458: (if rop
459: then (if offsetonly
460: then (e-write3 'moval lop rop)
461: else (e-move lop rop))
462: (if (eq type 'fixnum-block)
463: then (e-call-qnewint)
464: (d-clearreg)
465: (if (not (eq g-loc 'reg))
466: then (d-move 'reg g-loc))
467: ; result is always non nil.
468: (if (car g-cc) then (e-goto (car g-cc)))
469: else (d-handlecc))
470: elseif g-cc
471: then (if (eq type 'fixnum-block)
472: then (if (car g-cc)
473: then (e-goto (car g-cc)))
474: else (e-tst lop)
475: (d-handlecc))))))
476:
477: #+for-68k
478: (defun d-supercxr (type offsetonly)
479: (let ((arg1 (cadr v-form))
480: (arg2 (caddr v-form))
481: lop rop semisimple)
482: (makecomment `(Starting d-supercxr: vform: ,v-form))
483: (if (fixp arg1) then (setq lop `(immed ,arg1))
484: else (d-fixnumexp arg1) ; calculate index into fixnum-reg
485: (d-regused '#.fixnum-reg)
486: (setq lop '#.fixnum-reg)) ; and remember that it is there
487: ;
488: ; before we calculate the second expression, we may have to save
489: ; the value just calculated into fixnum-reg. To be safe we stack away
490: ; fixnum-reg if the expression is not simple or semisimple.
491: (if (not (setq rop (d-simple arg2)))
492: then (if (and (eq lop '#.fixnum-reg)
493: (not (setq semisimple (d-semisimple arg2))))
494: then (C-push (e-cvt lop)))
495: (let ((g-loc 'areg) g-cc)
496: (d-exp arg2))
497: (setq rop 'a0)
498: ;
499: (if (and (eq lop '#.fixnum-reg) (not semisimple))
500: then (C-pop (e-cvt lop))))
501: ;
502: (if (eq type 'flonum-block)
503: then (setq lop (d-structgen lop rop 8))
504: (break " d-supercxr : flonum stuff not done.")
505: (e-write3 'movq lop 'r4)
506: (e-quick-call '_qnewdoub) ; box number
507: (d-clearreg) ; clobbers all regs
508: (if (and g-loc (not (eq g-loc 'areg)))
509: then (d-move 'areg g-loc))
510: (if (car g-cc) then (e-goto (car g-cc)))
511: else (if (and (dtpr rop) (eq 'stack (car rop)))
512: then (e-move (e-cvt rop) 'a1)
513: (setq rop 'a1))
514: (setq lop (d-structgen lop rop 4)
515: rop (if g-loc then
516: (if (eq type 'fixnum-block)
517: then '#.fixnum-reg
518: else (e-cvt g-loc))))
519: (if rop
520: then (if offsetonly
521: then (e-write3 'lea lop 'a5)
522: (e-move 'a5 rop)
523: else (e-move lop rop))
524: (if (eq type 'fixnum-block)
525: then (e-call-qnewint)
526: (d-clearreg)
527: (if (not (eq g-loc 'areg))
528: then (d-move 'areg g-loc))
529: ; result is always non nil.
530: (if (car g-cc) then (e-goto (car g-cc)))
531: else (e-cmpnil lop)
532: (d-handlecc))
533: elseif g-cc
534: then (if (eq type 'fixnum-block)
535: then (if (car g-cc)
536: then (e-goto (car g-cc)))
537: else (if g-cc
538: then (e-cmpnil lop)
539: (d-handlecc)))))
540: (makecomment "Done with d-supercxr")))
541:
542: ;--- d-semisimple :: check if result is simple enough not to clobber r5
543: ; currently we look for the case of (getdata (getd 'foo))
544: ; since we know that this will only be references to r0.
545: ; More knowledge can be added to this routine.
546: ;
547: (defun d-semisimple (form)
548: (or (d-simple form)
549: (and (dtpr form)
550: (eq 'getdata (car form))
551: (dtpr (cadr form))
552: (eq 'getd (caadr form))
553: (dtpr (cadadr form))
554: (eq 'quote (caadadr form)))))
555:
556: ;--- d-structgen :: generate appropriate address for indexed access
557: ; index - index address, must be (immed n) or r5 (which contains int)
558: ; base - address of base
559: ; width - width of data element
560: ; want to calculate appropriate address for base[index]
561: ; may require emitting instructions to set up registers
562: ; returns the address of the base[index] suitable for setting or reading
563: ;
564: ; the code sees the base as a stack value as a special case since it
565: ; can generate (perhaps) better code for that case.
566:
567: #+(or for-vax for-tahoe)
568: (defun d-structgen (index base width)
569: (if (and (dtpr base) (eq (car base) 'stack))
570: then (if (dtpr index) ; i.e if index = (immed n)
571: then (d-move index 'r5)) ; get immed in register
572: ; the result is always *n(r6)[r5]
573: (append (e-cvt `(vstack ,(cadr base))) '(r5))
574: else (if (not (atom base)) ; i.e if base is not register
575: then (d-move base 'r0) ; (if nil gets here we will fail)
576: (d-clearreg 'r0)
577: (setq base 'r0))
578: (if (dtpr index) then `(,(* width (cadr index)) ;immed index
579: ,base)
580: else `(0 ,base r5))))
581:
582: #+for-68k
583: (defun d-structgen (index base width)
584: (if (and (dtpr base) (eq (car base) 'stack))
585: then (break "d-structgen: bad args(1)")
586: else (if (not (atom base)) ; i.e if base is not register
587: then (d-move base 'a0) ; (if nil gets here we will fail)
588: (d-clearreg 'a0)
589: (setq base 'a0))
590: (if (dtpr index)
591: then `(,(* width (cadr index)) ,base)
592: else (d-regused 'd6)
593: (e-move index 'd6)
594: (e-write3 'asll '($ 2) 'd6)
595: `(% 0 ,base d6))))
596:
597: ;--- c-rplacx :: complile a rplacx expression
598: ;
599: ; This simple calls the general structure hacking function, d-superrplacx
600: ; The argument, hunk, means that the elements stored in the hunk are not
601: ; fixum-block or flonum-block arrays.
602: (defun c-rplacx nil
603: (d-superrplacx 'hunk))
604:
605: ;--- d-superrplacx :: handle general setting of things in structures
606: ; type - one of fixnum-block, flonum-block, hunk
607: ; see d-supercxr for comments
608: ; form of rplacx is (rplacx index hunk valuetostore)
609: #+(or for-vax for-tahoe)
610: (defun d-superrplacx (type)
611: (let ((arg1 (cadr v-form))
612: (arg2 (caddr v-form))
613: (arg3 (cadddr v-form))
614: lop rop semisimple)
615:
616: ; calulate index and put it in r5 if it is not an immediate
617: ; set lop to the location of the index
618: (if (fixp arg1) then (setq lop `(immed ,arg1))
619: else (d-fixnumexp arg1)
620: (setq lop 'r5))
621:
622: ; set rop to the location of the hunk. If we have to
623: ; calculate the hunk, we may have to save r5.
624: ; If we are doing a rplacx (type equals hunk) then we must
625: ; return the hunk in r0.
626: (if (or (eq type 'hunk) (not (setq rop (d-simple arg2))))
627: then (if (and (eq lop 'r5)
628: (not (setq semisimple (d-semisimple arg2))))
629: then (d-move lop '#.Cstack))
630: (let ((g-loc 'r0) g-cc)
631: (d-exp arg2))
632: (setq rop 'r0)
633:
634: (if (and (eq lop 'r5) (not semisimple))
635: then (d-move '#.unCstack lop)))
636:
637: ; now that the index and data block locations are known, we
638: ; caclulate the location of the index'th element of hunk
639: (setq rop
640: (d-structgen lop rop
641: (if (eq type 'flonum-block) then 8 else 4)))
642:
643: ; the code to calculate the value to store and the actual
644: ; storing depends on the type of data block we are storing in.
645: (if (eq type 'flonum-block)
646: then (if (setq lop (d-simple `(cdr ,arg3)))
647: then (e-write3 'movq (e-cvt lop) rop)
648: else ; preserve rop since it may be destroyed
649: ; when arg3 is calculated
650: (e-write3 'movaq rop '#.Cstack)
651: (let ((g-loc 'r0) g-cc)
652: (d-exp arg3))
653: (d-clearreg 'r0)
654: (e-write3 'movq '(0 r0) "*(sp)+"))
655: elseif (and (eq type 'fixnum-block)
656: (setq arg3 `(cdr ,arg3))
657: nil)
658: ; fixnum-block is like hunk except we must grab the
659: ; fixnum value out of its box, hence the (cdr arg3)
660: thenret
661: else (if (setq lop (d-simple arg3))
662: then (e-move (e-cvt lop) rop)
663: else ; if we are dealing with hunks, we must save
664: ; r0 since that contains the value we want to
665: ; return.
666: (if (eq type 'hunk) then (d-move 'reg 'stack)
667: (Push g-locs nil)
668: (incr g-loccnt))
669: (e-write3 'moval rop '#.Cstack)
670: (let ((g-loc "*(sp)+") g-cc)
671: (d-exp arg3))
672: (if (eq type 'hunk) then (d-move 'unstack 'reg)
673: (unpush g-locs)
674: (decr g-loccnt))
675: (d-clearreg 'r0)))))
676:
677: #+for-68k
678: (defun d-superrplacx (type)
679: (let ((arg1 (cadr v-form))
680: (arg2 (caddr v-form))
681: (arg3 (cadddr v-form))
682: lop rop semisimple)
683: (makecomment `(starting d-superrplacx ,type :: v-form = ,v-form))
684: ;
685: ; calulate index and put it in '#.fixnum-reg if it is not an immediate
686: ; set lop to the location of the index
687: (if (fixp arg1) then (setq lop `(immed ,arg1))
688: else (d-fixnumexp arg1)
689: (d-regused '#.fixnum-reg)
690: (setq lop '#.fixnum-reg))
691: ;
692: ; set rop to the location of the hunk. If we have to
693: ; calculate the hunk, we may have to save '#.fixnum-reg.
694: ; If we are doing a rplacx (type equals hunk) then we must
695: ; return the hunk in d0.
696: (if (or (eq type 'hunk) (not (setq rop (d-simple arg2))))
697: then (if (and (eq lop '#.fixnum-reg)
698: (not (setq semisimple (d-semisimple arg2))))
699: then (d-move lop '#.Cstack))
700: (let ((g-loc 'a0) g-cc)
701: (d-exp arg2))
702: (setq rop 'a0)
703: (if (and (eq lop '#.fixnum-reg) (not semisimple))
704: then (d-move '#.unCstack lop)))
705: ;
706: ; now that the index and data block locations are known, we
707: ; caclulate the location of the index'th element of hunk
708: (setq rop
709: (d-structgen lop rop
710: (if (eq type 'flonum-block) then 8 else 4)))
711: ;
712: ; the code to calculate the value to store and the actual
713: ; storing depends on the type of data block we are storing in.
714: (if (eq type 'flonum-block)
715: then (break "flonum stuff not in yet")
716: (if (setq lop (d-simple `(cdr ,arg3)))
717: then (e-write3 'movq (e-cvt lop) rop)
718: else ; preserve rop since it may be destroyed
719: ; when arg3 is calculated
720: (e-write3 'movaq rop '#.Cstack)
721: (let ((g-loc 'd0) g-cc)
722: (d-exp arg3))
723: (d-clearreg 'd0)
724: (e-write3 'movq '(0 d0) "*(sp)+"))
725: elseif (and (eq type 'fixnum-block)
726: (setq arg3 `(cdr ,arg3))
727: nil)
728: ; fixnum-block is like hunk except we must grab the
729: ; fixnum value out of its box, hence the (cdr arg3)
730: thenret
731: else (if (setq lop (d-simple arg3))
732: then (e-move (e-cvt lop) rop)
733: else ; if we are dealing with hunks, we must save
734: ; d0 since that contains the value we want to
735: ; return.
736: (if (eq type 'hunk)
737: then (L-push 'a0)
738: (push nil g-locs)
739: (incr g-loccnt))
740: (e-write3 'lea rop 'a5)
741: (C-push 'a5)
742: (let ((g-loc '(racc * 0 sp)) g-cc)
743: (d-exp arg3))
744: (if (eq type 'hunk)
745: then (L-pop 'd0)
746: (unpush g-locs)
747: (decr g-loccnt))))
748: (makecomment '(d-superrplacx done))))
749:
750: ;--- cc-cxxr :: compile a "c*r" instr where *
751: ; is any sequence of a's and d's
752: ; - arg : argument of the cxxr function
753: ; - pat : a list of a's and d's in the reverse order of that
754: ; which appeared between the c and r
755: ;
756: #+(or for-vax for-tahoe)
757: (defun cc-cxxr (arg pat)
758: (prog (resloc loc qloc sofar togo keeptrack)
759: ; check for the special case of nil, since car's and cdr's
760: ; are nil anyway
761: (if (null arg)
762: then (if g-loc then (d-move 'Nil g-loc)
763: (d-handlecc)
764: elseif (cdr g-cc) then (e-goto (cdr g-cc)))
765: (return))
766:
767: (if (and (symbolp arg) (setq qloc (d-bestreg arg pat)))
768: then (setq resloc (car qloc)
769: loc resloc
770: sofar (cadr qloc)
771: togo (caddr qloc))
772: else (setq resloc
773: (if (d-simple arg)
774: thenret
775: else (let ((g-loc 'reg)
776: (g-cc nil)
777: (g-ret nil))
778: (d-exp arg))
779: 'r0))
780: (setq sofar nil togo pat))
781:
782: (if (and arg (symbolp arg)) then (setq keeptrack t))
783:
784: ; if resloc is a global variable, we must move it into a register
785: ; right away to be able to do car's and cdr's
786: (if (and (dtpr resloc) (or (eq (car resloc) 'bind)
787: (eq (car resloc) 'vstack)))
788: then (d-move resloc 'reg)
789: (setq resloc 'r0))
790:
791: ; now do car's and cdr's . Values are placed in r0. We stop when
792: ; we can get the result in one machine instruction. At that point
793: ; we see whether we want the value or just want to set the cc's.
794: ; If the intermediate value is in a register,
795: ; we can do : car cdr cddr cdar
796: ; If the intermediate value is on the local vrbl stack or lbind
797: ; we can do : cdr
798: (do ((curp togo newp)
799: (newp))
800: ((null curp) (if g-loc then (d-movespec loc g-loc)
801: elseif g-cc then (e-tst loc))
802: (d-handlecc))
803: (if (symbolp resloc)
804: then (if (eq 'd (car curp))
805: then (if (or (null (cdr curp))
806: (eq 'a (cadr curp)))
807: then (setq newp (cdr curp) ; cdr
808: loc `(0 ,resloc)
809: sofar (append sofar (list 'd)))
810: else (setq newp (cddr curp) ; cddr
811: loc `(* 0 ,resloc)
812: sofar (append sofar
813: (list 'd 'd))))
814: else (if (or (null (cdr curp))
815: (eq 'a (cadr curp)))
816: then (setq newp (cdr curp) ; car
817: loc `(4 ,resloc)
818: sofar (append sofar (list 'a)))
819: else (setq newp (cddr curp) ; cdar
820: loc `(* 4 ,resloc)
821: sofar (append sofar
822: (list 'a 'd)))))
823: elseif (and (eq 'd (car curp))
824: (not (eq '* (car (setq loc (e-cvt resloc))))))
825: then (setq newp (cdr curp) ; (cdr <local>)
826: loc (cons '* loc)
827: sofar (append sofar (list 'd)))
828: else (setq loc (e-cvt resloc)
829: newp curp))
830: (if newp ; if this is not the last move
831: then (setq resloc
832: (d-allocreg (if keeptrack then nil else 'r0)))
833: (d-movespec loc resloc)
834: (if keeptrack then (d-inreg resloc (cons arg sofar)))))))
835:
836: #+for-68k
837: (defun cc-cxxr (arg pat)
838: (prog (resloc loc qloc sofar togo keeptrack)
839: (makecomment '(starting cc-cxxr))
840: ; check for the special case of nil, since car's and cdr's
841: ; are nil anyway
842: (if (null arg)
843: then (if g-loc then (d-move 'Nil g-loc))
844: (if (cdr g-cc) then (e-goto (cdr g-cc)))
845: (return))
846: (if (and (symbolp arg) (setq qloc (d-bestreg arg pat)))
847: then (setq resloc (car qloc)
848: loc resloc
849: sofar (cadr qloc)
850: togo (caddr qloc))
851: else (setq resloc
852: (if (d-simple arg) thenret
853: else (d-clearreg 'a0)
854: (let ((g-loc 'areg)
855: (g-cc nil)
856: (g-ret nil))
857: (d-exp arg))
858: 'a0))
859: (setq sofar nil togo pat))
860: (if (and arg (symbolp arg)) then (setq keeptrack t))
861: ;
862: ; if resloc is a global variable, we must move it into a register
863: ; right away to be able to do car's and cdr's
864: (if (and (dtpr resloc) (or (eq (car resloc) 'bind)
865: (eq (car resloc) 'vstack)))
866: then (d-move resloc 'areg)
867: (setq resloc 'a0))
868: ; now do car's and cdr's . Values are placed in a0. We stop when
869: ; we can get the result in one machine instruction. At that point
870: ; we see whether we want the value or just want to set the cc's.
871: ; If the intermediate value is in a register,
872: ; we can do : car cdr cddr cdar
873: ; If the intermediate value is on the local vrbl stack or lbind
874: ; we can do : cdr
875: (do ((curp togo newp)
876: (newp))
877: ((null curp)
878: (if g-loc then (d-movespec loc g-loc))
879: ;
880: ;;;important: the below kludge is needed!!
881: ;;;consider the compilation of the following:
882: ;
883: ;;; (cond ((setq c (cdr c)) ...))
884: ;;; the following instructions are generated:
885: ;;; movl a4@(N),a5 ; the setq
886: ;;; movl a5@,a4@(N)
887: ;;; movl a4@,a5 ; the last two are generated if g-cc
888: ;;; cmpl a5@,d7 ; is non-nil
889: ;
890: ;;; observe that the original value the is supposed to set
891: ;;; the cc's is clobered in the operation!!
892: ;(msg "g-loc: " (e-cvt g-loc) N "loc: " loc N)
893: (if g-cc
894: then (if (and (eq '* (car loc))
895: (equal (caddr loc) (cadr (e-cvt g-loc))))
896: then (e-cmpnil '(0 a5))
897: else (e-cmpnil loc)))
898: (d-handlecc))
899: (if (symbolp resloc)
900: then (if (eq 'd (car curp))
901: then (if (or (null (cdr curp))
902: (eq 'a (cadr curp)))
903: then (setq newp (cdr curp) ; cdr
904: loc `(0 ,resloc)
905: sofar (append sofar (list 'd)))
906: else (setq newp (cddr curp) ; cddr
907: loc `(* 0 ,resloc)
908: sofar (append sofar
909: (list 'd 'd))))
910: else (if (or (null (cdr curp))
911: (eq 'a (cadr curp)))
912: then (setq newp (cdr curp) ; car
913: loc `(4 ,resloc)
914: sofar (append sofar (list 'a)))
915: else (setq newp (cddr curp) ; cdar
916: loc `(* 4 ,resloc)
917: sofar (append sofar
918: (list 'a 'd)))))
919: elseif (and (eq 'd (car curp))
920: (not (eq '* (car (setq loc (e-cvt resloc))))))
921: then (setq newp (cdr curp) ; (cdr <local>)
922: loc (cons '* loc)
923: sofar (append sofar (list 'd)))
924: else (setq loc (e-cvt resloc)
925: newp curp))
926: (if newp ; if this is not the last move
927: then (setq resloc
928: (d-alloc-register 'a
929: (if keeptrack then nil else 'a1)))
930: (d-movespec loc resloc)
931: ;(if keeptrack then (d-inreg resloc (cons arg sofar)))
932: ))
933: (makecomment '(done with cc-cxxr))))
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.