source: trunk/source/level-0/PPC/ppc-utils.lisp @ 11522

Last change on this file since 11522 was 11522, checked in by gb, 12 years ago

PPC support for FLASH-FREEZE, which is like FREEZE without forcing
GC.

Incidentally, ensure that GC-related functions (things called via
the gc_like_from_xp() mechanism) return signed_natural results, not
just ints. (I think that in most cases the return values are currently
ignored, but they shouldn't be truncated to 32 bits, just in case something
uses them.)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 18.5 KB
Line 
1;;; -*- Mode: Lisp; Package: CCL; -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17
18(in-package "CCL")
19
20#+ppc32-target
21(defppclapfunction %address-of ((arg arg_z))
22  ;; %address-of a fixnum is a fixnum, just for spite.
23  ;; %address-of anything else is the address of that thing as an integer.
24  (clrlwi. imm0 arg (- 32 ppc32::nlisptagbits))
25  (beqlr cr0)
26  (mr imm0 arg_z)
27  ;; set cr0_eq if result fits in a fixnum
28  (clrrwi. imm1 imm0 (- ppc32::least-significant-bit ppc32::nfixnumtagbits))
29  (box-fixnum arg_z imm0)               ; assume it did
30  (beqlr+ cr0)                          ; else arg_z tagged ok, but missing bits
31  (ba .SPmakeu32)         ; put all bits in bignum.
32)
33
34#+ppc64-target
35(defppclapfunction %address-of ((arg arg_z))
36  ;; %address-of a fixnum is a fixnum, just for spite.
37  ;; %address-of anything else is the address of that thing as an integer.
38  (clrldi. imm0 arg (- 64 ppc64::nlisptagbits))
39  (beqlr cr0)
40  (mr imm0 arg_z)
41  ;; set cr0_eq if result fits in a fixnum
42  (clrrdi. imm1 imm0 (- ppc64::least-significant-bit ppc64::nfixnumtagbits))
43  (box-fixnum arg_z imm0)               ; assume it did
44  (beqlr+ cr0)                          ; else arg_z tagged ok, but missing bits
45  (ba .SPmakeu64)         ; put all bits in bignum.
46)
47
48;;; "areas" are fixnum-tagged and, for the most part, so are their
49;;; contents.
50
51;;; The nilreg-relative global all-areas is a doubly-linked-list header
52;;; that describes nothing.  Its successor describes the current/active
53;;; dynamic heap.  Return a fixnum which "points to" that area, after
54;;; ensuring that the "active" pointers associated with the current thread's
55;;; stacks are correct.
56
57
58
59(defppclapfunction %normalize-areas ()
60  (let ((address imm0)
61        (temp imm2))
62
63    ; update active pointer for tsp area.
64    (ldr address target::tcr.ts-area target::rcontext)
65    (str tsp target::area.active address)
66   
67    ;; Update active pointer for vsp area.
68    (ldr address target::tcr.vs-area target::rcontext)
69    (str vsp target::area.active address)
70   
71    ; Update active pointer for SP area
72    (ldr arg_z target::tcr.cs-area target::rcontext)
73    (str sp target::area.active arg_z)
74
75
76    (ref-global arg_z all-areas)
77    (ldr arg_z target::area.succ arg_z)
78
79    (blr)))
80
81(defppclapfunction %active-dynamic-area ()
82  (ref-global arg_z all-areas)
83  (ldr arg_z target::area.succ arg_z)
84  (blr))
85
86 
87(defppclapfunction %object-in-stack-area-p ((object arg_y) (area arg_z))
88  (ldr imm0 target::area.active area)
89  (cmplr cr0 object imm0)
90  (ldr imm1 target::area.high area)
91  (cmplr cr1 object imm1)
92  (li arg_z nil)
93  (bltlr cr0)
94  (bgelr cr1)
95  (la arg_z target::t-offset arg_z)
96  (blr))
97
98(defppclapfunction %object-in-heap-area-p ((object arg_y) (area arg_z))
99  (ldr imm0 target::area.low area)
100  (cmplr cr0 object imm0)
101  (ldr imm1 target::area.active area)
102  (cmplr cr1 object imm1)
103  (li arg_z nil)
104  (bltlr cr0)
105  (bgelr cr1)
106  (la arg_z target::t-offset arg_z)
107  (blr))
108
109
110#+ppc32-target
111(defppclapfunction walk-static-area ((a arg_y) (f arg_z))
112  (let ((fun save0)
113        (obj save1)
114        (limit save2)
115        (header imm0)
116        (tag imm1)
117        (subtag imm2)
118        (bytes imm3)
119        (elements imm0))
120    (save-lisp-context)
121    (:regsave limit 0)
122    (vpush fun)
123    (vpush obj)
124    (vpush limit)
125    (mr fun f)
126    (lwz limit ppc32::area.active a)
127    (lwz obj ppc32::area.low a)
128    (b @test)
129    @loop
130    (lwz header 0 obj)
131    (extract-fulltag tag header)
132    (cmpwi cr0 tag ppc32::fulltag-immheader)
133    (cmpwi cr1 tag ppc32::fulltag-nodeheader)
134    (beq cr0 @misc)
135    (beq cr1 @misc)
136    (la arg_z ppc32::fulltag-cons obj)
137    (set-nargs 1)
138    (mr temp0 fun)
139    (bla .SPFuncall)
140    (la obj ppc32::cons.size obj)
141    (b @test)
142    @misc
143    (la arg_z ppc32::fulltag-misc obj)
144    (set-nargs 1)
145    (mr temp0 fun)
146    (bla .SPFuncall)
147    (lwz header 0 obj)
148    (extract-fulltag tag header)
149    (cmpwi cr1 tag ppc32::fulltag-nodeheader)
150    (clrlwi subtag header (- 32 ppc32::num-subtag-bits))
151    (cmpwi cr2 subtag ppc32::max-32-bit-ivector-subtag)
152    (cmpwi cr3 subtag ppc32::max-8-bit-ivector-subtag)
153    (cmpwi cr4 subtag ppc32::max-16-bit-ivector-subtag)
154    (cmpwi cr5 subtag ppc32::subtag-double-float-vector)
155    (header-size elements header)
156    (slwi bytes elements 2)
157    (beq cr1 @bump)
158    (ble cr2 @bump)
159    (mr bytes elements)
160    (ble cr3 @bump)
161    (slwi bytes elements 1)
162    (ble cr4 @bump)
163    (slwi bytes elements 3)
164    (beq cr5 @bump)
165    (la elements 7 elements)
166    (srwi bytes elements 3)
167    @bump
168    (la bytes (+ 4 7) bytes)
169    (clrrwi bytes bytes 3)
170    (add obj obj bytes)
171    @test
172    (cmplw :cr0 obj limit)
173    (blt cr0 @loop)
174    (vpop limit)
175    (vpop obj)
176    (vpop fun)
177    (restore-full-lisp-context)
178    (blr)))
179
180#+ppc64-target
181(defppclapfunction walk-static-area ((a arg_y) (f arg_z))
182  (let ((fun save0)
183        (obj save1)
184        (limit save2)
185        (header imm0)
186        (tag imm1)
187        (subtag imm2)
188        (bytes imm3)
189        (elements imm0))
190    (save-lisp-context)
191    (:regsave limit 0)
192    (vpush fun)
193    (vpush obj)
194    (vpush limit)
195    (mr fun f)
196    (ld limit ppc64::area.active a)
197    (ld obj ppc64::area.low a)
198    (b @test)
199    @loop
200    (ld header 0 obj)
201    (extract-lowtag tag header)
202    (cmpri cr0 tag ppc64::lowtag-immheader)
203    (cmpri cr1 tag ppc64::lowtag-nodeheader)
204    (beq cr0 @misc)
205    (beq cr1 @misc)
206    (la arg_z ppc64::fulltag-cons obj)
207    (set-nargs 1)
208    (mr temp0 fun)
209    (bla .SPFuncall)
210    (la obj ppc64::cons.size obj)
211    (b @test)
212    @misc
213    (la arg_z ppc64::fulltag-misc obj)
214    (set-nargs 1)
215    (mr temp0 fun)
216    (bla .SPFuncall)
217    (ldr header 0 obj)
218    (extract-lowtag tag header)
219    (extract-fulltag subtag header)
220    (cmpri cr1 tag ppc64::lowtag-nodeheader)
221    (extract-lowbyte tag header)
222    (cmpri cr2 subtag ppc64::ivector-class-64-bit)
223    (cmpri cr3 subtag ppc64::ivector-class-8-bit)
224    (cmpri cr4 subtag ppc64::ivector-class-32-bit)
225    (cmpri cr5 tag ppc64::subtag-bit-vector)
226    (header-size elements header)
227    (sldi bytes elements 3)
228    (beq cr1 @bump)
229    (beq cr2 @bump)
230    (mr bytes elements)
231    (beq cr3 @bump)
232    (sldi bytes elements 2)
233    (beq cr4 @bump)
234    (sldi bytes elements 1)
235    (bne cr5 @bump)
236    (la elements 7 elements)
237    (srdi bytes elements 3)
238    @bump
239    (la bytes (+ 8 15) bytes)
240    (clrrdi bytes bytes 4)
241    (add obj obj bytes)
242    @test
243    (cmpld :cr0 obj limit)
244    (blt cr0 @loop)
245    (vpop limit)
246    (vpop obj)
247    (vpop fun)
248    (restore-full-lisp-context)
249    (blr)))
250
251;;; This walks the active "dynamic" area.  Objects might be moving around
252;;; while we're doing this, so we have to be a lot more careful than we
253;;; are when walking a static area.
254;;; There's the vague notion that we can't take an interrupt when
255;;; "initptr" doesn't equal "freeptr", though what kind of hooks into a
256;;; preemptive scheduler we'd need to enforce this is unclear.  We use
257;;; initptr as an untagged pointer here (and set it to freeptr when we've
258;;; got a tagged pointer to the current object.)
259;;; There are a couple of approaches to termination:
260;;;  a) Allocate a "sentinel" cons, and terminate when we run into it.
261;;;  b) Check the area limit (which is changing if we're consing) and
262;;;     terminate when we hit it.
263;;; (b) loses if the function conses.  (a) conses.  I can't think of anything
264;;; better than (a).
265;;; This, of course, assumes that any GC we're doing does in-place compaction
266;;; (or at least preserves the relative order of objects in the heap.)
267
268#+ppc32-target
269(defppclapfunction %walk-dynamic-area ((a arg_y) (f arg_z))
270  (let ((fun save0)
271        (obj save1)
272        (sentinel save2)
273        (header imm0)
274        (tag imm1)
275        (subtag imm2)
276        (bytes imm3)
277        (elements imm4))
278    (save-lisp-context)
279    (:regsave sentinel 0)
280    (vpush fun)
281    (vpush obj)
282    (vpush sentinel)
283    (ref-global imm0 tenured-area)
284    (cmpwi cr0 imm0 0)
285    (li allocbase #xfff8)
286    (la allocptr (- ppc32::fulltag-cons ppc32::cons.size) allocptr)
287    (twllt allocptr allocbase)
288    (mr sentinel allocptr)
289    (clrrwi allocptr allocptr ppc32::ntagbits)
290    (mr fun f)
291    (if :ne
292      (mr a imm0))   
293    (lwz imm5 ppc32::area.low a)
294    @loop
295    (lwz header 0 imm5)
296    (extract-fulltag tag header)
297    (cmpwi cr0 tag ppc32::fulltag-immheader)
298    (cmpwi cr1 tag ppc32::fulltag-nodeheader)
299    (beq cr0 @misc)
300    (beq cr1 @misc)
301    (la obj ppc32::fulltag-cons imm5)
302    (cmpw cr0 obj sentinel)
303    (mr arg_z obj)
304    (set-nargs 1)
305    (mr temp0 fun)
306    (beq cr0 @done)
307    (bla .SPfuncall)
308    (la imm5 (- ppc32::cons.size ppc32::fulltag-cons) obj)
309    (b @loop)
310    @misc
311    (la obj ppc32::fulltag-misc imm5)
312    (mr arg_z obj)
313    (set-nargs 1)
314    (mr temp0 fun)
315    (bla .SPFuncall)
316    (getvheader header obj)
317    (extract-fulltag tag header)
318    (cmpwi cr1 tag ppc32::fulltag-nodeheader)
319    (cmpwi cr7 tag ppc32::fulltag-immheader)
320    (clrlwi subtag header (- 32 ppc32::num-subtag-bits))
321    (cmpwi cr2 subtag ppc32::max-32-bit-ivector-subtag)
322    (cmpwi cr3 subtag ppc32::max-8-bit-ivector-subtag)
323    (cmpwi cr4 subtag ppc32::max-16-bit-ivector-subtag)
324    (cmpwi cr5 subtag ppc32::subtag-double-float-vector)
325    (header-size elements header)
326    (slwi bytes elements 2)
327    (beq cr1 @bump)
328    (if (:cr7 :ne)
329      (twle 0 0))
330    (ble cr2 @bump)
331    (mr bytes elements)
332    (ble cr3 @bump)
333    (slwi bytes elements 1)
334    (ble cr4 @bump)
335    (slwi bytes elements 3)
336    (beq cr5 @bump)
337    (la elements 7 elements)
338    (srwi bytes elements 3)
339    @bump
340    (la bytes (+ 4 7) bytes)
341    (clrrwi bytes bytes 3)
342    (subi imm5 obj ppc32::fulltag-misc)
343    (add imm5 imm5 bytes)
344    (cmpw cr0 imm5  sentinel)
345    (blt cr0 @loop)
346    (uuo_interr 0 0)
347    (b @loop)
348    @done
349    (li arg_z nil)
350    (vpop sentinel)
351    (vpop obj)
352    (vpop fun)
353    (restore-full-lisp-context)
354    (blr)))
355
356#+ppc64-target
357(defppclapfunction %walk-dynamic-area ((a arg_y) (f arg_z))
358  (let ((fun save0)
359        (obj save1)
360        (sentinel save2)
361        (header imm0)
362        (tag imm1)
363        (subtag imm2)
364        (bytes imm3)
365        (elements imm4))
366    (save-lisp-context)
367    (:regsave sentinel 0)
368    (vpush fun)
369    (vpush obj)
370    (vpush sentinel)
371    (ref-global imm0 tenured-area)
372    (cmpdi cr0 imm0 0)
373    (lwi allocbase #x8000)
374    (sldi allocbase allocbase 32)
375    (subi allocbase allocbase 16)
376    (la allocptr (- ppc64::fulltag-cons ppc64::cons.size) allocptr)
377    (tdlt allocptr allocbase)
378    (mr sentinel allocptr)
379    (clrrdi allocptr allocptr ppc64::ntagbits)
380    (mr fun f)
381    (if :ne
382      (mr a imm0))   
383    (ld imm5 ppc64::area.low a)
384    @loop
385    (ld header 0 imm5)
386    (extract-lowtag tag header)
387    (cmpdi cr0 tag ppc64::lowtag-immheader)
388    (cmpdi cr1 tag ppc64::lowtag-nodeheader)
389    (beq cr0 @misc)
390    (beq cr1 @misc)
391    (la obj ppc64::fulltag-cons imm5)
392    (cmpd cr0 obj sentinel)
393    (mr arg_z obj)
394    (set-nargs 1)
395    (mr temp0 fun)
396    (beq cr0 @done)
397    (bla .SPfuncall)
398    (la imm5 (- ppc64::cons.size ppc64::fulltag-cons) obj)
399    (b @loop)
400    @misc
401    (la obj ppc64::fulltag-misc imm5)
402    (mr arg_z obj)
403    (set-nargs 1)
404    (mr temp0 fun)
405    (bla .SPFuncall)
406    (getvheader header obj)
407    (extract-lowtag tag header)   
408    (extract-fulltag subtag header)
409    (cmpdi cr1 tag ppc64::lowtag-nodeheader)
410    (extract-lowbyte tag header)
411    (cmpri cr2 subtag ppc64::ivector-class-64-bit)
412    (cmpri cr3 subtag ppc64::ivector-class-8-bit)
413    (cmpri cr4 subtag ppc64::ivector-class-32-bit)
414    (cmpri cr5 tag ppc64::subtag-bit-vector)
415    (header-size elements header)
416    (sldi bytes elements 3)
417    (beq cr1 @bump)
418    (beq cr2 @bump)
419    (mr bytes elements)
420    (beq cr3 @bump)
421    (sldi bytes elements 2)
422    (beq cr4 @bump)
423    (sldi bytes elements 1)
424    (bne cr5 @bump)
425    (la elements 7 elements)
426    (srdi bytes elements 3)
427    @bump
428    (la bytes (+ 8 15) bytes)
429    (clrrdi bytes bytes 4)
430    (subi imm5 obj ppc64::fulltag-misc)
431    (add imm5 imm5 bytes)
432    (b @loop)
433    @done
434    (li arg_z nil)
435    (vpop sentinel)
436    (vpop obj)
437    (vpop fun)
438    (restore-full-lisp-context)
439    (blr)))
440
441(defun walk-dynamic-area (area func)
442  (with-other-threads-suspended
443      (%walk-dynamic-area area func)))
444
445
446
447(defppclapfunction %class-of-instance ((i arg_z))
448  (svref arg_z instance.class-wrapper i)
449  (svref arg_z %wrapper-class arg_z)
450  (blr))
451
452(defppclapfunction class-of ((x arg_z))
453  (check-nargs 1)
454  (extract-fulltag imm0 x)
455  (cmpri imm0 target::fulltag-misc)
456  (beq @misc)
457  (extract-lowbyte imm0 x)
458  (b @done)
459  @misc
460  (extract-subtag imm0 x)
461  @done
462  (slri imm0 imm0 target::word-shift)
463  (ldr temp1 '*class-table* nfn)
464  (addi imm0 imm0 target::misc-data-offset)
465  (ldr temp1 target::symbol.vcell temp1)
466  (ldrx temp0 temp1 imm0) ; get entry from table
467  (cmpri cr0 temp0 nil)
468  (beq @bad)
469  ;; functionp?
470  (extract-typecode imm1 temp0)
471  (cmpri imm1 target::subtag-function)
472  (bne @ret)  ; not function - return entry
473  ;; else jump to the fn
474  (mr nfn temp0)
475  (ldr temp0 target::misc-data-offset temp0)
476  (SET-NARGS 1)
477  (mtctr temp0)
478  (bctr)
479  @bad
480  (ldr fname 'no-class-error nfn)
481  (ba .spjmpsym)
482  @ret
483  (mr arg_z temp0)  ; return frob from table
484  (blr))
485
486(defppclapfunction full-gccount ()
487  (ref-global arg_z tenured-area)
488  (cmpri cr0 arg_z 0)
489  (if :eq
490    (ref-global arg_z gc-count)
491    (ldr arg_z target::area.gc-count arg_z))
492  (blr))
493
494
495(defppclapfunction gc ()
496  (check-nargs 0)
497  (li imm0 arch::gc-trap-function-gc)
498  (trlgei allocptr 0)
499  (li arg_z (target-nil-value))
500  (blr))
501
502
503(defppclapfunction egc ((arg arg_z))
504  "Enable the EGC if arg is non-nil, disables the EGC otherwise. Return
505the previous enabled status. Although this function is thread-safe (in
506the sense that calls to it are serialized), it doesn't make a whole lot
507of sense to be turning the EGC on and off from multiple threads ..."
508  (check-nargs 1)
509  (subi imm1 arg nil)
510  (li imm0 arch::gc-trap-function-egc-control)
511  (trlgei allocptr 0)
512  (blr))
513
514
515
516(defppclapfunction %configure-egc ((e0size arg_x)
517                                   (e1size arg_y)
518                                   (e2size arg_z))
519  (check-nargs 3)
520  (li imm0 arch::gc-trap-function-configure-egc)
521  (trlgei allocptr 0)
522  (blr))
523
524(defppclapfunction purify ()
525  (li imm0 arch::gc-trap-function-purify)
526  (trlgei allocptr 0)
527  (li arg_z nil)
528  (blr))
529
530
531(defppclapfunction impurify ()
532  (li imm0 arch::gc-trap-function-impurify)
533  (trlgei allocptr 0)
534  (li arg_z nil)
535  (blr))
536
537(defppclapfunction lisp-heap-gc-threshold ()
538  "Return the value of the kernel variable that specifies the amount
539of free space to leave in the heap after full GC."
540  (check-nargs 0)
541  (li imm0 arch::gc-trap-function-get-lisp-heap-threshold)
542  (trlgei allocptr 0)
543  #+ppc32-target
544  (ba .SPmakeu32)
545  #+ppc64-target
546  (ba .SPmakeu64))
547
548(defppclapfunction set-lisp-heap-gc-threshold ((new arg_z))
549  "Set the value of the kernel variable that specifies the amount of free
550space to leave in the heap after full GC to new-value, which should be a
551non-negative fixnum. Returns the value of that kernel variable (which may
552be somewhat larger than what was specified)."
553  (check-nargs 1)
554  (mflr loc-pc)
555  #+ppc32-target
556  (bla .SPgetu32)
557  #+ppc64-target
558  (bla .SPgetu64)
559  (mtlr loc-pc)
560  (mr imm1 imm0)
561  (li imm0 arch::gc-trap-function-set-lisp-heap-threshold)
562  (trlgei allocptr 0)
563  #+ppc32-target
564  (ba .SPmakeu32)
565  #+ppc64-target
566  (ba .SPmakeu64))
567
568
569(defppclapfunction use-lisp-heap-gc-threshold ()
570  "Try to grow or shrink lisp's heap space, so that the free space is(approximately) equal to the current heap threshold. Return NIL"
571  (check-nargs 0) 
572  (li imm0 arch::gc-trap-function-use-lisp-heap-threshold)
573  (trlgei allocptr 0)
574  (li arg_z nil)
575  (blr))
576
577
578(defppclapfunction freeze ()
579  "Do a full GC, then consider all heap-allocated objects which survive to be non-relocatable."
580  (check-nargs 0)
581  (li imm0 arch::gc-trap-function-freeze)
582  (trlgei allocptr 0)
583  #+64-bit-target
584  (ba .SPmakeu64)
585  #+32-bit-target
586  (ba .SPmakeu32))
587
588(defppclapfunction flash-freeze ()
589  "Like FREEZE, but don't GC first."
590  (check-nargs 0)
591  (li imm0 arch::gc-trap-function-flash-freeze)
592  (trlgei allocptr 0)
593  #+64-bit-target
594  (ba .SPmakeu64)
595  #+32-bit-target
596  (ba .SPmakeu32))
597
598;;; Make a list.  This can be faster than doing so by doing CONS
599;;; repeatedly, since the latter strategy might triger the GC several
600;;; times if N is large.
601(defppclapfunction %allocate-list ((initial-element arg_y) (nconses arg_z))
602  (check-nargs 2)
603  (save-lisp-context)
604  (uuo_interr arch::error-allocate-list rzero)
605  (vpush arg_z)
606  (vpush arg_y)
607  (set-nargs 2)
608  (ba .SPnvalret))
609 
610
611
612;;; offset is a fixnum, one of the target::kernel-import-xxx constants.
613;;; Returns that kernel import, a fixnum.
614(defppclapfunction %kernel-import ((offset arg_z))
615  (ref-global imm0 kernel-imports)
616  (unbox-fixnum imm1 arg_z)
617  (ldrx arg_z imm0 imm1)
618  (blr))
619
620(defppclapfunction %get-unboxed-ptr ((macptr arg_z))
621  (macptr-ptr imm0 arg_z)
622  (ldr arg_z 0 imm0)
623  (blr))
624
625
626(defppclapfunction %revive-macptr ((p arg_z))
627  (li imm0 target::subtag-macptr)
628  (stb imm0 target::misc-subtag-offset p)
629  (blr))
630
631(defppclapfunction %macptr-type ((p arg_z))
632  (check-nargs 1)
633  (trap-unless-typecode= p target::subtag-macptr)
634  (svref imm0 target::macptr.type-cell p)
635  (box-fixnum arg_z imm0)
636  (blr))
637 
638(defppclapfunction %macptr-domain ((p arg_z))
639  (check-nargs 1)
640  (trap-unless-typecode= p target::subtag-macptr)
641  (svref imm0 target::macptr.domain-cell p)
642  (box-fixnum arg_z imm0)
643  (blr))
644
645(defppclapfunction %set-macptr-type ((p arg_y) (new arg_z))
646  (check-nargs 2)
647  (unbox-fixnum imm1 new)
648  (trap-unless-typecode= p target::subtag-macptr)
649  (svset imm1 target::macptr.type-cell p)
650  (blr))
651
652(defppclapfunction %set-macptr-domain ((p arg_y) (new arg_z))
653  (check-nargs 2)
654  (unbox-fixnum imm1 new)
655  (trap-unless-typecode= p target::subtag-macptr)
656  (svset imm1 target::macptr.domain-cell p)
657  (blr))
658
659(defppclapfunction true ()
660  (cmplri nargs '3)
661  (li arg_z t)
662  (blelr)
663  (subi imm0 nargs '3)
664  (add vsp vsp imm0)
665  (blr))
666
667(defppclapfunction false ()
668  (cmplri nargs '3)
669  (li arg_z nil)
670  (blelr)
671  (subi imm0 nargs '3)
672  (add vsp vsp imm0)
673  (blr))
674
675(lfun-bits #'true #.(encode-lambda-list '(&lap &rest ignore)))
676(lfun-bits #'false #.(encode-lambda-list '(&lap &rest ignore)))
677
678;;; end
Note: See TracBrowser for help on using the repository browser.