![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to util.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSDTahoe / ucb / lisp / liszt|
Return to util.l CVS log | Up to [CSRG BSD Unix] / 43BSDTahoe / ucb / lisp / liszt |
1.1 root 1: (include-if (null (get 'chead 'version)) "../chead.l")
2: (Liszt-file util
3: "$Header: util.l,v 1.15 87/12/15 17:09:21 sklower Exp $")
4:
5: ;;; ---- u t i l general utility functions
6: ;;;
7: ;;; -[Tue Aug 16 17:17:32 1983 by layer]-
8:
9:
10: ;--- d-handlecc :: handle g-cc
11: ; at this point the Z condition code has been set up and if g-cc is
12: ; non nil, we must jump on condition to the label given in g-cc
13: ;
14: (defun d-handlecc nil
15: (if (car g-cc)
16: then (e-gotot (car g-cc))
17: elseif (cdr g-cc)
18: then (e-gotonil (cdr g-cc))))
19:
20: ;--- d-invert :: handle inverted condition codes
21: ; this routine is called if a result has just be computed which alters
22: ; the condition codes such that Z=1 if the result is t, and Z=0 if the
23: ; result is nil (this is the reverse of the usual sense). The purpose
24: ; of this routine is to handle g-cc and g-loc. That is if g-loc is
25: ; specified, we must convert the value of the Z bit of the condition
26: ; code to t or nil and store that in g-loc. After handling g-loc we
27: ; must handle g-cc, that is if the part of g-cc is non nil which matches
28: ; the inverse of the current condition code, we must jump to that.
29: ;
30: (defun d-invert nil
31: (if (null g-loc)
32: then (if (car g-cc) then (e-gotonil (car g-cc))
33: elseif (cdr g-cc) then (e-gotot (cdr g-cc)))
34: else (let ((lab1 (d-genlab))
35: (lab2 (if (cdr g-cc) thenret else (d-genlab))))
36: (e-gotonil lab1)
37: ; Z=1, but remember that this implies nil due to inversion
38: (d-move 'Nil g-loc)
39: (e-goto lab2)
40: (e-label lab1)
41: ; Z=0, which means t
42: (d-move 'T g-loc)
43: (if (car g-cc) then (e-goto (car g-cc)))
44: (if (null (cdr g-cc)) then (e-label lab2)))))
45:
46: ;--- d-noninvert :: handle g-cc and g-loc assuming cc non inverted
47: ;
48: ; like d-invert except Z=0 implies nil, and Z=1 implies t
49: ;
50: (defun d-noninvert nil
51: (if (null g-loc)
52: then (if (car g-cc) then (e-gotot (car g-cc))
53: elseif (cdr g-cc) then (e-gotonil (cdr g-cc)))
54: else (let ((lab1 (d-genlab))
55: (lab2 (if (cdr g-cc) thenret else (d-genlab))))
56: (e-gotot lab1)
57: ; Z=0, this implies nil
58: (d-move 'Nil g-loc)
59: (e-goto lab2)
60: (e-label lab1)
61: ; Z=1, which means t
62: (d-move 'T g-loc)
63: (if (car g-cc) then (e-goto (car g-cc)))
64: (if (null (cdr g-cc)) then (e-label lab2)))))
65:
66: ;--- d-macroexpand :: macro expand a form as much as possible
67: ;
68: ; only macro expands the top level though.
69: (defun d-macroexpand (i)
70: (prog (first type)
71: loop
72: (if (and (dtpr i) (symbolp (setq first (car i))))
73: then (if (eq 'macro (setq type (d-functyp first 'macro-ok)))
74: then (setq i (apply first i))
75: (go loop)
76: elseif (eq 'cmacro type)
77: then (setq i (apply (get first 'cmacro) i))
78: (go loop)))
79: (return i)))
80:
81: ;--- d-fullmacroexpand :: macro expand down all levels
82: ; this is not always possible to due since it is not always clear
83: ; if a function is a lambda or nlambda, and there are lots of special
84: ; forms. This is just a first shot at such a function, this should
85: ; be improved upon.
86: ;
87: (defun d-fullmacroexpand (form)
88: (if (not (dtpr form))
89: then form
90: else (setq form (d-macroexpand form)) ; do one level
91: (if (and (dtpr form) (symbolp (car form)))
92: then (let ((func (getd (car form))))
93: (if (or (and (bcdp func)
94: (eq 'lambda (getdisc func)))
95: (and (dtpr func)
96: (memq (car func) '(lambda lexpr)))
97: (memq (car form) '(or and)))
98: then `(,(car form)
99: ,@(mapcar 'd-fullmacroexpand
100: (cdr form)))
101: elseif (eq (car form) 'setq)
102: then (d-setqexpand form)
103: else form))
104: else form)))
105:
106: ;--- d-setqexpand :: macro expand a setq statemant
107: ; a setq is unusual in that alternate values are macroexpanded.
108: ;
109: (defun d-setqexpand (form)
110: (if (oddp (length (cdr form)))
111: then (comp-err "wrong number of args to setq " form)
112: else (do ((xx (reverse (cdr form)) (cddr xx))
113: (res))
114: ((null xx) (cons 'setq res))
115: (setq res `(,(cadr xx)
116: ,(d-fullmacroexpand (car xx))
117: ,@res)))))
118:
119: ;--- d-typesimp :: determine the type of the argument
120: ;
121: #+(or for-vax for-tahoe)
122: (defun d-typesimp (arg val)
123: (let ((argloc (d-simple arg)))
124: (if (null argloc)
125: then (let ((g-loc 'reg)
126: g-cc g-ret)
127: (d-exp arg))
128: (setq argloc 'reg))
129: #+for-vax (e-write4 'ashl '$-9 (e-cvt argloc) 'r0)
130: #+for-tahoe (e-write4 'shar '$9 (e-cvt argloc) 'r0)
131: (e-write3 'cmpb '"_typetable+1[r0]" val)
132: (d-invert)))
133:
134: #+for-68k
135: (defun d-typesimp (arg val)
136: (let ((argloc (d-simple arg)))
137: (if (null argloc)
138: then (let ((g-loc 'reg)
139: g-cc g-ret)
140: (d-exp arg))
141: (setq argloc 'reg)
142: else (e-move (e-cvt argloc) 'd0))
143: (e-sub '#.nil-reg 'd0)
144: (e-write3 'moveq '($ 9) 'd1)
145: (e-write3 'asrl 'd1 'd0)
146: (e-write3 'lea '"_typetable+1" 'a5)
147: (e-write3 'cmpb val '(% 0 a5 d0))
148: (d-invert)))
149:
150: ;--- d-typecmplx :: determine if arg has one of many types
151: ; - arg : lcode argument to be evaluated and checked
152: ; - vals : fixnum with a bit in position n if we are to check type n
153: ;
154: #+(or for-vax for-tahoe)
155: (defun d-typecmplx (arg vals)
156: (let ((argloc (d-simple arg))
157: (reg))
158: (if (null argloc) then (let ((g-loc 'reg)
159: g-cc g-ret)
160: (d-exp arg))
161: (setq argloc 'reg))
162: (setq reg 'r0)
163: #+for-vax (e-write4 'ashl '$-9 (e-cvt argloc) reg)
164: #+for-tahoe (e-write4 'shar '$9 (e-cvt argloc) reg)
165: (e-write3 'cvtbl (concat "_typetable+1[" reg "]") reg)
166: (e-write4 #+for-vax 'ashl #+for-tahoe 'shal reg '$1 reg)
167: (e-write3 'bitw vals reg)
168: (d-noninvert)))
169:
170: #+for-68k
171: (defun d-typecmplx (arg vals)
172: (let ((argloc (d-simple arg))
173: (l1 (d-genlab))
174: (l2 (d-genlab)))
175: (makecomment '(d-typecmplx: type check))
176: (if (null argloc)
177: then (let ((g-loc 'reg)
178: g-cc g-ret)
179: (d-exp arg))
180: (setq argloc 'reg)
181: else (e-move (e-cvt argloc) 'd0))
182: (e-sub '#.nil-reg 'd0)
183: (e-write3 'moveq '($ 9) 'd1)
184: (e-write3 'asrl 'd1 'd0)
185: (e-write3 'lea '"_typetable+1" 'a5)
186: (e-add 'd0 'a5)
187: (e-write3 'movb '(0 a5) 'd0)
188: (e-write2 'extw 'd0)
189: (e-write2 'extl 'd0)
190: (e-write3 'moveq '($ 1) 'd1)
191: (e-write3 'asll 'd0 'd1)
192: (e-move 'd1 'd0)
193: (e-write3 'andw vals 'd0)
194: (d-noninvert)
195: (makecomment '(d-typecmplx: end))))
196:
197: ;---- register handling routines.
198:
199: ;--- d-allocreg :: allocate a register
200: ; name - the name of the register to allocate or nil if we should
201: ; allocate the least recently used.
202: ;
203: (defun d-allocreg (name)
204: (if name
205: then (let ((av (assoc name g-reguse)))
206: (if av then (rplaca (cdr av) (1+ (cadr av)))) ; inc used count
207: name)
208: else ; find smallest used count
209: (do ((small (car g-reguse))
210: (smc (cadar g-reguse))
211: (lis (cdr g-reguse) (cdr lis)))
212: ((null lis)
213: (rplaca (cdr small) (1+ smc))
214: (car small))
215: (if (< (cadar lis) smc)
216: then (setq small (car lis)
217: smc (cadr small))))))
218:
219:
220: ;--- d-bestreg :: determine the register which is closest to what we have
221: ; name - name of variable whose subcontents we want
222: ; pat - list of d's and a's which tell which part we want
223: ;
224: (defun d-bestreg (name pat)
225: (do ((ll g-reguse (cdr ll))
226: (val)
227: (best)
228: (tmp)
229: (bestv -1))
230: ((null ll)
231: (if best
232: then (rplaca (cdr best) (1+ (cadr best)))
233: (list (car best)
234: (if (> bestv 0)
235: then (rplacd (nthcdr (1- bestv)
236: (setq tmp
237: (copy pat)))
238: nil)
239: tmp
240: else nil)
241: (nthcdr bestv pat))))
242: (if (and (setq val (cddar ll))
243: (eq name (car val)))
244: then (if (> (setq tmp (d-matchcnt pat (cdr val)))
245: bestv)
246: then (setq bestv tmp
247: best (car ll))))))
248:
249: ;--- d-matchcnt :: determine how many parts of a pattern match
250: ; want - pattern we want to achieve
251: ; have - pattern whose value exists in a register
252: ;
253: ; we return a count of the number of parts of the pattern match.
254: ; If this pattern will be any help at all, we return a value from
255: ; 0 to the length of the pattern.
256: ; If this pattern will not work at all, we return a number smaller
257: ; than -1.
258: ; For `have' to be useful for `want', `have' must be a substring of
259: ; `want'. If it is a substring, we return the length of `have'.
260: ;
261: (defun d-matchcnt (want have)
262: (let ((length 0))
263: (if (do ((hh have (cdr hh))
264: (ww want (cdr ww)))
265: ((null hh) t)
266: (if (or (null ww) (not (eq (car ww) (car hh))))
267: then (return nil)
268: else (incr length)))
269: then length
270: else -2)))
271:
272: ;--- d-clearreg :: clear all values in registers or just one
273: ; if no args are given, clear all registers.
274: ; if an arg is given, clear that register
275: ;
276: (defun d-clearreg n
277: (cond ((zerop n)
278: (mapc '(lambda (x) (rplaca (cdr x) 0)
279: (rplacd (cdr x) nil))
280: g-reguse))
281: (t (let ((av (assoc (arg 1) g-reguse)))
282: (if av
283: then
284: #+for-68k (d-regused (car av))
285: (rplaca (cdr av) 0)
286: (rplacd (cdr av) nil)
287: else nil)))))
288:
289: ;--- d-clearuse :: clear all register which reference a given variable
290: ;
291: (defun d-clearuse (varib)
292: (mapc '(lambda (x)
293: (if (eq (caddr x) varib) then (rplacd (cdr x) nil)))
294: g-reguse))
295:
296: ;--- d-inreg :: declare that a value is in a register
297: ; name - register name
298: ; value - value in a register
299: ;
300: (defun d-inreg (name value)
301: (let ((av (assoc name g-reguse)))
302: (if av then (rplacd (cdr av) value))
303: name))
304:
305: (defun e-setup-np-lbot nil
306: (e-move '#.np-reg '#.np-sym)
307: (e-move '#.lbot-reg '#.lbot-sym))
308:
309: ;---------------MC68000 only routines
310: #+for-68k
311: (progn 'compile
312:
313: ;--- d-regtype :: find out what type of register the operand goes
314: ; in.
315: ; eiadr - an EIADR
316: ;
317: (defun d-regtype (eiadr)
318: (if (symbolp eiadr)
319: then (if (memq eiadr '(d0 d1 d2 d3 d4 d5 d6 d7 reg)) then 'd
320: elseif (memq eiadr '(a0 a1 a2 a3 a4 a5 a6 a7 sp areg)) then 'a)
321: elseif (or (eq '\# (car eiadr))
322: (eq '$ (car eiadr))
323: (and (eq '* (car eiadr))
324: (eq '\# (cadr eiadr))))
325: then 'd
326: else 'a))
327:
328: ;--- d-regused :: declare that a reg is used in a function
329: ; regname - name of the register that is going to be used
330: ; (ie, 'd0 'a2...)
331: ;
332: (defun d-regused (regname)
333: (let ((regnum (diff (cadr (exploden regname)) 48))
334: (regtype (car (explode regname))))
335: (if (memq regname '(a0 a1 d0 d1))
336: thenret
337: elseif (equal 'd regtype)
338: then (rplacx regnum g-regmaskvec t) regname
339: else (rplacx (plus regnum 8) g-regmaskvec t) regname)))
340:
341: ;--- d-makemask :: make register mask for moveml instr
342: ;
343: (defun d-makemask ()
344: (do ((ii 0 (1+ ii))
345: (mask 0))
346: ((greaterp ii 15) mask)
347: (if (cxr ii g-regmaskvec)
348: then (setq mask (plus mask (expt 2 ii))))))
349:
350: ;--- init-regmaskvec :: initalize hunk structure to all default
351: ; save mask.
352: ;
353: ; nil means don't save it, and t means save the register upon function entry.
354: ; order in vector: d0 .. d7, a0 .. a7.
355: ; d3 : lbot (if $global-reg$ is t then save)
356: ; d7 : _nilatom
357: ; a2 : _np
358: ; a3 : literal table ptr
359: ; a4 : old _lbot (if $global-reg$ is t don't save)
360: ; a5 : intermediate address calc
361: ;
362: (defun init-regmaskvec ()
363: (setq g-regmaskvec
364: (makhunk
365: (if $global-reg$
366: then (quote (nil nil nil t nil nil nil t
367: nil nil t t t t nil nil))
368: else (quote (nil nil nil nil nil nil nil t
369: nil nil t t t t nil nil))))))
370:
371: ;--- Cstackspace :: calc local space on C stack
372: ; space = 4 * (no. of register variables saved on stack)
373: ;
374: (defun Cstackspace ()
375: (do ((ii 0 (1+ ii))
376: (retval 0))
377: ((greaterp ii 15) (* 4 retval))
378: (if (cxr ii g-regmaskvec) then (setq retval (1+ retval)))))
379:
380: ;--- d-alloc-register :: allocate a register
381: ; type - type of register (a or d)
382: ; name - the name of the register to allocate or nil if we should
383: ; allocate the least recently used.
384: ;
385: (defun d-alloc-register (type name)
386: (if name
387: then (let ((av (assoc name g-reguse)))
388: (d-regused name)
389: (if av then (rplaca (cdr av) (1+ (cadr av)))) ; inc used count
390: name)
391: else ; find smallest used count
392: (let ((reguse))
393: (do ((cur g-reguse (cdr cur)))
394: ((null cur))
395: (if (eq type (car (explode (caar cur))))
396: then (setq reguse (cons (car cur) reguse))))
397: (do ((small (car reguse))
398: (smc (cadar reguse))
399: (lis (cdr reguse) (cdr lis)))
400: ((null lis)
401: (rplaca (cdr small) (1+ smc))
402: (d-regused (car small))
403: (car small))
404: (if (< (cadar lis) smc)
405: then (setq small (car lis)
406: smc (cadr small)))))))
407:
408: ); end 68000 only routines
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.