1%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2% 3% File: PXC:386-CMAC.SL 4% Description: Patterns and predicates for 386 PSL cmacro expansion 5% Author: Winfried Neun 6% Created: 16 August 1989 7% Modified: 8% Mode: Lisp 9% Package: 10% Status: Open Source: BSD License 11% 12% (c) Copyright 1989, Konrad Zuse Zentrum, all rights reserved 13% 14% Redistribution and use in source and binary forms, with or without 15% modification, are permitted provided that the following conditions are met: 16% 17% * Redistributions of source code must retain the relevant copyright 18% notice, this list of conditions and the following disclaimer. 19% * Redistributions in binary form must reproduce the above copyright 20% notice, this list of conditions and the following disclaimer in the 21% documentation and/or other materials provided with the distribution. 22% 23% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 24% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, 25% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 26% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR 27% CONTRIBUTORS 28% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 29% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 30% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 31% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 32% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 33% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 34% POSSIBILITY OF SUCH DAMAGE. 35% 36%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 37 38(loadtime (progn 39 (RemProp 'Wtimes2 'OpenFn) % So need explicit code 40 (RemProp 'Wtimes2 'MemModFn) % Since no longer a cmacro 41 (RemProp '*MpyMem 'UnMemMod) % " " " " " 42 )) % (RemProp 'WQuotient 'OpenCode) 43 % (RemProp 'WRemainder 'OpenCode))) 44 45 46(fluid '(AddressingUnitsPerItem % Constants defined in data machine. 47 *ImmediateQuote 48 )) 49 50 51% The following terminal operands try to follow the same meanings as 52% those outlined in the Motorola manuals. 53 54(flag '(Immediate % #xxx 55 UnImmediate % used for (unimmediate (immediate x)) 56 Indirect % (An) 57 displacement % d(An) 58 predecrement % -(An) 59 postincrement % (An)+ 60 Indexed % d(An,Dn) 61 absolute % absolute.long 62 extrareg % Regs 5 .. 15 63 idloc 64 reglist) 65 'TerminalOperand) 66 67(setf *ImmediateQuote T) 68 69%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 70% NECESSARY FUNCTIONS 71% These are useful macros for defining Cmarco pattern tables. 72%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 73 74(compiletime (setq savebitmask 'bitmask)) 75(compiletime (remob 'bitmask)) % avoid loss of bitmask for field operations 76 77(de BitMask (StartingBit Length) 78 (prog(x) 79 (setq x (wshift -1 (wminus StartingBit))) 80 (return (wand x (wshift -1 81 (wdifference BitsPerWord (wplus2 StartingBit Length))))))) 82 83(de NegMask (Length) (wshift -1 length)) 84 85(ds ShiftAmt (StartingBit Length) 86 (wdifference BitsPerWord 87 (wplus2 StartingBit Length) %always positive. 88 )) 89 90(de MakeTag (tag) (wshift (wand tag 16#1f) 27)) 91 92%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 93% REGISTER HANDLING PREDICATES% 94% The following predicates are for the 68000, they try to catagorize the 95% constraints relating to legal operands in 68000 assembly language. 96% There are a number of common predicates already available, 97% they are defined the the file PC:Common-Predicates.SL 98 99% The following predicates test for integers in the ranges outlined. 100% All numbers are expressed in base 16. 101% 102% InumP 7FFFFFFF >= x >= -80000000 ( 32 bits ) 103% PosInumP 7FFFFFFF >= x > 0 ( 32 bits ) 104% NegInumP 0 > x >= -80000000 ( 32 bits ) 105% Geq16P 7FFFFFFF >= x >= 10 ( 32 bits ) 106% LeqM16P -10 >= x >= -80000000 ( 32 bits ) 107% Gt8P 7FFFFFFF >= x > 8 ( 32 bits ) 108% LtM8P -8 > x >= -80000000 ( 32 bits ) 109% PosHWordP 10000 > x > 0 ( 16 bits, unsigned) 110% NegHWordP 0 > x >= -10000 ( 16 bits, unsigned) 111% DispInumP 7FFF >= x >= -8000 ( 16 bits ) 112% SmallInumP 7F >= x >= -80 ( 8 bits ) 113% QInumP 8 >= x >= -8 ( several bits ) 114% PosQInumP 8 >= x > 0 ( 3 bits, unsigned) 115% NegQInumP 0 > x >= -8 ( 3 bits, unsigned) 116 117(off R2I) % This function should exist in the kernel! scs 118(de IntP(N) (IntP N)) 119(on R2I) 120 121(de PosInumP (Expression) (and (InumP Expression) 122 (GreaterP Expression 0))) 123 124(de NegInumP (Expression) (and (InumP Expression) 125 (minusp Expression))) 126 127(de Geq16P (Expression) (and (InumP Expression) 128 (Geq Expression 16))) 129 130(de LeqM16P (Expression) (and (InumP Expression) 131 (Leq Expression -16))) 132 133(de Gt8P (Expression) (and (InumP Expression) 134 (GreaterP Expression 8))) 135 136(de LtM8P (Expression) (and (InumP Expression) 137 (LessP Expression -8))) 138 139(de PosHWordP (Expression) (and (IntP Expression) 140 (GreaterP Expression 0) 141 (lessP Expression 16#10000))) 142 143(de NegHWordP (Expression) (and (IntP Expression) 144 (minusp Expression) 145 (geq Expression (minus 16#10000)))) 146 147(de DispInumP (Expression) (and (IntP Expression) 148 (leq Expression 16#7fff) 149 (geq Expression (minus 16#8000)))) 150 151(de SmallInumP (Expression)(and (IntP Expression) 152 (leq Expression 16#7f) 153 (geq Expression (minus 16#80)))) 154 155(de QInumP (Expression) (and (IntP Expression) 156 (leq Expression 8) 157 (geq Expression -8))) 158 159(de PosQInumP (Expression) (and (IntP Expression) 160 (GreaterP Expression 0) 161 (leq Expression 8))) 162 163(de NegQInumP (Expression) (and (IntP Expression) 164 (minusp Expression) 165 (geq Expression -8))) 166 167 168%--------------------------------------------------------- 169% The following set of predicates describes certain classes of 170% register classes. RegP tests if the ophe operand is a valid 68000 register.% 171% 172% RegP any 80386 register 173% FakeRegP tests for argument register numbers greater than LastActualReg 174 175 176(de FakeRegP (Expression) (and (PosIntP Expression) 177 (GreaterP Expression LastActualReg&))) % scs 178 179(de RegP (RegName) 180 (AND (eqcar Regname 'reg) 181 (MemQ (cadr RegName) 182 '( 1 2 3 4 5 st t1 t2 eax ecx edx ebx esp ebp esi edi 183 al cl ax cx 184 es cs ss ds fs gs)))) 185 186(DefList '((EAX 1) (EBX 2) (ECX 3) (EDX 4) (EBP 5) ) 187 'RegisterNumber) 188 189(de RegisterNumber (RegSymbol) 190% registers numbered according to D register model scs 191 (cond ((NumberP RegSymbol) Regsymbol) 192 ( T (OR (GET REGSYMBOL 'REGISTERNUMBER) 193 (StdError (BldMsg "Unknown register %r" RegSymbol)))) 194 )) 195 196 197%------------- 198% ImmediateP tests if an item is tagged IMMEDIATE. (immediate x) 199% WConsts and WArrays are tagged immediate when they are not 200% inside MEMORY. The tagging means that the following expression 201% is to be used as an immediate value. For example, if WArray 202% SYMFNC is the base of some table, the expression 203% (*WPLUS2 (Reg 1) (immediate (WArray SYMFNC))) 204% means to add the address of SYMFNC to (Reg 1) and not the contents 205% of the SYMFNC location. Another immediate expression example would be 206% (*MOVE (postincrement (Reg st)) (immediate (plus2 (WArray ArgumentBlock) 32))' 207% which means move the popped value of the stack to the address resulting from 208% the plus computation. 209%------------- 210 211(de ImmediateP (x) 212 (and (EqCar x 'Immediate) (Null (fixp (cadr x))))) 213 214(de TaggedLabel (X) (EqCar X 'Label)) 215 216 217% For powers of two we could implement (de poweroftwoP (x) (zerop (land x 218% (sub1 x)))) 219 220(de Minus1P (x) (equal x -1)) 221(de OneP (x) (equal x 1)) 222(de TwoP (x) (equal x 2)) 223(de FourP (x) (equal x 4)) 224(de fivep (x) (equal x 5)) 225(de SixP (x) (equal x 6)) 226(de EightP (x) (equal x 8)) 227(de TenP (x) (equal x 10)) 228(de SixteenP (x) (equal x 16)) 229(de fixzerop (x) (eq x 0)) 230(de TwentysevenP (x) (equal x 27)) 231 232 233%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 234% ANYREG DEFINITIONS 235% These are the patterns for anyreg definitions. They are of the form: 236% 237% (DefAnyreg ANYREG_NAME RESOLUTION_FUNCTION_NAME 238% ((Register_Predicate1) (Returned value)) 239% ((Register_Predicate2) (returned value)) 240% ... 241% ) 242 243% The last element in the defintion has no predicate, it is a default 244% case. "Anyregs" are flagged (on their property list) with 'ANYREG. 245% They have property indicators ANYREGPATTERNTABLE. The predicate 246% value list, and the function to call - ANYREGRESOLUTIONFUNCTION. 247% 248% The associated function of most ANYREG's is called with 2 249% arguments, a temporary REGISTER, used in the computation if needed, 250% and the single SOURCE. 251% The associated function usually uses (OneOperandAnyreg Register Source 252% 'Anyregname) or (ExpandOneArgumentAnyReg Register Source 253% 'AnyregName). The 'AnyregName is used to find the associated pattern. 254% The MEMORY anyreg has an additional argument, called ARGTWO. The 255% (OneOperandAnyreg Register Source Anyregname)% 256% calls the lower level ExpandOneArgumentAnyreg, after replacing Source 257% by (ResolveOperand Register Source). This function processes Source 258% to see if it is. The MEMORY anyreg means that the location is the 259% address of the source or destination. 260%It is important that the anyregs DO NOT assign any explicit 261% registers because an instruction may have two similar anyregs which 262% cause the explicit register to be used twice in the same instruction. 263% The future may require a scheme to allocate temporary A and D regs. 264%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 265 266 267%%%%%%%%%%%%%%%%%%%%% scs %%%%%%%%%%% scs %%%%%%%%%%%%%%%%% scs %%%%%%%%%% 268 269(DefAnyreg CAR 270 AnyregCAR %Grab the source so caller can displace off it. 271 ((regp anyp) (displacement source 16#b8000000)) 272 ((anyp regp) (*move SOURCE REGISTER) 273 (displacement REGISTER 16#b8000000)) 274 ( (!*Field REGISTER SOURCE InfStartingBit InfBitLength) 275 (indirect REGISTER)) 276) 277 278(DefAnyreg CDR 279 AnyregCDR %Same as CAR, except move to next word in pair. 280 ((regp anyp) (displacement source 16#b8000004)) 281 ((anyp regp) (*move SOURCE REGISTER) 282 (displacement REGISTER 16#b8000004)) 283 ( (!*Field REGISTER SOURCE InfStartingBit InfBitLength) 284 (Displacement REGISTER 4)) 285) 286 287 288% This new version is based on the old Sun 3.2 cmacro. It is designed to act 289% without the help of the memory pattern under most circumstances. Previously 290% the pattern, was doing most of work using the 14 real reg model. 291% 292(DefAnyreg MEMORY 293 AnyregMEMORY 294 ((RegP ZeroP) (Indirect SOURCE)) 295 ((Anyp ZeroP) (*MOVE SOURCE REGISTER) 296 (Indirect REGISTER)) 297 ((RegP InumP) (Displacement SOURCE ARGTWO)) 298 ((AnyP InumP) (*MOVE SOURCE REGISTER) 299 (Displacement REGISTER ARGTWO)) 300 ((RegP RegP) (Indexed ARGTWO (Displacement SOURCE 0))) 301 ((RegP AnyP) (*MOVE SOURCE REGISTER) 302 (*WPLUS2 REGISTER ARGTWO) 303 (Indirect REGISTER)) 304 ((AnyP DispInumP) (!*MOVE SOURCE REGISTER) 305 (Indexed REGISTER (Displacement ARGTWO 0))) 306 ( (!*MOVE SOURCE REGISTER) 307 (!*WPLUS2 REGISTER ARGTWO) 308 (Indirect REGISTER))) 309 310 311(DefAnyreg FRAME 312 AnyregFRAME 313 ((zerop) (Indirect (reg st))) 314 ( (Displacement (REG st) SOURCE))) 315 316% The compiler will tag expressions immediate in the procedure ResolveWConst. 317% Only expressions are tagged immediate, not numbers. 318 319 320(De AnyRegImmediate(REGISTER SOURCE) 321 (cond ((InumP SOURCE) SOURCE) 322 ((Eqcar SOURCE 'Unimmediate) SOURCE) 323 (T (list 'immediate SOURCE) ) 324 )) 325 326(DefAnyReg IMMEDIATE 327 AnyRegImmediate) 328 329 330(Defanyreg QUOTE 331 AnyregQUOTE 332 ((IntP) SOURCE) %? 333 ( (QUOTE SOURCE))) %? Recursivly expand?? 334 335 336(DefAnyreg REG 337 AnyregREG 338 ((FakeRegP) (extrareg source)) 339 ( (REG SOURCE))) 340 341%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 342% CMACRO DEFINITIONS 343% Remember that it IS legal to use Other CMACROS in expansions% 344% or to define "fake" cmacros, ie procedures, for% 345% Common cases. If a new C-macro is not standard,% 346% e.g (*WFOO argone argtwo), then define its table and procedure.% 347% You may have to define some more "anyregs" or 'TerminalOperands% 348% Or define predicates to be CAREFUL.% 349% (def Cmacro *WFOO% 350% ...... )% 351% (de *WFOO (Arg1 Arg2)% 352% (Expand2OperandCmacro Arg1 Arg2 '*Wfoo))% 353%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 354 355(DefCMacro *Loc % This needs more study scs 356 ((regP ImmediateP)(lea (unimmediate ARGTWO) ARGONE)) 357 ((RegP AnyP) (lea ARGTWO ARGONE)) 358 ((AnyP ImmediateP)(*MOVE ARGTWO ARGONE)) 359 ( (lea ARGTWO (Reg T2)) 360 (*MOVE (Reg T2) ARGONE))) 361 362 363 364% Changed to use regs t0 and t1. Originally used regs t1 and t2, which caused 365% a register conflict in fastapply since it uses reg t2 to store the arg 366% list. The conflict occured when the number of args > maxnargs, since the 367% move from the argumentblock needed reg t2, which destroyed the argument 368% list. 369 370(de quotep (x) (eqcar x 'quote)) 371 372(commentoutcode 373(de *Move (Source Destination) % redefined from COMMON-CMACROS 374 (prog (resultingcode*) 375 (return 376 (CMacroPatternExpand 377 (list (ResolveOperand '(REG t1) Source) 378 (ResolveOperand '(REG t2) Destination)) 379 (get '*Move 'CMacroPatternTable))))) 380) 381 382%modification of *move (HM): 383% (*move (car (cdr ... )) (reg x)) 384% use (reg x) as intermediate aux register in order 385% to get parallelized car/cdr loads 386 387(de *Move (Source Destination) % redefined from COMMON-CMACROS 388 (let (resultingcode* r) 389 (CMacroPatternExpand 390 (list 391 (if (and 392 (pairp Source) 393 (memq(car Source) '(car cdr)) 394 (pairp (setq r (regp Destination))) 395 (numberp (car r)) 396 ) 397 (ResolveOperand Destination Source) 398 (ResolveOperand '(REG t1) Source)) 399 (ResolveOperand '(REG t2) Destination)) 400 (get '*Move 'CMacroPatternTable) 401 ))) 402 403(DefCMacro *Move % (*Move Source Destination) 404 ( Equal ) % if source=dest then do nothing 405 ((fixzerop regp) (xor ArgTwo ArgTwo)) 406 ((onep regp) (xor ArgTwo ArgTwo) 407 (inc ArgTwo)) 408 ((minus1p regp) (xor ArgTwo ArgTwo) 409 (dec ArgTwo)) 410 ((AnyP regP) (mov ARGONE ARGTWO)) 411 ((regp anyp) (mov argone argtwo)) 412 ((quotep anyp) (mov argone argtwo)) 413 ((inump anyp) (mov argone argtwo)) 414 ( (*move argone (reg t1)) 415 (*move (reg t1) argtwo)) 416 ) 417 418(DefCMacro *Pop 419 ( (pop ARGONE))) 420 421(DefCMacro *Push 422 ( (push ARGONE ))) 423 424(DefCMacro *WPlus2 % (*WPlus2 dest source) 425 ((AnyP ZeroP) ) 426 ((Anyp Onep) (inc ArgOne)) 427 ((Anyp Minus1p) (dec ArgOne)) 428 ((RegP AnyP) (add ARGTWO ARGONE)) 429 ((AnyP RegP) (add ARGTWO ARGONE)) 430 ((Anyp Inump) (add ArgTwo ArgOne)) 431 ( (*MOVE ARGTWO (Reg t2)) 432 (add (Reg t2) ARGONE)) 433) 434 435(DefCMacro *WDifference % scs 436 ((AnyP ZeroP) ) 437 (equal (*MOVE 0 ARGONE)) 438 ((Anyp Onep) (dec ArgOne)) 439 ((Anyp Minus1p) (inc ArgOne)) 440 ((regP AnyP ) (sub ARGTWO ARGONE)) 441 ((AnyP regP ) (sub ARGTWO ARGONE)) 442 ((Anyp Inump) (sub ArgTwo Argone)) 443 ( (*MOVE ARGTWO (Reg t2)) 444 (sub (Reg t2) ARGONE)) 445) 446 447(deflist '( 448 (Byte ((mov (indexed (reg 2) (displacement (reg 1) 0)) (reg AL)) 449 (cbw) 450 (cwde))) 451 % (PutByte ((mov (reg CL) (indexed (reg 1) (displacement (reg 2) 0))))) 452 (putByte ((mov (indexed (reg 2)(displacement (reg 1) 0)) (reg 4)) 453 (*wshift (reg 4) -8) 454 (*wshift (reg 4) 8) 455 (*wand (reg 3) 255) 456 (*wor (reg 3)(reg 4)) 457 (mov (reg 3) (indexed (reg 1)(displacement (reg 2) 0))) )) 458 (HalfWord ((shl 1 (reg 2)) 459 (mov (indexed (reg 2) (displacement (reg 1) 0))(reg AX)) 460 (cwde))) 461 (PutHalfWord ((shl 1 (reg 2)) 462 (OS:)(mov (reg CX) (indexed (reg 1)(displacement (reg 2) 0)))))) 463 'OpenCode) 464 465 466(put 'wtimes2 'opencode '((imul (reg 2) (reg 1)))) 467 468(put 'wquotient 'opencode '(%(*move (reg 1) (reg eax)) 469 (cdq) 470 (idiv (reg 2)) 471 ))%%%%(*move (reg eax) (reg 1)))) 472 473(put 'wremainder 'opencode '(%(*move (reg 1) (reg eax)) 474 (cdq) 475 (idiv (reg 2)) 476 (*move (reg edx) (reg 1)))) 477 478(put 'wdivide 'opencode '(%%(*move (reg 1) (reg eax)) 479 (cdq) 480 (idiv (reg 2)) 481 %(*move (reg eax) (reg 1)) 482 (*move (reg edx) ($fluid *second-value*)))) 483 484(de *WNegate(ARG1) 485 (Expand1OperandCMacro ARG1 '*WNegate)) 486 487(DefCMacro *WNegate 488 ( (neg ARGONE)) 489 ) 490 491(DefCMacro *WMinus % scs 492 ((AnyP InumP) (*MOVE (MINUS ARGTWO) ARGONE)) 493 ( Equal (*WNegate ARGONE)) 494 ((regP AnyP) (*MOVE ARGTWO ARGONE) 495 (neg ARGONE)) 496 ( (*WMinus ARGTWO (Reg T1)) 497 (*MOVE (reg t1) ARGONE)) 498) 499 500(de *WComplement(ARG1) 501 (Expand1OperandCMacro ARG1 '*WComplement)) 502 503(DefCMacro *WComplement 504 ( (not ARGONE)) 505 ) 506 507(de *Wcmp(arg1 arg2) 508 (Expand2OperandCMacro arg1 arg2 '*Wcmp)) 509 510(DefCmacro *Wcmp 511 ((Anyp Regp) (cmp argone argtwo)) 512 ((Regp Anyp) (cmp argtwo argone)) 513 ( (*Move argone (reg t1)) 514 (cmp argtwo (reg t1)) )) 515 516(DefCMacro *WNot 517 ((AnyP InumP) (*MOVE (LNOT ARGTWO) ARGONE)) 518 ( Equal (*WComplement ARGONE)) 519 ((regP AnyP) (*MOVE ARGTWO ARGONE) 520 (not ARGONE)) 521 ( (*WNot ARGTWO (Reg T1)) 522 (*MOVE (reg t1) ARGONE)) 523 ) 524 525(DefCMacro *WAnd 526 ( equal ) 527 ((AnyP Minus1P) ) 528 ((AnyP ZeroP) (*MOVE 0 ARGONE)) 529 ((RegP AnyP) (and ARGTWO ARGONE)) 530 ((AnyP RegP) (and ARGTWO ARGONE)) 531 ((AnyP InumP) (and ARGTWO ARGONE)) 532 ( (*MOVE ARGTWO (Reg t2)) 533 (and (Reg t2) ARGONE)) 534) 535 536(DefCMacro *WOr % scs 537 ( equal ) 538 ((AnyP ZeroP) ) 539 ((AnyP Minus1P) (*MOVE -1 ARGONE)) 540 ((RegP AnyP) (or ARGTWO ARGONE)) 541 ((AnyP RegP) (or ARGTWO ARGONE)) 542 ((AnyP InumP) (or ARGTWO ARGONE)) 543 ( (*MOVE ARGTWO (Reg t2)) 544 (or (Reg t2) ARGONE)) 545) 546 547(DefCMacro *WXOr % scs 548 ((AnyP ZeroP) ) 549 ( equal (*MOVE 0 ARGONE)) 550 ((AnyP Minus1P) (*WNOT ARGONE)) 551 ((AnyP InumP) (xor ARGTWO ARGONE)) 552 ((AnyP RegP) (xor ARGTWO ARGONE)) 553 ( (*MOVE ARGTWO (Reg t1)) 554 (xor (Reg t1) ARGONE)) 555) 556 557 558% ---------- 559% Ashift 560% +index shifts left and shifts in zeroes. 561% -index shifts right and sign extends. 562% ARGONE <- ARGONE shifted by ARGTWO 563%------------------------------------------ 564 565(de reg3p (x) (equal x '(reg 3))) 566 567(DefCMacro *AShift % scs 568 ((AnyP ZeroP) ) 569 ((AnyP PosInumP) (*WShift ARGONE ARGTWO)) 570 ((RegP NegInumP) (sar (minus ARGTWO) ARGONE)) 571 ((Reg3p Reg3p) (*cerror "So Geht das nicht")) 572 ((Reg3P regP) (xchg ArgOne ArgTwo) 573 (*Ashift ArgTwo ArgOne) 574 (xchg ArgOne ArgTwo)) 575 ((RegP reg3P) (cmp 0 ARGTWO) 576 (jge TEMPLABEL) 577 (neg ARGTWO) 578 (sar (reg cl) ARGONE) 579 (jmp TEMPLABEL2) 580 (*LBL (label TEMPLABEL)) 581 (shl (Reg cl) ARGONE) 582 (*LBL (label TEMPLABEL2))) 583 ((RegP regP) (cmp 0 ARGTWO) 584 (jge TEMPLABEL) 585 (neg ARGTWO) 586 (xchg argtwo (reg ecx)) 587 (sar (reg cl) ARGONE) 588 (jmp TEMPLABEL2) 589 (*LBL (label TEMPLABEL)) 590 (xchg argtwo (reg ecx)) 591 (shl (Reg cl) ARGONE) 592 (*LBL (label TEMPLABEL2)) 593 (xchg argtwo (reg ecx))) 594 ((RegP AnyP) (*MOVE ARGTWO (Reg T1)) 595 (*ashift argone (reg t1))) 596 ( (*MOVE ARGONE (Reg t2)) 597 (*ASHIFT (Reg t2) ARGTWO) 598 (*MOVE (Reg t2) ARGONE)) 599) 600 601 602(DefCMacro *WShift %Logical shift. +index=left. 603 ((AnyP ZeroP) ) 604 ((RegP OneP) (*WPLUS2 ARGONE ARGONE)) 605 ((RegP PosInumP) (shl ARGTWO ARGONE)) 606 ((RegP NegInumP) (shr (minus ARGTWO) ARGONE)) 607 ((Reg3p Reg3p) (*cerror "So Geht das nicht")) 608 ((Reg3P regP) (xchg ArgOne ArgTwo) 609 (*Wshift ArgTwo ArgOne) 610 (xchg ArgOne ArgTwo)) 611 ((RegP reg3P) (cmp 0 ARGTWO) 612 (jge TEMPLABEL) 613 (neg ARGTWO) 614 (shr (reg cl) ARGONE) 615 (jmp TEMPLABEL2) 616 (*LBL (label TEMPLABEL)) 617 (shl (Reg cl) ARGONE) 618 (*LBL (label TEMPLABEL2))) 619 ((RegP regP) (cmp 0 ARGTWO) 620 (jge TEMPLABEL) 621 (neg ARGTWO) 622 (xchg argtwo (reg ecx)) 623 (shr (reg cl) ARGONE) 624 (jmp TEMPLABEL2) 625 (*LBL (label TEMPLABEL)) 626 (xchg argtwo (reg ecx)) 627 (shl (Reg cl) ARGONE) 628 (*LBL (label TEMPLABEL2)) 629 (xchg argtwo (reg ecx))) 630 ((RegP AnyP) (*MOVE ARGTWO (Reg T1)) 631 (*wshift argone (reg t1))) 632 ( (*MOVE ARGONE (Reg t2)) 633 (*WSHIFT (Reg t2) ARGTWO) 634 (*MOVE (Reg t2) ARGONE)) 635) 636 637 638(de *WLshift (ARG1 arg2) 639 (Expand2OperandCMacro ARG1 ARG2 '*WLshift)) 640 641(DefCMacro *WLShift %Logical shift to the left. 642 ((AnyP ZeroP) ) 643 ((RegP OneP) (*WPLUS2 ARGONE ARGONE)) 644 ((RegP InumP) (shl ARGTWO ARGONE)) 645 ((Reg3p Reg3p) (*cerror "So Geht das nicht")) 646 ((Reg3P regP) (xchg ArgOne ArgTwo) 647 (*Wlshift ArgTwo ArgOne) 648 (xchg ArgOne ArgTwo)) 649 ((RegP reg3P) (shl (Reg cl) ARGONE)) 650 ((RegP regP) (xchg argtwo (reg ecx)) 651 (shl (Reg cl) ARGONE) 652 (xchg argtwo (reg ecx))) 653 ((RegP AnyP) (*MOVE ARGTWO (Reg T1)) 654 (*wlshift argone (reg t1))) 655 ( (*MOVE ARGONE (Reg t2)) 656 (*WlSHIFT (Reg t2) ARGTWO) 657 (*MOVE (Reg t2) ARGONE)) 658) 659 660(de *WRshift (ARG1 arg2) 661 (Expand2OperandCMacro ARG1 ARG2 '*WRshift)) 662 663(DefCMacro *WRShift %Logical shift to the right 664 ((AnyP ZeroP) ) 665 ((RegP InumP) (shr ARGTWO ARGONE)) 666 ((Reg3p Reg3p) (*cerror "So Geht das nicht")) 667 ((Reg3P regP) (xchg ArgOne ArgTwo) 668 (*WRshift ArgTwo ArgOne) 669 (xchg ArgOne ArgTwo)) 670 ((RegP reg3P) (shr (reg cl) ARGONE)) 671 ((RegP regP) (xchg argtwo (reg ecx)) 672 (shr (reg cl) ARGONE) 673 (xchg argtwo (reg ecx))) 674 ((RegP AnyP) (*MOVE ARGTWO (Reg T1)) 675 (*wrshift argone (reg t1))) 676 ( (*MOVE ARGONE (Reg t2)) 677 (*WRSHIFT (Reg t2) ARGTWO) 678 (*MOVE (Reg t2) ARGONE)) 679) 680 681% *JumpIfTag is an optimized form of *jumpif.It knows that we are doing word 682% compares only. 683 684(de *JumpIfTag (arg1 arg2 label instructions) 685 (prog (resultingcode*) 686 (return 687 (cmacropatternexpand 688 (list (resolveoperand '(reg t1) arg1) 689 (resolveoperand '(reg t2) arg2) 690 (resolveoperand '(reg error) label) 691 (car instructions) 692 (cdr instructions)) 693 (get '*JumpIfTag 'cmacropatterntable))))) 694 695 696 697% We could probably make the assumption here that we are comparing 698% a D register (16 bits only) to a constant of the form TAGxxxxxxxxxx. 699 700(DefCMacro *JumpIfTag %( JumpIfTag a b lbl jmp rev-jmp) 701%?((INumP INumP ) should be caught by front end constant folding 702 ((INumP AnyP ) (*JumpIfTag ARGTWO ARGONE ARGTHREE (ARGFIVE . ARGFOUR))) 703 ((AnyP ZeroP ) (cmp 0 ARGONE) (ARGFOUR ARGTHREE)) 704 ((regP AnyP ) (cmp ARGTWO ARGONE) (ARGFOUR ARGTHREE)) 705 ((AnyP regP ) (cmp ARGONE ARGTWO) (ARGFIVE ARGTHREE)) 706 ((AnyP InumP ) (cmp ARGTWO ARGONE) (ARGFOUR ARGTHREE)) 707 ( (mov ARGONE (reg t1)) 708 (cmp ARGTWO (reg t1)) (ARGFOUR ARGTHREE))) 709 710 711(De *JumpEQTag (Lbl Arg1 Arg2) 712 (*JumpIfTag Arg1 Arg2 Lbl '(je . je ))) 713(DefCmacro *JumpEqTag) 714 715(De *JumpNotEQTag (Lbl Arg1 Arg2) 716 (*JumpIfTag Arg1 Arg2 Lbl '(jne . jne))) 717(DefCmacro *JumpNotEQTag) 718 719(De *JumpWGEQTag (Lbl Arg1 Arg2) 720 (*JumpIfTag Arg1 Arg2 Lbl '(jge . jle))) 721(DefCmacro *JumpWGEQTag) 722 723(De *JumpWGreaterPTag (Lbl Arg1 Arg2) 724 (*JumpIfTag Arg1 Arg2 Lbl '(jg . jl ))) 725(DefCmacro *JumpWGreaterPTag) 726 727(De *JumpWLessPTag (Lbl Arg1 Arg2) 728 (*JumpIfTag Arg1 Arg2 Lbl '(jl . jg ))) 729(DefCmacro *JumpWLesspTag) 730 731(DefCMacro *JumpType 732 ( (*MOVE ARGONE (Reg T1)) 733 (shr 27 (Reg T1)) 734 (*JumpEQTag ARGTHREE (reg t1) ARGTWO)) 735 ) 736 737 738(DefCMacro *JumpNotType 739 ( (*MOVE ARGONE (Reg T1)) 740 (shr 27 (Reg T1)) 741 (*JumpNotEQTag ARGTHREE (reg t1) ARGTWO)) 742 ) 743 744(DefCMacro *JumpInType 745 ( (*MOVE ARGONE (Reg T1)) 746 (shr 27 (reg t1)) 747 (*JumpWGeqTag argthree ARGTWO (reg t1) ) 748 (*JumpeqTag argthree (reg t1) 31)) 749 ) 750 751(DefCMacro *JumpNotInType 752 ( (*MOVE ARGONE (Reg T1)) 753 (shr 27 (reg t1)) 754 (*JumpWGeqTag TEMPLABEL ArgTwo (reg t1)) 755 (*JumpnotEQTag ARGTHREE (reg t1) 31) 756 (*LBL (label TEMPLABEL))) 757 ) 758 759 760(DE *JUMPIF (ARG1 ARG2 LABEL INSTRUCTIONS) 761 762 (PROG (RESULTINGCODE*) 763 (RETURN 764 (CMACROPATTERNEXPAND 765 (LIST (RESOLVEOPERAND '(REG T1) ARG1) 766 (RESOLVEOPERAND '(REG T2) ARG2) 767 (RESOLVEOPERAND '(REG ERROR) LABEL) 768 (CAR INSTRUCTIONS) 769 (CDR INSTRUCTIONS)) 770 (GET '*JUMPIF 'CMACROPATTERNTABLE))))) 771 772(DefCMacro *JumpIf %( JumpIF a b lbl jmp rev-jmp) 773 ((INumP INumP ) (!*MOVE ARGONE (reg t1)) 774 (cmp ARGTWO (reg t1)) (ARGFOUR ARGTHREE)) 775 ((INumP AnyP ) (*JumpIf ARGTWO ARGONE ARGTHREE (ARGFIVE . ARGFOUR))) 776 ((AnyP ZeroP ) (cmp 0 ARGONE) (ARGFOUR ARGTHREE)) 777 ((AnyP InumP) (cmp ArgTWO ARGONE) (ARGFOUR ARGTHREE)) 778 ((regP AnyP ) (cmp ARGTWO ARGONE) (ARGFOUR ARGTHREE)) 779 ((AnyP regP ) (cmp ARGONE ARGTWO) (ARGFIVE ARGTHREE)) 780 ((AnyP InumP ) (cmp ARGTWO ARGONE) (ARGFOUR ARGTHREE)) 781 ( (*MOVE ARGONE (reg t1)) 782 (cmp ARGTWO (reg t1)) (ARGFOUR ARGTHREE))) 783 784(De *JumpEQ (Lbl Arg1 Arg2) 785 (*JumpIf Arg1 Arg2 Lbl '(je . je ))) 786(DefCmacro *JumpEq) 787 788(De *JumpNotEQ (Lbl Arg1 Arg2) 789 (*JumpIf Arg1 Arg2 Lbl '(jne . jne))) 790(DefCmacro *JumpNotEQ) 791 792(De *JumpWGEQ (Lbl Arg1 Arg2) 793 (*JumpIf Arg1 Arg2 Lbl '(jge . jle))) 794(DefCmacro *JumpWGEQ) 795 796(De *JumpWGreaterP (Lbl Arg1 Arg2) 797 (*JumpIf Arg1 Arg2 Lbl '(jg . jl))) 798(DefCmacro *JumpWGreaterP) 799 800(De *JumpWLEQ (Lbl Arg1 Arg2) 801 (*JumpIf Arg1 Arg2 Lbl '(jle . jge))) 802(DefCmacro *JumpWLEQ) 803 804(De *JumpWLessP (Lbl Arg1 Arg2) 805 (*JumpIf Arg1 Arg2 Lbl '(jl . jg))) 806(DefCmacro *JumpWLessp) 807 808 809 810%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 811% An item is formed on the 386 with the first five bits as the Tag, % 812% ----------------------------% 813% | Tag | Info field |% 814% ----------------------------% 815% 31 27 0% 816% % 817% To create a constant ITEM, the TagPart must first be shifted 24 bits % 818% to place it in the upper 5, then the InfoPart has its upper 5 bits% 819% masked off. The two are then ORed together.% 820% Not really correct as the inf could end up overlapping the tag% 821%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 822 823(DefCMacro *MkItem 824 ( (*PUTFIELD ARGTWO ARGONE 0 5)) 825 ) 826 827 828% Note that the arguments to *PutField are source, destination, start, size. 829% This is not what the CMACRO document indicates. MkItem above has been 830% modified to reflect this ordering. This is entirely backwards to the 831% majority of the CMACRO's.... 832 833(DefCMacro *PutField 834 ((InumP regP ZeroP AnyP) 835 ( and (LNOT (BITMASK ARGTHREE ARGFOUR)) ARGTWO) 836 ( or (LAND (BITMASK ARGTHREE ARGFOUR) 837 (LSHIFT ARGONE (SHIFTAMT ARGTHREE ARGFOUR))) 838 ARGTWO)) 839 ((InumP regP AnyP AnyP) 840 (*WAND ARGTWO (LNOT (BITMASK ARGTHREE ARGFOUR))) 841 (*WOR ARGTWO (LAND (BITMASK ARGTHREE ARGFOUR) 842 (LSHIFT ARGONE (SHIFTAMT ARGTHREE ARGFOUR))))) 843 844 ((regP regP ZeroP AnyP) 845 (*WSHIFT ARGONE (SHIFTAMT ARGTHREE ARGFOUR)) 846 ( and (LNOT (BITMASK ARGTHREE ARGFOUR)) ARGTWO) 847 ( or ARGONE ARGTWO)) 848 ((regP regP AnyP AnyP) 849 (*WSHIFT ARGONE (SHIFTAMT ARGTHREE ARGFOUR)) 850 ( and (BITMASK ARGTHREE ARGFOUR) ARGONE) 851 (*WAND ARGTWO (LNOT (BITMASK ARGTHREE ARGFOUR))) 852 (*WOR ARGTWO ARGONE)) 853 ((AnyP regP AnyP AnyP) 854 (*MOVE ARGONE (reg t1)) 855 (*PUTFIELD (Reg T1) ARGTWO ARGTHREE ARGFOUR)) 856 ( (*MOVE ARGTWO (reg t1)) 857 (*PUTFIELD ARGONE (Reg T1) ARGTHREE ARGFOUR) 858 (*MOVE (reg t1) ARGTWO)) 859 ) 860 861(DefCMacro *SignedField 862 ((regp anyp anyp anyp)(*MOVE ARGTWO ARGONE) 863 (*ASHIFT ARGONE ARGTHREE) 864 (*ASHIFT ARGONE (DIFFERENCE ARGFOUR 32))) 865 ( (*SignedField (reg t1) ARGTWO ARGTHREE ARGFOUR) 866 (*Move (reg t1) ARGONE)) 867) 868 869% *Field and *SignedField could be improved by using ROL/ROR. 870 871(DefCMacro *Field 872 ((regp anyp zerop anyp) (*MOVE ARGTWO ARGONE) 873 (*WSHIFT ARGONE (DIFFERENCE ARGFOUR 32))) 874 ((regp anyp fivep twentysevenp) 875 (*move ARGTWO ARGONE) 876 (and (bitmask ARGTHREE ARGFOUR) ARGONE)) 877 ((regp anyp anyp anyp)(*MOVE ARGTWO ARGONE) 878 ( and (bitmask ARGTHREE ARGFOUR) ARGONE) 879 (*WSHIFT ARGONE (minus (shiftamt ARGTHREE ARGFOUR)))) 880 ( (*Field (reg t1) ARGTWO ARGTHREE ARGFOUR) 881 (*Move (reg t1) ARGONE)) 882) 883 884% ---------- 885% Alloc 886% Allocates stack space upon procedure entry. 887% ---------- 888 889(de *ALLOC (framesize) 890 (progn 891 (setq NAlloc!* framesize) 892 (setq framesize (times2 framesize addressingunitsperitem)) 893 (cond 894 ((ZeroP framesize) 895 NIL) 896 (T `( % (*move (reg 1) (displacement (reg st) ,(minus (plus framesize 28)) )) 897 % (cmp 500(reg st)) 898 % (jle (indirect(entry stackoverflow))) 899 (sub ,framesize (reg st))))))) 900 901 % a special pass in compiler will do the job 902 903 % Otherwise, we could allocate the space and then the code to clear 904 % it out. Instead, we just push the appropriate number of NILs. 905 906% Declare *ALLOC to be a "cmacro". 907% *ALLOC function handles its expansion. 908 909(defcmacro *ALLOC) 910 911% FastCallableP function dont need a link register to be set 912 913(de FastCallableP(u) 914 (setq u (getd u)) 915 (and u 916 (setq u (cdr u)) 917 (codep u) 918 (or 919 (and nonkernelupperbound* 920 (wlessp (inf u) nonkernelupperbound*) 921 ) 922 (wlessp (inf u)(inf (cdr (getd 'getd)))) 923 ) 924 )) 925 926(DefCMacro *Call 927 ((InternallyCallableP) (call (InternalEntry ARGONE))) 928 ((FastCallableP) (call (indirect (entry ARGONE)))) 929 ( (*move (idloc argone) (reg t1)) 930 (call (indirect (entry ARGONE))))) 931 932(DefCMacro *DeAlloc 933 ((ZeroP)) 934 ( (add ARGONE (REG st)))) 935 936(DefCMacro *Exit 937 ((ZeroP) (ret)) 938 ( (add ARGONE (REG st)) 939 (ret))) 940 941(DefCMacro *JCall 942 ((InternallyCallableP) (jmp (InternalEntry ARGONE))) 943 ((FastCallableP) (JMP (indirect (entry ARGONE)))) 944 ( (*move (idloc argone) (reg t1)) 945 (JMP (indirect (entry ARGONE))))) 946 947 948(DefCMacro *Jump 949 ((Atom) (jmp ARGONE))% internal labels before compile 950 ((TaggedLabel) (jmp ARGONE))% compiler generated labels 951 ((ImmediateP) (jmp (unimmediate ARGONE))) 952 ( (jmp ARGONE))) 953 954 955(DefCMacro *Lbl 956 ( ARGONE)) 957 958(de *Link (FunctionName FunctionType NumberOfArguments) 959 (list 960 (cond ((FlagP FunctionName 'ForeignFunction) 961 (list '*ForeignLink FunctionName FunctionType NumberOfArguments)) 962 (t 963 (list '*Call FunctionName))))) 964 965(DefCMacro *Link) 966 967 968(de *LinkE (DeAllocCount FunctionName FunctionType NumberOfArguments) 969 (cons (list '*DeAlloc DeAllocCount) 970 (cond ((FlagP FunctionName 'ForeignFunction) 971 (list (list '*ForeignLink FunctionName 972 FunctionType NumberOfArguments) 973 '(*Exit 0))) 974 (t 975 (list (list '*JCall FunctionName)))))) 976 977(DefCMacro *LinkE) 978 979(De *LamBind (Regs Fluids) 980 981 % be careful, code is somewhat tricky 982 983 (prog (n lng list cregs cfluids cadrcfluids lab initload freeregs hugo) 984 (setq lab (gensym)) 985 (setq hugo (gensym)) 986 (setq n 0) 987 (setq Regs (rest Regs)) % Remove "Registers" from the front 988 (setq Fluids (rest fluids)) % Remove NONLOCALVARS 989 (setq lng (wtimes2 (length Regs) 8)) % two words per BndStk entry *4 990 991 %looking for free register to preload values of fluid s 992 993 (setq freeregs (mapcan '((reg 1)(reg 2)(reg 3)(reg 4)(reg 5)) 994 (function (lambda (x) 995 (cond ((member x regs) nil) 996 (t (cons x nil)) 997 ) ) ) ) ) 998 (setq cfluids fluids) % copy of fluids 999 (when (null freeregs) 1000 (setq freeregs cfluids) 1001 (go nopreload)) 1002 1003preload (setq initload 1004 (progn (setq cadrcfluids 1005 (nconc cadrcfluids (cons (car freeregs) nil))) 1006 (nconc initload `((*move ,(car cfluids) ,(car freeregs)))) 1007 ) ) 1008 (setq freeregs (cdr freeregs)) 1009 (setq cfluids (cdr cfluids)) 1010 1011 (cond ((and freeregs cfluids) (go preload))) 1012 1013 (setq freeregs (nconc cadrcfluids cfluids)) %end of preloadcode 1014 1015 % freeregs contains the list of preloaded regs 1016 % and not preloaded fluids if those exist 1017nopreload 1018 (setq list `((*move ($fluid BndStkPtr) (Reg t1)) 1019 (*move (reg t1) (reg t2)) 1020 (*wplus2 (Reg t2) ,lng) 1021 (cmp (reg t2) ($fluid BndstkUpperBound)) 1022 % (jge ,hugo) 1023 % (*call Bstackoverflow) %(jg (entry Bstackoverflow)) 1024 %,hugo 1025 (jle (indirect(entry Bstackoverflow))) 1026 (*move (Reg t2) ($fluid BndstkPtr)) )) %start of code 1027 1028 (setq list (append initload list)) 1029 1030 loop 1031 (setq cregs (car Regs)) 1032 (setq cfluids (car Fluids)) 1033 (setq cadrcfluids (cadr cfluids)) 1034 (when (or (eq cadrcfluids 't) (eq cadrcfluids 'nil)) 1035 (stderror "T and NIL cannot be rebound")) 1036 (setq n (wplus2 n 8)) 1037 (Setq list (append list 1038 `((*move ,(car freeregs)(reg t2)) 1039 (*move (reg t2) (displacement (Reg t1) ,n)) 1040 (*move (quote ,Cadrcfluids) (reg t2)) 1041 (*move (reg t2) (displacement (reg t1) ,(wplus2 n -4))) 1042 (*move ,cregs (reg t2)) 1043 (*move (reg t2) ,cfluids) 1044 ) )) 1045 (setq fluids (cdr Fluids)) 1046 (setq freeregs (cdr freeregs)) 1047 (cond ((setq regs (cdr Regs)) (go loop))) 1048 (return list) 1049) ) 1050 1051(defcmacro !*lambind) 1052 1053(De *ProgBind (Fluids) 1054 1055 % be careful, code is somewhat tricky 1056 1057 (prog (n lng list cfluids cadrcfluids lab initload freeregs kuno) 1058 (setq kuno (gensym)) 1059 (setq lab (gensym)) 1060 (setq n 0) 1061 (setq Fluids (rest fluids)) % Remove NONLOCALVARS 1062 (setq lng (wtimes2 (length Fluids) 8)) % two words per BndStk entry 1063 % * 4 addressingunits 1064 (setq freeregs '((reg 1)(reg 2)(reg 3)(reg 4)(reg 5))) 1065 (setq cfluids fluids) % copy of fluids 1066 1067preload (setq initload 1068 (progn (setq cadrcfluids 1069 (nconc cadrcfluids (cons (car freeregs) nil))) 1070 (nconc initload `((*move ,(car cfluids) ,(car freeregs)))) 1071 ) ) 1072 (setq freeregs (cdr freeregs)) 1073 (setq cfluids (cdr cfluids)) 1074 1075 (cond ((and freeregs cfluids) (go preload))) 1076 1077 (setq freeregs (nconc cadrcfluids cfluids)) %end of preloadcode 1078 1079 % freeregs contains the list of preloaded regs 1080 % and not preloaded fluids if those exist 1081 1082 1083 (setq list `((*move ($fluid BndStkPtr) (Reg t1)) 1084 (*move (reg t1) (reg t2)) 1085 (*wplus2 (Reg t2) ,lng) 1086 (cmp (reg t2) ($fluid BndstkUpperBound)) 1087 % (jge ,kuno) 1088 % (*call Bstackoverflow) %(jg (entry Bstackoverflow)) 1089 % ,kuno 1090 (jle (indirect(entry Bstackoverflow))) 1091 (*move (Reg t2) ($fluid BndstkPtr)) )) %start of code 1092 1093 (setq list (append initload list)) 1094 1095 loop 1096 (setq cfluids (car Fluids)) 1097 (setq cadrcfluids (cadr cfluids)) 1098 (when (or (eq cadrcfluids 't) (eq cadrcfluids 'nil)) 1099 (stderror "T and NIL cannot be rebound")) 1100 (setq n (wplus2 n 8)) 1101 (Setq list (append list 1102 `((*move ,(car freeregs)(reg t2)) 1103 (*move (reg t2) (displacement (Reg t1) ,n)) 1104 (*move (quote ,Cadrcfluids) (reg t2)) 1105 (*move (reg t2) (displacement (reg t1) ,(wplus2 n -4))) 1106 (*move (quote nil) (reg t2)) 1107 (*move (reg t2) ,cfluids) 1108 ) )) 1109 (setq freeregs (cdr freeregs)) 1110 (cond ((setq Fluids (cdr Fluids)) (go loop))) 1111 (return list) 1112) ) 1113(defcmacro *progbind) 1114 1115(De *FreeRstr (Fluids) 1116 1117 (prog (n lng list cfluids listfluids lab initload freeregs otto) 1118 (setq otto (gensym)) 1119 (setq lab (gensym)) 1120 (setq n 0) 1121 (setq Fluids (rest fluids)) % Remove NONLOCALVARS 1122 (setq lng (wtimes2 (length Fluids) 2)) % two words per BndStk entry 1123 (setq freeregs '((reg 2)(reg 3)(reg 4)(reg 5))) 1124 (setq cfluids fluids) % copy of fluids 1125 (setq n (wtimes2 4 (wdifference 2 lng))) 1126 (setq lng (wtimes2 lng 4)) % * addressingunitperitem 1127 (setq initload (list '(*move ($fluid Bndstkptr) (reg t1)))) 1128 1129preload (setq initload 1130 (progn (setq listfluids 1131 (if freeregs 1132 (nconc listfluids (cons (car freeregs) nil)) 1133 (nconc listfluids (cons nil nil))) ) 1134 (nconc initload 1135 (if freeregs 1136 `((*move (displacement (reg t1) ,n) ,(car freeregs))) nil) 1137 ) )) 1138 (setq n (wplus2 n 8)) 1139 (when freeregs (setq freeregs (cdr freeregs))) 1140 (setq cfluids (cdr cfluids)) 1141 1142 (cond (cfluids (go preload))) 1143 1144 (setq freeregs listfluids ) %end of preloadcode 1145 1146 % freeregs contains the list of preloaded regs 1147 % and nil if not enough regs available 1148 1149 (setq list `((*move (reg t1) (reg t2)) 1150 (sub ,lng (reg t2)) 1151 (cmp (reg t2) ($fluid BndstkLowerBound)) 1152 % (jle ,otto) 1153 % (*call Bstackunderflow) %(jl (entry Bstackunderflow)) 1154 % ,otto 1155 (jg (indirect (entry Bstackunderflow))) 1156 (*move (Reg t2) ($fluid BndstkPtr)) )) %start of code 1157 1158 (setq list (append initload list)) 1159 (setq n 0) 1160 1161 loop 1162 (setq cfluids (car Fluids)) 1163 (setq n (wplus2 n 8)) 1164 1165 % insert reloaded register or memory reference 1166 1167 (setq list (append list 1168 (if (car freeregs) `((*move ,(car freeregs) ,cfluids )) 1169 `((*move (displacement (Reg t2) ,n) ,cfluids ))) 1170 1171 ) ) 1172 (setq freeregs (cdr freeregs)) 1173 (cond ((setq Fluids (cdr Fluids)) (go loop))) 1174 (return list) 1175) ) 1176(defcmacro *freerstr) 1177 1178(setq *unsafebinder t) % has to save Registers across calls 1179 1180(de !*jumpon (register lowerbound upperbound labellist) 1181 (PROG (X LL LL2) 1182 (setq ll (gensym)) 1183 (setq ll2 (gensym)) 1184 (SETQ X 1185 (if (and (weq lowerbound 0) (weq upperbound 31) *syslisp) 1186 % jumpon on tags (most probably) 1187 `( % 4 bytes per jumptable entry 1188 (jmp (indirect (indexed (times ,register 4) (label ,ll2)))) 1189 ,ll2) 1190 `((cmp ,upperbound ,register) 1191 (jg (label ,ll)) 1192 (cmp ,Lowerbound ,register) 1193 (jl (label ,ll)) 1194 (*wdifference ,register ,lowerbound ) 1195 (jmp (indirect (indexed (times ,register 4) (label ,ll2)))) 1196 ,ll2) ) ) 1197 Loop (Setq x (nconc X `((FULLWORD ,(car Labellist)))) ) 1198 (setq Labellist (cdr Labellist)) 1199 (cond (Labellist (go loop))) 1200 1201 (setq x (nconc x `((*lbl (Label ,ll))) )) 1202 (return x) 1203) ) 1204 1205(defcmacro !*jumpon) 1206 1207(defcmacro *fast-apply-load 1208 ( (*move argone (reg t2))) 1209 ) 1210 1211(put 'fast-idapply 1212 'opencode 1213 '((*move (reg t2) (reg t1)) % save idnumber 1214 (*wand (reg t2)(wconst 16#7ffffff)) % remove what's left of the tag 1215 (*wshift (reg t2) (wconst 2)) % double ID number (ignore tag for now) 1216 (*wplus2 (reg t2) ($fluid SYMFNC)) % add base address to 6 times ID. 1217 (call (indirect (reg t2))) % jump indirect. 1218 )) 1219 1220(put 'fast-idapply 1221 'exitopencode 1222 '((*move (reg t2) (reg t1)) % save idnumber 1223 (*wand (reg t2)(wconst 16#7ffffff)) % remove what's left of the tag 1224 (*wshift (reg t2) (wconst 2)) % double ID number (ignore tag for now) 1225 (*wplus2 (reg t2) ($fluid SYMFNC)) % add base address to 6 times ID. 1226 (jmp (indirect (reg t2))) % jump indirect. 1227 )) 1228 1229 1230% Need to do tag stripping before doing the jsr. /LBS 1231% 1232(put 'fast-codeapply 1233 'opencode 1234 '((*field (reg t2) (reg t2) (wconst infstartingbit) 1235 (wconst infbitlength)) 1236 (*move ($fluid onewordbuffer)(reg t1)) 1237 (*move (reg t2)(indirect (reg t1))) 1238 (call (indirect (reg t1)))) 1239 ) 1240 1241(put 'fast-codeapply 1242 'exitopencode 1243 '((*field (reg t2) (reg t2) (wconst infstartingbit) 1244 (wconst infbitlength)) 1245 (jmp (reg t2))) 1246 1247 ) 1248 1249(DE !*ForeignLink (FunctionName FunctionType NumberOfArguments) 1250 (setq NumberOfArguments 4) 1251 (codedeclareexternal FunctionName) 1252 (append '((*move (reg st) (reg t1)) 1253 (sub 32 (reg st)) 1254 (shr 4 (reg st)) 1255 (shl 4 (reg st)) 1256 (add 16 (reg st)) 1257 (*move (reg t1) (displacement (reg st) 4))) 1258 (append (PNTH '((!*PUSH (REG 14)) (!*PUSH (REG 13)) 1259 (!*PUSH (REG 12)) (!*PUSH (REG 11)) 1260 (!*PUSH (REG 10)) (!*PUSH (REG 9)) 1261 (!*PUSH (REG 8)) (!*PUSH (REG 7)) 1262 (!*PUSH (REG 6)) (!*PUSH (REG 5)) 1263 (!*PUSH (REG 4)) (!*PUSH (REG 3)) 1264 (!*PUSH (REG 2)) (!*PUSH (REG 1))) 1265 (difference 15 NumberOfArguments)) 1266 (append 1267 (list (list '!*move '(fluid ebxsave!*) '(reg 2)) 1268 (list 'call (list 'ForeignEntry FunctionName)) 1269 (list '!*move '(reg 2) '(fluid ebxsave!*))) 1270 (list (list '*move (list 'displacement '(reg st) 1271 (plus 4 (times 4 NumberOfArguments))) '(reg st)))) 1272 )) 1273 ))) 1274 1275(DefCMacro *ForeignLink) 1276 1277% the floating point part 1278 1279% *feq, *fgreaterp and *flessp can only occur once in a function. 1280 1281(deflist '((*fclex (fclex)) 1282 (*wfix ((fld (indirect (reg 1))) 1283 (fistp (displacement (reg st) -4)) 1284 (wait) 1285 (mov (displacement (reg st) -4) (reg 1)))) 1286 (*wfloat ((mov (reg 2) (displacement (reg st) -4)) 1287 (fild (displacement (reg st) -4)) 1288 (fstp (indirect (reg 1))) 1289 (wait))) 1290 (*fgreaterp ((fld (indirect (reg 2))) 1291 (fcomp (indirect (reg 1))) 1292 (fstsw (reg ax)) 1293 (sahf) 1294 (*move (quote t) (reg 1)) 1295 (jb *donefgreaterp*) 1296 (mov (quote nil) (reg 1)) 1297 *donefgreaterp*)) 1298 (*flessp ((fld (indirect (reg 1))) 1299 (fcomp (indirect (reg 2))) 1300 (fstsw (reg ax)) 1301 (sahf) 1302 (*move (quote t) (reg 1)) 1303 (jb *doneflessp*) 1304 (mov (quote nil) (reg 1)) 1305 *doneflessp*)) 1306 (*fplus2 ((fld (indirect (reg 2))) 1307 (fadd (displacement (reg 3) 0)) 1308 (fstp (indirect (reg 1))) 1309 (wait))) 1310 (*fdifference ((fld (indirect (reg 2))) 1311 (fsub (displacement (reg 3) 0)) 1312 (fstp (indirect (reg 1))) 1313 (wait))) 1314 (*ftimes2 ((fld (indirect (reg 2))) 1315 (fmul (indirect (reg 3))) 1316 (fstp (indirect (reg 1))) 1317 (wait))) 1318 (*fquotient ((fld (indirect (reg 2))) 1319 (fdiv (displacement (reg 3) 0)) 1320 (fstp (indirect (reg 1))) 1321 (wait)))) 1322 'opencode) 1323 1324(de &stopt (u) 1325 % OPTFN: Convert MOVEs + ALLOCS into PUSHES 1326 % U: inverse sequence of cmacros. 1327 % 486: instruction for stack protection should be first one. 1328 (cond ((atom (cdr u)) NIL) 1329 ((and (equal (caadr u) '*alloc) (equal llngth& 1) 1330 (equal (cddar u) '((frame 1)))) 1331 (rplacw u (append `((*push ,(cadar u)) 1332%WN 1333 % (*move (reg 1) (displacement (reg st) -32)) 1334 % (jle (indirect(entry stackoverflow))) 1335 % (cmp 500(reg st)) 1336 ) 1337 (cddr u)))) 1338 ((and (equal (caadr u) '*move) (equal (caaddr u) '*alloc) 1339 (equal llngth& 2) (equal (cddar u) '((frame 2))) 1340 (equal (cddadr u) '((frame 1)))) 1341 (rplacw u 1342 (cons (list '*push (cadadr u)) 1343 (cons (list '*push (cadar u)) 1344 (append '((*move (reg 1) (reg 1))) %(*move (reg 1) (displacement (reg st) -32))) 1345%WN 1346 % '((jle (indirect(entry stackoverflow))) 1347 % (cmp 500(reg st))) 1348 (cdddr u))))) 1349))) 1350 1351 1352%------------------------- access to SS segment with DS instructions ---- 1353 1354(deflist 1355 '((*get-stack ((halfword 16#3636) % SS segment override prefix 1356 (*move (indexed (reg 1) 0) (reg 1)))) 1357 (*put-stack ((halfword 16#3636) 1358 (*move (reg 2) (indexed (reg 1) 0))))) 1359 'opencode) 1360 1361% End of file. 1362