1% "i86comp.red" Copyright 1991-2007, Codemist Ltd 2% 3% Compiler that turns Lisp code into Intel 80x86 32-bit assembler in a way 4% that fits in with the conventions used with CSL/CCL 5% 6% It is hoped that parts of this compoiler will form a framework upon 7% which native compilers for other architectures can be built. Even with 8% just the Intel one there are three different sets of register and calling 9% conventions I would like to support (!), viz 10% Watcom C 11.0 register based calling 11% Microsoft Visual C++ 5.0 fast calling 12% Linux/GCC for Intel architectures 13% This incoherence is amazing and horrid! 14% 15% The rules for these configurations appear to be as follows, but 16% astonishing though it may seem I have found it amazingly difficult to 17% find these rules documented. Certainly Microsoft explicitly indicate 18% that the register-usage for their __fastcall linkage may vary between 19% releases of their C compiler. Explanations of where to place arguments 20% are tolerably well explained, but the statement of what registers may be 21% corrupted and which must be preserved is buried somewhere... 22% 23% 24% register (a) (b) (c) 25% 26% EAX result arg1/result result 27% EBX preserved arg3 or preserved preserved 28% ECX scratch arg4 or preserved arg1 or scratch 29% EDX scratch arg2 or preserved arg2 or scratch 30% EBP preserved preserved preserved 31% ESI preserved preserved preserved 32% EDI preserved preserved preserved 33% ESP stack stack stack 34% 35% (a) Linux/GCC all functions, Watcom and MSVC __cdecl and va_args cases 36% (b) Watcom "/r5" register-based calling 37% (c) MSVC __fastcall 38% 39% 40% M A Dmitriev 41% A C Norman 42 43global '(i_machine); 44 45i_machine := cdr assoc('native, lispsystem!*); 46 47% i_machine = 2 Watcom 11.0 48% = 3 MS VC++ 5.0 49% = 4 Linux 50% otherwise something not supported here. 51 52if not (i_machine=2 or i_machine=3 or i_machine=4) then 53 error(0, "Unsupported architecture for this compiler"); 54 55% 56% Assembler for use when generating native code within CSL/CCL. The 57% overall structure of this code is intende to be fairly independent of 58% the actual machine architecture supported, and there will be call-backs 59% into particular code-generators when system sensitive operations have 60% to be performed. 61% 62 63% 64% This low-level assembler is activated using a procedural interface. 65% To create some native code the correct sequence to use is: 66% i_startproc(); set things going 67% for each basic block do 68% i_putlabel lab; 69% for each instruction in the block do 70% i_putcomment '(disassembly of the instrn); 71% mixture of 72% i_putbyte 8-bits 73% i_put32 32-bits Intel byte-order 74% i_extern <data> 32-bit ref to external symbol 75% i_putjump(data, lab) variable length jump instruction 76% i_resolve(); resolve labels 77% 78% There is a put32r to insert bytes in Sun rather than Intel byte order, 79% and put16, put16r calls for 16-bit values. 80% 81% To go with this assembler there must be machine-specific procedures 82% to decode the jump stuff: 83% i_jumpsize(pc, target, data) 84% i_jumpbytes(pc, target, data) 85% where i_jumpsize MUST return a list whose length is the same as 86% the value of i_jumpsize. The data handed down is whatever was passed to 87% i_putjump, and it can be as complicated a structure as the architecture 88% needs. 89% 90% put_extern takes an argument that one of the following, the meaning of 91% which are explained later: 92% (absolute xxx) 93% (relative xxx) 94% (rel_plus_4 xxx) 95% (rel_minus_2 xxx) 96% (rel_minus_4 xxx) 97% (rel_offset xxx n) 98% 99% where xxx can be one of the following possibilities: 100% a negative integer -(n+1) n is used to look up in a useful_functions 101% table (in file fns3.c of the CSL sources) 102% a positive integer n address_of_variable (from fns3.c) will be 103% called with n as an argument 104% (n 0) entry n from zero_arg_functions (eval4.c) 105% (n 1) entry n from one_arg_functions 106% (n 2) entry n from two_arg_functions 107% (n 3) entry n from three_arg_functions 108% and the code in restart.c will need to agree with the layout created 109% here for relocation modes that link to these entities. 110% 111% All the addressing modes (at present) generate a 32 bit reference. The 112% simplest one is ABSOLUTE which just puts the address of the target 113% in the 32 bit location. The other modes all insert an adddress of the 114% target relative to the current location. The complication is that some 115% computers want this to be relative to the start of the 32-bit address, 116% some relative to the start of the instruction containing that address and 117% some use the start of the NEXT instruction as the base. I use plain 118% RELATIVE for relocation from the start address of the value being 119% stored. REL_PLUS_4 is relative to the word after this (ie +4). REL_MINUS_2 120% and REL_MINUS_4 are expected to be useful if you need to be relative to the 121% start of an instruction which has 2 or 4 bytes before the 32-bit offset. 122% Finally REL_OFFSET is a catch-all that puts an extra signed byte in the 123% relocation table to show the offset from the effect of just RELATIVE. 124% In general I expect any particular computer to use just one of these, 125% for instance Intel use REL_PLUS_4, but the others are there to make it 126% easy to implement many different compiler back-ends. I have room in the 127% encoding to add several more modes if and when necessary! 128% 129% 130% Of course for any particular computer architecture I will have a 131% higher level assembler that accepts input in a fairly symbolic form 132% and converts it into the bit-patterns required here. 133% 134% A procedure is accumulated as a sequence of blocks. Each of these 135% has an associated label, which will be a gensym if no user label was 136% provided. Jump instructions only occur at the end of one of these 137% blocks. When a block is complete it sits in the list of blocks in 138% the form 139% (label location size b<n> b<n-1> ... b<0>) 140% where size is the size in bytes represented by the sequence of bytes 141% b<i>, except that the size of any final JUMP is not included. The 142% items in the list may be 143% an integer just that byte 144% (JUMP shortform longform label) short/long are lists of bytes 145% (EXTERN something) 4 bytes external reference 146% (COMMENT c1 c2 ...) to display in listing 147% 148 149fluid '(i_procedure i_block i_blocksize i_label i_pc i_externs); 150 151global '(!*genlisting); 152 153!*genlisting := nil; 154 155switch genlisting; % For the benefit of RLISP/Reduce users 156 157 158symbolic procedure i_startproc(); 159 << i_label := list nil; 160 i_procedure := nil; 161 i_externs := nil; 162 i_block := nil; 163 i_blocksize := 0; 164 i_pc := 0; 165 nil 166 >>; 167 168symbolic procedure i_putlabel l; 169 begin 170% car i_label can be nil at the start of a procedure or just after a jump 171% has been issued. If a label is set in such a case and any instructions 172% have been set in the dummy block then I invent a gensym-label for it, 173% but if a real label gets set soon enough I can avoid introducing any 174% sort of dummy mess. 175 if car i_label = nil then << 176 if i_block = nil then << 177 rplaca(i_label, l); 178 return >> 179 else rplaca(i_label, gensym()) >>; 180% 181 rplacd(i_label, i_pc . i_blocksize . i_block); 182 i_procedure := i_label . i_procedure; 183 put(car i_label, 'i_label, i_label); 184% When I first create a procedure I suppose (optimistically) that all 185% jumps can be rendered in short form. 186 i_pc := i_pc + i_blocksize; 187 if i_block and eqcar(car i_block, 'jump) then 188 i_pc := i_pc + length cadar i_block + 1; 189 i_label := list l; 190 i_block := nil; 191 i_blocksize := 0; 192 nil 193 end; 194 195% The user MUST put a comment just before each instruction if 196% disassembly is to behave properly. However if the assembly code 197% is not going to be displayed I can avoid storing the extra rubbish. 198 199symbolic procedure i_putcomment n; 200 << if !*genlisting then i_block := ('comment . n) . i_block; 201 nil 202 >>; 203 204symbolic procedure i_putbyte n; 205 << i_block := n . i_block; 206 i_blocksize := i_blocksize + 1; 207 nil 208 >>; 209 210symbolic procedure i_put32 n; 211 << i_putbyte logand(n, 0xff); 212 n := logand(n, 0xffffffff) / 0x100; 213 i_putbyte logand(n, 0xff); 214 n := irightshift(n, 8); 215 i_putbyte logand(n, 0xff); 216 n := irightshift(n, 8); 217 i_putbyte logand(n, 0xff); 218 nil 219 >>; 220 221% Codegenerators will need to use whether i_put32 or i_put32r 222% depending on the byte ordering used by the architecture that they support. 223 224symbolic procedure i_put32r n; 225 << n := logand(n, 0xffffffff); 226 i_putbyte logand(n / 0x01000000, 0xff); 227 i_putbyte logand(n / 0x00010000, 0xff); 228 i_putbyte logand(n / 0x00000100, 0xff); 229 i_putbyte logand(n, 0xff); 230 nil 231 >>; 232 233% 234% i_put16 and i_put16r dump 16 bit values. 235% 236 237symbolic procedure i_put16 n; 238 << i_putbyte logand(n, 0xff); 239 n := irightshift(ilogand(n, 0xffff), 8); 240 i_putbyte logand(n, 0xff); 241 nil 242 >>; 243 244symbolic procedure i_put16r n; 245 << n := logand(n, 0xffff); 246 i_putbyte irightshift(n, 8); 247 i_putbyte logand(n, 0xff); 248 nil 249 >>; 250 251% In order to be able to optimise short jumps I will arrange to start a 252% fresh basic block after every jump instruction. I also store two 253% possible byte sequences for use in the final code, one for when the 254% target address is close by and the other for when it is further away. 255% 256 257symbolic procedure i_putjump(data, lab); 258 << i_block := list('jump, data, lab) . i_block; 259 if car i_label = nil then rplaca(i_label, gensym()); 260 rplacd(i_label, i_pc . i_blocksize . i_block); 261 i_procedure := i_label . i_procedure; 262 put(car i_label, 'i_label, i_label); 263% When a jump is first issued I will assemble it as a jump-to-self 264% which I expect to use the shortest form of jump available. Later on 265% and only if necessary I will expand it to a longer variant of the 266% instruction. 267 i_pc := i_pc + i_blocksize + i_jumpsize(i_pc, i_pc, data); 268 i_label := list nil; % leave in pending state 269 i_block := nil; 270 i_blocksize := 0; 271 flag(list lab, 'i_used); % To get it displayed in listing 272 nil 273 >>; 274 275% References to "external" symbols will be used to call functions in the 276% Lisp kernel and to reference key variables there. At present I assume that 277% all such references will require a 32-bit field. This will get filled in by 278% load-time relocation code. 279 280symbolic procedure i_putextern a; 281 << i_block := list('extern, a) . i_block; 282 i_externs := list(i_label, i_blocksize, a) . i_externs; 283 i_blocksize := i_blocksize + 4; 284 nil 285 >>; 286 287% prinhexb displays a hex number and then a blank, but only 288% if !*genlisting is true. 289 290symbolic procedure prinhexb(n, w); 291 if !*genlisting then << 292 prinhex(n, w); 293 princ " " >>; 294 295% i_resolve() iterates over the code re-calculating the length of 296% each basic block and hence deducing how long each jump instruction 297% has to be. When it has done that it scans the code to make a map 298% showing what external symbols will need relocating, and it builds 299% the relevant tables. Finally it allocates space for the assembled 300% code and puts the bytes where they need to be, optionally printing 301% a nice neat version for the user to admire. 302 303symbolic procedure i_resolve(); 304 begin 305 scalar changed, pc, hardcode_handle, c, c1, c2, c3, gap, oll; 306 oll := linelength 80; 307 i_putlabel nil; % Flushes last block into data structures 308% The blocks had been collected in reverse order since that is how Lisp 309% finds it easiest to build up lists. 310 i_procedure := reversip i_procedure; 311% Iterate until position of all blocks stabilises. In the very worst case 312% this could take a number of passes proportional to the length of the 313% code being assembled, but I do not expect that to happen often enough 314% to worry about it. 315 repeat << 316 changed := nil; 317 pc := 0; 318 for each b in i_procedure do begin 319 scalar loc, len, j; 320 loc := cadr b; % estimated location 321 len := caddr b; % length of block (excluding jump) 322 j := cdddr b; 323 if j then j := car j; 324 if eqcar(j, 'jump) then j := cdr j else j := nil; 325 if loc neq pc then << 326 changed := t; % will need to go around again. 327 rplaca(cdr b, pc) >>; 328 pc := pc + len; 329% The next bit evaluates the size of a jump instruction. 330 if j then begin 331 scalar target, offset; 332 target := cadr get(cadr j, 'i_label); 333 pc := pc + i_jumpsize(pc, target, car j) end 334 end 335 >> until not changed; 336% When I get to here pc shows the total size of the compiled code, and 337% all labels have been resolved with jumps able to be in their shortest 338% valid forms. The next thing to do is to sort out external references. 339 i_pc := pc; 340 341 i_externs := reversip i_externs; 342 for each r in i_externs do rplaca(r, cadar r); 343 c := i_externs; 344 pc := 0; 345 i_externs := nil; 346 while c do begin 347 scalar data, address, offset, addressmode, target, op; 348 c1 := car c; 349 data := caddr c1; % The "data" passed to i_putextern 350 address := car c1 + cadr c1; % word to relocate 351 offset := address - pc; % distance from previous relocation 352 pc := address; % store loc to calculate next offset 353 addressmode := car data; % data = {addressmode,target} 354 target := cadr data; 355% The variable op will accumulate the first byte of the relocation information 356% which packs an address mode and a target catagory into 169 possibilities 357% as 13*13. 358 op := 13*get(addressmode, 'i_addressmode); 359% The target is coded in a slighly (!) ugly way here. I decode it and 360% merge part of the information into the opcode byte, leaving the variable 361% "target" holding an 8-bit specification of just what to address. 362 if numberp target then << 363 if target < 0 then << 364 op := op + 4; % RELOC_DIRECT_ENTRY 365 target := -(target+1) >> 366 else op := op + 5 >> % RELOC_VAR 367 else << 368 op := op + cadr target; % RELOC_0_ARGS to RELOC_3_ARGS 369 target := car target >>; 370% Now things are a bit messy. If the next relocation is close to the 371% current one (which it almost always will be) I use a single byte offset 372% to indicate where it is. 373 if offset < 256 then % can use one-byte offset 374 i_externs := offset . (op+1) . i_externs 375% If the next relocation is 256 or more bytes away I have to use an extended 376% form of relocation record. This spreads the opcode across two bytes and 377% that give space for 15 bits of genuine offset. If the gap was over 378% 0x7fff then even this is not enough, and in that case I use multiple 379% instances of the biggest offset I do support and do null relocations 380% at the intermediate places. 381 else << 382 while offset > 0x7fff do << 383% The sequence 0xff 0xff 0xff will be treated as NOP with offset 0x7fff 384% and thus provides for arbitrary expansion of the range of offsets. 385 i_externs := 0xff . 0xff . 0xff . i_externs; 386 offset := offset - 0x7fff >>; 387% NB (obviously?) the coding use here must agree with the corresponding 388% stuff in source file "restart.c" that unpicks stuff. 389 i_externs := logand(offset, 0xff) . (171 + op/2) . i_externs; 390 i_externs := (128*remainder(op, 2) + (offset/256)) . i_externs >>; 391 i_externs := target . i_externs; 392% Here when I support RELOC_SELF_2 I will need to insert a target extension 393% byte into the code-stream here. 394% 395% Add an extra byte if the relocation needed patching with a further offset, 396% if we had address mode REL_OFFSET. 397 if eqcar(gap, 'rel_offset) then 398 i_externs := logand(caddr data, 0xff) . i_externs; 399% I put a "comment" into the list so that I can display a nice 400% or at least fairly symbolic indication of the relocation information 401% when the user has !*genlisting switched on. 402 i_externs := list(pc, data) . i_externs; 403 c := cdr c end; 404 i_externs := '(termination) . 0 . i_externs; % Terminate the list 405% The first 4 bytes of some BPS give its length, and then the 406% next 4 bytes give the offset of the start of the actual code in it. 407% thuse there are 8 bytes of stuff to allow for. 408 gap := 8; 409 for each r in i_externs do if numberp r then gap := gap+1; 410% I will ensure that the compiled code itself starts at a word boundary. I 411% could make it start at a doubleword boundary easily enough if that made 412% a real difference to performance. 413 c := logand(gap, 3); 414 if c neq 0 then << 415 while c neq 4 do << 416 i_externs := 0 . i_externs; 417 c := c + 1; 418 gap := gap + 1 >>; % Word align 419 i_externs := '(alignment) . i_externs >>; 420 i_externs := reversip i_externs; % Back in the tidy order; 421% Insert the data that gives the offset to the start of real compiled code 422 i_externs := list('start, compress 423 ('!! . '!0 . '!x . explodehex gap)) . i_externs; 424 i_externs := logand(gap / 0x01000000, 0xff) . i_externs; 425 i_externs := logand(gap / 0x00010000, 0xff) . i_externs; 426 i_externs := logand(gap / 0x00000100, 0xff) . i_externs; 427 i_externs := logand(gap, 0xff) . i_externs; 428% Create space for the assembled code. 429 i_pc := i_pc + gap; 430 hardcode_handle := make!-native(i_pc); 431 pc := 4; 432 while i_externs do << 433 prinhexb(pc, 4); 434 if !*genlisting then princ ": "; 435 while i_externs and numberp car i_externs do << 436 prinhexb(car i_externs, 2); 437 native!-putv(hardcode_handle, pc, car i_externs); 438 pc := pc + 1; 439 i_externs := cdr i_externs >>; 440 if not atom i_externs then << 441 if !*genlisting then << 442 ttab 35; 443 if numberp caar i_externs then << 444 princ "@"; 445 prinhex(gap+caar i_externs, 4); 446 princ ": " >> 447 else << 448 princ caar i_externs; 449 princ " " >>; 450 if cdar i_externs then printc cadar i_externs 451 else terpri() >>; 452 i_externs := cdr i_externs >> >>; 453 if !*genlisting then terpri(); % between relocation table & code 454 pc := gap; 455 for each b in i_procedure do << 456% I display labels unless they are never referenced. 457 if !*genlisting and flagp(car b, 'i_used) then << 458 ttab 30; prin car b; printc ":" >>; 459% The instructions within a basic block had been accumulated in a list 460% that is reversed, so put it right here. 461 c := reverse cdddr b; % Code list 462% I expect the first item in the list to be a comment, but if it is not 463% I will annotate things with a "?" rather than crashing. 464 if c and eqcar(car c, 'comment) then << 465 c1 := cdar c; c := cdr c >> 466 else c1 := '(!?); 467 while c do << 468 prinhexb(pc, 4); princ ": "; % Address to put things at. 469% Since I really wanted comments before each instruction I will scan 470% forwrad until I either find the next comment or I hit the end of the list. 471 while c and not eqcar(c2 := car c, 'comment) do << 472 if numberp c2 then << 473 prinhexb(c2, 2); 474 native!-putv(hardcode_handle, pc, c2); 475 pc := pc + 1 >> 476 else if eqcar(c2, 'extern) then << 477 if !*genlisting then princ "xx xx xx xx "; 478 native!-putv(hardcode_handle, pc, 0); pc := pc + 1; 479 native!-putv(hardcode_handle, pc, 0); pc := pc + 1; 480 native!-putv(hardcode_handle, pc, 0); pc := pc + 1; 481 native!-putv(hardcode_handle, pc, 0); pc := pc + 1 >> 482 else if eqcar(c2, 'jump) then << 483 for each j in i_jumpbytes(pc-gap, 484 cadr get(caddr c2, 'i_label), 485 cadr c2) do << 486 prinhexb(j, 2); 487 native!-putv(hardcode_handle, pc, j); pc := pc + 1 >> >>; 488 c := cdr c >>; 489 if !*genlisting then << % Now display the comment 490 ttab 34; 491 for each w in c1 do << 492 if w = '!; then ttab 55 else princ " "; 493 princ w >>; 494 terpri() >>; 495 if c and eqcar(c2, 'comment) then << 496 c1 := cdr c2; c := cdr c >> >> >>; 497% At the end of dealing with a procedure I will clean up the property lists 498% of all the symbols that were used as labels in it. 499 for each b in i_procedure do << 500 remflag(list car b, 'i_used); 501 remprop(car b, 'i_label) >>; 502 linelength oll; 503 return (hardcode_handle . gap) 504 end; 505 506put('absolute, 'i_addressmode, 0); % Absolute address of target 507put('relative, 'i_addressmode, 1); % relative to start of reference 508put('rel_plus_4, 'i_addressmode, 2); % relative to end of reference 509put('rel_minus_2, 'i_addressmode, 3);% relative to 2 before item 510put('rel_minus_4, 'i_addressmode, 4);% relative to 4 before item 511put('rel_offset, 'i_addressmode, 5); % generic offset relative address 512 513 514 515 516%============================================================================ 517% Now some Intel versions of jump support. This supposes that the "jump data" 518% passed down to i_putjump was just the one-byte opcode for the short 519% form of a relative jump. 520 521symbolic procedure i_jumpsize(pc, target, data); 522 begin 523 scalar offset; 524 offset := target - (pc + 2); % Suppose short here 525 if offset >= -128 and offset <= 127 then return 2 % short jump 526 else if data = 0xeb then return 5 % unconditional 527 else return 6 % conditional 528 end; 529 530symbolic procedure i_jumpbytes(pc, target, data); 531 begin 532 scalar r, offset; 533 offset := target - (pc + 2); % Suppose short for the moment 534 if offset >= -128 and offset <= 127 then 535 return list(data, logand(offset, 0xff)); 536% An unconditional jump grows by 3 bytes while a conditional one 537% needs an extra 4. And on this architecture the offset is taken from the 538% end of the jump instruction, and so I need to adjust it a bit here. 539 if data = 0xeb then << % 0xeb = short unconditional jump 540 offset := offset - 3; 541 r := list 0xe9 >> % 0xe9 = long unconditional jump 542 else << 543 offset := offset - 4; 544 r := list(data+0x10, 0x0f) >>; % +0x10 turns short to long jump 545 offset := logand(offset, 0xffffffff); 546 r := logand(offset, 0xff) . r; 547 offset := offset / 0x100; 548 r := ilogand(offset, 0xff) . r; 549 offset := irightshift(offset, 8); 550 r := ilogand(offset, 0xff) . r; 551 offset := irightshift(offset, 8); 552 r := ilogand(offset, 0xff) . r; 553 return reversip r 554 end; 555 556 557 558 559 560% 561% Next the code that transforms symbolically represented i80x86 instructions 562% into native machine code. 563% 564 565 566% The main macro of the code generator. Generates opcodes for a sequence of 567% i80x86 instructions represented in symbolic form. A macro is used just to 568% make the calling form perhaps more natural. The sequence supplied to this 569% macro looks as a list of parameters of arbitary length, not as a Lisp list 570% (into which the macro transforms this sequence). Things that are names 571% of Intel opcodes or registers do not need to be quoted... I detect them 572% and insert a quote during macro expansion. 573 574symbolic macro procedure i!:gopcode u; 575 list('i!:genopcode, 'list . 576 for each v in cdr u collect 577 if atom v then 578 (if get(v, 'i!:regcode) or get(v, 'i!:nargs) then mkquote v 579 else v) 580 else if eqcar(v, 'list) then for each v1 in v collect 581 (if atom v1 and get(v1, 'i!:regcode) then mkquote v1 582 else v1) 583 else v); 584 585% Now the procedure which actually gets called. It looks for items that 586% are flagged as being opcodes, and for each such it knows how many 587% operands to expect. It can then call lower level routines to collect and 588% process those operands. Some amount of peephole optimisation is done on 589% the way, which is probably not where I want it to be done, but it can 590% remain here until I have re-worked the higher level compiler. 591 592symbolic procedure i!:genopcode u; 593 begin 594 scalar c, nargs; 595 while u do << 596 c := car u; 597 nargs := get(c, 'i!:nargs); 598 if nargs then << % It is an opcode... 599 u := cdr u; 600 if nargs = 2 then << 601 i!:2arginstr(c, car u, cadr u); 602 u := cddr u >> 603 else if nargs = 1 then << 604 i!:1arginstr(c, car u); 605 u := cdr u >> 606 else i!:noarginstr c >> 607 else if c = '!: then << % label 608 i!:proc_label cadr u; 609 u := cddr u >> 610 else u := cdr u >> % Ignore anything that is not understood! 611 end; 612 613 614<< 615 % Codes of the processor registers 616 put('eax, 'i!:regcode, 0); 617 put('ecx, 'i!:regcode, 1); 618 put('edx, 'i!:regcode, 2); 619 put('ebx, 'i!:regcode, 3); 620 put('esp, 'i!:regcode, 4); 621 put('ebp, 'i!:regcode, 5); 622 put('esi, 'i!:regcode, 6); 623 put('edi, 'i!:regcode, 7); 624 % ds and ebp have the same code, but instructions which contain memory 625 % references of the form {ds,...} have a special prefix. However, this 626 % code generator will produce wrong output for "mov ds,const" instruction. 627 % But I can't imagine what it can be needed for and I am not sure it is 628 % legal in the user mode. 629 put('ds, 'i!:regcode, 5); 630 631% Irregular table of instructions opcodes. Values associated with the 632% properties are either main or secondary opcodes for different formats 633% of the instructions. 634 635 put('add, 'i!:nargs, 2); put('add, 'i!:rm!-reg, 0x01); 636 put('add, 'i!:immed!-rm, 0x81); put('add, 'i!:immed!-rm!-secopcode, 0); 637 put('add, 'i!:immed!-eax, 0x05); 638 639 put('and, 'i!:nargs, 2); put('and, 'i!:rm!-reg, 0x21); 640 put('and, 'i!:immed!-rm, 0x81); put('and, 'i!:immed!-rm!-secopcode, 4); 641 put('and, 'i!:immed!-eax, 0x25); 642 643 put('call, 'i!:nargs, 1); 644 put('call, 'i!:reg, 0xff); put('call, 'i!:reg!-secopcode, 0xd0); 645 put('call, 'i!:jump, 0xe8); 646 647 put('cmp, 'i!:nargs, 2); put('cmp, 'i!:rm!-reg, 0x39); 648 put('cmp, 'i!:immed!-rm, 0x81); put('cmp, 'i!:immed!-rm!-secopcode, 7); 649 put('cmp, 'i!:immed!-eax, 0x3d); 650 651 put('dec, 'i!:nargs, 1); 652 put('dec, 'i!:reg, 0x48); 653 654 put('mul, 'i!:nargs, 2); 655 put('mul, 'i!:rm!-reg!-prefix, 0x0f); 656 657 put('mul, 'i!:rm!-reg, 0xaf); put('mul, 'i!:rm!-reg!-dbit_preset, 1); 658 put('mul, 'i!:immed!-rm, 0x69); 659 660 put('inc, 'i!:nargs, 1); 661 put('inc, 'i!:reg, 0x40); 662 663 put('je, 'i!:nargs, 1); put('je, 'i!:jump, 0x74); 664 put('jne, 'i!:nargs, 1); put('jne, 'i!:jump, 0x75); 665 put('jg, 'i!:nargs, 1); put('jg, 'i!:jump, 0x7f); 666 put('jge, 'i!:nargs, 1); put('jge, 'i!:jump, 0x7d); 667 put('jl, 'i!:nargs, 1); put('jl, 'i!:jump, 0x7c); 668 put('jle, 'i!:nargs, 1); put('jle, 'i!:jump, 0x7e); 669 put('ja, 'i!:nargs, 1); put('ja, 'i!:jump, 0x77); 670 put('jae, 'i!:nargs, 1); put('jae, 'i!:jump, 0x73); 671 put('jb, 'i!:nargs, 1); put('jb, 'i!:jump, 0x72); 672 put('jbe, 'i!:nargs, 1); put('jbe, 'i!:jump, 0x76); 673 674 put('jmp, 'i!:nargs, 1); put('jmp, 'i!:jump, 0xeb); 675 676 put('mov, 'i!:nargs, 2); put('mov, 'i!:rm!-reg, 0x89); 677 put('mov, 'i!:immed!-rm, 0xc7); put('mov, 'i!:immed!-rm!-secopcode, 0); 678 flag('(mov), 'i!:immed!-rm!-noshortform); 679 put('mov, 'i!:immed!-reg, 0xb8); 680 681 put('neg, 'i!:nargs, 1); 682 put('neg, 'i!:rm, 0xf5); put('neg, 'i!:rm!-secopcode, 3); 683 684 put('or, 'i!:nargs, 2); put('or, 'i!:rm!-reg, 0x09); 685 put('or, 'i!:immed!-rm, 0x81); put('or, 'i!:immed!-rm!-secopcode, 1); 686 put('or, 'i!:immed!-eax, 0x0d); 687 688 put('pop, 'i!:nargs, 1); 689 put('pop, 'i!:reg, 0x58); 690 put('pop, 'i!:mem, 0x8f); put('pop, 'i!:mem!-secopcode, 0x00); 691 692 put('push, 'i!:nargs, 1); 693 put('push, 'i!:reg, 0x50); 694 put('push, 'i!:mem, 0xff); put('push, 'i!:mem!-secopcode, 0x06); 695 put('push, 'i!:immed8, 0x6a); put('push, 'i!:immed32, 0x68); 696 697 put('ret, 'i!:nargs, 0); put('ret, 'i!:code, 0xc3); 698 699 put('shl, 'i!:nargs, 2); 700 put('shl, 'i!:immed!-rm, 0xc1); put('shl, 'i!:immed!-rm!-secopcode, 4); 701 flag('(shl), 'i!:immed!-rm!-shortformonly); 702 703 put('shr, 'i!:nargs, 2); 704 put('shr, 'i!:immed!-rm, 0xc1); put('shr, 'i!:immed!-rm!-secopcode, 5); 705 flag('(shr), 'i!:immed!-rm!-shortformonly); 706 707 put('sub, 'i!:nargs, 2); put('sub, 'i!:rm!-reg, 0x29); 708 put('sub, 'i!:immed!-rm, 0x81); put('sub, 'i!:immed!-rm!-secopcode, 5); 709 put('sub, 'i!:immed!-eax, 0x2d); 710 711 put('test, 'i!:nargs, 2); 712 put('test, 'i!:rm!-reg, 0x85); put('test, 'i!:rm!-reg!-dbit_preset, 0); 713 put('test, 'i!:immed!-rm, 0xf7); put('test, 'i!:immed!-rm!-secopcode, 0); 714 flag('(test), 'i!:immed!-rm!-noshortform); 715 put('test, 'i!:immed!-eax, 0xa9); 716 717 put('xor, 'i!:nargs, 2); put('xor, 'i!:rm!-reg, 0x31); 718 put('xor, 'i!:immed!-rm, 0x81); put('xor, 'i!:immed!-rm!-secopcode, 6); 719 put('xor, 'i!:immed!-eax, 0x35); 720 721% These instructions necessarily change registers when they are executed. 722% Hence we should keep track of them to get peephole optimisation right. 723 724 flag('(add and dec mul inc neg or shl shr sub xor), 'i!:changes_reg) 725 726>>; 727 728 729fluid '(i!:reg_vec); 730 731% Addresses of some internal CSL variables and functions. 732% This table is needed by code compiled from Lisp which necessarily uses 733% Lisp run-time library and internal variables 734 735% Of course a worry here is that these addresses potentially change each 736% time Lisp is re-loaded into memory, and so I need to be a little 737% careful about their treatment. 738 739global '(OFS_NIL OFS_STACK OFS_LISP_TRUE OFS_CURRENT_MODULUS OFS_STACKLIMIT); 740 741<< 742 OFS_NIL := 0; % Arg to give to native!-address 743 OFS_STACK := 1; 744 OFS_LISP_TRUE := 98; 745 OFS_CURRENT_MODULUS := 29; 746!#if common!-lisp!-mode 747 OFS_STACKLIMIT := 16; 748!#else 749 OFS_STACKLIMIT := 15; 750!#endif 751 752% What follows will allow me to patch up direct calls to Lisp kernel 753% functions. The (negative) integers are codes to pass to native!-address 754% at the Lisp level and are then slightly adjusted to go in the relocation 755% tables that are generated here. 756 757 put('cons, 'c!:direct_call_func, -1); 758 put('ncons, 'c!:direct_call_func, -2); 759 put('list2, 'c!:direct_call_func, -3); 760 put('list2!*, 'c!:direct_call_func, -4); 761 put('acons, 'c!:direct_call_func, -5); 762 put('list3, 'c!:direct_call_func, -6); 763 put('plus2, 'c!:direct_call_func, -7); 764 put('difference, 'c!:direct_call_func, -8); 765 put('add1, 'c!:direct_call_func, -9); 766 put('sub1, 'c!:direct_call_func, -10); 767 put('get, 'c!:direct_call_func, -11); 768 put('lognot, 'c!:direct_call_func, -12); 769 put('ash, 'c!:direct_call_func, -13); 770 put('quotient, 'c!:direct_call_func, -14); 771 put('remainder, 'c!:direct_call_func, -15); 772 put('times2, 'c!:direct_call_func, -16); 773 put('minus, 'c!:direct_call_func, -17); 774 put('rational, 'c!:direct_call_func, -18); 775 put('lessp, 'c!:direct_call_func, -19); 776 put('leq, 'c!:direct_call_func, -20); 777 put('greaterp, 'c!:direct_call_func, -21); 778 put('geq, 'c!:direct_call_func, -22); 779 put('zerop, 'c!:direct_call_func, -23); 780 put('reclaim, 'c!:direct_call_func, -24); 781 put('error, 'c!:direct_call_func, -25); 782 put('equal_fn, 'c!:direct_call_func, -26); 783 put('cl_equal_fn, 'c!:direct_call_func, -27); 784 put('aerror, 'c!:direct_call_func, -28); 785 put('integerp, 'c!:direct_call_func, -29); 786 put('apply, 'c!:direct_call_func, -30); 787>>; 788 789fluid '(off_env off_nargs); 790 791off_nargs := 12; % off_env is set dynamically in cg_fndef 792 793symbolic procedure i!:translate_memref(a); 794% Check if an atomic symbol is a variable of the program being compiled, and 795% if so, return its assembler representation (memory address in a suitable 796% form). The first line implements the general mechanism of translating 797% references for local variables kept in stack. For such a symbolic variable 798% the 'i!:locoffs property should contain its offset in stack. The rest deals 799% with the translation of symbolic representations of CSL internal variables. 800% 801% ACN dislikes the use of the STRING "nil" here. Also resolution of the 802% addresses of C_nil, stack etc should be deferred to load time. But leave 803% it as it is for now since it works! 804% 805 if (get(a, 'i!:locoffs)) then {'ebp, get(a, 'i!:locoffs)} 806 else if a = "nil" then {'ebp,-4} 807 else if a = 'env or a = '!.env then {'ebp,off_env} 808 else if a = 'C_nil then {'ds,OFS_NIL} 809 else if a = 'stack then {'ds,OFS_STACK} 810 else if a = 'lisp_true then {'ds,OFS_LISP_TRUE} 811 else if a = 'current_modulus then {'ds,OFS_CURRENT_MODULUS} 812 else if a = 'stacklimit then {'ds,OFS_STACKLIMIT} 813 else if flagp(a, 'c!:live_across_call) then {'ebx,-get(a, 'c!:location)*4} 814 else a; % Otherwise we hope that this is a symbolic label - a call 815 % or jump operand. 816 817 818symbolic procedure i!:outmemfield(reg, mem); 819% Generate the second and further bytes of the instruction whose operand is 820% memory. For 2-arg instructions reg means code of the register operand, 821% for 1-arg instructions it is a secondary opcode 822% Examples of the forms of memory references accepted are given below: 823% {ds,1234}, {ebx,-16}, {eax,2,ebx}, {ecx,4,edx,32} 824 begin 825 scalar secbyte, thirdbyte, constofs, constofslong, reg1name, 826 reg1, reg2, mul; 827 828 reg1name := car mem; 829 reg1 := get(reg1name, 'i!:regcode); 830 831 if length mem = 1 or 832 ((length mem = 2) and numberp cadr mem) then << 833 % [reg1] or [reg1 + ofs] 834 secbyte := reg*8 + reg1; 835 mem := cdr mem; 836 837 % Curious peculiarities of constant offset length field behaviour 838 % when ebp (or ds) is an operand force me to do this weird thing. 839 if (not mem) and (reg1name = 'ebp) then mem := cons(0, nil); 840 841 if mem then << 842 constofs := car mem; 843 if (constofs > 127) or (constofs < -128) or (reg1name = 'ds) then << 844 if reg1name neq 'ds then secbyte := secbyte + 0x80; 845 constofslong := t >> 846 else << 847 secbyte := secbyte + 0x40; 848 constofslong := nil >> 849 >>; 850 i_putbyte secbyte 851 >> 852 else << % [reg + reg] or [reg + const*reg] or [reg + const*reg + ofs] 853 secbyte := 0x04 + reg*8; % 0x04 is a magic number, imho 854 thirdbyte := reg1; 855 mem := cdr mem; 856 if numberp car mem then << 857 mul := car mem; 858 if mul = 8 then thirdbyte := thirdbyte + 0xc0 859 else if mul = 4 then thirdbyte := thirdbyte + 0x80 860 else if mul = 2 then thirdbyte := thirdbyte + 0x40; 861 mem := cdr mem >>; 862 reg2 := get(car mem, 'i!:regcode); 863 thirdbyte := thirdbyte + reg2*8; 864 mem := cdr mem; 865 866 if (not mem) and (reg1name = 'ebp) then mem := 0 . nil; 867 868 if mem then << 869 constofs := car mem; 870 if (constofs > 127) or (constofs < -128) then << 871 % Weird thing with ebp again - only for it in this case we should 872 % put 00 in two bits representing the offset length 873 if reg1name neq 'ebp then secbyte := secbyte + 0x80; 874 constofslong := t >> 875 else << 876 secbyte := secbyte + 0x40; 877 constofslong := nil >> 878 >> 879 else constofs := nil; 880 i_putbyte secbyte; 881 i_putbyte thirdbyte 882 >>; 883 884 if constofs then 885 if constofslong then << 886 if reg1name='ds then i_putextern list('absolute, constofs) 887 else i_put32 constofs >> 888 else i_putbyte ilogand(constofs, 0xff) 889 end; 890 891 892symbolic procedure i!:remove_reg_memrefs(reg); 893% A part of peephole optimisation. We maintain the table which has an entry 894% per register. An entry for register reg contains registers and memory 895% references whose contents are equal to reg. When reg is changed, we 896% must flush its entry. This is already done when this procedure called. 897% But what we should also do (here) is to check if the buffer for any 898% register other than reg contains reg or a memory reference which includes 899% reg, such as {reg,1000}, and remove all such references. 900begin 901 scalar regi, regi1, memref; 902 903 for i := 0:2 do << 904 regi := getv(i!:reg_vec, i); 905 regi1 := nil; 906 while regi neq nil do << 907 memref := car regi; 908 regi := cdr regi; 909 if (atom memref) and (memref neq reg) then regi1 := memref . regi1 910 else if not member(reg, memref) then regi1 := memref . regi1; 911 >>; 912 putv(i!:reg_vec, i, regi1) 913 >> 914end; 915 916 917symbolic procedure i!:eq_to_reg(mem); 918% Check if a memory variable is equal to some register at the current moment 919begin 920 scalar i,res; 921 922 res := nil; 923 for i := 0:2 do 924 if member(mem, getv(i!:reg_vec, i)) then res := i; 925 926 return res; 927end; 928 929 930symbolic procedure i!:regname(code); 931% Return register symbolic name for its code 932 if code = 0 then 'eax 933 else if code = 1 then 'ecx 934 else if code = 2 then 'edx 935 else error1 "bad regname"; 936 937 938symbolic procedure encomment(reg1, a1); 939 if reg1 then list a1 940 else begin 941 scalar x; 942 x := i!:translate_memref a1; 943 if a1 = x then return list a1 944 else return list(x, '!;, list a1) end; 945 946symbolic procedure i!:2arginstr(instr, a1, a2); 947% Process an instruction with two arguments 948 begin 949 scalar reg1, reg2, isnuma2, longnuma2, code, secopcode, 950 tmp, dbit, pref, c1, c2; 951 952 reg1 := get(a1, 'i!:regcode); 953 reg2 := get(a2, 'i!:regcode); 954 isnuma2 := numberp a2; 955 if isnuma2 then longnuma2 := not zerop irightshift(a2,8); 956 957 % Peephole optimisation - replace "instr d,mem" with 958 % "instr d,reg" if reg = mem 959 if (not reg2) and (not isnuma2) then << 960 reg2 := i!:eq_to_reg(a2); 961 if reg2 and not ((instr = 'mov) and (reg1 = reg2)) then 962 a2 := i!:regname(reg2) 963 else reg2 := nil; 964 >>; 965 966 % Peephole optimisation - redundant memory-register transfers suppression 967 if (reg1) and (reg1 <= 2) then << 968 if flagp(instr, 'i!:changes_reg) then << 969 putv(i!:reg_vec, reg1, nil); 970 i!:remove_reg_memrefs(a1); 971 >> 972 else if (instr = 'mov) then << % mov reg1, a2(which is mem or reg) 973 if member(a2, getv(i!:reg_vec, reg1)) then % Suppress MOV 974 return nil 975 else << 976 i!:remove_reg_memrefs(a1); 977 if not reg2 then << % a2 is a memory location 978 if (not atom a2) and (member(a1,a2)) then 979 putv(i!:reg_vec, reg1, nil) 980 else putv(i!:reg_vec, reg1, a2 . nil) >> 981 else << % a2 is a register 982 putv(i!:reg_vec, reg1, a2 . getv(i!:reg_vec, reg2)); 983 putv(i!:reg_vec, reg2, a1 . getv(i!:reg_vec, reg2)); 984 >> 985 >> 986 >> 987 >> 988 else if (instr = 'mov) and reg2 and (reg2 <= 2) then << 989 if member(a1, getv(i!:reg_vec, reg2)) then % Suppress MOV 990 return nil 991 else << 992 for i := 0:2 do 993 putv(i!:reg_vec, i, delete(a1, getv(i!:reg_vec,i))); 994 putv(i!:reg_vec, reg2, a1 . getv(i!:reg_vec, reg2)) 995 >> 996 >>; 997 998 c1 := encomment(reg1, a1); c2 := encomment(reg2, a2); 999 if null cdr c1 then c1 := append(c1, c2) 1000 else c1 := car c1 . append(c2, cdr c1); 1001 1002 i_putcomment (instr . c1); 1003 1004 if reg1 then % Immediate/register/memory to register variant 1005 if isnuma2 then << % Immediate to register variants 1006 if longnuma2 and (a1 = 'eax) then code := get(instr, 'i!:immed!-eax) 1007 else code := nil; 1008 if code then << % "Immediate to eax" version of instruction 1009 i_putbyte code; 1010 i_put32 a2; 1011 >> 1012 else << % "Immediate to register" version of 1013 % instruction (MOV,?..) 1014 code := get(instr, 'i!:immed!-reg); 1015 if code then << 1016 i_putbyte(code + reg1); 1017 i_put32 a2; 1018 >> 1019 else << % General "immediate to register/memory" version 1020 code := get(instr, 'i!:immed!-rm); 1021 if code then << 1022 secopcode := get(instr, 'i!:immed!-rm!-secopcode); 1023 if not secopcode then secopcode := reg1; 1024 1025 if longnuma2 then << % Long immediate constant 1026 if flagp(instr, 'i!:immed!-rm!-shortformonly) then << 1027 error1 "Long constant is invalid here" >>; 1028 i_putbyte code; i_putbyte(0xc0 + secopcode*8 + reg1); 1029 i_put32 a2 1030 >> 1031 else << % Short immediate constant 1032 if flagp(instr, 'i!:immed!-rm!-noshortform) then << 1033 i_putbyte code; i_putbyte(0xc0 + secopcode*8 + reg1); 1034 i_put32 a2 >> 1035 else if flagp(instr, 'i!:immed!-rm!-shortformonly) then << 1036 i_putbyte code; i_putbyte(0xc0 + secopcode*8 + reg1); 1037 i_putbyte a2 >> 1038 else << 1039 i_putbyte(code+2); 1040 i_putbyte(0xc0 + secopcode*8 + reg1); 1041 i_putbyte a2 >> 1042 >> 1043 >> 1044 else error1 "Invalid combination of opcode and operands 1" 1045 >> 1046 >> 1047 >> 1048 else << % Register/memory to register 1049 code := get(instr, 'i!:rm!-reg); 1050 if not code then 1051 error1 "Invalid combination of opcode and operands 2"; 1052 if reg2 then << % Register to register 1053 if (pref := get(instr, 'i!:rm!-reg!-prefix)) then i_putbyte pref; 1054 if (dbit := get(instr, 'i!:rm!-reg!-dbit_preset)) then << 1055 % Special case when changing d bit changes the whole instruction 1056 i_putbyte code; 1057 if dbit = 0 then << 1058 tmp := reg1; reg1 := reg2; reg2 := tmp >> 1059 >> 1060 else i_putbyte(code + 2); 1061 i_putbyte(0xc0 + reg1*8 + reg2) 1062 >> 1063 else << % Memory to register 1064 if atom a2 then a2 := i!:translate_memref(a2); 1065 if car a2 = 'ds then << 1066 i_putbyte 0x3E; 1067 if (instr = 'mov) and (reg1 = 0) then << % mov eax,ds:[...] 1068 i_putbyte 0xa1; 1069 i_putextern list('absolute, cadr a2); 1070 % More complicated ds addressing is not implemented yet! 1071 return nil 1072 >> 1073 >>; 1074 i_putbyte(code + 2); 1075 i!:outmemfield(reg1, a2) 1076 >> 1077 >> 1078 1079 else if reg2 then << % Register to memory 1080 code := get(instr, 'i!:rm!-reg); 1081 if not code then 1082 error1 "Invalid combination of opcode and operands 3"; 1083 if atom a1 then a1 := i!:translate_memref(a1); 1084 if car a1 = 'ds then << 1085 i_putbyte 0x3E; 1086 if (instr = 'mov) and (reg2 = 0) then << % mov ds:[...],eax 1087 i_putbyte 0xa3; 1088 i_putextern list('absolute, cadr a1); 1089 % More complicated ds addressing is not implemented yet! 1090 return nil 1091 >> 1092 >>; 1093 i_putbyte code; 1094 i!:outmemfield(reg2, a1) 1095 >> 1096 1097 else error1 "Invalid combination of opcode and operands 4" 1098 1099 end; 1100 1101 1102symbolic procedure i!:1arginstr(instr, a1); 1103% Process an instruction with one argument 1104 begin 1105 scalar reg1, code, secopcode, labrec, curpos, dist; 1106 1107 reg1 := get(a1, 'i!:regcode); 1108 % Peephole optimisation - replace push mem with push reg if mem = reg 1109 if (not reg1) and (instr = 'push) then << 1110 reg1 := i!:eq_to_reg(a1); 1111 if reg1 then a1 := i!:regname(reg1) 1112 >>; 1113 1114 if not reg1 and atom a1 then a1 := i!:translate_memref(a1); 1115 1116 % Part of peephole optimisation - control of changing register contents 1117 if flagp(instr, 'i!:changes_reg) and reg1 and (reg1 <= 2) then << 1118 putv(i!:reg_vec, reg1, nil); 1119 i!:remove_reg_memrefs(a1) 1120 >>; 1121 1122 i_putcomment (instr . encomment(reg1, a1)); 1123 1124 if atom a1 then << % Register or label operand 1125 if reg1 then << % Register operand 1126 code := get(instr, 'i!:reg); 1127 if code then << % "Register" version of instruction 1128 secopcode := get(instr, 'i!:reg!-secopcode); 1129 if not secopcode then i_putbyte(code + reg1) 1130 else << 1131 i_putbyte code; 1132 i_putbyte(secopcode + reg1) >> 1133 >> 1134 else << % "Register/memory" version of instruction 1135 code := get(instr, 'i!:rm); 1136 secopcode := get(instr, 'i!:rm!-secopcode); 1137 i_putbyte(code+2); 1138 i_putbyte(0xc0 + secopcode*8 + reg1) 1139 >> 1140 >> 1141 else if numberp a1 then << % Immediate operand 1142 if (a1 > 127) or (a1 < -128) then << 1143 code := get(instr, 'i!:immed32); 1144 i_putbyte code; 1145 i_put32 a1 >> 1146 else << 1147 code := get(instr, 'i!:immed8); 1148 i_putbyte code; 1149 i_putbyte a1 >> 1150 >> 1151 else << % Jumps and call remain, thus label operand 1152 code := get(instr, 'i!:jump); 1153 if not code then 1154 error1 "Invalid combination of opcode and operands 1"; 1155 1156 if instr = 'call then << 1157printc("##### CALL ", a1); 1158 i_putbyte code; 1159 i_putextern list('rel_plus_4, 99); % What am I calling???? 1160 % Part of peephole optimisation 1161 for i := 0:2 do putv(i!:reg_vec, i, nil) 1162 >> 1163 else i_putjump(code, a1); 1164 >> 1165 >> 1166 else << % Memory operand 1167 code := get(instr, 'i!:mem); 1168 secopcode := get(instr, 'i!:mem!-secopcode); 1169 if not secopcode then secopcode := 0; 1170 if car a1 = 'ds then i_putbyte 0x3E; 1171 i_putbyte code; 1172 i!:outmemfield(secopcode, a1); 1173 >> 1174 1175 end; 1176 1177 1178symbolic procedure i!:noarginstr instr; 1179% Process an instruction with no arguments 1180 << i_putcomment list instr; 1181 i_putbyte get(instr,'i!:code) >>; 1182 1183 1184symbolic procedure i!:proc_label lab; 1185% Process a label 1186 begin 1187 i_putlabel lab; 1188 % Part of peephole optimisation 1189 for i := 0:2 do putv(i!:reg_vec, i, nil) 1190 end; 1191 1192 1193 1194 1195% 1196% Now the higher level parts of the compiler. 1197% 1198 1199 1200global '(!*fastvector !*unsafecar); 1201flag('(fastvector unsafecar), 'switch); 1202 1203% Some internal CSL constants 1204global '(TAG_BITS TAG_CONS TAG_FIXNUM TAG_ODDS TAG_SYMBOL TAG_NUMBERS 1205 TAG_VECTOR GC_STACK SPID_NOPROP); 1206TAG_BITS := 7; 1207TAG_CONS := 0; 1208TAG_FIXNUM := 1; 1209TAG_ODDS := 2; 1210TAG_SYMBOL := 4; 1211TAG_NUMBERS := 5; 1212TAG_VECTOR := 6; 1213GC_STACK := 2; 1214SPID_NOPROP := 0xc2 + 0x0b00; 1215 1216 1217 1218% 1219% I start with some utility functions that provide something 1220% related to a FORMAT or PRINTF facility 1221% 1222 1223 1224% This establishes a default handler for each special form so that 1225% any that I forget to treat more directly will cause a tidy error 1226% if found in compiled code. 1227 1228symbolic procedure c!:cspecform(x, env); 1229 error(0, list("special form", x)); 1230 1231<< put('and, 'c!:code, function c!:cspecform); 1232!#if common!-lisp!-mode 1233 put('block, 'c!:code, function c!:cspecform); 1234!#endif 1235 put('catch, 'c!:code, function c!:cspecform); 1236 put('compiler!-let, 'c!:code, function c!:cspecform); 1237 put('cond, 'c!:code, function c!:cspecform); 1238 put('declare, 'c!:code, function c!:cspecform); 1239 put('de, 'c!:code, function c!:cspecform); 1240!#if common!-lisp!-mode 1241 put('defun, 'c!:code, function c!:cspecform); 1242!#endif 1243 put('eval!-when, 'c!:code, function c!:cspecform); 1244 put('flet, 'c!:code, function c!:cspecform); 1245 put('function, 'c!:code, function c!:cspecform); 1246 put('go, 'c!:code, function c!:cspecform); 1247 put('if, 'c!:code, function c!:cspecform); 1248 put('labels, 'c!:code, function c!:cspecform); 1249!#if common!-lisp!-mode 1250 put('let, 'c!:code, function c!:cspecform); 1251!#else 1252 put('!~let, 'c!:code, function c!:cspecform); 1253!#endif 1254 put('let!*, 'c!:code, function c!:cspecform); 1255 put('list, 'c!:code, function c!:cspecform); 1256 put('list!*, 'c!:code, function c!:cspecform); 1257 put('macrolet, 'c!:code, function c!:cspecform); 1258 put('multiple!-value!-call, 'c!:code, function c!:cspecform); 1259 put('multiple!-value!-prog1, 'c!:code, function c!:cspecform); 1260 put('or, 'c!:code, function c!:cspecform); 1261 put('prog, 'c!:code, function c!:cspecform); 1262 put('prog!*, 'c!:code, function c!:cspecform); 1263 put('prog1, 'c!:code, function c!:cspecform); 1264 put('prog2, 'c!:code, function c!:cspecform); 1265 put('progn, 'c!:code, function c!:cspecform); 1266 put('progv, 'c!:code, function c!:cspecform); 1267 put('quote, 'c!:code, function c!:cspecform); 1268 put('return, 'c!:code, function c!:cspecform); 1269 put('return!-from, 'c!:code, function c!:cspecform); 1270 put('setq, 'c!:code, function c!:cspecform); 1271 put('tagbody, 'c!:code, function c!:cspecform); 1272 put('the, 'c!:code, function c!:cspecform); 1273 put('throw, 'c!:code, function c!:cspecform); 1274 put('unless, 'c!:code, function c!:cspecform); 1275 put('unwind!-protect, 'c!:code, function c!:cspecform); 1276 put('when, 'c!:code, function c!:cspecform) >>; 1277 1278fluid '(current_procedure current_args current_block current_contents 1279 all_blocks registers stacklocs); 1280 1281fluid '(available used); 1282 1283available := used := nil; 1284 1285fluid '(lab_end_proc); 1286 1287symbolic procedure c!:reset_gensyms(); 1288 << remflag(used, 'c!:live_across_call); 1289 remflag(used, 'c!:visited); 1290 while used do << 1291 remprop(car used, 'c!:contents); 1292 remprop(car used, 'c!:why); 1293 remprop(car used, 'c!:where_to); 1294 remprop(car used, 'c!:count); 1295 remprop(car used, 'c!:live); 1296 remprop(car used, 'c!:clash); 1297 remprop(car used, 'c!:chosen); 1298 remprop(car used, 'c!:location); 1299 remprop(car used, 'i!:locoffs); 1300 if plist car used then begin 1301 scalar o; o := wrs nil; 1302 princ "+++++ "; prin car used; princ " "; 1303 prin plist car used; terpri(); 1304 wrs o end; 1305 available := car used . available; 1306 used := cdr used >> >>; 1307 1308!#if common!-lisp!-mode 1309 1310fluid '(my_gensym_counter); 1311my_gensym_counter := 0; 1312 1313!#endif 1314 1315symbolic procedure c!:my_gensym(); 1316 begin 1317 scalar w; 1318 if available then << w := car available; available := cdr available >> 1319!#if common!-lisp!-mode 1320 else w := compress1 1321 ('!v . explodec (my_gensym_counter := my_gensym_counter + 1)); 1322!#else 1323 else w := gensym1 "v"; 1324!#endif 1325 used := w . used; 1326 if plist w then << princ "????? "; prin w; princ " => "; prin plist w; terpri() >>; 1327 return w 1328 end; 1329 1330symbolic procedure c!:newreg(); 1331 begin 1332 scalar r; 1333 r := c!:my_gensym(); 1334 registers := r . registers; 1335 return r 1336 end; 1337 1338symbolic procedure c!:startblock s; 1339 << current_block := s; 1340 current_contents := nil 1341 >>; 1342 1343symbolic procedure c!:outop(a,b,c,d); 1344 if current_block then 1345 current_contents := list(a,b,c,d) . current_contents; 1346 1347symbolic procedure c!:endblock(why, where_to); 1348 if current_block then << 1349% Note that the operations within a block are in reversed order. 1350 put(current_block, 'c!:contents, current_contents); 1351 put(current_block, 'c!:why, why); 1352 put(current_block, 'c!:where_to, where_to); 1353 all_blocks := current_block . all_blocks; 1354 current_contents := nil; 1355 current_block := nil >>; 1356 1357% 1358% Now for a general driver for compilation 1359% 1360 1361symbolic procedure c!:cval_inner(x, env); 1362 begin 1363 scalar helper; 1364% NB use the "improve" function from the regular compiler here... 1365 x := s!:improve x; 1366% atoms and embedded lambda expressions need their own treatment. 1367 if atom x then return c!:catom(x, env) 1368 else if eqcar(car x, 'lambda) then 1369 return c!:clambda(cadar x, 'progn . cddar x, cdr x, env) 1370% a c!:code property gives direct control over compilation 1371 else if helper := get(car x, 'c!:code) then 1372 return funcall(helper, x, env) 1373% compiler-macros take precedence over regular macros, so that I can 1374% make special expansions in the context of compilation. Only used if the 1375% expansion is non-nil 1376 else if (helper := get(car x, 'c!:compile_macro)) and 1377 (helper := funcall(helper, x)) then 1378 return c!:cval(helper, env) 1379% regular Lisp macros get expanded 1380 else if idp car x and (helper := macro!-function car x) then 1381 return c!:cval(funcall(helper, x), env) 1382% anything not recognised as special will be turned into a 1383% function call, but there will still be special cases, such as 1384% calls to the current function, calls into the C-coded kernel, etc. 1385 else return c!:ccall(car x, cdr x, env) 1386 end; 1387 1388symbolic procedure c!:cval(x, env); 1389 begin 1390 scalar r; 1391 r := c!:cval_inner(x, env); 1392 if r and not member!*!*(r, registers) then 1393 error(0, list(r, "not a register", x)); 1394 return r 1395 end; 1396 1397symbolic procedure c!:clambda(bvl, body, args, env); 1398 begin 1399 scalar w, fluids, env1; 1400 env1 := car env; 1401 w := for each a in args collect c!:cval(a, env); 1402 for each v in bvl do << 1403 if globalp v then begin scalar oo; 1404 oo := wrs nil; 1405 princ "+++++ "; prin v; 1406 princ " converted from GLOBAL to FLUID"; terpri(); 1407 wrs oo; 1408 unglobal list v; 1409 fluid list v end; 1410 if fluidp v then << 1411 fluids := (v . c!:newreg()) . fluids; 1412 flag(list cdar fluids, 'c!:live_across_call); % silly if not 1413 env1 := ('c!:dummy!:name . cdar fluids) . env1; 1414 c!:outop('ldrglob, cdar fluids, v, c!:find_literal v); 1415 c!:outop('strglob, car w, v, c!:find_literal v) >> 1416 else << 1417 env1 := (v . c!:newreg()) . env1; 1418 c!:outop('movr, cdar env1, nil, car w) >>; 1419 w := cdr w >>; 1420 if fluids then c!:outop('fluidbind, nil, nil, fluids); 1421 env := env1 . append(fluids, cdr env); 1422 w := c!:cval(body, env); 1423 for each v in fluids do 1424 c!:outop('strglob, cdr v, car v, c!:find_literal car v); 1425 return w 1426 end; 1427 1428symbolic procedure c!:locally_bound(x, env); 1429 atsoc(x, car env); 1430 1431flag('(nil t), 'c!:constant); 1432 1433fluid '(literal_vector); 1434 1435symbolic procedure c!:find_literal x; 1436 begin 1437 scalar n, w; 1438 w := literal_vector; 1439 n := 0; 1440 while w and not (car w = x) do << 1441 n := n + 1; 1442 w := cdr w >>; 1443 if null w then literal_vector := append(literal_vector, list x); 1444 return n 1445 end; 1446 1447symbolic procedure c!:catom(x, env); 1448 begin 1449 scalar v, w; 1450 v := c!:newreg(); 1451 if idp x and (w := c!:locally_bound(x, env)) then 1452 c!:outop('movr, v, nil, cdr w) 1453 else if null x or x = 't or c!:small_number x then 1454 c!:outop('movk1, v, nil, x) 1455 else if not idp x or flagp(x, 'c!:constant) then 1456 c!:outop('movk, v, x, c!:find_literal x) 1457 else c!:outop('ldrglob, v, x, c!:find_literal x); 1458 return v 1459 end; 1460 1461symbolic procedure c!:cjumpif(x, env, d1, d2); 1462 begin 1463 scalar helper, r; 1464 x := s!:improve x; 1465 if atom x and (not idp x or 1466 (flagp(x, 'c!:constant) and not c!:locally_bound(x, env))) then 1467 c!:endblock('goto, list (if x then d1 else d2)) 1468 else if not atom x and (helper := get(car x, 'c!:ctest)) then 1469 return funcall(helper, x, env, d1, d2) 1470 else << 1471 r := c!:cval(x, env); 1472 c!:endblock(list('ifnull, r), list(d2, d1)) >> 1473 end; 1474 1475fluid '(current); 1476 1477symbolic procedure c!:ccall(fn, args, env); 1478 c!:ccall1(fn, args, env); 1479 1480fluid '(visited); 1481 1482symbolic procedure c!:has_calls(a, b); 1483 begin 1484 scalar visited; 1485 return c!:has_calls_1(a, b) 1486 end; 1487 1488symbolic procedure c!:has_calls_1(a, b); 1489% true if there is a path from node a to node b that has a call instruction 1490% on the way. 1491 if a = b or not atom a or memq(a, visited) then nil 1492 else begin 1493 scalar has_call; 1494 visited := a . visited; 1495 for each z in get(a, 'c!:contents) do 1496 if eqcar(z, 'call) then has_call := t; 1497 if has_call then return 1498 begin scalar visited; 1499 return c!:can_reach(a, b) end; 1500 for each d in get(a, 'c!:where_to) do 1501 if c!:has_calls_1(d, b) then has_call := t; 1502 return has_call 1503 end; 1504 1505symbolic procedure c!:can_reach(a, b); 1506 if a = b then t 1507 else if not atom a or memq(a, visited) then nil 1508 else << 1509 visited := a . visited; 1510 c!:any_can_reach(get(a, 'c!:where_to), b) >>; 1511 1512symbolic procedure c!:any_can_reach(l, b); 1513 if null l then nil 1514 else if c!:can_reach(car l, b) then t 1515 else c!:any_can_reach(cdr l, b); 1516 1517symbolic procedure c!:pareval(args, env); 1518 begin 1519 scalar tasks, tasks1, merge, split, r; 1520 tasks := for each a in args collect (c!:my_gensym() . c!:my_gensym()); 1521 split := c!:my_gensym(); 1522 c!:endblock('goto, list split); 1523 for each a in args do begin 1524 scalar s; 1525% I evaluate each arg as what is (at this stage) a separate task 1526 s := car tasks; 1527 tasks := cdr tasks; 1528 c!:startblock car s; 1529 r := c!:cval(a, env) . r; 1530 c!:endblock('goto, list cdr s); 1531% If the task did no procedure calls (or only tail calls) then it can be 1532% executed sequentially with the other args without need for stacking 1533% anything. Otherwise it more care will be needed. Put the hard 1534% cases onto tasks1. 1535!#if common!-lisp!-mode 1536 tasks1 := s . tasks1 1537!#else 1538 if c!:has_calls(car s, cdr s) then tasks1 := s . tasks1 1539 else merge := s . merge 1540!#endif 1541 end; 1542%-- % if there are zero or one items in tasks1 then again it is easy - 1543%-- % otherwise I flag the problem with a notionally parallel construction. 1544%-- if tasks1 then << 1545%-- if null cdr tasks1 then merge := car tasks1 . merge 1546%-- else << 1547%-- c!:startblock split; 1548%-- printc "***** ParEval needed parallel block here..."; 1549%-- c!:endblock('par, for each v in tasks1 collect car v); 1550%-- split := c!:my_gensym(); 1551%-- for each v in tasks1 do << 1552%-- c!:startblock cdr v; 1553%-- c!:endblock('goto, list split) >> >> >>; 1554 for each z in tasks1 do merge := z . merge; % do sequentially 1555%-- 1556%-- 1557% Finally string end-to-end all the bits of sequential code I have left over. 1558 for each v in merge do << 1559 c!:startblock split; 1560 c!:endblock('goto, list car v); 1561 split := cdr v >>; 1562 c!:startblock split; 1563 return reversip r 1564 end; 1565 1566symbolic procedure c!:ccall1(fn, args, env); 1567 begin 1568 scalar tasks, merge, r, val; 1569 fn := list(fn, cdr env); 1570 val := c!:newreg(); 1571 if null args then c!:outop('call, val, nil, fn) 1572 else if null cdr args then 1573 c!:outop('call, val, list c!:cval(car args, env), fn) 1574 else << 1575 r := c!:pareval(args, env); 1576 c!:outop('call, val, r, fn) >>; 1577 c!:outop('reloadenv, 'env, nil, nil); 1578 return val 1579 end; 1580 1581fluid '(restart_label reloadenv does_call current_c_name); 1582 1583% 1584% The "proper" recipe here arranges that functions that expect over 2 args use 1585% the "va_arg" mechanism to pick up ALL their args. This would be pretty 1586% heavy-handed, and at least on a lot of machines it does not seem to 1587% be necessary. I will duck it for a while more at least. 1588% 1589 1590fluid '(proglabs blockstack retloc); 1591 1592symbolic procedure c!:cfndef(current_procedure, current_c_name, args, body); 1593 begin 1594 scalar env, n, w, current_args, current_block, restart_label, 1595 current_contents, all_blocks, entrypoint, exitpoint, args1, 1596 registers, stacklocs, literal_vector, reloadenv, does_call, 1597 blockstack, proglabs, stackoffs, env_vec, i, retloc; 1598 1599 c!:reset_gensyms(); 1600 i_startproc(); 1601 i!:reg_vec := mkvect 2; 1602 c!:find_literal current_procedure; % For benefit of backtraces 1603% 1604% cope with fluid vars in an argument list by mapping the definition 1605% (de f (a B C d) body) B and C fluid 1606% onto 1607% (de f (a x y c) (prog (B C) (setq B x) (setq C y) (return body))) 1608% so that the fluids get bound by PROG. 1609% 1610 current_args := args; 1611 for each v in args do 1612 if v = '!&optional or v = '!&rest then 1613 error(0, "&optional and &rest not supported by this compiler (yet)") 1614 else if globalp v then begin scalar oo; 1615 oo := wrs nil; 1616 princ "+++++ "; prin v; 1617 princ " converted from GLOBAL to FLUID"; terpri(); 1618 wrs oo; 1619 unglobal list v; 1620 fluid list v; 1621 n := (v . c!:my_gensym()) . n end 1622 else if fluidp v then n := (v . c!:my_gensym()) . n; 1623 1624 restart_label := c!:my_gensym(); 1625 body := list('c!:private_tagbody, restart_label, body); 1626 if n then << 1627 body := list list('return, body); 1628 args := subla(n, args); 1629 for each v in n do 1630 body := list('setq, car v, cdr v) . body; 1631 body := 'prog . (for each v in reverse n collect car v) . body >>; 1632 1633 n := length args; 1634 if n = 0 or n >= 3 then w := t else w := nil; 1635 1636 if w or i_machine = 4 then off_env := 8 else off_env := 4; 1637 1638% Here I FUDDGE the issue of args passed in registers by flushing them 1639% back to the stack. I guess I will need to repair the stack to 1640% compensate somewhere too... 1641 retloc := 0; 1642 if i_machine = 2 then << 1643 if n = 1 then << i!:gopcode(push,edx, push,eax); retloc := 2 >> 1644 else if n = 2 then << i!:gopcode(push,ebx, push,edx, push,eax); retloc := 3 >> >> 1645 else if i_machine = 3 then << 1646 if n = 1 or n = 2 then i!:gopcode(push, edx, push, ecx); 1647 retloc := 2 >>; 1648 1649 if i_machine = 4 then << 1650 if w then stackoffs := 16 else stackoffs := 12 >> 1651 else if i_machine = 3 then << 1652 if w then stackoffs := 16 else stackoffs := 8 >> 1653 else if i_machine = 2 then << 1654 if w then stackoffs := 12 else stackoffs := 8 >> 1655 else error(0, "unknown machine"); 1656 1657 n := 0; 1658 env := nil; 1659 for each x in args do begin 1660 scalar aa; 1661 n := n+1; 1662 if n = retloc then stackoffs := stackoffs+4; 1663 aa := c!:my_gensym(); 1664 env := (x . aa) . env; 1665 registers := aa . registers; 1666 args1 := aa . args1; 1667 put(aa, 'i!:locoffs, stackoffs); 1668 stackoffs := stackoffs + 4 1669 end; 1670 c!:startblock (entrypoint := c!:my_gensym()); 1671 exitpoint := current_block; 1672 c!:endblock('goto, list list c!:cval(body, env . nil)); 1673 1674 c!:optimise_flowgraph(entrypoint, all_blocks, env, 1675 length args . current_procedure, args1); 1676 1677 1678 env_vec := mkvect(length literal_vector - 1); 1679 i := 0; 1680 for each v in literal_vector do << 1681 putv(env_vec, i, v); 1682 i := i + 1 >>; 1683 1684 if !*genlisting then << 1685 terpri(); 1686 ttab 28; 1687 princ "+++ Native code for "; 1688 prin current_procedure; 1689 printc " +++" >>; 1690 1691 i := i_resolve(); 1692 symbol!-set!-native(current_procedure, length args, 1693 car i, cdr i, 1694 env_vec); 1695 return nil 1696 end; 1697 1698% c!:ccompile1 directs the compilation of a single function, and bind all the 1699% major fluids used by the compilation process 1700 1701flag('(rds deflist flag fluid global 1702 remprop remflag unfluid 1703 unglobal dm carcheck i86!-end), 'eval); 1704 1705flag('(rds), 'ignore); 1706 1707fluid '(!*backtrace); 1708 1709symbolic procedure c!:ccompilesupervisor; 1710 begin 1711 scalar u, w; 1712top:u := errorset('(read), t, !*backtrace); 1713 if atom u then return; % failed, or maybe EOF 1714 u := car u; 1715 if u = !$eof!$ then return; % end of file 1716 if atom u then go to top 1717% the apply('i86!-end, nil) is here because i86!-end has a "stat" 1718% property and so it will mis-parse if I just write "i86!-end()". Yuk. 1719 else if eqcar(u, 'i86!-end) then return apply('i86!-end, nil) 1720 else if eqcar(u, 'rdf) then << 1721!#if common!-lisp!-mode 1722 w := open(u := eval cadr u, !:direction, !:input, 1723 !:if!-does!-not!-exist, nil); 1724!#else 1725 w := open(u := eval cadr u, 'input); 1726!#endif 1727 if w then << 1728 terpri(); 1729 princ "Reading file "; print u; 1730 w := rds w; 1731 c!:ccompilesupervisor(); 1732 princ "End of file "; print u; 1733 close rds w >> 1734 else << princ "Failed to open file "; print u >> >> 1735 else c!:ccmpout1 u; 1736 go to top 1737 end; 1738 1739 1740global '(c!:char_mappings); 1741 1742c!:char_mappings := '( 1743 (! . !A) (!! . !B) (!# . !C) (!$ . !D) 1744 (!% . !E) (!^ . !F) (!& . !G) (!* . !H) 1745 (!( . !I) (!) . !J) (!- . !K) (!+ . !L) 1746 (!= . !M) (!\ . !N) (!| . !O) (!, . !P) 1747 (!. . !Q) (!< . !R) (!> . !S) (!: . !T) 1748 (!; . !U) (!/ . !V) (!? . !W) (!~ . !X) 1749 (!` . !Y)); 1750 1751symbolic procedure c!:inv_name n; 1752 begin 1753 scalar r, w; 1754 r := '(_ !C !C !"); 1755!#if common!-lisp!-mode 1756 for each c in explode2 package!-name symbol!-package n do << 1757 if c = '_ then r := '_ . r 1758 else if alpha!-char!-p c or digit c then r := c . r 1759 else if w := atsoc(c, c!:char_mappings) then r := cdr w . r 1760 else r := '!Z . r >>; 1761 r := '!_ . '!_ . r; 1762!#endif 1763 for each c in explode2 n do << 1764 if c = '_ then r := '_ . r 1765!#if common!-lisp!-mode 1766 else if alpha!-char!-p c or digit c then r := c . r 1767!#else 1768 else if liter c or digit c then r := c . r 1769!#endif 1770 else if w := atsoc(c, c!:char_mappings) then r := cdr w . r 1771 else r := '!Z . r >>; 1772 r := '!" . r; 1773!#if common!-lisp!-mode 1774 return compress1 reverse r 1775!#else 1776 return compress reverse r 1777!#endif 1778 end; 1779 1780 1781fluid '(defnames); 1782 1783symbolic procedure c!:ccmpout1 u; 1784 begin 1785 scalar w; 1786 1787 if atom u then return nil 1788 else if eqcar(u, 'progn) then << 1789 for each v in cdr u do codesize := codesize + c!:ccmpout1 v; 1790 return nil >> 1791 else if eqcar(u, 'i86!-end) then nil 1792 else if flagp(car u, 'eval) or 1793 (car u = 'setq and not atom caddr u and flagp(caaddr u, 'eval)) then 1794 errorset(u, t, !*backtrace); 1795 if eqcar(u, 'rdf) then begin 1796!#if common!-lisp!-mode 1797 w := open(u := eval cadr u, !:direction, !:input, 1798 !:if!-does!_not!-exist, nil); 1799!#else 1800 w := open(u := eval cadr u, 'input); 1801!#endif 1802 if w then << 1803 princ "Reading file "; print u; 1804 w := rds w; 1805 c!:ccompilesupervisor(); 1806 princ "End of file "; print u; 1807 close rds w >> 1808 else << princ "Failed to open file "; print u >> end 1809!#if common!-lisp!-mode 1810 else if eqcar(u, 'defun) then return c!:ccmpout1 macroexpand u 1811!#endif 1812 else if eqcar(u, 'de) then << 1813 u := cdr u; 1814!#if common!-lisp!-mode 1815 w := compress1 ('!" . append(explodec package!-name 1816 symbol!-package car u, 1817 '!@ . '!@ . append(explodec symbol!-name car u, 1818 append(explodec "@@Builtin", '(!"))))); 1819 w := intern w; 1820 defnames := list(car u, c!:inv_name car u, length cadr u, w) . defnames; 1821!#else 1822 defnames := list(car u, c!:inv_name car u, length cadr u) . defnames; 1823!#endif 1824 if posn() neq 0 then terpri(); 1825 princ "Compiling "; prin caar defnames; princ " ... "; 1826 c!:cfndef(caar defnames, cadar defnames, cadr u, 'progn . cddr u); 1827 terpri() >>; 1828 1829 return nil; 1830 end; 1831 1832 1833fluid '(!*defn dfprint!* dfprintsave); 1834 1835!#if common!-lisp!-mode 1836symbolic procedure c!:concat(a, b); 1837 compress1('!" . append(explode2 a, append(explode2 b, '(!")))); 1838!#else 1839symbolic procedure c!:concat(a, b); 1840 compress('!" . append(explode2 a, append(explode2 b, '(!")))); 1841!#endif 1842 1843symbolic procedure c!:ccompilestart name; 1844 defnames := nil; 1845 1846 1847symbolic procedure i86!-end; 1848<< 1849 !*defn := nil; 1850 dfprint!* := dfprintsave 1851>>; 1852 1853put('i86!-end, 'stat, 'endstat); 1854 1855symbolic procedure i86!-begin u; 1856 begin 1857 terpri(); 1858 princ "IN files; or type in expressions"; terpri(); 1859 princ "When all done, execute i86!-END;"; terpri(); 1860 verbos nil; 1861 defnames := nil; 1862 dfprintsave := dfprint!*; 1863 dfprint!* := 'c!:ccmpout1; 1864 !*defn := t; 1865 if getd 'begin then return nil; 1866 return c!:ccompilesupervisor() 1867 % There is a problem with compilesupervisor at the moment, so this way the 1868 % function does not return code size. 1869 end; 1870 1871 1872put('i86!-begin, 'stat, 'rlis); 1873 1874 1875symbolic procedure i86!-compile u; 1876 begin 1877 defnames := nil; % but subsequently ignored! 1878 c!:ccmpout1 u; 1879 end; 1880 1881 1882% 1883% Global treatment of a flow-graph... 1884% 1885 1886symbolic procedure c!:print_opcode(s, depth); 1887 begin 1888 scalar op, r1, r2, r3, helper; 1889 op := car s; r1 := cadr s; r2 := caddr s; r3 := cadddr s; 1890 helper := get(op, 'c!:opcode_printer); 1891 if helper then funcall(helper, op, r1, r2, r3, depth) 1892 else << prin s; terpri() >> 1893 end; 1894 1895symbolic procedure c!:print_exit_condition(why, where_to, depth); 1896 begin 1897 scalar helper, lab1, drop1, lab2, drop2, negate, jmptype, args, 1898 nargs, iflab1, iflab2, lab_end, pops; 1899% An exit condition is one of 1900% goto (lab) 1901% goto ((return-register)) 1902% (ifnull v) (lab1 lab2) ) etc, where v is a register and 1903% (ifatom v) (lab1 lab2) ) lab1, lab2 are labels for true & false 1904% (ifeq v1 v2) (lab1 lab2) ) and various predicates are supported 1905% ((call fn) a1 a2) () tail-call to given function 1906% 1907 if why = 'goto then << 1908 where_to := car where_to; 1909 if atom where_to then << 1910 i!:gopcode(jmp, where_to); 1911 c!:display_flowgraph(where_to, depth, t) >> 1912 else << 1913 c!:pgoto(nil, where_to, depth) >>; 1914 return nil >> 1915 else if eqcar(car why, 'call) then return begin 1916 scalar locs, g, w; 1917 nargs := length cdr why; 1918 1919 << 1920 for each a in cdr why do 1921 if flagp(a, 'c!:live_across_call) then << 1922 g := c!:my_gensym(); 1923 args := g . args >> 1924 else args := a . args; 1925 1926 i!:gopcode(push, esi); 1927 1928% The next line is a HORRID fudge to keep ebx safe when it was going to be 1929% used by the calling standard. Ugh 1930 if i_machine = 2 and length cdr why = 2 then i!:gopcode(push,ebx); 1931 1932 for each a in reverse(cdr why) do 1933 if flagp(a, 'c!:live_across_call) then 1934 i!:gopcode(push,{ebx,-get(a, 'c!:location)*4}) 1935 else i!:gopcode(push, a); 1936 1937 c!:pld_eltenv(c!:find_literal cadar why); 1938 1939 % Compute qenv(fn) and put into edx 1940 i!:gopcode(mov,edx,{eax,4}); 1941 % See further comments for the similar construction in c!:pcall 1942 if nargs = 1 then i!:gopcode(mov,esi,{eax,8}) 1943 else if nargs = 2 then i!:gopcode(mov,esi,{eax,12}) 1944 else << 1945 i!:gopcode(mov,esi,{eax,16}); 1946 i!:gopcode(push, nargs); 1947 nargs := nargs + 1 1948 >>; 1949 i!:gopcode(push,edx); 1950% Here I adapt (CRUDELY) for possibly different calling machanisms 1951 pops := 4*(nargs+1); 1952print list(i_machine, nargs, pops, 'tailcall); 1953 if i_machine = 2 and (pops = 8 or pops = 12) then << 1954 i!:gopcode(pop,eax, pop,edx); pops := pops-8; 1955 if pops = 4 then << i!:gopcode(pop,ebx); pops := pops-4 >> >> 1956 else if i_machine = 3 and (pops = 8 or pops = 12) then << 1957 i!:gopcode(pop,ecx, pop,edx); pops := pops-8 >>; 1958 i!:gopcode(call,esi); 1959 if pops neq 0 then i!:gopcode(add,esp,pops); 1960 1961% The next line is a HORRID fudge to keep ebx safe when it was going to be 1962% used by the calling standard. Ugh 1963 if i_machine = 2 and length cdr why = 2 then i!:gopcode(pop,ebx); 1964 1965 i!:gopcode(pop, esi); 1966 if depth neq 0 then c!:ppopv(depth); 1967 i!:gopcode(jmp,lab_end_proc) 1968 >>; 1969 return nil end; 1970 1971 lab1 := car where_to; 1972 drop1 := atom lab1 and not flagp(lab1, 'c!:visited); 1973 lab2 := cadr where_to; 1974 drop2 := atom lab2 and not flagp(drop2, 'c!:visited); 1975 if drop2 and get(lab2, 'c!:count) = 1 then << 1976 where_to := list(lab2, lab1); 1977 drop1 := t >> 1978 else if drop1 then negate := t; 1979 helper := get(car why, 'c!:exit_helper); 1980 if null helper then error(0, list("Bad exit condition", why)); 1981 1982 1983 %! Left for testing purposes and should be removed later ------ 1984 1985 if not atom(car where_to) then 1986 % In this case it is implied that we should generate not just a jump, but 1987 % a piece of code which is executed if the condition is satisfied. 1988 iflab1 := c!:my_gensym(); 1989 if not atom(cadr where_to) then iflab2 := c!:my_gensym(); 1990 1991 jmptype := funcall(helper, cdr why, negate); 1992 1993 if not drop1 then << 1994 if not iflab1 then c!:pgoto(jmptype, car where_to, depth) 1995 else i!:gopcode(jmptype, iflab1); 1996 if not iflab2 then c!:pgoto('jmp, cadr where_to, depth) 1997 else i!:gopcode(jmp, iflab2) 1998 >> 1999 else 2000 if not iflab2 then c!:pgoto(jmptype, cadr where_to, depth) 2001 else << 2002 i!:gopcode(jmptype,iflab2); 2003 lab_end := c!:my_gensym(); 2004 i!:gopcode(jmp,lab_end) >>; 2005 2006 if iflab1 then << 2007 i!:gopcode('!:,iflab1); 2008 c!:pgoto(jmptype, car where_to, depth) >>; 2009 if iflab2 then << 2010 i!:gopcode('!:,iflab2); 2011 c!:pgoto(jmptype, cadr where_to, depth) >>; 2012 if lab_end then i!:gopcode('!:,lab_end); 2013 2014 if atom car where_to then c!:display_flowgraph(car where_to, depth, drop1); 2015 if atom cadr where_to then c!:display_flowgraph(cadr where_to, depth, nil) 2016 end; 2017 2018%----------------------------------------------------------------------------- 2019 2020% There are certain conventions about locations of some variables: 2021% 1. I assume the address of current stack top is residing in ebx permanently; 2022% *OOGGGUMPHHH*. On Linux ebx is perserved across procedure calls and so 2023% this use of it as a "register variable" is OK, but on Watcom it gets 2024% used in some procedure calls and potentially clobbered on any. Oh dear! 2025% 2. nil is always the first local variable of any function, thus it is referred 2026% everywhere as [ebp-4] 2027% 3. env is always the first formal parameter of any function, thus it is 2028% referred everywhere as [ebp+off_env] 2029% 4. nargs (if exists at all) is always the second formal parameter of any 2030% function, thus it is referred everywhere as [ebp+off_nargs] 2031 2032symbolic procedure c!:pmovr(op, r1, r2, r3, depth); 2033 << 2034 2035 if flagp(r3, 'c!:live_across_call) then 2036 i!:gopcode(mov, eax, {ebx,-4*get(r3, 'c!:location)}) 2037 else i!:gopcode(mov, eax, r3); 2038 if flagp(r1, 'c!:live_across_call) then 2039 i!:gopcode(mov, {ebx,-4*get(r1, 'c!:location)},eax) 2040 else i!:gopcode(mov, r1, eax) 2041 >>; 2042 2043put('movr, ' c!:opcode_printer, function c!:pmovr); 2044 2045symbolic procedure c!:pld_eltenv(elno); 2046 << 2047 % #define elt(v, n) (*(Lisp_Object *)((char *)(v)-2+(((int32_t)(n))<<2))) 2048 2049 i!:gopcode(mov, edx,{ebp,off_env}); 2050 i!:gopcode(mov, eax,{edx,4*elno-2}) 2051 >>; 2052 2053symbolic procedure c!:pst_eltenv(elno); 2054 << 2055 i!:gopcode(mov, edx,{ebp,off_env}); 2056 i!:gopcode(mov, {edx,4*elno-2},eax) 2057 >>; 2058 2059symbolic procedure c!:pld_qvaleltenv(elno); 2060 << 2061 % #define qvalue(p) (*(Lisp_Object *)(p)) 2062 2063 c!:pld_eltenv(elno); 2064 i!:gopcode(mov, eax, {eax}); 2065 >>; 2066 2067symbolic procedure c!:pst_qvaleltenv(elno); 2068 << 2069 i!:gopcode(mov, edx,{ebp,off_env}); 2070 i!:gopcode(mov, ecx,{edx,4*elno-2}); 2071 i!:gopcode(mov, {ecx},eax); 2072 >>; 2073 2074symbolic procedure c!:pmovk(op, r1, r2, r3, depth); 2075 << 2076 2077 c!:pld_eltenv(r3); 2078 i!:gopcode(mov, r1,eax) 2079 >>; 2080 2081put('movk, 'c!:opcode_printer, function c!:pmovk); 2082 2083symbolic procedure c!:pmovk1(op, r1, r2, r3, depth); 2084 if null r3 then << 2085 i!:gopcode(mov, eax, {ebp,-4}); 2086 i!:gopcode(mov, r1, eax) 2087 >> 2088 else if r3 = 't then << 2089 i!:gopcode(mov, eax, 'lisp_true); 2090 i!:gopcode(mov, r1, eax) 2091 >> 2092 else << 2093 i!:gopcode(mov, eax, 16*r3+1); 2094 i!:gopcode(mov, r1, eax) 2095 >>; 2096 2097put('movk1, 'c!:opcode_printer, function c!:pmovk1); 2098 2099procedure c!:preloadenv(op, r1, r2, r3, depth); 2100% will not be encountered unless reloadenv variable has been set up. 2101 << 2102 i!:gopcode(mov, ecx,{ebx,-reloadenv*4}); 2103 i!:gopcode(mov, {ebp,off_env},ecx) 2104 >>; 2105 2106put('reloadenv, 'c!:opcode_printer, function c!:preloadenv); 2107 2108symbolic procedure c!:pldrglob(op, r1, r2, r3, depth); 2109 << 2110 c!:pld_qvaleltenv(r3); 2111 i!:gopcode(mov, r1,eax) 2112 >>; 2113 2114put('ldrglob, 'c!:opcode_printer, function c!:pldrglob); 2115 2116symbolic procedure c!:pstrglob(op, r1, r2, r3, depth); 2117 << 2118 i!:gopcode(mov, eax,r1); 2119 c!:pst_qvaleltenv(r3) 2120 >>; 2121 2122put('strglob, 'c!:opcode_printer, function c!:pstrglob); 2123 2124symbolic procedure c!:pnilglob(op, r1, r2, r3, depth); 2125 << 2126 i!:gopcode(mov, eax, {ebp,-4}); 2127 c!:pst_qvaleltenv(r3) 2128 >>; 2129 2130put('nilglob, 'c!:opcode_printer, function c!:pnilglob); 2131 2132symbolic procedure c!:pgentornil(condtype, dest); 2133 begin 2134 scalar condjmp, lab1, lab2; 2135 2136 if condtype = 'eq then condjmp := 'jne 2137 else if condtype = 'neq then condjmp := 'je 2138 else if condtype = '< then condjmp := 'jge 2139 else if condtype = '> then condjmp := 'jle; 2140 lab1 := c!:my_gensym(); 2141 lab2 := c!:my_gensym(); 2142 i!:gopcode(condjmp, lab1); 2143 i!:gopcode(mov,eax,'lisp_true, jmp,lab2); 2144 i!:gopcode('!:,lab1, mov,eax,{ebp,-4}); 2145 i!:gopcode('!:,lab2, mov,dest,eax) 2146 end; 2147 2148 2149symbolic procedure c!:pnull(op, r1, r2, r3, depth); 2150 << 2151 2152 i!:gopcode(mov,eax,r3); 2153 i!:gopcode(cmp,eax,{ebp,-4}); 2154 c!:pgentornil('eq, r1) 2155 >>; 2156 2157 2158put('null, 'c!:opcode_printer, function c!:pnull); 2159put('not, 'c!:opcode_printer, function c!:pnull); 2160 2161symbolic procedure c!:pfastget(op, r1, r2, r3, depth); 2162 begin 2163 scalar lab1,lab_end; 2164 2165 lab1 := c!:my_gensym(); lab_end := c!:my_gensym(); 2166 2167 i!:gopcode(mov,eax,r2); 2168 i!:gopcode(and,eax,TAG_BITS, cmp,eax,TAG_SYMBOL, je,lab1); 2169 i!:gopcode(mov,eax,{ebp,-4}, jmp,lab_end); 2170 i!:gopcode('!:,lab1); 2171 i!:gopcode(mov,eax,r2, mov,eax,{eax,28}, cmp,eax,{ebp,-4}, je,lab_end); 2172 i!:gopcode(mov,eax,{eax,4*(car r3)-2}); 2173 2174 i!:gopcode(cmp,eax,SPID_NOPROP, jne,lab_end, mov,eax,{ebp,-4}); 2175 i!:gopcode('!:,lab_end, mov,r1,eax) 2176 end; 2177 2178put('fastget, 'c!:opcode_printer, function c!:pfastget); 2179flag('(fastget), 'c!:uses_nil); 2180 2181symbolic procedure c!:pfastflag(op, r1, r2, r3, depth); 2182 begin 2183 scalar lab1, lab2, lab_end; 2184 2185 2186 lab1 := c!:my_gensym(); lab2 := c!:my_gensym(); lab_end := c!:my_gensym(); 2187 2188 i!:gopcode(mov,eax,r2); 2189 i!:gopcode(and,eax,TAG_BITS, cmp,eax,TAG_SYMBOL, je,lab1); 2190 i!:gopcode(mov,eax,{ebp,-4}, jmp,lab_end); 2191 i!:gopcode('!:,lab1); 2192 i!:gopcode(mov,eax,r2, mov,eax,{eax,28}, cmp,eax,{ebp,-4}, je,lab_end); 2193 i!:gopcode(mov,eax,{eax,4*(car r3)-2}); 2194 2195 i!:gopcode(cmp,eax,SPID_NOPROP, je,lab2, mov,eax,'lisp_true, jmp,lab_end); 2196 i!:gopcode('!:,lab2, mov,eax,{ebp,-4}); 2197 i!:gopcode('!:,lab_end, mov,r1,eax) 2198 end; 2199 2200put('fastflag, 'c!:opcode_printer, function c!:pfastflag); 2201flag('(fastflag), 'c!:uses_nil); 2202 2203symbolic procedure c!:pcar(op, r1, r2, r3, depth); 2204 begin 2205 if not !*unsafecar then << 2206 c!:pgoto(nil, c!:find_error_label(list('car, r3), r2, depth), depth); 2207 2208 % #define car_legal(p) is_cons(p) 2209 % #define is_cons(p) ((((int)(p)) & TAG_BITS) == TAG_CONS) 2210 % TAG_CONS = 0 2211 i!:gopcode(mov,eax,r3, test,eax,TAG_BITS); 2212 c!:pgoto('jne, c!:find_error_label(list('car, r3), r2, depth), depth) 2213 >>; 2214 2215 c!:pqcar(op, r1, r2, r3, depth) 2216 end; 2217 2218put('car, 'c!:opcode_printer, function c!:pcar); 2219 2220symbolic procedure c!:pcdr(op, r1, r2, r3, depth); 2221 begin 2222 if not !*unsafecar then << 2223 c!:pgoto(nil, c!:find_error_label(list('cdr, r3), r2, depth), depth); 2224 2225 i!:gopcode(mov,eax,r3, test,eax,TAG_BITS); 2226 c!:pgoto('jne, c!:find_error_label(list('cdr, r3), r2, depth), depth) 2227 >>; 2228 2229 c!:pqcdr(op, r1, r2, r3, depth) 2230 end; 2231 2232put('cdr, 'c!:opcode_printer, function c!:pcdr); 2233 2234symbolic procedure c!:pqcar(op, r1, r2, r3, depth); 2235 << 2236 i!:gopcode(mov,eax,r3); 2237 i!:gopcode(mov,eax,{eax}, mov,r1,eax) 2238 >>; 2239 2240put('qcar, 'c!:opcode_printer, function c!:pqcar); 2241 2242symbolic procedure c!:pqcdr(op, r1, r2, r3, depth); 2243 << 2244 i!:gopcode(mov,eax,r3); 2245 i!:gopcode(mov,eax,{eax,4}, mov,r1,eax) 2246 >>; 2247 2248put('qcdr, 'c!:opcode_printer, function c!:pqcdr); 2249 2250symbolic procedure c!:patom(op, r1, r2, r3, depth); 2251 << 2252 2253 i!:gopcode(mov,eax,r3, test,eax,TAG_BITS); 2254 c!:pgentornil('neq, r1); 2255 >>; 2256 2257put('atom, 'c!:opcode_printer, function c!:patom); 2258 2259symbolic procedure c!:pnumberp(op, r1, r2, r3, depth); 2260 << 2261 i!:gopcode(mov,eax,r3, test,eax,1); 2262 c!:pgentornil('neq, r1) 2263 >>; 2264 2265put('numberp, 'c!:opcode_printer, function c!:pnumberp); 2266 2267symbolic procedure c!:pfixp(op, r1, r2, r3, depth); 2268 << 2269 c!:pgencall('integerp, {"nil",r3}, r1) 2270 >>; 2271 2272put('fixp, 'c!:opcode_printer, function c!:pfixp); 2273 2274symbolic procedure c!:piminusp(op, r1, r2, r3, depth); 2275 << 2276 i!:gopcode(mov,eax,r3, test,eax,eax); 2277 c!:pgentornil('<, r1) 2278 >>; 2279 2280put('iminusp, 'c!:opcode_printer, function c!:piminusp); 2281 2282symbolic procedure c!:pilessp(op, r1, r2, r3, depth); 2283 << 2284 i!:gopcode(mov,eax,r2, cmp,eax,r3); 2285 c!:pgentornil('<, r1) 2286 >>; 2287 2288put('ilessp, 'c!:opcode_printer, function c!:pilessp); 2289 2290symbolic procedure c!:pigreaterp(op, r1, r2, r3, depth); 2291 << 2292 i!:gopcode(mov,eax,r2, cmp,eax,r3); 2293 c!:pgentornil('>, r1) 2294 >>; 2295 2296put('igreaterp, 'c!:opcode_printer, function c!:pigreaterp); 2297 2298symbolic procedure c!:piminus(op, r1, r2, r3, depth); 2299 << 2300 i!:gopcode(mov,eax,2, sub,eax,r3); 2301 i!:gopcode(mov, r1, eax) 2302 >>; 2303 2304put('iminus, 'c!:opcode_printer, function c!:piminus); 2305 2306symbolic procedure c!:piadd1(op, r1, r2, r3, depth); 2307 << 2308 i!:gopcode(mov, eax, r3); 2309 i!:gopcode(add,eax,0x10, mov,r1,eax) 2310 >>; 2311 2312put('iadd1, 'c!:opcode_printer, function c!:piadd1); 2313 2314symbolic procedure c!:pisub1(op, r1, r2, r3, depth); 2315 << 2316 i!:gopcode(mov, eax, r3); 2317 i!:gopcode(sub,eax,0x10, mov,r1,eax) 2318 >>; 2319 2320put('isub1, 'c!:opcode_printer, function c!:pisub1); 2321 2322symbolic procedure c!:piplus2(op, r1, r2, r3, depth); 2323 << 2324 i!:gopcode(mov,eax,r2, add,eax,r3); 2325 i!:gopcode(sub,eax,TAG_FIXNUM, mov,r1,eax) 2326 >>; 2327 2328put('iplus2, 'c!:opcode_printer, function c!:piplus2); 2329 2330symbolic procedure c!:pidifference(op, r1, r2, r3, depth); 2331 << 2332 i!:gopcode(mov,eax,r2, sub,eax,r3); 2333 i!:gopcode(add,eax,TAG_FIXNUM, mov,r1,eax) 2334 >>; 2335 2336put('idifference, 'c!:opcode_printer, function c!:pidifference); 2337 2338symbolic procedure c!:pitimes2(op, r1, r2, r3, depth); 2339 << 2340 i!:gopcode(mov,eax,r2, shr,eax,4); 2341 i!:gopcode(mov,edx,r3, shr,edx,4); 2342 i!:gopcode(mul,eax,edx, shl,eax,4, add,eax,TAG_FIXNUM); 2343 i!:gopcode(mov, r1, eax); 2344 >>; 2345 2346put('itimes2, 'c!:opcode_printer, function c!:pitimes2); 2347 2348symbolic procedure c!:pmodular_plus(op, r1, r2, r3, depth); 2349 begin 2350 scalar lab1; 2351 2352 lab1 := c!:my_gensym(); 2353 i!:gopcode(mov,eax,r2, shr,eax,4); 2354 i!:gopcode(mov,edx,r3, shr,edx,4); 2355 i!:gopcode(add,eax,edx, cmp,eax,'current_modulus, jl,lab1); 2356 i!:gopcode(sub, eax, 'current_modulus); 2357 i!:gopcode('!:,lab1, shl,eax,4, add,eax,TAG_FIXNUM, mov,r1,eax) 2358 end; 2359 2360put('modular!-plus, 'c!:opcode_printer, function c!:pmodular_plus); 2361 2362symbolic procedure c!:pmodular_difference(op, r1, r2, r3, depth); 2363 begin 2364 scalar lab1; 2365 2366 lab1 := c!:my_gensym(); 2367 i!:gopcode(mov,eax,r2, shr,eax,4); 2368 i!:gopcode(mov,edx,r3, shr,edx,4); 2369 i!:gopcode(sub,eax,edx, test,eax,eax, jge,lab1); 2370 i!:gopcode(add,eax,'current_modulus); 2371 i!:gopcode('!:,lab1, shl,eax,4, add,eax,TAG_FIXNUM, mov,r1,eax) 2372 end; 2373 2374put('modular!-difference, 'c!:opcode_printer, function c!:pmodular_difference); 2375 2376symbolic procedure c!:pmodular_minus(op, r1, r2, r3, depth); 2377 begin 2378 scalar lab1; 2379 2380 lab1 := c!:my_gensym(); 2381 i!:gopcode(mov,eax,r3, shr,eax,4); 2382 i!:gopcode(test,eax,eax, je,lab1); 2383 i!:gopcode(sub,eax,'current_modulus, neg,eax); 2384 i!:gopcode('!:,lab1, shl,eax,4, add,eax,TAG_FIXNUM, mov,r1,eax) 2385 end; 2386 2387put('modular!-minus, 'c!:opcode_printer, function c!:pmodular_minus); 2388 2389!#if (not common!-lisp!-mode) 2390 2391symbolic procedure c!:passoc(op, r1, r2, r3, depth); 2392 << 2393 c!:pgencall('assoc, list("nil", r2, r3), r1) 2394 >>; 2395 2396put('assoc, 'c!:opcode_printer, function c!:passoc); 2397flag('(assoc), 'c!:uses_nil); 2398 2399!#endif 2400 2401symbolic procedure c!:patsoc(op, r1, r2, r3, depth); 2402 << 2403 c!:pgencall('atsoc, list("nil", r2, r3), r1) 2404 >>; 2405 2406put('atsoc, 'c!:opcode_printer, function c!:patsoc); 2407flag('(atsoc), 'c!:uses_nil); 2408 2409!#if (not common!-lisp!-mode) 2410 2411symbolic procedure c!:pmember(op, r1, r2, r3, depth); 2412 << 2413 c!:pgencall('member, {"nil", r2, r3}, r1) 2414 >>; 2415 2416put('member, 'c!:opcode_printer, function c!:pmember); 2417flag('(member), 'c!:uses_nil); 2418 2419!#endif 2420 2421symbolic procedure c!:pmemq(op, r1, r2, r3, depth); 2422 << 2423 c!:pgencall('memq, {"nil", r2, r3}, r1) 2424 >>; 2425 2426put('memq, 'c!:opcode_printer, function c!:pmemq); 2427flag('(memq), 'c!:uses_nil); 2428 2429!#if common!-lisp!-mode 2430 2431symbolic procedure c!:pget(op, r1, r2, r3, depth); 2432 << 2433 c!:pgencall('get, {r2, r3, "nil"}, r1); 2434 >>; 2435 2436flag('(get), 'c!:uses_nil); 2437!#else 2438 2439symbolic procedure c!:pget(op, r1, r2, r3, depth); 2440 << 2441 c!:pgencall('get, list(r2, r3), r1); 2442 >>; 2443 2444!#endif 2445 2446put('get, 'c!:opcode_printer, function c!:pget); 2447 2448symbolic procedure c!:pgetv(op, r1, r2, r3, depth); 2449 << 2450 i!:gopcode(mov,eax,r2, sub,eax,2); 2451 i!:gopcode(mov,edx,r3, shr,edx,2, add,eax,edx); 2452 i!:gopcode(mov,eax,{eax}, mov,r1,eax) 2453 >>; 2454 2455put('getv, 'c!:opcode_printer, function c!:pgetv); 2456 2457symbolic procedure c!:pqputv(op, r1, r2, r3, depth); 2458 << 2459 i!:gopcode(mov,eax,r2, sub,eax,2); 2460 i!:gopcode(mov,edx,r3, shr,edx,2, add,edx,eax); 2461 i!:gopcode(mov,eax,r1, mov,{edx},eax) 2462 >>; 2463 2464put('qputv, 'c!:opcode_printer, function c!:pqputv); 2465 2466symbolic procedure c!:peq(op, r1, r2, r3, depth); 2467 << 2468 i!:gopcode(mov,eax,r2, cmp,eax,r3); 2469 c!:pgentornil('eq, r1) 2470 >>; 2471 2472put('eq, 'c!:opcode_printer, function c!:peq); 2473flag('(eq), 'c!:uses_nil); 2474 2475 2476symbolic procedure c!:pgenpequal(fname, args, res); 2477 begin 2478 scalar jmpinstr, lab1, lab2; 2479 jmpinstr := c!:pgenequal(fname, args, nil); 2480 % Jump instruction is issued for the case the condition is true 2481 lab1 := c!:my_gensym(); 2482 lab2 := c!:my_gensym(); 2483 i!:gopcode(jmpinstr, lab1); 2484 i!:gopcode(mov,eax,{ebp,-4}, jmp,lab2); 2485 i!:gopcode('!:,lab1, mov,eax,'lisp_true); 2486 i!:gopcode('!:,lab2, mov,res,eax) 2487 end; 2488 2489!#if common!-lisp!-mode 2490symbolic procedure c!:pequal(op, r1, r2, r3, depth); 2491 << 2492 c!:pgenpequal('cl_equal_fn, list(r2, r3), r1); 2493 >>; 2494!#else 2495symbolic procedure c!:pequal(op, r1, r2, r3, depth); 2496 begin 2497 c!:pgenpequal('equal_fn, list(r2, r3), r1) 2498 end; 2499!#endif 2500 2501put('equal, 'c!:opcode_printer, function c!:pequal); 2502flag('(equal), 'c!:uses_nil); 2503 2504symbolic procedure c!:pfluidbind(op, r1, r2, r3, depth); 2505 nil; 2506 2507put('fluidbind, 'c!:opcode_printer, function c!:pfluidbind); 2508 2509 2510symbolic procedure c!:pgencall(addr, arglist, dest); 2511% Generate a call sequence. 2512 begin 2513 scalar reg, nargs, c_dir, pops; 2514 2515 if not (reg := get(addr,'i!:regcode)) then << 2516 nargs := length arglist; 2517 if not atom car arglist then << 2518 % We encode (nil, actual no of args) or (env, actual no of args) this way 2519 nargs := cadar arglist; 2520 car arglist := caar arglist; 2521 >> 2522 else if (car arglist = 'env) or (car arglist = "nil") then 2523 nargs := nargs - 1 2524 else << 2525 % This is a direct C entrypoint or direct C predicate or one of special 2526 % functions: reclaim, error, equal_fn, aerror which behave the same 2527 % and for which we don't need to pass the number of args. 2528 if (c_dir := get(addr, 'c!:direct_call_func)) then nargs := nil >> 2529 >>; 2530 2531% The next line is a HORRID fudge to keep ebx safe when it was going to be 2532% used by the calling standard. Ugh 2533 if i_machine = 2 and length arglist = 3 then i!:gopcode(push,ebx); 2534 2535% I have to reverse the order of parameters, since we use C call model 2536 for each a in reverse arglist do i!:gopcode(push, a); 2537 pops := 4*length arglist; 2538% Here I adapt (CRUDELY) for possibly different calling mechanisms 2539print list(i_machine, pops, 'call); 2540 if i_machine = 2 and (pops = 8 or nargs = 12) then << 2541 i!:gopcode(pop,eax, pop,edx); pops := pops-8; 2542 if pops = 4 then << i!:gopcode(pop,ebx); pops := pops-4 >> >> 2543 else if i_machine = 3 and (pops = 8 or pops = 12) then << 2544 i!:gopcode(pop,ecx, pop,edx); pops := pops-8 >>; 2545 if reg then i!:gopcode(call, addr) 2546 else << 2547 i_putcomment list('call, addr, list nargs, c_dir); 2548 i_putbyte 0xe8; 2549 if c_dir then i_putextern list('rel_plus_4, c_dir) 2550 else i_putextern list('rel_plus_4, list(addr, nargs)) >>; 2551 if pops neq 0 then i!:gopcode(add, esp, pops); 2552 2553% The next line is a HORRID fudge to keep ebx safe when it was going to be 2554% used by the calling standard. Ugh 2555 if i_machine = 2 and length arglist = 3 then i!:gopcode(pop,ebx); 2556 if dest neq nil then i!:gopcode(mov,dest,eax); 2557 end; 2558 2559symbolic procedure c!:pcall(op, r1, r2, r3, depth); 2560 begin 2561 % r3 is (name <fluids to unbind on error>) 2562 scalar w, boolfn, nargs, lab1; 2563 2564%-- if car r3 = current_procedure then << 2565%-- nargs := length r2; 2566%-- if null r2 or nargs >= 3 then << 2567%-- r2 := cons(nargs, r2); 2568%-- r2 := cons({'env, nargs}, r2) >> 2569%-- else r2 := cons('env, r2); 2570%-- c!:pgencall(car r3, r2, r1) 2571%-- >> 2572 2573 begin 2574 nargs := length r2; 2575 c!:pld_eltenv(c!:find_literal car r3); 2576 2577 % Compute qenv(fn) and put into edx 2578 i!:gopcode(mov,edx,{eax,4}); 2579 2580 r2 := cons('edx, r2); 2581 if nargs = 1 then i!:gopcode(mov,ecx,{eax,8}) 2582 else if nargs = 2 then i!:gopcode(mov,ecx,{eax,12}) 2583 else << 2584 i!:gopcode(mov,ecx,{eax,16}); 2585 r2 := car r2 . nargs . cdr r2 2586 >>; 2587 c!:pgencall('ecx, r2, r1) 2588 end; 2589 2590 if not flagp(car r3, 'c!:no_errors) then << 2591 if null cadr r3 and depth = 0 then << 2592 2593 lab1 := c!:my_gensym(); 2594 i!:gopcode(mov,eax,'C_nil, mov,{ebp,-4},eax); 2595 i!:gopcode(and,eax,1, je,lab1); 2596 i!:gopcode(mov,eax,{ebp,-4}, jmp,lab_end_proc); 2597 i!:gopcode('!:,lab1) 2598 >> 2599 else << 2600 i!:gopcode(mov,eax,'C_nil, mov,{ebp,-4},eax); 2601 2602 c!:pgoto(nil, c!:find_error_label(nil, cadr r3, depth), depth); 2603 2604 i!:gopcode(and,eax,1); 2605 c!:pgoto('jne, c!:find_error_label(nil, cadr r3, depth), depth) 2606 >> 2607 >>; 2608 2609 if boolfn then << 2610 2611 i!:gopcode(mov,eax,r1, test,eax,eax); 2612 c!:pgentornil('neq, r1) 2613 >> 2614 end; 2615 2616put('call, 'c!:opcode_printer, function c!:pcall); 2617 2618 2619symbolic procedure c!:ppopv(depth); 2620 << 2621 i!:gopcode(sub,ebx,depth*4, mov,'stack,ebx) 2622 >>; 2623 2624symbolic procedure c!:pgoto(jmptype, lab, depth); 2625 begin 2626 if atom lab then << 2627 if jmptype neq nil then %! when test sup removed nil test not required 2628 return i!:gopcode(jmptype, lab) 2629 else return nil 2630 >>; 2631 lab := get(car lab, 'c!:chosen); 2632 if zerop depth then << 2633 i!:gopcode(mov,eax,lab, jmp,lab_end_proc) 2634 >> 2635 else if flagp(lab, 'c!:live_across_call) then << 2636 i!:gopcode(mov, eax, {ebx, -get(lab, 'c!:location)*4}); 2637 c!:ppopv(depth); 2638 i!:gopcode(jmp,lab_end_proc) 2639 >> 2640 else << 2641 c!:ppopv(depth); 2642 i!:gopcode(mov,eax,lab, jmp,lab_end_proc) 2643 >> 2644end; 2645 2646symbolic procedure c!:pifnull(s, negate); 2647 << 2648 i!:gopcode(mov, eax, car s); 2649 i!:gopcode(cmp, eax, {ebp,-4}); 2650 if negate then 'jne 2651 else 'je 2652 >>; 2653 2654put('ifnull, 'c!:exit_helper, function c!:pifnull); 2655 2656symbolic procedure c!:pifatom(s, negate); 2657 << 2658 i!:gopcode(mov,eax,car s, test,eax,TAG_BITS); 2659 if negate then 'je 2660 else 'jne 2661 >>; 2662 2663put('ifatom, 'c!:exit_helper, function c!:pifatom); 2664 2665symbolic procedure c!:pifsymbol(s, negate); 2666 << 2667 i!:gopcode(mov, eax, car s); 2668 i!:gopcode(and,eax,TAG_BITS, cmp,eax,TAG_SYMBOL); 2669 if negate then 'jne 2670 else 'je 2671 >>; 2672 2673put('ifsymbol, 'c!:exit_helper, function c!:pifsymbol); 2674 2675symbolic procedure c!:pifnumber(s, negate); 2676 << 2677 i!:gopcode(mov,eax,car s, test,eax,1); 2678 if negate then 'je 2679 else 'jne 2680 >>; 2681 2682put('ifnumber, 'c!:exit_helper, function c!:pifnumber); 2683 2684symbolic procedure c!:pifizerop(s, negate); 2685 << 2686 i!:gopcode(mov,eax,car s, cmp,eax,1); 2687 if negate then 'jne 2688 else 'je 2689 >>; 2690 2691put('ifizerop, 'c!:exit_helper, function c!:pifizerop); 2692 2693symbolic procedure c!:pifeq(s, negate); 2694 << 2695 i!:gopcode(mov,eax,car s, cmp,eax,cadr s); 2696 if negate then 'jne 2697 else 'je 2698 >>; 2699 2700put('ifeq, 'c!:exit_helper, function c!:pifeq); 2701 2702symbolic procedure c!:pgenequal(fname, args, negate); 2703% Perform the evaluation of the macro below, and issue a cond jump command so 2704% that jump is performed if the condition is satisfied. fname should be 2705% either equal_fn or cl_equal_fn, and this parameter is required only 2706% because of my desire to support both SL and CL at least here 2707 begin 2708 scalar lab_ok, lab_fail, lab_end; 2709 % #define equal(a, b) \ 2710 % ((a) == (b) || \ 2711 % (((((a) ^ (b)) & TAG_BITS) == 0) && \ 2712 % ((unsigned)(((a) & TAG_BITS) - 1) > 3) && \ 2713 % equal_fn(a, b))) 2714 2715 lab_ok := c!:my_gensym(); lab_fail := c!:my_gensym(); lab_end := c!:my_gensym(); 2716 i!:gopcode(mov, ecx,car args); 2717 i!:gopcode(mov, edx,cadr args); 2718 i!:gopcode(cmp,ecx,edx, je,lab_ok); 2719 i!:gopcode(mov,eax,ecx, xor,eax,edx, test,eax,7, jne,lab_fail); 2720 i!:gopcode(mov,eax,ecx, and,eax,7, dec,eax); 2721 i!:gopcode(cmp,eax,3, jbe,lab_fail); 2722 c!:pgencall(fname,{'ecx,'edx},nil); 2723 i!:gopcode(test,eax,eax, jne,lab_ok); 2724 i!:gopcode('!:,lab_fail, xor,eax,eax, jmp,lab_end); 2725 i!:gopcode('!:,lab_ok, mov,eax,1); 2726 i!:gopcode('!:,lab_end, test,eax,eax); 2727 if negate then return 'je 2728 else return 'jne 2729 end; 2730 2731!#if common!-lisp!-mode 2732symbolic procedure c!:pifequal(s, negate); 2733 c!:pgenequal('cl_equal_fn, s, negate); 2734!#else 2735symbolic procedure c!:pifequal(s, negate); 2736 c!:pgenequal('equal_fn, s, negate); 2737!#endif 2738 2739put('ifequal, 'c!:exit_helper, function c!:pifequal); 2740 2741symbolic procedure c!:pifilessp(s, negate); 2742 << 2743 i!:gopcode(mov,eax,car s, cmp,eax,cadr s); 2744 if negate then 'jge 2745 else 'jl >>; 2746 2747put('ifilessp, 'c!:exit_helper, function c!:pifilessp); 2748 2749symbolic procedure c!:pifigreaterp(s, negate); 2750 << 2751 i!:gopcode(mov,eax,car s, cmp,eax,cadr s); 2752 if negate then 'jle 2753 else 'jg >>; 2754 2755put('ifigreaterp, 'c!:exit_helper, function c!:pifigreaterp); 2756 2757%------------------------------------------------------------------------------ 2758 2759symbolic procedure c!:display_flowgraph(s, depth, dropping_through); 2760 if not atom s then << 2761 c!:pgoto(nil, s, depth) >> 2762 else if not flagp(s, 'c!:visited) then begin 2763 scalar why, where_to; 2764 flag(list s, 'c!:visited); 2765 if not dropping_through or not (get(s, 'c!:count) = 1) then 2766 i!:gopcode('!:, s); 2767 for each k in reverse get(s, 'c!:contents) do c!:print_opcode(k, depth); 2768 why := get(s, 'c!:why); 2769 where_to := get(s, 'c!:where_to); 2770 if why = 'goto and (not atom car where_to or 2771 (not flagp(car where_to, 'c!:visited) and 2772 get(car where_to, 'c!:count) = 1)) then 2773 c!:display_flowgraph(car where_to, depth, t) 2774 else c!:print_exit_condition(why, where_to, depth) 2775 end; 2776 2777fluid '(startpoint); 2778 2779symbolic procedure c!:branch_chain(s, count); 2780 begin 2781 scalar contents, why, where_to, n; 2782% do nothing to blocks already visted or return blocks. 2783 if not atom s then return s 2784 else if flagp(s, 'c!:visited) then << 2785 n := get(s, 'c!:count); 2786 if null n then n := 1 else n := n + 1; 2787 put(s, 'c!:count, n); 2788 return s >>; 2789 flag(list s, 'c!:visited); 2790 contents := get(s, 'c!:contents); 2791 why := get(s, 'c!:why); 2792 where_to := for each z in get(s, 'c!:where_to) collect 2793 c!:branch_chain(z, count); 2794% Turn movr a,b; return a; into return b; 2795 while contents and eqcar(car contents, 'movr) and 2796 why = 'goto and not atom car where_to and 2797 caar where_to = cadr car contents do << 2798 where_to := list list cadddr car contents; 2799 contents := cdr contents >>; 2800 put(s, 'c!:contents, contents); 2801 put(s, 'c!:where_to, where_to); 2802% discard empty blocks 2803 if null contents and why = 'goto then << 2804 remflag(list s, 'c!:visited); 2805 return car where_to >>; 2806 if count then << 2807 n := get(s, 'c!:count); 2808 if null n then n := 1 2809 else n := n + 1; 2810 put(s, 'c!:count, n) >>; 2811 return s 2812 end; 2813 2814symbolic procedure c!:one_operand op; 2815 << flag(list op, 'c!:set_r1); 2816 flag(list op, 'c!:read_r3); 2817 put(op, 'c!:code, function c!:builtin_one) >>; 2818 2819symbolic procedure c!:two_operands op; 2820 << flag(list op, 'c!:set_r1); 2821 flag(list op, 'c!:read_r2); 2822 flag(list op, 'c!:read_r3); 2823 put(op, 'c!:code, function c!:builtin_two) >>; 2824 2825for each n in '(car cdr qcar qcdr null not atom numberp fixp iminusp 2826 iminus iadd1 isub1 modular!-minus) do c!:one_operand n; 2827!#if common!-lisp!-mode 2828for each n in '(eq equal atsoc memq iplus2 idifference 2829 itimes2 ilessp igreaterp getv get 2830 modular!-plus modular!-difference 2831 ) do c!:two_operands n; 2832!#else 2833for each n in '(eq equal atsoc memq iplus2 idifference 2834 assoc member 2835 itimes2 ilessp igreaterp getv get 2836 modular!-plus modular!-difference 2837 ) do c!:two_operands n; 2838!#endif 2839 2840 2841flag('(movr movk movk1 ldrglob call reloadenv fastget fastflag), 'c!:set_r1); 2842flag('(strglob qputv), 'c!:read_r1); 2843flag('(qputv fastget fastflag), 'c!:read_r2); 2844flag('(movr qputv), 'c!:read_r3); 2845flag('(ldrglob strglob nilglob movk call), 'c!:read_env); 2846% special opcodes: 2847% call fluidbind 2848 2849fluid '(fn_used nil_used nilbase_used); 2850 2851symbolic procedure c!:live_variable_analysis all_blocks; 2852 begin 2853 scalar changed, z; 2854 repeat << 2855 changed := nil; 2856 for each b in all_blocks do 2857 begin 2858 scalar w, live; 2859 for each x in get(b, 'c!:where_to) do 2860 if atom x then live := union(live, get(x, 'c!:live)) 2861 else live := union(live, x); 2862 w := get(b, 'c!:why); 2863 if not atom w then << 2864 if eqcar(w, 'ifnull) or eqcar(w, 'ifequal) then nil_used := t; 2865 live := union(live, cdr w); 2866 if eqcar(car w, 'call) and 2867 not (cadar w = current_procedure) then << 2868 fn_used := t; live := union('(env), live) >> >>; 2869 for each s in get(b, 'c!:contents) do 2870 begin % backwards over contents 2871 scalar op, r1, r2, r3; 2872 op := car s; r1 := cadr s; r2 := caddr s; r3 := cadddr s; 2873 if op = 'movk1 then << 2874 if r3 = nil then nil_used := t 2875 else if r3 = 't then nilbase_used := t >> 2876 else if atom op and flagp(op, 'c!:uses_nil) then nil_used := t; 2877 if flagp(op, 'c!:set_r1) then 2878!#if common!-lisp!-mode 2879 if memq(r1, live) then live := remove(r1, live) 2880!#else 2881 if memq(r1, live) then live := delete(r1, live) 2882!#endif 2883 else if op = 'call then nil % Always needed 2884 else op := 'nop; 2885 if flagp(op, 'c!:read_r1) then live := union(live, list r1); 2886 if flagp(op, 'c!:read_r2) then live := union(live, list r2); 2887 if flagp(op, 'c!:read_r3) then live := union(live, list r3); 2888 if op = 'call then << 2889 if not flagp(car r3, 'c!:no_errors) then nil_used := t; 2890 does_call := t; 2891 fn_used := t; 2892 if not flagp(car r3, 'c!:no_errors) then 2893 flag(live, 'c!:live_across_call); 2894 live := union(live, r2) >>; 2895 if flagp(op, 'c!:read_env) then live := union(live, '(env)) 2896 end; 2897!#if common!-lisp!-mode 2898 live := append(live, nil); % because CL sort is destructive! 2899!#endif 2900 live := sort(live, function orderp); 2901 if not (live = get(b, 'c!:live)) then << 2902 put(b, 'c!:live, live); 2903 changed := t >> 2904 end 2905 >> until not changed; 2906 z := registers; 2907 registers := stacklocs := nil; 2908 for each r in z do 2909 if flagp(r, 'c!:live_across_call) then stacklocs := r . stacklocs 2910 else registers := r . registers; 2911 end; 2912 2913symbolic procedure c!:insert1(a, b); 2914 if memq(a, b) then b 2915 else a . b; 2916 2917symbolic procedure c!:clash(a, b); 2918 if flagp(a, 'c!:live_across_call) = flagp(b, 'c!:live_across_call) then << 2919 put(a, 'c!:clash, c!:insert1(b, get(a, 'c!:clash))); 2920 put(b, 'c!:clash, c!:insert1(a, get(b, 'c!:clash))) >>; 2921 2922symbolic procedure c!:build_clash_matrix all_blocks; 2923 begin 2924 for each b in all_blocks do 2925 begin 2926 scalar live, w; 2927 for each x in get(b, 'c!:where_to) do 2928 if atom x then live := union(live, get(x, 'c!:live)) 2929 else live := union(live, x); 2930 w := get(b, 'c!:why); 2931 if not atom w then << 2932 live := union(live, cdr w); 2933 if eqcar(car w, 'call) then 2934 live := union('(env), live) >>; 2935 for each s in get(b, 'c!:contents) do 2936 begin 2937 scalar op, r1, r2, r3; 2938 op := car s; r1 := cadr s; r2 := caddr s; r3 := cadddr s; 2939 if flagp(op, 'c!:set_r1) then 2940 if memq(r1, live) then << 2941!#if common!-lisp!-mode 2942 live := remove(r1, live); 2943!#else 2944 live := delete(r1, live); 2945!#endif 2946 if op = 'reloadenv then reloadenv := t; 2947 for each v in live do c!:clash(r1, v) >> 2948 else if op = 'call then nil 2949 else << 2950 op := 'nop; 2951 rplacd(s, car s . cdr s); % Leaves original instrn visible 2952 rplaca(s, op) >>; 2953 if flagp(op, 'c!:read_r1) then live := union(live, list r1); 2954 if flagp(op, 'c!:read_r2) then live := union(live, list r2); 2955 if flagp(op, 'c!:read_r3) then live := union(live, list r3); 2956% Maybe CALL should be a little more selective about need for "env"? 2957 if op = 'call then live := union(live, r2); 2958 if flagp(op, 'c!:read_env) then live := union(live, '(env)) 2959 end 2960 end; 2961 return nil 2962 end; 2963 2964symbolic procedure c!:allocate_registers rl; 2965 begin 2966 scalar schedule, neighbours, allocation; 2967 neighbours := 0; 2968 while rl do begin 2969 scalar w, x; 2970 w := rl; 2971 while w and length (x := get(car w, 'c!:clash)) > neighbours do 2972 w := cdr w; 2973 if w then << 2974 schedule := car w . schedule; 2975 rl := deleq(car w, rl); 2976 for each r in x do put(r, 'c!:clash, deleq(car w, get(r, 'c!:clash))) >> 2977 else neighbours := neighbours + 1 2978 end; 2979 for each r in schedule do begin 2980 scalar poss; 2981 poss := allocation; 2982 for each x in get(r, 'c!:clash) do 2983 poss := deleq(get(x, 'c!:chosen), poss); 2984 if null poss then << 2985 poss := c!:my_gensym(); 2986 allocation := append(allocation, list poss) >> 2987 else poss := car poss; 2988 put(r, 'c!:chosen, poss) 2989 end; 2990 return allocation 2991 end; 2992 2993symbolic procedure c!:remove_nops all_blocks; 2994% Remove no-operation instructions, and map registers to reflect allocation 2995 for each b in all_blocks do 2996 begin 2997 scalar r; 2998 for each s in get(b, 'c!:contents) do 2999 if not eqcar(s, 'nop) then 3000 begin 3001 scalar op, r1, r2, r3; 3002 op := car s; r1 := cadr s; r2 := caddr s; r3 := cadddr s; 3003 if flagp(op, 'c!:set_r1) or flagp(op, 'c!:read_r1) then 3004 r1 := get(r1, 'c!:chosen); 3005 if flagp(op, 'c!:read_r2) then r2 := get(r2, 'c!:chosen); 3006 if flagp(op, 'c!:read_r3) then r3 := get(r3, 'c!:chosen); 3007 if op = 'call then 3008 r2 := for each v in r2 collect get(v, 'c!:chosen); 3009 if not (op = 'movr and r1 = r3) then 3010 r := list(op, r1, r2, r3) . r 3011 end; 3012 put(b, 'c!:contents, reversip r); 3013 r := get(b, 'c!:why); 3014 if not atom r then 3015 put(b, 'c!:why, 3016 car r . for each v in cdr r collect get(v, 'c!:chosen)) 3017 end; 3018 3019fluid '(error_labels); 3020 3021symbolic procedure c!:find_error_label(why, env, depth); 3022 begin 3023 scalar w, z; 3024 z := list(why, env, depth); 3025 w := assoc!*!*(z, error_labels); 3026 if null w then << 3027 w := z . c!:my_gensym(); 3028 error_labels := w . error_labels >>; 3029 return cdr w 3030 end; 3031 3032symbolic procedure c!:assign(u, v, c); 3033 if flagp(u, 'fluid) then list('strglob, v, u, c!:find_literal u) . c 3034 else list('movr, u, nil, v) . c; 3035 3036symbolic procedure c!:insert_tailcall b; 3037 begin 3038 scalar why, dest, contents, fcall, res, w; 3039 why := get(b, 'c!:why); 3040 dest := get(b, 'c!:where_to); 3041 contents := get(b, 'c!:contents); 3042 while contents and not eqcar(car contents, 'call) do << 3043 w := car contents . w; 3044 contents := cdr contents >>; 3045 if null contents then return nil; 3046 fcall := car contents; 3047 contents := cdr contents; 3048 res := cadr fcall; 3049 while w do << 3050 if eqcar(car w, 'reloadenv) then w := cdr w 3051 else if eqcar(car w, 'movr) and cadddr car w = res then << 3052 res := cadr car w; 3053 w := cdr w >> 3054 else res := w := nil >>; 3055 if null res then return nil; 3056 if c!:does_return(res, why, dest) then 3057 if car cadddr fcall = current_procedure then << 3058 for each p in pair(current_args, caddr fcall) do 3059 contents := c!:assign(car p, cdr p, contents); 3060 put(b, 'c!:contents, contents); 3061 put(b, 'c!:why, 'goto); 3062 put(b, 'c!:where_to, list restart_label) >> 3063 else << 3064 nil_used := t; 3065 put(b, 'c!:contents, contents); 3066 put(b, 'c!:why, list('call, car cadddr fcall) . caddr fcall); 3067 put(b, 'c!:where_to, nil) >> 3068 end; 3069 3070symbolic procedure c!:does_return(res, why, where_to); 3071 if not (why = 'goto) then nil 3072 else if not atom car where_to then res = caar where_to 3073 else begin 3074 scalar contents; 3075 where_to := car where_to; 3076 contents := reverse get(where_to, 'c!:contents); 3077 why := get(where_to, 'c!:why); 3078 where_to := get(where_to, 'c!:where_to); 3079 while contents do 3080 if eqcar(car contents, 'reloadenv) then contents := cdr contents 3081 else if eqcar(car contents, 'movr) and cadddr car contents = res then << 3082 res := cadr car contents; 3083 contents := cdr contents >> 3084 else res := contents := nil; 3085 if null res then return nil 3086 else return c!:does_return(res, why, where_to) 3087 end; 3088 3089symbolic procedure c!:pushpop(op, v); 3090 begin 3091 scalar n, w, instr, src, dest, addr, v1,n1; 3092 3093 if null v then return nil; 3094 n := length v; 3095 3096 if op = 'push then << 3097 instr := 'add; 3098 src := 'eax >> 3099 else << 3100 instr := 'sub; 3101 dest := 'eax >>; 3102 3103 addr := 0; 3104 for each x in v do << 3105 if op = 'push then << 3106 addr := addr + 4; 3107 dest := {'ebx, addr}; 3108 i!:gopcode(mov, eax, x) >> 3109 else src := {'ebx, addr}; 3110 i!:gopcode(mov, dest, src); 3111 if op = 'pop then << 3112 i!:gopcode(mov, x,eax); 3113 addr := addr - 4 >> 3114 >>; 3115 3116 i!:gopcode(add,ebx,addr, mov,'stack,ebx) 3117 end; 3118 3119symbolic procedure c!:optimise_flowgraph(startpoint, all_blocks, 3120 env, argch, args); 3121 begin 3122 scalar w, n, locs, stacks, error_labels, fn_used, nil_used, 3123 nilbase_used, locsno, lab1, addr, lab_ok, stackoffs; 3124 3125!#if common!-lisp!-mode 3126 nilbase_used := t; % For onevalue(xxx) at least 3127!#endif 3128 for each b in all_blocks do c!:insert_tailcall b; 3129 startpoint := c!:branch_chain(startpoint, nil); 3130 remflag(all_blocks, 'c!:visited); 3131 c!:live_variable_analysis all_blocks; 3132 c!:build_clash_matrix all_blocks; 3133 if error_labels and env then reloadenv := t; 3134 for each u in env do 3135 for each v in env do c!:clash(cdr u, cdr v); % keep all args distinct 3136 locs := c!:allocate_registers registers; 3137 stacks := c!:allocate_registers stacklocs; 3138 flag(stacks, 'c!:live_across_call); 3139 c!:remove_nops all_blocks; 3140 startpoint := c!:branch_chain(startpoint, nil); % after tailcall insertion 3141 remflag(all_blocks, 'c!:visited); 3142 startpoint := c!:branch_chain(startpoint, t); % ... AGAIN to tidy up 3143 remflag(all_blocks, 'c!:visited); 3144 if does_call then nil_used := t; 3145 3146 lab_end_proc := c!:my_gensym(); 3147 locsno := 0; 3148 3149 if nil_used then << 3150 locsno := locsno + 1 >>; 3151 if locs then << 3152 locsno := locsno + length(locs) 3153 >>; 3154 3155 % In ASM code I don't use fn since it is well replaced by hardware register 3156 3157 i!:gopcode(push,ebp, mov,ebp,esp); 3158 3159 if locsno > 0 then << 3160 i!:gopcode(sub,esp,locsno*4); 3161 stackoffs := 0; 3162 if nil_used then stackoffs := stackoffs - 4; 3163 for each v in locs do << 3164 stackoffs := stackoffs - 4; 3165 put(v, 'i!:locoffs, stackoffs) >> 3166 >>; 3167 3168 if nil_used then 3169 i!:gopcode(mov,eax,'C_nil, mov,{ebp,-4},eax); 3170 i!:gopcode(push,ebx, mov,ebx,'stack); 3171 3172 %!! Has not been perfectly processed yet due to the string parameter 3173 % # define argcheck(var, n, msg) if ((var)!=(n)) return aerror(msg); 3174 if car argch = 0 or car argch >= 3 then << 3175 lab_ok := c!:my_gensym(); 3176 i!:gopcode(mov,eax,{ebp,off_nargs}, cmp,eax,car argch, je,lab_ok); 3177 c!:pgencall('aerror, {999}, nil); 3178 i!:gopcode(jmp,lab_end_proc); 3179 i!:gopcode('!:,lab_ok) >>; 3180 3181% I will not do a stack check if I have a leaf procedure, and I hope 3182% that this policy will speed up code a bit. 3183 if does_call then << 3184 3185 lab1 := c!:my_gensym(); 3186 i!:gopcode(cmp,ebx,'stacklimit, jl,lab1); 3187% This is slightly clumsy code to save all args on the stack across the 3188% call to reclaim(), but it is not executed often... 3189 c!:pushpop('push, args); 3190 3191 3192 %!! Has not been perfectly processed yet due to the string parameter 3193 c!:pgencall('reclaim, {'!.env,0,GC_STACK,0}, {'ebp,off_env}); 3194 3195 c!:pushpop('pop, reverse args); 3196 i!:gopcode(mov,eax,'C_nil, mov,{ebp,-4},eax); 3197 3198 i!:gopcode(and,eax,1, je,lab1); 3199 i!:gopcode(mov,eax,{ebp,-4}, jmp,lab_end_proc); 3200 3201 i!:gopcode('!:,lab1) >>; 3202 3203 if reloadenv then << 3204 i!:gopcode(mov,eax,{ebp,off_env}, add,ebx,4, 3205 mov,{ebx},eax, mov,'stack,ebx) >>; 3206 n := 0; 3207 if stacks then << 3208 3209 for each v in stacks do << 3210 put(v, 'c!:location, n); 3211 n := n+1 >>; 3212 3213 stackoffs := 0; 3214 i!:gopcode(mov, eax,{ebp,-4}); 3215 for each v in stacks do << 3216 stackoffs := stackoffs + 4; 3217 i!:gopcode(mov, {ebx,stackoffs},eax) >>; 3218 i!:gopcode(add,ebx,stackoffs, mov,'stack,ebx) >>; 3219 if reloadenv then << 3220 reloadenv := n; 3221 n := n + 1 >>; 3222 for each v in env do 3223 if flagp(cdr v, 'c!:live_across_call) then << 3224 i!:gopcode(mov, eax,cdr v); 3225 i!:gopcode(mov, {ebx,-get(get(cdr v, 'c!:chosen), 'c!:location)*4},eax) >> 3226 else << 3227 i!:gopcode(mov, eax,cdr v); 3228 i!:gopcode(mov, get(cdr v, 'c!:chosen),eax) >>; 3229 3230 c!:display_flowgraph(startpoint, n, t); 3231 3232 if error_labels then << 3233 for each x in error_labels do << 3234 i!:gopcode('!:, cdr x); 3235 c!:print_error_return(caar x, cadar x, caddar x) >> >>; 3236 remflag(all_blocks, 'c!:visited); 3237 3238 i!:gopcode('!:,lab_end_proc); 3239 i!:gopcode(pop,ebx, mov,esp,ebp, pop,ebp); 3240 if retloc neq 0 then i!:gopcode(add,esp,4*retloc); 3241 i!:gopcode(ret); 3242 end; 3243 3244symbolic procedure c!:print_error_return(why, env, depth); 3245 begin 3246 scalar args; 3247 3248 if reloadenv and env then << 3249 i!:gopcode(mov,eax,{ebx,-reloadenv*4}, mov,{ebp,off_env},eax) 3250 >>; 3251 if null why then << 3252% One could imagine generating backtrace entries here... 3253 for each v in env do << 3254 i!:gopcode(mov, eax,get(cdr v, 'c!:chosen)); 3255 c!:pst_qvaleltenv(c!:find_literal car v) >>; 3256 3257 if depth neq 0 then c!:ppopv(depth); 3258 3259 i!:gopcode(mov,eax,{ebp,-4}, jmp,lab_end_proc) 3260 >> 3261 else if flagp(cadr why, 'c!:live_across_call) then << 3262 i!:gopcode(push, {ebx,-get(cadr why, 'c!:location)*4}); 3263 for each v in env do << 3264 i!:gopcode(mov, eax,get(cdr v, 'c!:chosen)); 3265 c!:pst_qvaleltenv(c!:find_literal car v) 3266 >>; 3267 if depth neq 0 then c!:ppopv(depth); 3268 if eqcar(why, 'car) then "err_bad_car" 3269 else if eqcar(why, 'cdr) then "err_bad_cdr" 3270 else error(0, list(why, "unknown_error")); 3271 3272 %!! Has not been properly processed yet because of the string parameter 3273 args := list(1, 3274 if eqcar(why, 'car) then 0 % "err_bad_car" 3275 else if eqcar(why, 'cdr) then 0 % "err_bad_cdr" 3276 else 0, % error(0, list(why, "unknown_error")); 3277 cadr why); 3278 c!:pgencall('error, args, nil); 3279 i!:gopcode(jmp,lab_end_proc) 3280 >> 3281 else << 3282 for each v in env do << 3283 i!:gopcode(mov, eax, get(cdr v, 'c!:chosen)); 3284 c!:pst_qvaleltenv(c!:find_literal car v) 3285 >>; 3286 if depth neq 0 then c!:ppopv(depth); 3287 3288 %!! Has not been properly processed yet due to the string parameter 3289 args := list(1, 3290 if eqcar(why, 'car) then 0 % "err_bad_car" 3291 else if eqcar(why, 'cdr) then 0 % "err_bad_cdr" 3292 else 0, % error(0, list(why, "unknown_error")); 3293 cadr why); 3294 c!:pgencall('error, args, nil); 3295 i!:gopcode(jmp,lab_end_proc) 3296 >> 3297 end; 3298 3299 3300% 3301% Now I have a series of separable sections each of which gives a special 3302% recipe that implements or optimises compilation of some specific Lisp 3303% form. 3304% 3305 3306symbolic procedure c!:cand(u, env); 3307 begin 3308 scalar w, r; 3309 w := reverse cdr u; 3310 if null w then return c!:cval(nil, env); 3311 r := list(list('t, car w)); 3312 w := cdr w; 3313 for each z in w do 3314 r := list(list('null, z), nil) . r; 3315 r := 'cond . r; 3316 return c!:cval(r, env) 3317 end; 3318%-- scalar next, done, v, r; 3319%-- v := c!:newreg(); 3320%-- done := c!:my_gensym(); 3321%-- u := cdr u; 3322%-- while cdr u do << 3323%-- next := c!:my_gensym(); 3324%-- c!:outop('movr, v, nil, c!:cval(car u, env)); 3325%-- u := cdr u; 3326%-- c!:endblock(list('ifnull, v), list(done, next)); 3327%-- c!:startblock next >>; 3328%-- c!:outop('movr, v, nil, c!:cval(car u, env)); 3329%-- c!:endblock('goto, list done); 3330%-- c!:startblock done; 3331%-- return v 3332%-- end; 3333 3334put('and, 'c!:code, function c!:cand); 3335 3336!#if common!-lisp!-mode 3337 3338symbolic procedure c!:cblock(u, env); 3339 begin 3340 scalar progret, progexit, r; 3341 progret := c!:newreg(); 3342 progexit := c!:my_gensym(); 3343 blockstack := (cadr u . progret . progexit) . blockstack; 3344 u := cddr u; 3345 for each a in u do r := c!:cval(a, env); 3346 c!:outop('movr, progret, nil, r); 3347 c!:endblock('goto, list progexit); 3348 c!:startblock progexit; 3349 blockstack := cdr blockstack; 3350 return progret 3351 end; 3352 3353 3354put('block, 'c!:code, function c!:cblock); 3355 3356!#endif 3357 3358symbolic procedure c!:ccatch(u, env); 3359 error(0, "catch"); 3360 3361put('catch, 'c!:code, function c!:ccatch); 3362 3363symbolic procedure c!:ccompile_let(u, env); 3364 error(0, "compiler-let"); 3365 3366put('compiler!-let, 'c!:code, function c!:ccompiler_let); 3367 3368symbolic procedure c!:ccond(u, env); 3369 begin 3370 scalar v, join; 3371 v := c!:newreg(); 3372 join := c!:my_gensym(); 3373 for each c in cdr u do begin 3374 scalar l1, l2; 3375 l1 := c!:my_gensym(); l2 := c!:my_gensym(); 3376 if atom cdr c then << 3377 c!:outop('movr, v, nil, c!:cval(car c, env)); 3378 c!:endblock(list('ifnull, v), list(l2, join)) >> 3379 else << 3380 c!:cjumpif(car c, env, l1, l2); 3381 c!:startblock l1; % if the condition is true 3382 c!:outop('movr, v, nil, c!:cval('progn . cdr c, env)); 3383 c!:endblock('goto, list join) >>; 3384 c!:startblock l2 end; 3385 c!:outop('movk1, v, nil, nil); 3386 c!:endblock('goto, list join); 3387 c!:startblock join; 3388 return v 3389 end; 3390 3391put('cond, 'c!:code, function c!:ccond); 3392 3393symbolic procedure c!:cdeclare(u, env); 3394 error(0, "declare"); 3395 3396put('declare, 'c!:code, function c!:cdeclare); 3397 3398symbolic procedure c!:cde(u, env); 3399 error(0, "de"); 3400 3401put('de, 'c!:code, function c!:cde); 3402 3403symbolic procedure c!:cdefun(u, env); 3404 error(0, "defun"); 3405 3406put('!~defun, 'c!:code, function c!:cdefun); 3407 3408symbolic procedure c!:ceval_when(u, env); 3409 error(0, "eval-when"); 3410 3411put('eval!-when, 'c!:code, function c!:ceval_when); 3412 3413symbolic procedure c!:cflet(u, env); 3414 error(0, "flet"); 3415 3416put('flet, 'c!:code, function c!:cflet); 3417 3418 3419symbolic procedure c!:cfunction(u, env); 3420 begin 3421 scalar v; 3422 u := cadr u; 3423 if not atom u then error(0, "function/funarg needed"); 3424 v := c!:newreg(); 3425 c!:outop('movk, v, u, c!:find_literal u); 3426 return v 3427 end; 3428 3429put('function, 'c!:code, function c!:cfunction); 3430 3431symbolic procedure c!:cgo(u, env); 3432 begin 3433 scalar w, w1; 3434 w1 := proglabs; 3435 while null w and w1 do << 3436 w := assoc!*!*(cadr u, car w1); 3437 w1 := cdr w1 >>; 3438 if null w then error(0, list(u, "label not set")); 3439 c!:endblock('goto, list cadr w); 3440 return nil % value should not be used 3441 end; 3442 3443put('go, 'c!:code, function c!:cgo); 3444 3445symbolic procedure c!:cif(u, env); 3446 begin 3447 scalar v, join, l1, l2; 3448 v := c!:newreg(); 3449 join := c!:my_gensym(); 3450 l1 := c!:my_gensym(); 3451 l2 := c!:my_gensym(); 3452 c!:cjumpif(cadr u, env, l1, l2); 3453 c!:startblock l1; 3454 c!:outop('movr, v, nil, c!:cval(car (u := cddr u), env)); 3455 c!:endblock('goto, list join); 3456 c!:startblock l2; 3457 c!:outop('movr, v, nil, c!:cval(cadr u, env)); 3458 c!:endblock('goto, list join); 3459 c!:startblock join; 3460 return v 3461 end; 3462 3463put('if, 'c!:code, function c!:cif); 3464 3465symbolic procedure c!:clabels(u, env); 3466 error(0, "labels"); 3467 3468put('labels, 'c!:code, function c!:clabels); 3469 3470symbolic procedure c!:expand!-let(vl, b); 3471 if null vl then 'progn . b 3472 else if null cdr vl then c!:expand!-let!*(vl, b) 3473 else begin scalar vars, vals; 3474 for each v in vl do 3475 if atom v then << vars := v . vars; vals := nil . vals >> 3476 else if atom cdr v then << vars := car v . vars; vals := nil . vals >> 3477 else << vars := car v . vars; vals := cadr v . vals >>; 3478 return ('lambda . vars . b) . vals 3479 end; 3480 3481symbolic procedure c!:clet(x, env); 3482 c!:cval(c!:expand!-let(cadr x, cddr x), env); 3483 3484!#if common!-lisp!-mode 3485put('let, 'c!:code, function c!:clet); 3486!#else 3487put('!~let, 'c!:code, function c!:clet); 3488!#endif 3489 3490symbolic procedure c!:expand!-let!*(vl, b); 3491 if null vl then 'progn . b 3492 else begin scalar var, val; 3493 var := car vl; 3494 if not atom var then << 3495 val := cdr var; 3496 var := car var; 3497 if not atom val then val := car val >>; 3498 b := list list('return, c!:expand!-let!*(cdr vl, b)); 3499 if val then b := list('setq, var, val) . b; 3500 return 'prog . list var . b 3501 end; 3502 3503symbolic procedure c!:clet!*(x, env); 3504 c!:cval(c!:expand!-let!*(cadr x, cddr x), env); 3505 3506put('let!*, 'c!:code, function c!:clet!*); 3507 3508symbolic procedure c!:clist(u, env); 3509 if null cdr u then c!:cval(nil, env) 3510 else if null cddr u then c!:cval('ncons . cdr u, env) 3511 else if eqcar(cadr u, 'cons) then 3512 c!:cval(list('acons, cadr cadr u, caddr cadr u, 'list . cddr u), env) 3513 else if null cdddr u then c!:cval('list2 . cdr u, env) 3514 else c!:cval(list('list2!*, cadr u, caddr u, 'list . cdddr u), env); 3515 3516put('list, 'c!:code, function c!:clist); 3517 3518symbolic procedure c!:clist!*(u, env); 3519 begin 3520 scalar v; 3521 u := reverse cdr u; 3522 v := car u; 3523 for each a in cdr u do 3524 v := list('cons, a, v); 3525 return c!:cval(v, env) 3526 end; 3527 3528put('list!*, 'c!:code, function c!:clist!*); 3529 3530symbolic procedure c!:ccons(u, env); 3531 begin 3532 scalar a1, a2; 3533 a1 := s!:improve cadr u; 3534 a2 := s!:improve caddr u; 3535 if a2 = nil or a2 = '(quote nil) or a2 = '(list) then 3536 return c!:cval(list('ncons, a1), env); 3537 if eqcar(a1, 'cons) then 3538 return c!:cval(list('acons, cadr a1, caddr a1, a2), env); 3539 if eqcar(a2, 'cons) then 3540 return c!:cval(list('list2!*, a1, cadr a2, caddr a2), env); 3541 if eqcar(a2, 'list) then 3542 return c!:cval(list('cons, a1, 3543 list('cons, cadr a2, 'list . cddr a2)), env); 3544 return c!:ccall(car u, cdr u, env) 3545 end; 3546 3547put('cons, 'c!:code, function c!:ccons); 3548 3549symbolic procedure c!:cget(u, env); 3550 begin 3551 scalar a1, a2, w, r, r1; 3552 a1 := s!:improve cadr u; 3553 a2 := s!:improve caddr u; 3554 if eqcar(a2, 'quote) and idp(w := cadr a2) and 3555 (w := symbol!-make!-fastget(w, nil)) then << 3556 r := c!:newreg(); 3557 c!:outop('fastget, r, c!:cval(a1, env), w . cadr a2); 3558 return r >> 3559 else return c!:ccall(car u, cdr u, env) 3560 end; 3561 3562put('get, 'c!:code, function c!:cget); 3563 3564symbolic procedure c!:cflag(u, env); 3565 begin 3566 scalar a1, a2, w, r, r1; 3567 a1 := s!:improve cadr u; 3568 a2 := s!:improve caddr u; 3569 if eqcar(a2, 'quote) and idp(w := cadr a2) and 3570 (w := symbol!-make!-fastget(w, nil)) then << 3571 r := c!:newreg(); 3572 c!:outop('fastflag, r, c!:cval(a1, env), w . cadr a2); 3573 return r >> 3574 else return c!:ccall(car u, cdr u, env) 3575 end; 3576 3577put('flagp, 'c!:code, function c!:cflag); 3578 3579symbolic procedure c!:cgetv(u, env); 3580 if not !*fastvector then c!:ccall(car u, cdr u, env) 3581 else c!:cval('qgetv . cdr u, env); 3582 3583put('getv, 'c!:code, function c!:cgetv); 3584!#if common!-lisp!-mode 3585put('svref, 'c!:code, function c!:cgetv); 3586!#endif 3587 3588symbolic procedure c!:cputv(u, env); 3589 if not !*fastvector then c!:ccall(car u, cdr u, env) 3590 else c!:cval('qputv . cdr u, env); 3591 3592put('putv, 'c!:code, function c!:cputv); 3593 3594symbolic procedure c!:cqputv(x, env); 3595 begin 3596 scalar rr; 3597 rr := c!:pareval(cdr x, env); 3598 c!:outop('qputv, caddr rr, car rr, cadr rr); 3599 return caddr rr 3600 end; 3601 3602put('qputv, 'c!:code, function c!:cqputv); 3603 3604symbolic procedure c!:cmacrolet(u, env); 3605 error(0, "macrolet"); 3606 3607put('macrolet, 'c!:code, function c!:cmacrolet); 3608 3609symbolic procedure c!:cmultiple_value_call(u, env); 3610 error(0, "multiple_value_call"); 3611 3612put('multiple!-value!-call, 'c!:code, function c!:cmultiple_value_call); 3613 3614symbolic procedure c!:cmultiple_value_prog1(u, env); 3615 error(0, "multiple_value_prog1"); 3616 3617put('multiple!-value!-prog1, 'c!:code, function c!:cmultiple_value_prog1); 3618 3619symbolic procedure c!:cor(u, env); 3620 begin 3621 scalar next, done, v, r; 3622 v := c!:newreg(); 3623 done := c!:my_gensym(); 3624 u := cdr u; 3625 while cdr u do << 3626 next := c!:my_gensym(); 3627 c!:outop('movr, v, nil, c!:cval(car u, env)); 3628 u := cdr u; 3629 c!:endblock(list('ifnull, v), list(next, done)); 3630 c!:startblock next >>; 3631 c!:outop('movr, v, nil, c!:cval(car u, env)); 3632 c!:endblock('goto, list done); 3633 c!:startblock done; 3634 return v 3635 end; 3636 3637put('or, 'c!:code, function c!:cor); 3638 3639symbolic procedure c!:cprog(u, env); 3640 begin 3641 scalar w, w1, bvl, local_proglabs, progret, progexit, fluids, env1; 3642 env1 := car env; 3643 bvl := cadr u; 3644 for each v in bvl do 3645 if globalp v then error(0, list(v, "attempt to bind a global")) 3646 else if fluidp v then << 3647 fluids := (v . c!:newreg()) . fluids; 3648 flag(list cdar fluids, 'c!:live_across_call); % silly if not 3649 env1 := ('c!:dummy!:name . cdar fluids) . env1; 3650 c!:outop('ldrglob, cdar fluids, v, c!:find_literal v); 3651 c!:outop('nilglob, nil, v, c!:find_literal v) >> 3652 else << 3653 env1 := (v . c!:newreg()) . env1; 3654 c!:outop('movk1, cdar env1, nil, nil) >>; 3655 if fluids then c!:outop('fluidbind, nil, nil, fluids); 3656 env := env1 . append(fluids, cdr env); 3657 u := cddr u; 3658 progret := c!:newreg(); 3659 progexit := c!:my_gensym(); 3660 blockstack := (nil . progret . progexit) . blockstack; 3661 for each a in u do if atom a then 3662 if atsoc(a, local_proglabs) then << 3663 if not null a then << 3664 w := wrs nil; 3665 princ "+++++ multiply defined label: "; prin a; 3666 terpri(); wrs w >> >> 3667 else local_proglabs := list(a, c!:my_gensym()) . local_proglabs; 3668 proglabs := local_proglabs . proglabs; 3669 for each a in u do 3670 if atom a then << 3671 w := cdr(assoc!*!*(a, local_proglabs)); 3672 if null cdr w then << 3673 rplacd(w, t); 3674 c!:endblock('goto, list car w); 3675 c!:startblock car w >> >> 3676 else c!:cval(a, env); 3677 c!:outop('movk1, progret, nil, nil); 3678 c!:endblock('goto, list progexit); 3679 c!:startblock progexit; 3680 for each v in fluids do 3681 c!:outop('strglob, cdr v, car v, c!:find_literal car v); 3682 blockstack := cdr blockstack; 3683 proglabs := cdr proglabs; 3684 return progret 3685 end; 3686 3687put('prog, 'c!:code, function c!:cprog); 3688 3689symbolic procedure c!:cprog!*(u, env); 3690 error(0, "prog*"); 3691 3692put('prog!*, 'c!:code, function c!:cprog!*); 3693 3694symbolic procedure c!:cprog1(u, env); 3695 begin 3696 scalar g; 3697 g := c!:my_gensym(); 3698 g := list('prog, list g, 3699 list('setq, g, cadr u), 3700 'progn . cddr u, 3701 list('return, g)); 3702 return c!:cval(g, env) 3703 end; 3704 3705put('prog1, 'c!:code, function c!:cprog1); 3706 3707symbolic procedure c!:cprog2(u, env); 3708 begin 3709 scalar g; 3710 u := cdr u; 3711 g := c!:my_gensym(); 3712 g := list('prog, list g, 3713 list('setq, g, cadr u), 3714 'progn . cddr u, 3715 list('return, g)); 3716 g := list('progn, car u, g); 3717 return c!:cval(g, env) 3718 end; 3719 3720put('prog2, 'c!:code, function c!:cprog2); 3721 3722symbolic procedure c!:cprogn(u, env); 3723 begin 3724 scalar r; 3725 u := cdr u; 3726 if u = nil then u := '(nil); 3727 for each s in u do r := c!:cval(s, env); 3728 return r 3729 end; 3730 3731put('progn, 'c!:code, function c!:cprogn); 3732 3733symbolic procedure c!:cprogv(u, env); 3734 error(0, "progv"); 3735 3736put('progv, 'c!:code, function c!:cprogv); 3737 3738symbolic procedure c!:cquote(u, env); 3739 begin 3740 scalar v; 3741 u := cadr u; 3742 v := c!:newreg(); 3743 if null u or u = 't or c!:small_number u then 3744 c!:outop('movk1, v, nil, u) 3745 else c!:outop('movk, v, u, c!:find_literal u); 3746 return v; 3747 end; 3748 3749put('quote, 'c!:code, function c!:cquote); 3750 3751symbolic procedure c!:creturn(u, env); 3752 begin 3753 scalar w; 3754 w := assoc!*!*(nil, blockstack); 3755 if null w then error(0, "RETURN out of context"); 3756 c!:outop('movr, cadr w, nil, c!:cval(cadr u, env)); 3757 c!:endblock('goto, list cddr w); 3758 return nil % value should not be used 3759 end; 3760 3761put('return, 'c!:code, function c!:creturn); 3762 3763!#if common!-lisp!-mode 3764 3765symbolic procedure c!:creturn_from(u, env); 3766 begin 3767 scalar w; 3768 w := assoc!*!*(cadr u, blockstack); 3769 if null w then error(0, "RETURN-FROM out of context"); 3770 c!:outop('movr, cadr w, nil, c!:cval(caddr u, env)); 3771 c!:endblock('goto, list cddr w); 3772 return nil % value should not be used 3773 end; 3774 3775!#endif 3776 3777put('return!-from, 'c!:code, function c!:creturn_from); 3778 3779symbolic procedure c!:csetq(u, env); 3780 begin 3781 scalar v, w; 3782 v := c!:cval(caddr u, env); 3783 u := cadr u; 3784 if not idp u then error(0, list(u, "bad variable in setq")) 3785 else if (w := c!:locally_bound(u, env)) then 3786 c!:outop('movr, cdr w, nil, v) 3787 else if flagp(u, 'c!:constant) then 3788 error(0, list(u, "attempt to use setq on a constant")) 3789 else c!:outop('strglob, v, u, c!:find_literal u); 3790 return v 3791 end; 3792 3793put('setq, 'c!:code, function c!:csetq); 3794put('noisy!-setq, 'c!:code, function c!:csetq); 3795 3796!#if common!-lisp!-mode 3797 3798symbolic procedure c!:ctagbody(u, env); 3799 begin 3800 scalar w, bvl, local_proglabs, res; 3801 u := cdr u; 3802 for each a in u do if atom a then 3803 if atsoc(a, local_proglabs) then << 3804 if not null a then << 3805 w := wrs nil; 3806 princ "+++++ multiply defined label: "; prin a; 3807 terpri(); wrs w >> >> 3808 else local_proglabs := list(a, c!:my_gensym()) . local_proglabs; 3809 proglabs := local_proglabs . proglabs; 3810 for each a in u do 3811 if atom a then << 3812 w := cdr(assoc!*!*(a, local_proglabs)); 3813 if null cdr w then << 3814 rplacd(w, t); 3815 c!:endblock('goto, list car w); 3816 c!:startblock car w >> >> 3817 else res := c!:cval(a, env); 3818 if null res then res := c!:cval(nil, env); 3819 proglabs := cdr proglabs; 3820 return res 3821 end; 3822 3823put('tagbody, 'c!:code, function c!:ctagbody); 3824 3825!#endif 3826 3827symbolic procedure c!:cprivate_tagbody(u, env); 3828% This sets a label for use for tail-call to self. 3829 begin 3830 u := cdr u; 3831 c!:endblock('goto, list car u); 3832 c!:startblock car u; 3833% This seems to be the proper place to capture the internal names associated 3834% with argument-vars that must be reset if a tail-call is mapped into a loop. 3835 current_args := for each v in current_args collect begin 3836 scalar z; 3837 z := assoc!*!*(v, car env); 3838 return if z then cdr z else v end; 3839 return c!:cval(cadr u, env) 3840 end; 3841 3842put('c!:private_tagbody, 'c!:code, function c!:cprivate_tagbody); 3843 3844symbolic procedure c!:cthe(u, env); 3845 c!:cval(caddr u, env); 3846 3847put('the, 'c!:code, function c!:cthe); 3848 3849symbolic procedure c!:cthrow(u, env); 3850 error(0, "throw"); 3851 3852put('throw, 'c!:code, function c!:cthrow); 3853 3854symbolic procedure c!:cunless(u, env); 3855 begin 3856 scalar v, join, l1, l2; 3857 v := c!:newreg(); 3858 join := c!:my_gensym(); 3859 l1 := c!:my_gensym(); 3860 l2 := c!:my_gensym(); 3861 c!:cjumpif(cadr u, env, l2, l1); 3862 c!:startblock l1; 3863 c!:outop('movr, v, nil, c!:cval('progn . cddr u, env)); 3864 c!:endblock('goto, list join); 3865 c!:startblock l2; 3866 c!:outop('movk1, v, nil, nil); 3867 c!:endblock('goto, list join); 3868 c!:startblock join; 3869 return v 3870 end; 3871 3872put('unless, 'c!:code, function c!:cunless); 3873 3874symbolic procedure c!:cunwind_protect(u, env); 3875 error(0, "unwind_protect"); 3876 3877put('unwind!-protect, 'c!:code, function c!:cunwind_protect); 3878 3879symbolic procedure c!:cwhen(u, env); 3880 begin 3881 scalar v, join, l1, l2; 3882 v := c!:newreg(); 3883 join := c!:my_gensym(); 3884 l1 := c!:my_gensym(); 3885 l2 := c!:my_gensym(); 3886 c!:cjumpif(cadr u, env, l1, l2); 3887 c!:startblock l1; 3888 c!:outop('movr, v, nil, c!:cval('progn . cddr u, env)); 3889 c!:endblock('goto, list join); 3890 c!:startblock l2; 3891 c!:outop('movk1, v, nil, nil); 3892 c!:endblock('goto, list join); 3893 c!:startblock join; 3894 return v 3895 end; 3896 3897put('when, 'c!:code, function c!:cwhen); 3898 3899% 3900% End of code to handle special forms - what comes from here on is 3901% more concerned with performance than with speed. 3902% 3903 3904!#if (not common!-lisp!-mode) 3905 3906% mapcar etc are compiled specially as a fudge to achieve an effect as 3907% if proper environment-capture was implemented for the functional 3908% argument (which I do not support at present). 3909 3910symbolic procedure c!:expand_map(fnargs); 3911 begin 3912 scalar carp, fn, fn1, args, var, avar, moveon, l1, r, s, closed; 3913 fn := car fnargs; 3914% if the value of a mapping function is not needed I demote from mapcar to 3915% mapc or from maplist to map. 3916% if context > 1 then << 3917% if fn = 'mapcar then fn := 'mapc 3918% else if fn = 'maplist then fn := 'map >>; 3919 if fn = 'mapc or fn = 'mapcar or fn = 'mapcan then carp := t; 3920 fnargs := cdr fnargs; 3921 if atom fnargs then error(0,"bad arguments to map function"); 3922 fn1 := cadr fnargs; 3923 while eqcar(fn1, 'function) or 3924 (eqcar(fn1, 'quote) and eqcar(cadr fn1, 'lambda)) do << 3925 fn1 := cadr fn1; 3926 closed := t >>; 3927% if closed is false I will insert FUNCALL since I am invoking a function 3928% stored in a variable - NB this means that the word FUNCTION becomes 3929% essential when using mapping operators - this is because I have built 3930% a 2-Lisp rather than a 1-Lisp. 3931 args := car fnargs; 3932 l1 := c!:my_gensym(); 3933 r := c!:my_gensym(); 3934 s := c!:my_gensym(); 3935 var := c!:my_gensym(); 3936 avar := var; 3937 if carp then avar := list('car, avar); 3938 if closed then fn1 := list(fn1, avar) 3939 else fn1 := list('apply1, fn1, avar); 3940 moveon := list('setq, var, list('cdr, var)); 3941 if fn = 'map or fn = 'mapc then fn := sublis( 3942 list('l1 . l1, 'var . var, 3943 'fn . fn1, 'args . args, 'moveon . moveon), 3944 '(prog (var) 3945 (setq var args) 3946 l1 (cond 3947 ((not var) (return nil))) 3948 fn 3949 moveon 3950 (go l1))) 3951 else if fn = 'maplist or fn = 'mapcar then fn := sublis( 3952 list('l1 . l1, 'var . var, 3953 'fn . fn1, 'args . args, 'moveon . moveon, 'r . r), 3954 '(prog (var r) 3955 (setq var args) 3956 l1 (cond 3957 ((not var) (return (reversip r)))) 3958 (setq r (cons fn r)) 3959 moveon 3960 (go l1))) 3961 else fn := sublis( 3962 list('l1 . l1, 'l2 . c!:my_gensym(), 'var . var, 3963 'fn . fn1, 'args . args, 'moveon . moveon, 3964 'r . c!:my_gensym(), 's . c!:my_gensym()), 3965 '(prog (var r s) 3966 (setq var args) 3967 (setq r (setq s (list nil))) 3968 l1 (cond 3969 ((not var) (return (cdr r)))) 3970 (rplacd s fn) 3971 l2 (cond 3972 ((not (atom (cdr s))) (setq s (cdr s)) (go l2))) 3973 moveon 3974 (go l1))); 3975 return fn 3976 end; 3977 3978 3979put('map, 'c!:compile_macro, function c!:expand_map); 3980put('maplist, 'c!:compile_macro, function c!:expand_map); 3981put('mapc, 'c!:compile_macro, function c!:expand_map); 3982put('mapcar, 'c!:compile_macro, function c!:expand_map); 3983put('mapcon, 'c!:compile_macro, function c!:expand_map); 3984put('mapcan, 'c!:compile_macro, function c!:expand_map); 3985 3986!#endif 3987 3988% caaar to cddddr get expanded into compositions of 3989% car, cdr which are compiled in-line 3990 3991symbolic procedure c!:expand_carcdr(x); 3992 begin 3993 scalar name; 3994 name := cdr reverse cdr explode2 car x; 3995 x := cadr x; 3996 for each v in name do 3997 x := list(if v = 'a then 'car else 'cdr, x); 3998 return x 3999 end; 4000 4001<< put('caar, 'c!:compile_macro, function c!:expand_carcdr); 4002 put('cadr, 'c!:compile_macro, function c!:expand_carcdr); 4003 put('cdar, 'c!:compile_macro, function c!:expand_carcdr); 4004 put('cddr, 'c!:compile_macro, function c!:expand_carcdr); 4005 put('caaar, 'c!:compile_macro, function c!:expand_carcdr); 4006 put('caadr, 'c!:compile_macro, function c!:expand_carcdr); 4007 put('cadar, 'c!:compile_macro, function c!:expand_carcdr); 4008 put('caddr, 'c!:compile_macro, function c!:expand_carcdr); 4009 put('cdaar, 'c!:compile_macro, function c!:expand_carcdr); 4010 put('cdadr, 'c!:compile_macro, function c!:expand_carcdr); 4011 put('cddar, 'c!:compile_macro, function c!:expand_carcdr); 4012 put('cdddr, 'c!:compile_macro, function c!:expand_carcdr); 4013 put('caaaar, 'c!:compile_macro, function c!:expand_carcdr); 4014 put('caaadr, 'c!:compile_macro, function c!:expand_carcdr); 4015 put('caadar, 'c!:compile_macro, function c!:expand_carcdr); 4016 put('caaddr, 'c!:compile_macro, function c!:expand_carcdr); 4017 put('cadaar, 'c!:compile_macro, function c!:expand_carcdr); 4018 put('cadadr, 'c!:compile_macro, function c!:expand_carcdr); 4019 put('caddar, 'c!:compile_macro, function c!:expand_carcdr); 4020 put('cadddr, 'c!:compile_macro, function c!:expand_carcdr); 4021 put('cdaaar, 'c!:compile_macro, function c!:expand_carcdr); 4022 put('cdaadr, 'c!:compile_macro, function c!:expand_carcdr); 4023 put('cdadar, 'c!:compile_macro, function c!:expand_carcdr); 4024 put('cdaddr, 'c!:compile_macro, function c!:expand_carcdr); 4025 put('cddaar, 'c!:compile_macro, function c!:expand_carcdr); 4026 put('cddadr, 'c!:compile_macro, function c!:expand_carcdr); 4027 put('cdddar, 'c!:compile_macro, function c!:expand_carcdr); 4028 put('cddddr, 'c!:compile_macro, function c!:expand_carcdr) >>; 4029 4030symbolic procedure c!:builtin_one(x, env); 4031 begin 4032 scalar r1, r2; 4033 r1 := c!:cval(cadr x, env); 4034 c!:outop(car x, r2:=c!:newreg(), cdr env, r1); 4035 return r2 4036 end; 4037 4038symbolic procedure c!:builtin_two(x, env); 4039 begin 4040 scalar a1, a2, r, rr; 4041 a1 := cadr x; 4042 a2 := caddr x; 4043 rr := c!:pareval(list(a1, a2), env); 4044 c!:outop(car x, r:=c!:newreg(), car rr, cadr rr); 4045 return r 4046 end; 4047 4048symbolic procedure c!:narg(x, env); 4049 c!:cval(expand(cdr x, get(car x, 'c!:binary_version)), env); 4050 4051for each n in 4052 '((plus plus2) 4053 (times times2) 4054 (iplus iplus2) 4055 (itimes itimes2)) do << 4056 put(car n, 'c!:binary_version, cadr n); 4057 put(car n, 'c!:code, function c!:narg) >>; 4058 4059!#if common!-lisp!-mode 4060for each n in 4061 '((!+ plus2) 4062 (!* times2)) do << 4063 put(car n, 'c!:binary_version, cadr n); 4064 put(car n, 'c!:code, function c!:narg) >>; 4065!#endif 4066 4067symbolic procedure c!:cplus2(u, env); 4068 begin 4069 scalar a, b; 4070 a := s!:improve cadr u; 4071 b := s!:improve caddr u; 4072 return if numberp a and numberp b then c!:cval(a+b, env) 4073 else if a = 0 then c!:cval(b, env) 4074 else if a = 1 then c!:cval(list('add1, b), env) 4075 else if b = 0 then c!:cval(a, env) 4076 else if b = 1 then c!:cval(list('add1, a), env) 4077 else if b = -1 then c!:cval(list('sub1, a), env) 4078 else c!:ccall(car u, cdr u, env) 4079 end; 4080 4081put('plus2, 'c!:code, function c!:cplus2); 4082 4083symbolic procedure c!:ciplus2(u, env); 4084 begin 4085 scalar a, b; 4086 a := s!:improve cadr u; 4087 b := s!:improve caddr u; 4088 return if numberp a and numberp b then c!:cval(a+b, env) 4089 else if a = 0 then c!:cval(b, env) 4090 else if a = 1 then c!:cval(list('iadd1, b), env) 4091 else if b = 0 then c!:cval(a, env) 4092 else if b = 1 then c!:cval(list('iadd1, a), env) 4093 else if b = -1 then c!:cval(list('isub1, a), env) 4094 else c!:builtin_two(u, env) 4095 end; 4096 4097put('iplus2, 'c!:code, function c!:ciplus2); 4098 4099symbolic procedure c!:cdifference(u, env); 4100 begin 4101 scalar a, b; 4102 a := s!:improve cadr u; 4103 b := s!:improve caddr u; 4104 return if numberp a and numberp b then c!:cval(a-b, env) 4105 else if a = 0 then c!:cval(list('minus, b), env) 4106 else if b = 0 then c!:cval(a, env) 4107 else if b = 1 then c!:cval(list('sub1, a), env) 4108 else if b = -1 then c!:cval(list('add1, a), env) 4109 else c!:ccall(car u, cdr u, env) 4110 end; 4111 4112put('difference, 'c!:code, function c!:cdifference); 4113 4114symbolic procedure c!:cidifference(u, env); 4115 begin 4116 scalar a, b; 4117 a := s!:improve cadr u; 4118 b := s!:improve caddr u; 4119 return if numberp a and numberp b then c!:cval(a-b, env) 4120 else if a = 0 then c!:cval(list('iminus, b), env) 4121 else if b = 0 then c!:cval(a, env) 4122 else if b = 1 then c!:cval(list('isub1, a), env) 4123 else if b = -1 then c!:cval(list('iadd1, a), env) 4124 else c!:builtin_two(u, env) 4125 end; 4126 4127put('idifference, 'c!:code, function c!:cidifference); 4128 4129symbolic procedure c!:ctimes2(u, env); 4130 begin 4131 scalar a, b; 4132 a := s!:improve cadr u; 4133 b := s!:improve caddr u; 4134 return if numberp a and numberp b then c!:cval(a*b, env) 4135 else if a = 0 or b = 0 then c!:cval(0, env) 4136 else if a = 1 then c!:cval(b, env) 4137 else if b = 1 then c!:cval(a, env) 4138 else if a = -1 then c!:cval(list('minus, b), env) 4139 else if b = -1 then c!:cval(list('minus, a), env) 4140 else c!:ccall(car u, cdr u, env) 4141 end; 4142 4143put('times2, 'c!:code, function c!:ctimes2); 4144 4145symbolic procedure c!:citimes2(u, env); 4146 begin 4147 scalar a, b; 4148 a := s!:improve cadr u; 4149 b := s!:improve caddr u; 4150 return if numberp a and numberp b then c!:cval(a*b, env) 4151 else if a = 0 or b = 0 then c!:cval(0, env) 4152 else if a = 1 then c!:cval(b, env) 4153 else if b = 1 then c!:cval(a, env) 4154 else if a = -1 then c!:cval(list('iminus, b), env) 4155 else if b = -1 then c!:cval(list('iminus, a), env) 4156 else c!:builtin_two(u, env) 4157 end; 4158 4159put('itimes2, 'c!:code, function c!:citimes2); 4160 4161symbolic procedure c!:cminus(u, env); 4162 begin 4163 scalar a, b; 4164 a := s!:improve cadr u; 4165 return if numberp a then c!:cval(-a, env) 4166 else if eqcar(a, 'minus) then c!:cval(cadr a, env) 4167 else c!:ccall(car u, cdr u, env) 4168 end; 4169 4170put('minus, 'c!:code, function c!:cminus); 4171 4172symbolic procedure c!:ceq(x, env); 4173 begin 4174 scalar a1, a2, r, rr; 4175 a1 := s!:improve cadr x; 4176 a2 := s!:improve caddr x; 4177 if a1 = nil then return c!:cval(list('null, a2), env) 4178 else if a2 = nil then return c!:cval(list('null, a1), env); 4179 rr := c!:pareval(list(a1, a2), env); 4180 c!:outop('eq, r:=c!:newreg(), car rr, cadr rr); 4181 return r 4182 end; 4183 4184put('eq, 'c!:code, function c!:ceq); 4185 4186symbolic procedure c!:cequal(x, env); 4187 begin 4188 scalar a1, a2, r, rr; 4189 a1 := s!:improve cadr x; 4190 a2 := s!:improve caddr x; 4191 if a1 = nil then return c!:cval(list('null, a2), env) 4192 else if a2 = nil then return c!:cval(list('null, a1), env); 4193 rr := c!:pareval(list(a1, a2), env); 4194 c!:outop((if c!:eqvalid a1 or c!:eqvalid a2 then 'eq else 'equal), 4195 r:=c!:newreg(), car rr, cadr rr); 4196 return r 4197 end; 4198 4199put('equal, 'c!:code, function c!:cequal); 4200 4201 4202% 4203% The next few cases are concerned with demoting functions that use 4204% equal tests into ones that use eq instead 4205 4206symbolic procedure c!:is_fixnum x; 4207 fixp x and x >= -134217728 and x <= 134217727; 4208 4209symbolic procedure c!:certainlyatom x; 4210 null x or x=t or c!:is_fixnum x or 4211 (eqcar(x, 'quote) and (symbolp cadr x or c!:is_fixnum cadr x)); 4212 4213symbolic procedure c!:atomlist1 u; 4214 atom u or 4215 ((symbolp car u or c!:is_fixnum car u) and c!:atomlist1 cdr u); 4216 4217symbolic procedure c!:atomlist x; 4218 null x or 4219 (eqcar(x, 'quote) and c!:atomlist1 cadr x) or 4220 (eqcar(x, 'list) and 4221 (null cdr x or 4222 (c!:certainlyatom cadr x and 4223 c!:atomlist ('list . cddr x)))) or 4224 (eqcar(x, 'cons) and 4225 c!:certainlyatom cadr x and 4226 c!:atomlist caddr x); 4227 4228symbolic procedure c!:atomcar x; 4229 (eqcar(x, 'cons) or eqcar(x, 'list)) and 4230 not null cdr x and 4231 c!:certainlyatom cadr x; 4232 4233symbolic procedure c!:atomkeys1 u; 4234 atom u or 4235 (not atom car u and 4236 (symbolp caar u or c!:is_fixnum caar u) and 4237 c!:atomlist1 cdr u); 4238 4239symbolic procedure c!:atomkeys x; 4240 null x or 4241 (eqcar(x, 'quote) and c!:atomkeys1 cadr x) or 4242 (eqcar(x, 'list) and 4243 (null cdr x or 4244 (c!:atomcar cadr x and 4245 c!:atomkeys ('list . cddr x)))) or 4246 (eqcar(x, 'cons) and 4247 c!:atomcar cadr x and 4248 c!:atomkeys caddr x); 4249 4250!#if (not common!-lisp!-mode) 4251 4252symbolic procedure c!:comsublis x; 4253 if c!:atomkeys cadr x then 'subla . cdr x 4254 else nil; 4255 4256put('sublis, 'c!:compile_macro, function c!:comsublis); 4257 4258symbolic procedure c!:comassoc x; 4259 if c!:certainlyatom cadr x or c!:atomkeys caddr x then 'atsoc . cdr x 4260 else nil; 4261 4262put('assoc, 'c!:compile_macro, function c!:comassoc); 4263put('assoc!*!*, 'c!:compile_macro, function c!:comassoc); 4264 4265symbolic procedure c!:commember x; 4266 if c!:certainlyatom cadr x or c!:atomlist caddr x then 'memq . cdr x 4267 else nil; 4268 4269put('member, 'c!:compile_macro, function c!:commember); 4270 4271symbolic procedure c!:comdelete x; 4272 if c!:certainlyatom cadr x or c!:atomlist caddr x then 'deleq . cdr x 4273 else nil; 4274 4275put('delete, 'c!:compile_macro, function c!:comdelete); 4276 4277!#endif 4278 4279symbolic procedure c!:ctestif(x, env, d1, d2); 4280 begin 4281 scalar l1, l2; 4282 l1 := c!:my_gensym(); 4283 l2 := c!:my_gensym(); 4284 c!:jumpif(cadr x, l1, l2); 4285 x := cddr x; 4286 c!:startblock l1; 4287 c!:jumpif(car x, d1, d2); 4288 c!:startblock l2; 4289 c!:jumpif(cadr x, d1, d2) 4290 end; 4291 4292put('if, 'c!:ctest, function c!:ctestif); 4293 4294symbolic procedure c!:ctestnull(x, env, d1, d2); 4295 c!:cjumpif(cadr x, env, d2, d1); 4296 4297put('null, 'c!:ctest, function c!:ctestnull); 4298put('not, 'c!:ctest, function c!:ctestnull); 4299 4300symbolic procedure c!:ctestatom(x, env, d1, d2); 4301 begin 4302 x := c!:cval(cadr x, env); 4303 c!:endblock(list('ifatom, x), list(d1, d2)) 4304 end; 4305 4306put('atom, 'c!:ctest, function c!:ctestatom); 4307 4308symbolic procedure c!:ctestconsp(x, env, d1, d2); 4309 begin 4310 x := c!:cval(cadr x, env); 4311 c!:endblock(list('ifatom, x), list(d2, d1)) 4312 end; 4313 4314put('consp, 'c!:ctest, function c!:ctestconsp); 4315 4316symbolic procedure c!:ctestsymbol(x, env, d1, d2); 4317 begin 4318 x := c!:cval(cadr x, env); 4319 c!:endblock(list('ifsymbol, x), list(d1, d2)) 4320 end; 4321 4322put('idp, 'c!:ctest, function c!:ctestsymbol); 4323 4324symbolic procedure c!:ctestnumberp(x, env, d1, d2); 4325 begin 4326 x := c!:cval(cadr x, env); 4327 c!:endblock(list('ifnumber, x), list(d1, d2)) 4328 end; 4329 4330put('numberp, 'c!:ctest, function c!:ctestnumberp); 4331 4332symbolic procedure c!:ctestizerop(x, env, d1, d2); 4333 begin 4334 x := c!:cval(cadr x, env); 4335 c!:endblock(list('ifizerop, x), list(d1, d2)) 4336 end; 4337 4338put('izerop, 'c!:ctest, function c!:ctestizerop); 4339 4340symbolic procedure c!:ctesteq(x, env, d1, d2); 4341 begin 4342 scalar a1, a2, r; 4343 a1 := cadr x; 4344 a2 := caddr x; 4345 if a1 = nil then return c!:cjumpif(a2, env, d2, d1) 4346 else if a2 = nil then return c!:cjumpif(a1, env, d2, d1); 4347 r := c!:pareval(list(a1, a2), env); 4348 c!:endblock('ifeq . r, list(d1, d2)) 4349 end; 4350 4351put('eq, 'c!:ctest, function c!:ctesteq); 4352 4353symbolic procedure c!:ctesteqcar(x, env, d1, d2); 4354 begin 4355 scalar a1, a2, r, d3; 4356 a1 := cadr x; 4357 a2 := caddr x; 4358 d3 := c!:my_gensym(); 4359 r := c!:pareval(list(a1, a2), env); 4360 c!:endblock(list('ifatom, car r), list(d2, d3)); 4361 c!:startblock d3; 4362 c!:outop('qcar, car r, nil, car r); 4363 c!:endblock('ifeq . r, list(d1, d2)) 4364 end; 4365 4366put('eqcar, 'c!:ctest, function c!:ctesteqcar); 4367 4368global '(least_fixnum greatest_fixnum); 4369 4370least_fixnum := -expt(2, 27); 4371greatest_fixnum := expt(2, 27) - 1; 4372 4373symbolic procedure c!:small_number x; 4374 fixp x and x >= least_fixnum and x <= greatest_fixnum; 4375 4376symbolic procedure c!:eqvalid x; 4377 if atom x then c!:small_number x 4378 else if flagp(car x, 'c!:fixnum_fn) then t 4379 else car x = 'quote and (idp cadr x or c!:small_number cadr x); 4380 4381flag('(iplus iplus2 idifference iminus itimes itimes2), 'c!:fixnum_fn); 4382 4383symbolic procedure c!:ctestequal(x, env, d1, d2); 4384 begin 4385 scalar a1, a2, r; 4386 a1 := s!:improve cadr x; 4387 a2 := s!:improve caddr x; 4388 if a1 = nil then return c!:cjumpif(a2, env, d2, d1) 4389 else if a2 = nil then return c!:cjumpif(a1, env, d2, d1); 4390 r := c!:pareval(list(a1, a2), env); 4391 c!:endblock((if c!:eqvalid a1 or c!:eqvalid a2 then 'ifeq else 'ifequal) . 4392 r, list(d1, d2)) 4393 end; 4394 4395put('equal, 'c!:ctest, function c!:ctestequal); 4396 4397symbolic procedure c!:ctestilessp(x, env, d1, d2); 4398 begin 4399 scalar r; 4400 r := c!:pareval(list(cadr x, caddr x), env); 4401 c!:endblock('ifilessp . r, list(d1, d2)) 4402 end; 4403 4404put('ilessp, 'c!:ctest, function c!:ctestilessp); 4405 4406symbolic procedure c!:ctestigreaterp(x, env, d1, d2); 4407 begin 4408 scalar r; 4409 r := c!:pareval(list(cadr x, caddr x), env); 4410 c!:endblock('ifigreaterp . r, list(d1, d2)) 4411 end; 4412 4413put('igreaterp, 'c!:ctest, function c!:ctestigreaterp); 4414 4415symbolic procedure c!:ctestand(x, env, d1, d2); 4416 begin 4417 scalar next; 4418 for each a in cdr x do << 4419 next := c!:my_gensym(); 4420 c!:cjumpif(a, env, next, d2); 4421 c!:startblock next >>; 4422 c!:endblock('goto, list d1) 4423 end; 4424 4425put('and, 'c!:ctest, function c!:ctestand); 4426 4427symbolic procedure c!:ctestor(x, env, d1, d2); 4428 begin 4429 scalar next; 4430 for each a in cdr x do << 4431 next := c!:my_gensym(); 4432 c!:cjumpif(a, env, d1, next); 4433 c!:startblock next >>; 4434 c!:endblock('goto, list d2) 4435 end; 4436 4437put('or, 'c!:ctest, function c!:ctestor); 4438 4439% Here are some of the things that are built into the Lisp kernel 4440% and that I am happy to allow the compiler to generate direct calls to. 4441 4442<< 4443 4444% 4445% In these tables there are some functions that would need adjusting 4446% for a Common Lisp compiler, since they take different numbers of 4447% args in Common and Standard Lisp. 4448% This means, to be specific: 4449% 4450% Lgensym Lread Latan Ltruncate Lfloat 4451% Lintern Lmacroexpand Lmacroexpand_1 4452% Lrandom Lunintern Lappend Leqn Lgcd 4453% Lgeq Lgreaterp Llcm Lleq Llessp 4454% Lquotient 4455% 4456% In these cases (at least!) the Common Lisp version of the compiler will 4457% need to avoid generating the call that uses this table. 4458% 4459% Some functions are missing from the list here because they seemed 4460% critical enough to be awarded single-byte opcodes or because the 4461% compiler always expands them away - car through cddddr are the main 4462% cases, together with eq and equal. 4463% 4464 4465 put('batchp, 'zero_arg_fn, 0); 4466 put('date, 'zero_arg_fn, 1); 4467 put('eject, 'zero_arg_fn, 2); 4468 put('error0, 'zero_arg_fn, 3); 4469 put('gctime, 'zero_arg_fn, 4); 4470 put('gensym, 'zero_arg_fn, 5); 4471 put('lposn, 'zero_arg_fn, 6); 4472 put('next!-random, 'zero_arg_fn, 7); 4473 put('posn, 'zero_arg_fn, 8); 4474 put('read, 'zero_arg_fn, 9); 4475 put('readch, 'zero_arg_fn, 10); 4476 put('terpri, 'zero_arg_fn, 11); 4477 put('time, 'zero_arg_fn, 12); 4478 put('tyi, 'zero_arg_fn, 13); 4479 put('load!-spid, 'zero_arg_fn, 14); % ONLY used in compiled code 4480 4481 put('absval, 'one_arg_fn, 0); 4482 put('add1, 'one_arg_fn, 1); 4483 put('atan, 'one_arg_fn, 2); 4484 put('apply0, 'one_arg_fn, 3); 4485 put('atom, 'one_arg_fn, 4); 4486 put('boundp, 'one_arg_fn, 5); 4487 put('char!-code, 'one_arg_fn, 6); 4488 put('close, 'one_arg_fn, 7); 4489 put('codep, 'one_arg_fn, 8); 4490 put('compress, 'one_arg_fn, 9); 4491 put('constantp, 'one_arg_fn, 10); 4492 put('digitp, 'one_arg_fn, 11); 4493 put('endp, 'one_arg_fn, 12); 4494 put('eval, 'one_arg_fn, 13); 4495 put('evenp, 'one_arg_fn, 14); 4496 put('evlis, 'one_arg_fn, 15); 4497 put('explode, 'one_arg_fn, 16); 4498 put('explode2lc, 'one_arg_fn, 17); 4499 put('explodec, 'one_arg_fn, 18); 4500 put('fixp, 'one_arg_fn, 19); 4501 put('float, 'one_arg_fn, 20); 4502 put('floatp, 'one_arg_fn, 21); 4503 put('symbol!-specialp, 'one_arg_fn, 22); 4504 put('gc, 'one_arg_fn, 23); 4505 put('gensym1, 'one_arg_fn, 24); 4506 put('getenv, 'one_arg_fn, 25); 4507 put('symbol!-globalp, 'one_arg_fn, 26); 4508 put('iadd1, 'one_arg_fn, 27); 4509 put('symbolp, 'one_arg_fn, 28); 4510 put('iminus, 'one_arg_fn, 29); 4511 put('iminusp, 'one_arg_fn, 30); 4512 put('indirect, 'one_arg_fn, 31); 4513 put('integerp, 'one_arg_fn, 32); 4514 put('intern, 'one_arg_fn, 33); 4515 put('isub1, 'one_arg_fn, 34); 4516 put('length, 'one_arg_fn, 35); 4517 put('lengthc, 'one_arg_fn, 36); 4518 put('linelength, 'one_arg_fn, 37); 4519 put('alpha!-char!-p, 'one_arg_fn, 38); 4520 put('load!-module, 'one_arg_fn, 39); 4521 put('lognot, 'one_arg_fn, 40); 4522 put('macroexpand, 'one_arg_fn, 41); 4523 put('macroexpand!-1, 'one_arg_fn, 42); 4524 put('macro!-function, 'one_arg_fn, 43); 4525 put('get!-bps, 'one_arg_fn, 44); 4526 put('make!-global, 'one_arg_fn, 45); 4527 put('smkvect, 'one_arg_fn, 46); 4528 put('make!-special, 'one_arg_fn, 47); 4529 put('minus, 'one_arg_fn, 48); 4530 put('minusp, 'one_arg_fn, 49); 4531 put('mkvect, 'one_arg_fn, 50); 4532 put('modular!-minus, 'one_arg_fn, 51); 4533 put('modular!-number, 'one_arg_fn, 52); 4534 put('modular!-reciprocal, 'one_arg_fn, 53); 4535 put('null, 'one_arg_fn, 54); 4536 put('oddp, 'one_arg_fn, 55); 4537 put('onep, 'one_arg_fn, 56); 4538 put('pagelength, 'one_arg_fn, 57); 4539 put('consp, 'one_arg_fn, 58); 4540 put('plist, 'one_arg_fn, 59); 4541 put('plusp, 'one_arg_fn, 60); 4542 put('prin, 'one_arg_fn, 61); 4543 put('princ, 'one_arg_fn, 62); 4544 put('print, 'one_arg_fn, 63); 4545 put('printc, 'one_arg_fn, 64); 4546 put('random, 'one_arg_fn, 65); 4547 put('rational, 'one_arg_fn, 66); 4548 put('rdf1, 'one_arg_fn, 67); 4549 put('rds, 'one_arg_fn, 68); 4550 put('remd, 'one_arg_fn, 69); 4551 put('reverse, 'one_arg_fn, 70); 4552 put('nreverse, 'one_arg_fn, 71); 4553 put('whitespace!-char!-p, 'one_arg_fn, 72); 4554 put('set!-small!-modulus, 'one_arg_fn, 73); 4555 put('xtab, 'one_arg_fn, 74); 4556 put('special!-char, 'one_arg_fn, 75); 4557 put('special!-form!-p, 'one_arg_fn, 76); 4558 put('spool, 'one_arg_fn, 77); 4559 put('stop, 'one_arg_fn, 78); 4560 put('stringp, 'one_arg_fn, 79); 4561 put('sub1, 'one_arg_fn, 80); 4562 put('symbol!-env, 'one_arg_fn, 81); 4563 put('symbol!-function, 'one_arg_fn, 82); 4564 put('symbol!-name, 'one_arg_fn, 83); 4565 put('symbol!-value, 'one_arg_fn, 84); 4566 put('system, 'one_arg_fn, 85); 4567 put('truncate, 'one_arg_fn, 86); 4568 put('ttab, 'one_arg_fn, 87); 4569 put('tyo, 'one_arg_fn, 88); 4570 put('unintern, 'one_arg_fn, 89); 4571 put('unmake!-global, 'one_arg_fn, 90); 4572 put('unmake!-special, 'one_arg_fn, 91); 4573 put('upbv, 'one_arg_fn, 92); 4574 put('simple!-vectorp, 'one_arg_fn, 93); 4575 put('verbos, 'one_arg_fn, 94); 4576 put('wrs, 'one_arg_fn, 95); 4577 put('zerop, 'one_arg_fn, 96); 4578 put('car, 'one_arg_fn, 97); 4579 put('cdr, 'one_arg_fn, 98); 4580 put('caar, 'one_arg_fn, 99); 4581 put('cadr, 'one_arg_fn, 100); 4582 put('cdar, 'one_arg_fn, 101); 4583 put('cddr, 'one_arg_fn, 102); 4584 put('car, 'one_arg_fn, 103); % Really QCAR (unchecked) 4585 put('cdr, 'one_arg_fn, 104); 4586 put('caar, 'one_arg_fn, 105); 4587 put('cadr, 'one_arg_fn, 106); 4588 put('cdar, 'one_arg_fn, 107); 4589 put('cddr, 'one_arg_fn, 108); 4590 put('ncons, 'one_arg_fn, 109); 4591 put('numberp, 'one_arg_fn, 110); 4592 put('is!-spid, 'one_arg_fn, 111); % ONLY used in compiled code 4593 put('spid!-to!-nil, 'one_arg_fn, 112); % ONLY used in compiled code 4594 put('mv!-list, 'one_arg_fn, 113); % ONLY used in compiled code 4595 4596 put('append, 'two_arg_fn, 0); 4597 put('ash, 'two_arg_fn, 1); 4598 put('assoc, 'two_arg_fn, 2); 4599 put('atsoc, 'two_arg_fn, 3); 4600 put('deleq, 'two_arg_fn, 4); 4601 put('delete, 'two_arg_fn, 5); 4602 put('divide, 'two_arg_fn, 6); 4603 put('eqcar, 'two_arg_fn, 7); 4604 put('eql, 'two_arg_fn, 8); 4605 put('eqn, 'two_arg_fn, 9); 4606 put('expt, 'two_arg_fn, 10); 4607 put('flag, 'two_arg_fn, 11); 4608 put('flagpcar, 'two_arg_fn, 12); 4609 put('gcd, 'two_arg_fn, 13); 4610 put('geq, 'two_arg_fn, 14); 4611 put('getv, 'two_arg_fn, 15); 4612 put('greaterp, 'two_arg_fn, 16); 4613 put('idifference, 'two_arg_fn, 17); 4614 put('igreaterp, 'two_arg_fn, 18); 4615 put('ilessp, 'two_arg_fn, 19); 4616 put('imax, 'two_arg_fn, 20); 4617 put('imin, 'two_arg_fn, 21); 4618 put('iplus2, 'two_arg_fn, 22); 4619 put('iquotient, 'two_arg_fn, 23); 4620 put('iremainder, 'two_arg_fn, 24); 4621 put('irightshift, 'two_arg_fn, 25); 4622 put('itimes2, 'two_arg_fn, 26); 4623 put('lcm, 'two_arg_fn, 27); 4624 put('leq, 'two_arg_fn, 28); 4625 put('lessp, 'two_arg_fn, 29); 4626 put('make!-random!-state, 'two_arg_fn, 30); 4627 put('max2, 'two_arg_fn, 31); 4628 put('member, 'two_arg_fn, 32); 4629 put('memq, 'two_arg_fn, 33); 4630 put('min2, 'two_arg_fn, 34); 4631 put('mod, 'two_arg_fn, 35); 4632 put('modular!-difference, 'two_arg_fn, 36); 4633 put('modular!-expt, 'two_arg_fn, 37); 4634 put('modular!-plus, 'two_arg_fn, 38); 4635 put('modular!-quotient, 'two_arg_fn, 39); 4636 put('modular!-times, 'two_arg_fn, 40); 4637 put('nconc, 'two_arg_fn, 41); 4638 put('neq, 'two_arg_fn, 42); 4639 put('orderp, 'two_arg_fn, 43); 4640 put('quotient, 'two_arg_fn, 44); 4641 put('rem, 'two_arg_fn, 45); 4642 put('remflag, 'two_arg_fn, 46); 4643 put('remprop, 'two_arg_fn, 47); 4644 put('rplaca, 'two_arg_fn, 48); 4645 put('rplacd, 'two_arg_fn, 49); 4646 put('sgetv, 'two_arg_fn, 50); 4647 put('set, 'two_arg_fn, 51); 4648 put('smemq, 'two_arg_fn, 52); 4649 put('subla, 'two_arg_fn, 53); 4650 put('sublis, 'two_arg_fn, 54); 4651 put('symbol!-set!-definition, 'two_arg_fn, 55); 4652 put('symbol!-set!-env, 'two_arg_fn, 56); 4653 put('times2, 'two_arg_fn, 57); 4654 put('xcons, 'two_arg_fn, 58); 4655 put('equal, 'two_arg_fn, 59); 4656 put('eq, 'two_arg_fn, 60); 4657 put('cons, 'two_arg_fn, 61); 4658 put('list2, 'two_arg_fn, 62); 4659 put('get, 'two_arg_fn, 63); 4660 put('getv, 'two_arg_fn, 64); % QGETV 4661 put('flagp, 'two_arg_fn, 65); 4662 put('apply1, 'two_arg_fn, 66); 4663 put('difference2, 'two_arg_fn, 67); 4664 put('plus2, 'two_arg_fn, 68); 4665 put('times2, 'two_arg_fn, 69); 4666 4667 put('bpsputv, 'three_arg_fn, 0); 4668 put('errorsetn, 'three_arg_fn, 1); 4669 put('list2star, 'three_arg_fn, 2); 4670 put('list3, 'three_arg_fn, 3); 4671 put('putprop, 'three_arg_fn, 4); 4672 put('putv, 'three_arg_fn, 5); 4673 put('sputv, 'three_arg_fn, 6); 4674 put('subst, 'three_arg_fn, 7); 4675 put('apply2, 'three_arg_fn, 8); 4676 put('acons, 'three_arg_fn, 9); 4677 4678 "native entrypoints established" >>; 4679 4680flag( 4681 '(atom atsoc codep constantp deleq digit endp eq eqcar evenp 4682 eql fixp flagp flagpcar floatp get globalp iadd1 idifference idp 4683 igreaterp ilessp iminus iminusp indirect integerp iplus2 irightshift 4684 isub1 itimes2 liter memq minusp modular!-difference modular!-expt 4685 modular!-minus modular!-number modular!-plus modular!-times not 4686 null numberp onep pairp plusp qcaar qcadr qcar qcdar qcddr 4687 qcdr remflag remprop reversip seprp special!-form!-p stringp 4688 symbol!-env symbol!-name symbol!-value threevectorp vectorp zerop), 4689 'c!:no_errors); 4690 4691end; 4692 4693% End of i86comp.red 4694 4695