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