1%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2%
3% File:         PXK:SYS-SUPPORT.SL
4% Description:  System specific kernel support functions.
5% Author:       Brian Beach, Hewlett-Packard`CRC
6% Created:      22-Feb-84
7% Modified:     29-Jun-84 13:56:27 (RAM)
8% Mode:         Lisp
9% Status:       Experimental (Do Not Distribute)
10%
11% (c) Copyright 1984, Hewlett-Packard Company, all rights reserved.
12% (c) Copyright 1989, Konrad-Zuse-Zentrum Berlin, all rights reserved.
13%
14%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
15%
16% Revisions:
17%
18% 28-Nov-90 (Winfried Neun)
19%  Version for IBM RS 6000
20%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
21
22(on fast-integers)
23
24(lap '((*entry PlantUnbound expr 1)
25
26        (*alloc 0)
27	(*move (reg 1) (reg t2))
28	(*wshift (reg t2) 2)
29	(*WPLUS2 (reg t2) (fluid SYMFNC))
30	(*move (times2 4 (idloc UndefinedFunction)) (reg t3))
31	(*wplus2 (reg t3) (fluid symfnc))
32	(l (reg t1) (displacement (reg  t3) 0))
33	(*move (reg t1) (displacement (reg t2) 0))
34	(*EXIT 0)))
35
36(compiletime (flag '(PlantCodePointer-normal PlantCodePointer-kernel)
37			'internalfunction))
38
39(de PlantCodePointer (idnum codinf)
40     (if (wlessp codinf (inf bpslowerbound))
41			 % then it points to kernel most probably
42         (PlantCodePointer-kernel idnum codinf)
43        (PlantCodePointer-normal idnum codinf)))
44
45(lap '( (*entry PlantCodePointer-normal expr 2)
46         (*alloc 0)
47	(*move (reg 1) (reg t2))
48	(*wshift (reg t2) 2)
49	(*WPLUS2 (reg t2) (fluid SYMFNC))
50	(*mkitem (reg 2) string-tag)
51	(*move (reg 2) (displacement (reg t2) 0)) % and plant it
52        (*EXIT 0)))
53
54(lap '( (*entry PlantCodePointer-kernel  expr 2) % this one is for copyd of
55         (*alloc 0)                              % kernel functions
56        (*move (reg 1) (reg t2))
57        (*wshift (reg t2) 2)
58        (*WPLUS2 (reg t2) (fluid SYMFNC))
59        (*mkitem (reg 2) 2)
60        (*move (reg 2) (displacement (reg t2) 0)) % and plant it
61        (*EXIT 0)))
62
63(lap '( (*entry PlantLambdaLink expr 1)
64        (*alloc 0)
65        (*move (reg 1) (reg t2))
66        (*wshift (reg t2) 2)
67        (*WPLUS2 (reg t2) (fluid SYMFNC))
68        (*move (times2 4 (idloc COMPILEDCALLINGINTERPRETED)) (reg t3))
69        (*wplus2 (reg t3) (fluid symfnc))
70        (l (reg t1) (displacement (reg  t3) 0))
71        (*move (reg t1) (displacement (reg t2) 0))
72        (*EXIT 0)))
73
74
75(lap '((*entry COMPILEDCALLINGINTERPRETED expr 0)
76      (l (reg t4) "T.SYMFNC(2)")
77      (l (reg t4) (displacement (reg t4)
78			 (times2 4 (idloc compiledcallinginterpretedaux))))
79      (mtspr (reg ctr) (reg t4))
80      (bcc always 0)))
81
82(de bittable (baseaddress bitoffset)
83  (field (ilsh (byte baseaddress (ilsh bitoffset -2))
84               (idifference (itimes2 (field bitoffset 30 2) 2) 6))
85         30 2))
86
87   % to be redefined in nonkernel
88
89(lap '((*entry undefinedfunction expr 1)
90      (l (reg t4) "T.SYMFNC(2)")
91      (l (reg t4) (displacement (reg t4)
92                         (times2 4 (idloc undefinedfunctionaux))))
93      (mtspr (reg ctr) (reg t4))
94      (bccl always 0)))
95
96(lap '((*entry undefinedfunctionaux expr 1)
97       (*alloc 1)
98       (*move (reg t3) (frame 1))
99       (*move (quote "Undefined function called: ") (reg 1))
100       (*call console-print-string)
101       (*move (frame 1) (reg t1))
102       (*wshift (reg t1) 2)
103       (*wplus2 (reg t1) (fluid symnam))
104       (*move (displacement (reg t1) 0) (reg 1))
105       (*call console-print-string)
106       (*call console-newline)
107       (*move 0 (reg 1))
108       (*call Exit-with-status)
109       (*exit 1)))
110
111(de kernel-fatal-error (string)
112  (console-print-string (kernelstring2string "FATAL ERROR: "))
113  (console-print-string string)
114  (console-newline)
115  (exit-with-status -1))
116
117(off fast-integers)
118
119% signalhandler must reside in kernel
120
121(lap '((*entry signalhaendler expr 0)
122%       We save the information which is in 'scratch' registers.
123%
124       (*move (reg 1) (fluid ibmrs-signumber))
125       (*move (reg 3) (fluid ibmrs-sigcp))
126       (*move (indexed (reg 3) 40) (reg 5))
127       (*move (reg st) (fluid ibmrs-sigaddr))
128       (*move (reg 5) (fluid ibmrs-sigpc))
129
130%  Check whether LISP trap handling is appropriate now
131
132       (*movex ($fluid *kernelmode) (reg 5))
133       (*move 16#80 (reg nil))
134       (*mkitem (reg nil) id-tag)
135       (*jumpnoteq (label goon) (reg 5) 'nil)
136       (*jumpnoteq (label templab) (reg 1) (quote 2)) % interrupt
137       (*movex ($fluid *bruch*) (reg 5))
138       (*jumpeq    (label templab) (reg 5) 0)
139%
140% Now we have a 'weaponed' interrupt. This is used e.g. by gc to remain
141% operable. Return Immediately and mark with a negative value in *bruch* !!
142%
143    goon
144       (*move -17 (reg 5))
145       (*movex (reg 5) ($fluid *bruch*))
146       (*move 0 (reg 5))
147       (*movex (reg 5) (fluid ibmrs-sigcp))
148       (*exit 0)
149
150    templab
151       (*move 0 (reg 4))
152       (*move (reg 3) (reg t2))
153       (*wplus2 (reg t2) 224)
154       (*move ($fluid ibmrs-dumparray*) (reg 5))
155      loop
156       (*wplus3 (reg t3) (reg t2) (reg 4))
157       (*wplus3 (reg t4) (reg 5) (reg 4))
158       (*move (displacement (reg t3) 0) (reg t1))
159       (*move (reg t1) (displacement (reg t4) 0))
160       (*wplus2 (reg 4) 4)
161       (*jumpwlessp (label loop) (reg 4) 129)
162
163       (*jcall signal-done)
164))
165
166(compiletime (flag '(profil) 'foreignfunction))
167
168(lap '((*entry unix-profile expr 4)
169       (*alloc 1)
170       (*link profil expr 4)
171
172       (*move 0 (reg 1))
173       (*exit 1)))
174
175