1%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2% 3% File: PK:FASLIN.SL 4% Title: Loading of binary format files. 5% Author: E. Benson 6% Created: ??? 7% Status: Experimental 8% Mode: Lisp 9% Package: Kernel 10% Compiletime: PL:FASL-DECLS.B 11% Runtime: 12% 13% (c) Copyright 1983, Hewlett-Packard Company, all rights reserved. 14% 15% 16%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 17% 18% Revisions: 19% 20% 1-Nov-90 (Winfried Neun) 21% Initial version for IBM RS 6000 22% 14-Jun-88 (Tsuyoshi Yamamoto) 23% Added new relocation types (relocate-movex,relocate-call) and long word 24% alignment for halfword access. 25% 10-Jan-84 (Brian Beach) 26% Commented-in checking of fasl-magic-number. 27% 13-Nov-84 14:13:11 (Brian Beach) 28% Moved FASLIN-INTERN to INTERN.SL. 29% 10-May-84 14:35:05 (Brian Beach) 30% Changed fasl-magic-number to faslin-magic (which is defined now in SYS-CONSTS.) 31% 01-Dec-83 14:44:33 (Brian Beach) 32% Translated from Rlisp to Lisp. 33% 34%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 35 36(compiletime (load fasl-decls) 37(ds reloc-inf-tag (x) (field x 8 2)) 38(ds reloc-inf-inf (x) (field x 42 22)) 39) 40 41 42(on fast-integers) 43 44(fluid '(code-base-hack 45 symfnc 46 symval 47 tokenbuffer 48 argumentblock)) 49 50(compiletime (flag '(relocate-movex relocate-inf relocate-word read-id-table/de 51 do-relocation relocate-right-half compute-relocation 52 local-to-global-id) 'internalfunction)) 53 54 55(de faslin (file) 56 (prog (fid % file pointer 57 local-id-count % number of ids in the file 58 local-id-table % table for mapping local ID numbers to global ID numbers. 59 code-size % number of words of code 60 code-base % location of the start of the code 61 init-function-address% Offset into the code of the init function 62 bit-table-size % number of words in the bit table 63 bit-table % the bit table 64 Btop 65 ) 66 67 % Open the file 68 (setf fid (binaryopenread file)) 69 70 % Check that the first word is the correct magic number. 71 (let ((first-word (binaryread fid))) 72 (unless (weq first-word faslin-magic) 73 (binaryclose fid) 74 (faslin-bad-file file) 75 (return nil) 76 )) 77 78 % Read in the ID table. 79 (setf local-id-table (read-id-table fid)) 80 81 % Read the code. 82 (setf code-size (binaryread fid)) % Size of code segment in words 83 (setf code-base (gtbps code-size)) % Allocate space in BPS 84 (setq Btop (GtBPS 0)) % pointer to top of alloc. BPS 85 (setf init-function-address (wplus2 code-base (binaryread fid))) 86 (binaryreadblock fid (loc (wgetv code-base 0)) code-size) 87 88 % Read the bit table 89 (setf bit-table-size (binaryread fid)) 90 (setq bit-table (gtwrds bit-table-size)) 91 (setq bit-table (mkwrds bit-table)) 92 (binaryreadblock fid (loc (words-fetch bit-table 0)) bit-table-size) 93 94 % Close the file 95 (binaryclose fid) 96 97 % Twiddle the bits. 98 (do-relocation code-base code-size bit-table local-id-table) 99 100 % Call the init code 101 (let ((temp code-base-hack)) % avoid use of fluid binding 102 (setf code-base-hack code-base) 103 (flushcache code-base (wdifference btop code-base) 0) 104 (external_system (strbase (strinf "sync"))) 105 (addressapply0 init-function-address) 106 (setf code-base-hack temp) 107 (DelBPS (wplus2 init-function-address 4) Btop) 108 ) 109 )) 110 111 112(define-constant reloc-movex 1) 113(define-constant reloc-call 2) 114(define-constant reloc-xidloc 3) 115 116(compiletime (put 'halfword_getmem 'opencode 117 '((lwz (reg 1) (displacement (reg 1) 0)) )) 118 (put 'halfword_putmem 'opencode 119 '((stw (reg 2) (displacement (reg 1) 0))))) 120 121(de do-relocation (code-base code-size bit-table id-table) 122 % CODE-AU-SIZE is the size of the code measured in addressing 123 % units, rather than words. 124 125 (let ((code-au-size code-size )) %addressingunitsperitem))) 126 (for (from i 0 (wshift (wdifference code-au-size 1) 3) 4) 127 (do 128 (let ((bit-table-entry (bittable (loc (words-fetch bit-table 0)) i)) 129 (code-location (wplus2 code-base i )) memo ) 130 (case bit-table-entry 131 ((reloc-word) 132 (case (bittable (loc (words-fetch bit-table 0)) 133 (wplus2 i 1)) 134 ((0) (relocate-word code-location code-base id-table)) 135 ((reloc-movex) 136 (relocate-movex code-location code-base id-table)) 137 ((reloc-call) 138 (progn (setq memo (halfword_getmem code-location)) 139 (setq memo 140 (wplus2 memo (wshift (wshift code-base 6) -6))) 141 %clear out first bits (see J instr!) 142 (halfword_putmem code-location memo))) 143 ((reloc-xidloc) 144 (progn (setq memo (wand (halfword_getmem code-location) 145 16#ffff)) 146 (when (local-id-number? memo) 147 (setq memo (local-to-global-id memo id-table))) 148 (halfword_putmem code-location 149 (wor (wand (halfword_getmem code-location) 150 (wnot 16#ffff)) 151 (wand (wtimes2 8 (wplus2 memo -4000)) 16#ffff))) 152 )))) 153 % 154 ((reloc-inf) (relocate-inf code-location code-base id-table)) 155 ((reloc-right-half) 156 (relocate-right-half code-location code-base id-table)) 157)))))) 158 159 160(de relocate-word (code-location code-base id-table) 161 (let ((reloc-tag (reloc-word-tag (halfword_getmem code-location))) 162 (reloc-inf (reloc-word-inf (halfword_getmem code-location)))) 163 (cond ((posintp (halfword_getmem code-location)) 164 % a naked pointer from movex 165 (halfword_putmem code-location 166 (wplus2 code-base (halfword_getmem code-location)) )) 167 (t (halfword_putmem code-location % an item 168 (compute-relocation reloc-tag reloc-inf code-base id-table)))) 169 )) 170 171(de relocate-inf (code-location code-base id-table) 172 (let ((reloc-tag (reloc-inf-tag (getmem code-location))) 173 (reloc-inf (reloc-inf-inf (getmem code-location)))) 174 (putmem code-location 175 (mkitem (tag (getmem code-location)) 176 (compute-relocation reloc-tag reloc-inf code-base id-table)) 177 ))) 178% 179% 180(de relocate-right-half (code-location code-base id-table) 181 (let ((temp1 (halfword_getmem code-location)) 182 (temp2 nil)) 183 (setq temp2 (wand temp1 16#ffff)) 184 (cond ((local-id-number? temp2) 185 (setq temp2 (local-to-global-id temp2 id-table)) 186 (halfword_putmem code-location (wor (wand temp1 (wnot 16#ffff)) 187 temp2)))))) 188 189 190(de compute-relocation (reloc-tag reloc-inf code-base id-table) 191 (case reloc-tag 192 ((reloc-code-offset) (wplus2 code-base reloc-inf )) 193 ((reloc-value-cell) 194 (cond ((local-id-number? reloc-inf) 195 (loc (symval (local-to-global-id reloc-inf id-table)))) 196 (t (loc (symval reloc-inf))))) 197 ((reloc-function-cell) 198 (progn 199 (when (local-id-number? reloc-inf) 200 (setq reloc-inf (local-to-global-id reloc-inf id-table))) 201 (wplus2 symfnc %%% Should be (LOC (SYMFNC xxx)) ??? 202 (wtimes2 addressingunitsperfunctioncell reloc-inf)))) 203 ((reloc-id-number) 204 (if (local-id-number? reloc-inf) 205 (local-to-global-id reloc-inf id-table) 206 reloc-inf 207 )) 208 )) 209 210(de local-to-global-id (local-id-number id-table) 211 (words-fetch id-table (wdifference local-id-number 2048)) 212 ) 213 214(de read-id-table (fid) 215 % Read in the table of local IDs at the front of the FASL file. 216 % Each ID is stored as one word which holds the length, followed 217 % by the appropriate number of words holding the string. 218 219 (let* ((local-id-count (binaryread fid)) 220 (id-table (mkwrds (gtwrds (wplus2 local-id-count 1))))) 221 222 (for 223 (from i 0 local-id-count) 224 (do (setf (wgetv tokenbuffer 0) (binaryread fid)) 225 % word is length of ID name 226 (binaryreadblock fid (loc (wgetv tokenbuffer 1)) 227 (strpack (wgetv tokenbuffer 0))) 228 (setf (words-fetch id-table i) 229 (idinf (faslin-intern (mkstr (loc (wgetv tokenbuffer 0)))))) 230 )) 231 id-table 232 )) 233 234(de putentry (name type offset) 235 % Called by the initcode. 236 % CODE-BASE-HACK is set by FASLIN before the initcode is called. 237 (putd name type (mkcode (wplus2 code-base-hack offset) ))) 238 239(de faslin-bad-file (name) % To be redefined 240 (console-print-string "File is not FASL format") 241 (console-newline) ) 242 243(de relocate-movex (code-location code-base id-table) 244 (let ((val (halfword_getmem (wplus2 code-location -4))) 245 (add (halfword_getmem code-location)) 246 (twentysix 26) 247 (lui nil)) 248 (setq lui (wor (wshift 15 twentysix) % LIS instruction 249 (wor (wand (wshift val -16) 16#ffff) 250 % pull the register out of next instr 251 (wshift (wand (wshift add -21) 16#1f) 21)))) 252 (setq add (wor add (wand val 16#ffff))) 253 % adjust in case of not oril instruction 254 (when (and (eq 1 (wshift (wand val 16#ffff) -15)) 255 (not (eq 24 (wshift add -26)))) % 24 is ORIL opcode 256 (setq lui (wplus2 1 lui))) 257 (halfword_putmem (wplus2 code-location -4) lui) 258 (halfword_putmem code-location add))) 259 260(de delbps (bottom top) % returns space to Bps 261 262 (when (weq nextbps top) 263 (flushcache bottom (wdifference nextbps bottom) 1) 264 (setq nextbps bottom))) 265 266 267(lap '((*entry flushcache expr 3) 268 (icbi (reg 1) (reg r0)) % see instruction manual 269 (*exit 0))) 270 271(off fast-integers) 272