Lines Matching +refs:emit +refs:conditional +refs:instruction
1799 (define (conditional? exp) (eq? (car exp) 'if))
1814 (define (make-conditional e0 e1 e2) (list 'if e0 e1 e2))
3347 (make-conditional (m-expand (cadr exp) env)
4017 ((conditional? exp)
4018 (make-conditional (copy (if.test exp) env notepad R-table)
4123 ((conditional? exp)
4209 ((conditional? exp)
4298 ((conditional? exp)
4793 (and (conditional? E)
6419 (define instruction.op car)
6420 (define instruction.arg1 cadr)
6421 (define instruction.arg2 caddr)
6422 (define instruction.arg3 cadddr)
6549 ; A non-inclusive upper bound for the instruction encodings.
7101 ; of a conditional expression, on arguments described by the second
7276 ((if) (simplify-conditional exp notepad))
7593 ((and (conditional? body)
8245 (define (simplify-conditional exp notepad)
8247 (and (conditional? exp)
8264 (and (conditional? body)
8283 (make-conditional (if.else body)
8289 (simplify-conditional exp notepad))
8297 ((and (conditional? test)
8320 ((and (conditional? test)
8327 ((and (conditional? test)
8362 ; Given a conditional expression whose test has been simplified,
8392 ; A case expression turns into a conditional expression
8423 (if (not (conditional? E))
8645 (make-conditional (make-call (make-variable name:FIXNUM?)
8651 (make-conditional (make-call (make-variable name:CHAR?)
8657 (make-conditional (make-call (make-variable name:SYMBOL?)
8718 (make-conditional
8723 (make-conditional
8765 (make-conditional (make-call-to-memv var0 constants)
8775 (make-conditional (make-call-to-eqv var0 (car constants))
8830 (make-conditional (make-call (make-variable name:FX<)
8853 (make-conditional (make-call-to-memv var0 constants1)
9746 (make-conditional exp0 exp1 exp2))))
9904 ; a conditional with the test already evaluated, or
9932 ; the alternatives of a non-tail conditional
9991 ((if) (anf-conditional E bindings regvars))
10077 (define (anf-conditional E bindings regvars)
10085 (make-conditional E0 E1 E2)
10091 (make-conditional (anf-result bindings) E1 E2)
10513 ((conditional? E)
10698 ; If E1 is a conditional or a real call, then wrap category 3.
10702 (if (or (conditional? E1)
10874 ((conditional? E)
10890 (values (make-conditional
10902 (scan-rhs (make-conditional E0 E1 E2)
10929 (let ((E (make-conditional
11701 ; (gen! as . instruction)
11702 ; (gen-instruction! as instruction)
11741 ; (cgframe-bind! frame n v instruction)
11811 (define (gen-instruction! output instruction)
11812 (let ((pair (list instruction))
11820 (define (gen! output . instruction)
11821 (gen-instruction! output instruction))
11825 (gen-instruction! output (cons $save size))
11831 (gen-instruction! output (cons $restore size))))
11835 (gen-instruction! output (cons $pop size))))
11838 (let ((instruction (list $nop $setstk -1)))
11839 (cgframe-bind! frame tempname instruction)
11840 (gen-instruction! output instruction)))
11843 (let ((instruction (list $nop $store r -1)))
11844 (cgframe-bind! frame tempname instruction)
11845 (gen-instruction! output instruction)))
12040 ; (v n instruction stale)
12044 ; instruction is a possibly phantom store or setstk instruction
12050 ; before the store or setstk instruction was generated.
12062 ; environment is shared with the save instruction that
12073 (define cgframe:slot.instruction caddr)
12085 (let ((instruction (caddr entry)))
12087 (not (eq? $nop (car instruction))))
12091 (set-car! instruction (cadr instruction))
12092 (set-cdr! instruction (cddr instruction))
12093 (if (eq? $setstk (car instruction))
12094 (set-car! (cdr instruction) n)
12095 (set-car! (cddr instruction) n))))))
12097 ; Reserves a slot offset that was unused where the instruction
12123 ; Gen-save! generates a store instruction for register 0,
12124 ; with slot 0 as the only stale slot for that instruction;
12149 (define (cgframe-bind! frame var instruction)
12151 (cons (list var #f instruction (cgframe:stale frame))
12227 ; For a conditional expression, the then and else parts must be
12230 ; nature of the resolution depends upon whether the conditional
12235 ; conditional involve variables and temporaries that are local to the
12236 ; conditional.
12238 ; If the conditional expression is in a tail position, then a slot
12240 ; two arms of the conditional. If the conditional expression is in a
12243 ; store instruction.
12496 ; A save instruction is generated
12499 ; * at the beginning of the code for each arm of a conditional,
12501 ; the conditional is in a tail position
12503 ; that dominate the arms of the conditional have not been
12507 ; The operand of a save instruction, and of its matching pop instructions,
12523 ; unless there is a matching load instruction. If all of the instructions
12596 ; This is hard because the MacScheme machine's lambda instruction
12682 ; registers in preparation for a $lambda or $lexes instruction.
12725 ; compiled here. They don't need an args= instruction at their head.
12957 ; Same as return, but doesn't emit a store instruction.
14177 ((conditional? exp)
14215 ((conditional? exp)
14239 (make-conditional E1 (if.then exp) (if.else exp)))
14482 "Local optimization detected a useless instruction.")
14484 ; Each instruction is mapping to an encoding of the actions
14652 (let* ((instruction (car instructions))
14654 (op (instruction.op instruction))
14657 (forwards instructions (cons instruction filtered)))
14661 (if (negative? (instruction.arg1 instruction))
14665 (cons instruction filtered)))))
14669 (cons instruction filtered)))
14673 (forwards-label instruction
14677 (cons instruction filtered))))
14681 (instruction.arg1 instruction)
14684 (cons instruction filtered)))
14687 (instruction.arg2 instruction)
14690 (cons instruction filtered)))
14693 (instruction.arg2 instruction)
14696 (cons instruction filtered)))
14698 (kill-stack! (instruction.arg1 instruction))
14700 (cons instruction filtered)))
14702 (let ((i (instruction.arg1 instruction))
14703 (j (instruction.arg2 instruction)))
14707 (suppress-forwards instruction
14712 (cons instruction
14715 (let ((i (instruction.arg1 instruction))
14716 (j (instruction.arg2 instruction)))
14720 (suppress-forwards instruction
14725 (cons instruction
14735 (let ((label1 (instruction.arg1 instruction1)))
14741 (let* ((instruction (car instructions))
14742 (op (instruction.op instruction))
14747 (negative? (instruction.arg1 instruction)))
14750 (let ((label2 (instruction.arg1 instruction)))
14752 (forwards-label instruction
14756 (let ((label2 (instruction.arg1 instruction)))
14758 ; We can't get rid of the skip instruction
14770 (let* ((instruction (car instructions))
14772 (op (instruction.op instruction))
14775 (backwards instructions (cons instruction filtered)))
14777 (backwards0 (cons instruction instructions)
14781 (cons instruction filtered)))
14787 (instruction.arg1 instruction)
14788 (instruction.arg2 instruction))))
14794 (cons instruction filtered))))
14798 (cons instruction filtered)))
14804 (instruction.arg1 instruction))))
14806 (suppress-backwards instruction
14812 (instruction.arg2 instruction))))
14814 (suppress-backwards instruction
14818 (= (instruction.arg1 instruction)
14819 (instruction.arg2 instruction)))
14822 (let ((filtered (cons instruction filtered)))
14826 (instruction.arg1 instruction)
14831 (instruction.arg2 instruction)
14836 (instruction.arg1 instruction)
14841 (instruction.arg2 instruction)
14846 (instruction.arg3 instruction)
14851 ; element is the last instruction of a basic block,
14858 (let* ((instruction (car instructions))
14859 (mnemonic (instruction.op instruction)))
14865 (cons instruction filtered)))
14871 (cons instruction filtered)))
14875 (+ (instruction.arg1 instruction) 1))))
14879 (cons instruction filtered))))
14884 (let* ((live (instruction.arg2 instruction))
14888 (let ((instruction
14892 (instruction.arg1 instruction))
14895 (cons instruction filtered)))))
14898 (+ (instruction.arg3 instruction) 1))))
14902 (cons instruction filtered))))
14906 (let* ((live (instruction.arg2 instruction))
14909 (let ((instruction
14913 (instruction.arg1 instruction))
14916 (cons instruction filtered)))))
14919 (define (suppress-forwards instruction instructions filtered)
14925 (define (suppress-backwards instruction instructions filtered)
15406 ; machine instruction or pseudo-instruction is a list whose car
15408 ; instruction. The rest of the list is interpreted as indicated
15414 ; This assembler is table-driven, and may be customized to emit
15418 ; and a source instruction. The procedure should just assemble
15419 ; the instruction using the operations defined below.
15480 (define (emit! as bv)
15486 (define (emit-string! as s)
15493 (define (emit-constant as x)
15501 (define (emit-datum as x)
15502 (emit-constant as (list 'data x)))
15504 (define (emit-global as x)
15505 (emit-constant as (list 'global x)))
15507 (define (emit-codevector as x)
15508 (emit-constants as (list 'codevector x)))
15510 (define (emit-constantvector as x)
15511 (emit-constants as (list 'constantvector x)))
15526 (define (emit-constants as x . rest)
15534 (define (emit-label! as L)
15540 (define (emit-fixup! as offset size n)
15547 (define (emit-fixup-label! as offset size L)
15554 (define (emit-fixup-proc! as proc)
15601 (define (next-instruction as)
15607 (define (consume-next-instruction! as)
15610 (define (push-instruction as instruction)
15611 (as-source! as (cons instruction (as-source as))))
15774 (emit-datum as doc)
15951 ; emit is a procedure that takes an as and emits instructions into it.
15953 (define (test-asm emit)
15955 (emit as)
16165 ; instruction templates, and during development.
16564 ; which emit a byte and a 4-byte word respectively. These update
17123 (lambda (instruction as)
17124 (asm-error "Unrecognized mnemonic " instruction))))
17126 (define (define-instruction i proc)
17130 (define (list-instruction name instruction)
17137 (if (not (null? (cdr instruction)))
17138 (begin (write (cadr instruction))
17139 (do ((operands (cddr instruction)
17147 (define (list-label instruction)
17151 (write (cadr instruction))
17154 (define (list-lambda-start instruction)
17155 (list-instruction "lambda" (list $lambda '* (operand2 instruction)))
17170 (define-instruction $.label
17171 (lambda (instruction as)
17172 (list-label instruction)
17173 (sparc.label as (make-asm-label as (operand1 instruction)))))
17175 (define-instruction $.proc
17176 (lambda (instruction as)
17177 (list-instruction ".proc" instruction)
17180 (define-instruction $.proc-doc
17181 (lambda (instruction as)
17182 (list-instruction ".proc-doc" instruction)
17183 (add-documentation as (operand1 instruction))
17186 (define-instruction $.cont
17187 (lambda (instruction as)
17188 (list-instruction ".cont" instruction)
17191 (define-instruction $.align
17192 (lambda (instruction as)
17193 (list-instruction ".align" instruction)
17196 (define-instruction $.end
17197 (lambda (instruction as)
17200 (define-instruction $.singlestep
17201 (lambda (instruction as)
17220 (let ((o (emit-datum as repr)))
17221 (emit-singlestep-instr! as funky? 0 o)))))))
17226 (define-instruction $op1
17227 (lambda (instruction as)
17228 (list-instruction "op1" instruction)
17229 (emit-primop.1arg! as (operand1 instruction))))
17231 (define-instruction $op2
17232 (lambda (instruction as)
17233 (list-instruction "op2" instruction)
17234 (emit-primop.2arg! as
17235 (operand1 instruction)
17236 (regname (operand2 instruction)))))
17238 (define-instruction $op3
17239 (lambda (instruction as)
17240 (list-instruction "op3" instruction)
17241 (emit-primop.3arg! as
17242 (operand1 instruction)
17243 (regname (operand2 instruction))
17244 (regname (operand3 instruction)))))
17246 (define-instruction $op2imm
17247 (lambda (instruction as)
17248 (list-instruction "op2imm" instruction)
17249 (let ((op (case (operand1 instruction)
17266 (emit-primop.4arg! as op $r.result (operand2 instruction) $r.result)
17268 (emit-constant->register as (operand2 instruction) $r.argreg2)
17269 (emit-primop.2arg! as
17270 (operand1 instruction)
17273 (define-instruction $const
17274 (lambda (instruction as)
17275 (list-instruction "const" instruction)
17276 (emit-constant->register as (operand1 instruction) $r.result)))
17278 (define-instruction $global
17279 (lambda (instruction as)
17280 (list-instruction "global" instruction)
17281 (emit-global->register! as
17282 (emit-global as (operand1 instruction))
17285 (define-instruction $setglbl
17286 (lambda (instruction as)
17287 (list-instruction "setglbl" instruction)
17288 (emit-register->global! as
17290 (emit-global as (operand1 instruction)))))
17296 (define-instruction $lambda
17297 (lambda (instruction as)
17300 (list-lambda-start instruction)
17302 (operand1 instruction)
17303 (operand3 instruction) ; documentation
17308 (set! code-offset (emit-codevector as 0))
17309 (set! const-offset (emit-constantvector as 0))
17310 (emit-lambda! as
17313 (operand2 instruction)))))
17315 (define-instruction $lexes
17316 (lambda (instruction as)
17317 (list-instruction "lexes" instruction)
17318 (emit-lexes! as (operand1 instruction))))
17320 (define-instruction $args=
17321 (lambda (instruction as)
17322 (list-instruction "args=" instruction)
17323 (emit-args=! as (operand1 instruction))))
17325 (define-instruction $args>=
17326 (lambda (instruction as)
17327 (list-instruction "args>=" instruction)
17328 (emit-args>=! as (operand1 instruction))))
17330 (define-instruction $invoke
17331 (lambda (instruction as)
17332 (list-instruction "invoke" instruction)
17333 (emit-invoke as (operand1 instruction) #f $m.invoke-ex)))
17335 (define-instruction $restore
17336 (lambda (instruction as)
17337 (if (not (negative? (operand1 instruction)))
17339 (list-instruction "restore" instruction)
17340 (emit-restore! as (operand1 instruction))))))
17342 (define-instruction $pop
17343 (lambda (instruction as)
17344 (if (not (negative? (operand1 instruction)))
17346 (list-instruction "pop" instruction)
17347 (let ((next (next-instruction as)))
17350 (begin (list-instruction "return" next)
17351 (consume-next-instruction! as)
17352 (emit-pop! as (operand1 instruction) #t))
17353 (emit-pop! as (operand1 instruction) #f)))))))
17355 (define-instruction $stack
17356 (lambda (instruction as)
17357 (list-instruction "stack" instruction)
17358 (emit-load! as (operand1 instruction) $r.result)))
17360 (define-instruction $setstk
17361 (lambda (instruction as)
17362 (list-instruction "setstk" instruction)
17363 (emit-store! as $r.result (operand1 instruction))))
17365 (define-instruction $load
17366 (lambda (instruction as)
17367 (list-instruction "load" instruction)
17368 (emit-load! as (operand2 instruction) (regname (operand1 instruction)))))
17370 (define-instruction $store
17371 (lambda (instruction as)
17372 (list-instruction "store" instruction)
17373 (emit-store! as (regname (operand1 instruction)) (operand2 instruction))))
17375 (define-instruction $lexical
17376 (lambda (instruction as)
17377 (list-instruction "lexical" instruction)
17378 (emit-lexical! as (operand1 instruction) (operand2 instruction))))
17380 (define-instruction $setlex
17381 (lambda (instruction as)
17382 (list-instruction "setlex" instruction)
17383 (emit-setlex! as (operand1 instruction) (operand2 instruction))))
17385 (define-instruction $reg
17386 (lambda (instruction as)
17387 (list-instruction "reg" instruction)
17388 (emit-register->register! as (regname (operand1 instruction)) $r.result)))
17390 (define-instruction $setreg
17391 (lambda (instruction as)
17392 (list-instruction "setreg" instruction)
17393 (emit-register->register! as $r.result (regname (operand1 instruction)))))
17395 (define-instruction $movereg
17396 (lambda (instruction as)
17397 (list-instruction "movereg" instruction)
17398 (emit-register->register! as
17399 (regname (operand1 instruction))
17400 (regname (operand2 instruction)))))
17402 (define-instruction $return
17403 (lambda (instruction as)
17404 (list-instruction "return" instruction)
17405 (emit-return! as)))
17407 (define-instruction $reg/return
17408 (lambda (instruction as)
17409 (list-instruction "reg/return" instruction)
17410 (emit-return-reg! as (regname (operand1 instruction)))))
17412 (define-instruction $const/return
17413 (lambda (instruction as)
17414 (list-instruction "const/return" instruction)
17415 (emit-return-const! as (operand1 instruction))))
17417 (define-instruction $nop
17418 (lambda (instruction as)
17419 (list-instruction "nop" instruction)))
17421 (define-instruction $save
17422 (lambda (instruction as)
17423 (if (not (negative? (operand1 instruction)))
17425 (list-instruction "save" instruction)
17426 (let* ((n (operand1 instruction))
17428 (emit-save0! as n)
17430 (let loop ((instruction (next-instruction as)))
17431 (if (eqv? $store (operand0 instruction))
17432 (begin (list-instruction "store" instruction)
17433 (emit-store! as
17434 (regname (operand1 instruction))
17435 (operand2 instruction))
17436 (consume-next-instruction! as)
17437 (vector-set! v (operand2 instruction) #f)
17438 (loop (next-instruction as))))))
17439 (emit-save1! as v))))))
17441 (define-instruction $setrtn
17442 (lambda (instruction as)
17443 (list-instruction "setrtn" instruction)
17444 (emit-setrtn! as (make-asm-label as (operand1 instruction)))))
17446 (define-instruction $apply
17447 (lambda (instruction as)
17448 (list-instruction "apply" instruction)
17449 (emit-apply! as
17450 (regname (operand1 instruction))
17451 (regname (operand2 instruction)))))
17453 (define-instruction $jump
17454 (lambda (instruction as)
17455 (list-instruction "jump" instruction)
17456 (emit-jump! as
17457 (operand1 instruction)
17458 (make-asm-label as (operand2 instruction)))))
17460 (define-instruction $skip
17461 (lambda (instruction as)
17462 (list-instruction "skip" instruction)
17463 (emit-branch! as #f (make-asm-label as (operand1 instruction)))))
17465 (define-instruction $branch
17466 (lambda (instruction as)
17467 (list-instruction "branch" instruction)
17468 (emit-branch! as #t (make-asm-label as (operand1 instruction)))))
17470 (define-instruction $branchf
17471 (lambda (instruction as)
17472 (list-instruction "branchf" instruction)
17473 (emit-branchf! as (make-asm-label as (operand1 instruction)))))
17475 (define-instruction $check
17476 (lambda (instruction as)
17477 (list-instruction "check" instruction)
17479 (emit-check! as $r.result
17480 (make-asm-label as (operand4 instruction))
17481 (list (regname (operand1 instruction))
17482 (regname (operand2 instruction))
17483 (regname (operand3 instruction)))))))
17485 (define-instruction $trap
17486 (lambda (instruction as)
17487 (list-instruction "trap" instruction)
17488 (emit-trap! as
17489 (regname (operand1 instruction))
17490 (regname (operand2 instruction))
17491 (regname (operand3 instruction))
17492 (operand4 instruction))))
17494 (define-instruction $const/setreg
17495 (lambda (instruction as)
17496 (list-instruction "const/setreg" instruction)
17497 (let ((x (operand1 instruction))
17498 (r (operand2 instruction)))
17500 (emit-constant->register as x (regname r))
17501 (begin (emit-constant->register as x $r.tmp0)
17502 (emit-register->register! as $r.tmp0 (regname r)))))))
17509 (define-instruction $reg/op1/branchf
17510 (lambda (instruction as)
17511 (list-instruction "reg/op1/branchf" instruction)
17512 (emit-primop.3arg! as
17513 (operand1 instruction)
17514 (peep-regname (operand2 instruction))
17515 (make-asm-label as (operand3 instruction)))))
17517 (define-instruction $reg/op2/branchf
17518 (lambda (instruction as)
17519 (list-instruction "reg/op2/branchf" instruction)
17520 (emit-primop.4arg! as
17521 (operand1 instruction)
17522 (peep-regname (operand2 instruction))
17523 (peep-regname (operand3 instruction))
17524 (make-asm-label as (operand4 instruction)))))
17526 (define-instruction $reg/op2imm/branchf
17527 (lambda (instruction as)
17528 (list-instruction "reg/op2imm/branchf" instruction)
17529 (emit-primop.4arg! as
17530 (operand1 instruction)
17531 (peep-regname (operand2 instruction))
17532 (operand3 instruction)
17533 (make-asm-label as (operand4 instruction)))))
17538 (define-instruction $reg/op1/check
17539 (lambda (instruction as)
17540 (list-instruction "reg/op1/check" instruction)
17541 (emit-primop.4arg! as
17542 (operand1 instruction)
17543 (peep-regname (operand2 instruction))
17544 (make-asm-label as (operand3 instruction))
17545 (map peep-regname (operand4 instruction)))))
17547 (define-instruction $reg/op2/check
17548 (lambda (instruction as)
17549 (list-instruction "reg/op2/check" instruction)
17550 (emit-primop.5arg! as
17551 (operand1 instruction)
17552 (peep-regname (operand2 instruction))
17553 (peep-regname (operand3 instruction))
17554 (make-asm-label as (operand4 instruction))
17555 (map peep-regname (operand5 instruction)))))
17557 (define-instruction $reg/op2imm/check
17558 (lambda (instruction as)
17559 (list-instruction "reg/op2imm/check" instruction)
17560 (emit-primop.5arg! as
17561 (operand1 instruction)
17562 (peep-regname (operand2 instruction))
17563 (operand3 instruction)
17564 (make-asm-label as (operand4 instruction))
17565 (map peep-regname (operand5 instruction)))))
17569 (define-instruction $reg/op1/setreg
17570 (lambda (instruction as)
17571 (list-instruction "reg/op1/setreg" instruction)
17572 (emit-primop.3arg! as
17573 (operand1 instruction)
17574 (peep-regname (operand2 instruction))
17575 (peep-regname (operand3 instruction)))))
17577 (define-instruction $reg/op2/setreg
17578 (lambda (instruction as)
17579 (list-instruction "reg/op2/setreg" instruction)
17580 (emit-primop.4arg! as
17581 (operand1 instruction)
17582 (peep-regname (operand2 instruction))
17583 (peep-regname (operand3 instruction))
17584 (peep-regname (operand4 instruction)))))
17586 (define-instruction $reg/op2imm/setreg
17587 (lambda (instruction as)
17588 (list-instruction "reg/op2imm/setreg" instruction)
17589 (emit-primop.4arg! as
17590 (operand1 instruction)
17591 (peep-regname (operand2 instruction))
17592 (operand3 instruction)
17593 (peep-regname (operand4 instruction)))))
17595 (define-instruction $reg/op3
17596 (lambda (instruction as)
17597 (list-instruction "reg/op3" instruction)
17598 (emit-primop.4arg! as
17599 (operand1 instruction)
17600 (peep-regname (operand2 instruction))
17601 (peep-regname (operand3 instruction))
17602 (peep-regname (operand4 instruction)))))
17604 (define-instruction $reg/branchf
17605 (lambda (instruction as)
17606 (list-instruction "reg/branchf" instruction)
17607 (emit-branchfreg! as
17608 (regname (operand1 instruction))
17609 (make-asm-label as (operand2 instruction)))))
17611 (define-instruction $setrtn/branch
17612 (lambda (instruction as)
17613 (list-instruction "setrtn/branch" instruction)
17614 (emit-branch-with-setrtn! as (make-asm-label as (operand1 instruction)))))
17616 (define-instruction $setrtn/invoke
17617 (lambda (instruction as)
17618 (list-instruction "setrtn/invoke" instruction)
17619 (emit-invoke as (operand1 instruction) #t $m.invoke-ex)))
17621 (define-instruction $global/setreg
17622 (lambda (instruction as)
17623 (list-instruction "global/setreg" instruction)
17624 (emit-global->register! as
17625 (emit-global as (operand1 instruction))
17626 (regname (operand2 instruction)))))
17628 (define-instruction $global/invoke
17629 (lambda (instruction as)
17630 (list-instruction "global/invoke" instruction)
17631 (emit-load-global as
17632 (emit-global as (operand1 instruction))
17635 (emit-invoke as (operand2 instruction) #f $m.global-invoke-ex)))
17637 (define-instruction $reg/setglbl
17638 (lambda (instruction as)
17639 (list-instruction "reg/setglbl" instruction)
17640 (emit-register->global! as
17641 (regname (operand1 instruction))
17642 (emit-global as (operand2 instruction)))))
17654 ; instruction is assembled. It may replace the prefix of the instruction
17655 ; stream by some other instruction sequence.
18236 ; a standard instruction.
18271 ; Constants that can be synthesized in a single instruction can be
18272 ; moved into RESULT in the delay slot of the return instruction.
18315 ; Gets rid of spurious branch-to-next-instruction
18435 ; Does the integer x fit in the immediate field of an instruction?
18462 ; hardware register, return src. Otherwise, emit an instruction to load
18468 (emit-load-reg! as src hwreg)))
18473 (define (emit-constant->register as opd r)
18476 (emit-immediate->register! as (thefixnum opd) r)
18477 (emit-const->register! as (emit-datum as opd) r)))
18479 (emit-immediate->register! as
18485 (emit-immediate->register! as $imm.eof r))
18487 (emit-immediate->register! as $imm.unspecified r))
18489 (emit-immediate->register! as $imm.undefined r))
18491 (emit-immediate->register! as $imm.null r))
18493 (emit-immediate->register! as (char->immediate opd) r))
18495 (emit-const->register! as (emit-datum as opd) r))))
18505 (define (emit-immediate->register! as i r)
18515 (emit-store-reg! as r dest))))
18524 (define (emit-const->register! as offset r)
18534 (emit-const->register! as offset $r.tmp0)
18535 (emit-store-reg! as $r.tmp0 r)))))
18539 ; Emit single instruction to load sw-mapped reg into another reg, and return
18542 (define (emit-load-reg! as from to)
18544 (asm-error "emit-load-reg: " from to)
18548 (define (emit-store-reg! as from to)
18550 (asm-error "emit-store-reg: " from to)
18556 (define (emit-move2hwreg! as from to)
18559 (emit-load-reg! as from to))
18564 ; branchf.a is an annulled conditional branch that tests the condition codes
18574 (define (emit-evaluate-cc! as branchf.a rd target)
18586 (define (emit-check! as rs0 L1 liveregs)
18588 (emit-checkcc! as sparc.be L1 liveregs))
18592 (define (emit-trap! as rs1 rs2 rs3 exn)
18594 (emit-move2hwreg! as rs3 $r.argreg3))
18596 (emit-move2hwreg! as rs2 $r.argreg2))
18598 (emit-move2hwreg! as rs1 $r.result))
18602 ; an annulled conditional branch that branches
18604 ; a non-annulled conditional branch that branches
18607 ; argument and emits an instruction that goes into
18615 ; FIXME: The nop can often be replaced by the instruction that
18620 (define (emit-checkcc-and-fill-slot!
18640 (emit-move2hwreg! as rs3 $r.argreg3))
18642 (emit-store-reg! as rs3 $r.argreg3))
18644 (emit-move2hwreg! as rs3 $r.tmp0)
18645 (emit-store-reg! as $r.tmp0 $r.argreg3)))
18647 (emit-move2hwreg! as rs2 $r.argreg2))
18649 (emit-move2hwreg! as rs1 $r.result))
18652 (emit-immediate->register! as (thefixnum exn) $r.tmp0)
18657 (define (emit-checkcc! as branch-bad L1 liveregs)
18709 (emit-move2hwreg! as r $r.argreg2))
18716 (emit-move2hwreg! as rs rd))
18729 (emit-move2hwreg! as r1 $r.argreg2)
18731 (emit-move2hwreg! as r2 $r.argreg3))
18740 ; and to avoid generating a fixup. See emit-return-address! in gen-msi.sch.
18778 ; The procedure `sparc-instruction' takes an instruction class keyword and
18779 ; some operands and returns an assembler procedure for the instruction
18785 ; This assembler currently accepts a subset of the SPARC v8 instruction set.
18788 ; Asm/Common/pass5p1.sch) and operands relevant to the instruction, and
18789 ; side-effects the assembly structure by emitting bits for the instruction
18790 ; and any necessary fixups. There are separate instruction mnemonics and
18791 ; assembler procedures for instructions which in the SPARC instruction set
18792 ; are normally considered the "same". For example, the `add' instruction is
18810 ; their instruction fields. It is a fatal error for an operand not
18815 ; a jump instruction into an offset calculation and a jump).
18818 ; (emit-fixup-proc! as (lambda (b l) (fixup b l)))
18826 ; An annulled conditional branch or an un-annulled unconditional branch
18827 ; may be followed by the strange instruction SPARC.SLOT, which turns into
18828 ; a nop in the delay slot that may be replaced by copying the instruction
18832 ; An un-annulled conditional branch whose target depends upon a known set
18834 ; be followed by the strange instruction SPARC.SLOT2, which takes any
18835 ; number of registers as operands. This strange instruction turns into
18836 ; nothing at all if the following instruction has no side effects except
18839 ; the SPARC.SLOT2 instruction becomes a nop in the delay slot. The
18843 (define sparc-instruction)
18845 (let ((original-emit-label! emit-label!)
18847 (set! emit-label!
18850 (original-emit-label! as L)))
18855 'emit-label!)
18857 (let ((emit! (lambda (as bits)
18859 (emit! as bits)))
18860 (emit-fixup-proc! (lambda (as proc)
18862 (emit-fixup-proc! as proc)))
19047 ; Add 1 to an instruction (to bump a branch offset by 4).
19073 ; Mark the instruction at the current address as not being eligible
19078 (define (not-a-delay-slot-instruction as)
19083 (define (is-a-delay-slot-instruction? as bv addr)
19104 (emit-fixup-proc! as
19112 (emit-fixup-proc! as (lambda (b l) (fixup b l))))
19114 (emit! as bits))))))
19136 ; filling based on the `slot' pseudo-instruction.
19140 ; instruction is found (it has its own class) then the cached
19143 ; target instruction can be found, examined, and evaluated.
19145 ; The cached value is always valid when the slot instruction is assembled,
19146 ; because a slot instruction is always directly preceded by an annulled
19178 (not-a-delay-slot-instruction as)
19183 (emit-fixup-proc! as (lambda (b l) (fixup b l))))
19184 (emit! as bits))))))
19186 ; Branch delay slot pseudo-instruction.
19190 ; will copy the target instruction to the slot and add 4 to the branch
19191 ; offset (unless that will overflow the offset or the instruction at the
19195 ; instruction itself!
19209 (if (is-a-delay-slot-instruction? as bv bt)
19215 (emit-fixup-proc! as (lambda (b l) (fixup b l))))
19218 ; Branch delay slot pseudo-instruction 2.
19221 ; replaced by a sufficiently harmless ALU instruction.
19249 (not-a-delay-slot-instruction as)
19250 (emit! as bits))
19252 (emit-fixup-proc!
19257 (emit! as bits)))))))))
19280 (asm-value-too-large as "ALU instruction" e imm)))))
19286 (signal-error 'fixup "ALU instruction" e))))
19292 (emit-fixup-proc! as (lambda (b l) (fixup b l))))
19296 (not-a-delay-slot-instruction as)
19297 (emit! as bits))
19299 (emit-fixup-proc!
19304 (emit! as bits))))))))
19315 (emit! as bits)))))
19328 (signal-error 'toolarge "Memory instruction" e imm)))))
19334 (signal-error 'fixup "Memory instruction" e))))
19342 (emit-fixup-proc! as (lambda (b l) (fixup b l))))
19343 (emit! as bits)))))
19347 ; a store, so we transform the instruction into (st c b a) and pass it
19375 (not-a-delay-slot-instruction as)
19378 (emit-fixup-proc! as (lambda (b l) (fixup b l))))
19379 (emit! as bits))))))
19383 (emit-label! as label)))
19402 (emit! as bits)))))
19404 (set! sparc-instruction
19426 (asm-error "sparc-instruction: unrecognized class: " kwd)))))
19427 'sparc-instruction)
19432 (define sparc.lddi (sparc-instruction 'i11 #b000011))
19433 (define sparc.lddr (sparc-instruction 'r11 #b000011))
19434 (define sparc.ldi (sparc-instruction 'i11 #b000000))
19435 (define sparc.ldr (sparc-instruction 'r11 #b000000))
19436 (define sparc.ldhi (sparc-instruction 'i11 #b000010))
19437 (define sparc.ldhr (sparc-instruction 'r11 #b000010))
19438 (define sparc.ldbi (sparc-instruction 'i11 #b000001))
19439 (define sparc.ldbr (sparc-instruction 'r11 #b000001))
19440 (define sparc.lddfi (sparc-instruction 'i11 #b100011))
19441 (define sparc.lddfr (sparc-instruction 'r11 #b100011))
19442 (define sparc.stdi (sparc-instruction 'si11 #b000111))
19443 (define sparc.stdr (sparc-instruction 'sr11 #b000111))
19444 (define sparc.sti (sparc-instruction 'si11 #b000100))
19445 (define sparc.str (sparc-instruction 'sr11 #b000100))
19446 (define sparc.sthi (sparc-instruction 'si11 #b000110))
19447 (define sparc.sthr (sparc-instruction 'sr11 #b000110))
19448 (define sparc.stbi (sparc-instruction 'si11 #b000101))
19449 (define sparc.stbr (sparc-instruction 'sr11 #b000101))
19450 (define sparc.stdfi (sparc-instruction 'si11 #b100111))
19451 (define sparc.stdfr (sparc-instruction 'sr11 #b100111))
19452 (define sparc.sethi (sparc-instruction 'sethi #b100))
19453 (define sparc.andr (sparc-instruction 'r10 #b000001))
19454 (define sparc.andrcc (sparc-instruction 'r10 #b010001))
19455 (define sparc.andi (sparc-instruction 'i10 #b000001))
19456 (define sparc.andicc (sparc-instruction 'i10 #b010001))
19457 (define sparc.orr (sparc-instruction 'r10 #b000010))
19458 (define sparc.orrcc (sparc-instruction 'r10 #b010010))
19459 (define sparc.ori (sparc-instruction 'i10 #b000010))
19460 (define sparc.oricc (sparc-instruction 'i10 #b010010))
19461 (define sparc.xorr (sparc-instruction 'r10 #b000011))
19462 (define sparc.xorrcc (sparc-instruction 'r10 #b010011))
19463 (define sparc.xori (sparc-instruction 'i10 #b000011))
19464 (define sparc.xoricc (sparc-instruction 'i10 #b010011))
19465 (define sparc.sllr (sparc-instruction 'r10 #b100101))
19466 (define sparc.slli (sparc-instruction 'i10 #b100101))
19467 (define sparc.srlr (sparc-instruction 'r10 #b100110))
19468 (define sparc.srli (sparc-instruction 'i10 #b100110))
19469 (define sparc.srar (sparc-instruction 'r10 #b100111))
19470 (define sparc.srai (sparc-instruction 'i10 #b100111))
19471 (define sparc.addr (sparc-instruction 'r10 #b000000))
19472 (define sparc.addrcc (sparc-instruction 'r10 #b010000))
19473 (define sparc.addi (sparc-instruction 'i10 #b000000))
19474 (define sparc.addicc (sparc-instruction 'i10 #b010000))
19475 (define sparc.taddrcc (sparc-instruction 'r10 #b100000))
19476 (define sparc.taddicc (sparc-instruction 'i10 #b100000))
19477 (define sparc.subr (sparc-instruction 'r10 #b000100))
19478 (define sparc.subrcc (sparc-instruction 'r10 #b010100))
19479 (define sparc.subi (sparc-instruction 'i10 #b000100))
19480 (define sparc.subicc (sparc-instruction 'i10 #b010100))
19481 (define sparc.tsubrcc (sparc-instruction 'r10 #b100001))
19482 (define sparc.tsubicc (sparc-instruction 'i10 #b100001))
19483 (define sparc.smulr (sparc-instruction 'r10 #b001011))
19484 (define sparc.smulrcc (sparc-instruction 'r10 #b011011))
19485 (define sparc.smuli (sparc-instruction 'i10 #b001011))
19486 (define sparc.smulicc (sparc-instruction 'i10 #b011011))
19487 (define sparc.sdivr (sparc-instruction 'r10 #b001111))
19488 (define sparc.sdivrcc (sparc-instruction 'r10 #b011111))
19489 (define sparc.sdivi (sparc-instruction 'i10 #b001111))
19490 (define sparc.sdivicc (sparc-instruction 'i10 #b011111))
19491 (define sparc.b (sparc-instruction 'b00 #b1000))
19492 (define sparc.b.a (sparc-instruction 'a00 #b1000))
19493 (define sparc.bne (sparc-instruction 'b00 #b1001))
19494 (define sparc.bne.a (sparc-instruction 'a00 #b1001))
19495 (define sparc.be (sparc-instruction 'b00 #b0001))
19496 (define sparc.be.a (sparc-instruction 'a00 #b0001))
19497 (define sparc.bg (sparc-instruction 'b00 #b1010))
19498 (define sparc.bg.a (sparc-instruction 'a00 #b1010))
19499 (define sparc.ble (sparc-instruction 'b00 #b0010))
19500 (define sparc.ble.a (sparc-instruction 'a00 #b0010))
19501 (define sparc.bge (sparc-instruction 'b00 #b1011))
19502 (define sparc.bge.a (sparc-instruction 'a00 #b1011))
19503 (define sparc.bl (sparc-instruction 'b00 #b0011))
19504 (define sparc.bl.a (sparc-instruction 'a00 #b0011))
19505 (define sparc.bgu (sparc-instruction 'b00 #b1100))
19506 (define sparc.bgu.a (sparc-instruction 'a00 #b1100))
19507 (define sparc.bleu (sparc-instruction 'b00 #b0100))
19508 (define sparc.bleu.a (sparc-instruction 'a00 #b0100))
19509 (define sparc.bcc (sparc-instruction 'b00 #b1101))
19510 (define sparc.bcc.a (sparc-instruction 'a00 #b1101))
19511 (define sparc.bcs (sparc-instruction 'b00 #b0101))
19512 (define sparc.bcs.a (sparc-instruction 'a00 #b0101))
19513 (define sparc.bpos (sparc-instruction 'b00 #b1110))
19514 (define sparc.bpos.a (sparc-instruction 'a00 #b1110))
19515 (define sparc.bneg (sparc-instruction 'b00 #b0110))
19516 (define sparc.bneg.a (sparc-instruction 'a00 #b0110))
19517 (define sparc.bvc (sparc-instruction 'b00 #b1111))
19518 (define sparc.bvc.a (sparc-instruction 'a00 #b1111))
19519 (define sparc.bvs (sparc-instruction 'b00 #b0111))
19520 (define sparc.bvs.a (sparc-instruction 'a00 #b0111))
19521 (define sparc.call (sparc-instruction 'call))
19522 (define sparc.jmplr (sparc-instruction 'r10 #b111000 'jump))
19523 (define sparc.jmpli (sparc-instruction 'i10 #b111000 'jump))
19524 (define sparc.nop (sparc-instruction 'nop #b100))
19525 (define sparc.ornr (sparc-instruction 'r10 #b000110))
19526 (define sparc.orni (sparc-instruction 'i10 #b000110))
19527 (define sparc.ornrcc (sparc-instruction 'r10 #b010110))
19528 (define sparc.ornicc (sparc-instruction 'i10 #b010110))
19529 (define sparc.andni (sparc-instruction 'i10 #b000101))
19530 (define sparc.andnr (sparc-instruction 'r10 #b000101))
19531 (define sparc.andnicc (sparc-instruction 'i10 #b010101))
19532 (define sparc.andnrcc (sparc-instruction 'r10 #b010101))
19533 (define sparc.rdy (sparc-instruction 'r10 #b101000 'rdy))
19534 (define sparc.wryr (sparc-instruction 'r10 #b110000 'wry))
19535 (define sparc.wryi (sparc-instruction 'i10 #b110000 'wry))
19536 (define sparc.fb (sparc-instruction 'fb00 #b1000))
19537 (define sparc.fb.a (sparc-instruction 'fa00 #b1000))
19538 (define sparc.fbn (sparc-instruction 'fb00 #b0000))
19539 (define sparc.fbn.a (sparc-instruction 'fa00 #b0000))
19540 (define sparc.fbu (sparc-instruction 'fb00 #b0111))
19541 (define sparc.fbu.a (sparc-instruction 'fa00 #b0111))
19542 (define sparc.fbg (sparc-instruction 'fb00 #b0110))
19543 (define sparc.fbg.a (sparc-instruction 'fa00 #b0110))
19544 (define sparc.fbug (sparc-instruction 'fb00 #b0101))
19545 (define sparc.fbug.a (sparc-instruction 'fa00 #b0101))
19546 (define sparc.fbl (sparc-instruction 'fb00 #b0100))
19547 (define sparc.fbl.a (sparc-instruction 'fa00 #b0100))
19548 (define sparc.fbul (sparc-instruction 'fb00 #b0011))
19549 (define sparc.fbul.a (sparc-instruction 'fa00 #b0011))
19550 (define sparc.fblg (sparc-instruction 'fb00 #b0010))
19551 (define sparc.fblg.a (sparc-instruction 'fa00 #b0010))
19552 (define sparc.fbne (sparc-instruction 'fb00 #b0001))
19553 (define sparc.fbne.a (sparc-instruction 'fa00 #b0001))
19554 (define sparc.fbe (sparc-instruction 'fb00 #b1001))
19555 (define sparc.fbe.a (sparc-instruction 'fa00 #b1001))
19556 (define sparc.fbue (sparc-instruction 'fb00 #b1010))
19557 (define sparc.fbue.a (sparc-instruction 'fa00 #b1010))
19558 (define sparc.fbge (sparc-instruction 'fb00 #b1011))
19559 (define sparc.fbge.a (sparc-instruction 'fa00 #b1011))
19560 (define sparc.fbuge (sparc-instruction 'fb00 #b1100))
19561 (define sparc.fbuge.a (sparc-instruction 'fa00 #b1100))
19562 (define sparc.fble (sparc-instruction 'fb00 #b1101))
19563 (define sparc.fble.a (sparc-instruction 'fa00 #b1101))
19564 (define sparc.fbule (sparc-instruction 'fb00 #b1110))
19565 (define sparc.fbule.a (sparc-instruction 'fa00 #b1110))
19566 (define sparc.fbo (sparc-instruction 'fb00 #b1111))
19567 (define sparc.fbo.a (sparc-instruction 'fa00 #b1111))
19568 (define sparc.faddd (sparc-instruction 'fp #b001000010))
19569 (define sparc.fsubd (sparc-instruction 'fp #b001000110))
19570 (define sparc.fmuld (sparc-instruction 'fp #b001001010))
19571 (define sparc.fdivd (sparc-instruction 'fp #b001001110))
19572 (define sparc%fnegs (sparc-instruction 'fp #b000000101)) ; See below
19573 (define sparc%fmovs (sparc-instruction 'fp #b000000001)) ; See below
19574 (define sparc%fabss (sparc-instruction 'fp #b000001001)) ; See below
19575 (define sparc%fcmpdcc (sparc-instruction 'fpcc #b001010010)) ; See below
19579 (define sparc.slot (sparc-instruction 'slot))
19580 (define sparc.slot2 (sparc-instruction 'slot2))
19581 (define sparc.label (sparc-instruction 'label))
19611 ; For fmovd, fnegd, and fabsd, we must synthesize the instruction from
19649 (define (emit-register->global! as rs offset)
19652 (emit-const->register! as offset $r.result)
19657 (emit-const->register! as offset $r.result)
19670 (define (emit-global->register! as offset r)
19671 (emit-load-global as offset r (catch-undefined-globals)))
19676 (define (emit-load-global as offset r check?)
19678 (define (emit-undef-check! as r)
19687 (emit-const->register! as offset $r.argreg2) ; Load cell.
19690 (emit-undef-check! as r))
19692 (emit-store-reg! as $r.tmp0 r)
19693 (emit-undef-check! as $r.tmp0))))
19698 (define (emit-register->register! as from to)
19703 (emit-store-reg! as from to))
19705 (emit-load-reg! as from to))
19707 (emit-load-reg! as from $r.tmp0)
19708 (emit-store-reg! as $r.tmp0 to)))))
19713 (define (emit-args=! as n)
19731 (define (emit-args>=! as n)
19776 (define (emit-invoke as n setrtn? mc-exception)
19813 ; immediately be initialized by a MacScheme machine store instruction.
19814 ; The creation is done by emit-save0!, and the initialization is done
19815 ; by emit-save1!.
19817 (define (emit-save0! as n)
19837 (define (emit-save1! as v)
19852 ; FIXME: Use ldd/std here; see comments for emit-save!, above.
19855 (define (emit-restore! as n)
19864 (emit-store-reg! as $r.tmp0 r)))))))
19869 ; If returning?, then emit the return as well and put the pop
19872 (define (emit-pop! as n returning?)
19886 (define (emit-setrtn! as label)
19887 (emit-return-address! as label)
19898 (define (emit-apply! as r1 r2)
19902 (emit-move2hwreg! as r1 $r.argreg2)
19903 (emit-move2hwreg! as r2 $r.argreg3)
19909 (define (emit-load! as slot dest-reg)
19913 (emit-store-reg! as $r.tmp0 dest-reg))))
19918 (define (emit-store! as k n)
19921 (begin (emit-load-reg! as k $r.tmp0)
19927 (define (emit-lexical! as m n)
19928 (let ((base (emit-follow-chain! as m)))
19936 (define (emit-setlex! as m n)
19937 (let ((base (emit-follow-chain! as m)))
19951 (define (emit-follow-chain! as m)
19966 (define (emit-return! as)
19974 (define (emit-return-reg! as r)
19982 ; The constant c must be synthesizable in a single instruction.
19984 (define (emit-return-const! as c)
19987 (emit-constant->register as c $r.result))
19992 (define (emit-mvrtn! as)
19998 (define (emit-lexes! as n-slots)
19999 (emit-alloc-proc! as n-slots)
20004 (emit-init-proc-slots! as n-slots))
20009 (define (emit-lambda! as code-offs0 const-offs0 n-slots)
20013 (emit-alloc-proc! as n-slots)
20017 (emit-const->register! as code-offs0 $r.tmp1))
20022 (emit-const->register! as const-offs0 $r.tmp1))
20024 (emit-init-proc-slots! as n-slots)))
20028 (define emit-alloc-proc!
20033 (emit-immediate->register! as header $r.tmp0)
20045 (define (emit-init-proc-slots! as n)
20055 (emit-load-reg! as $r.reg31 $r.tmp0)
20073 (define (emit-branch! as check-timer? label)
20082 (define (emit-branchf! as label)
20083 (emit-branchfreg! as $r.result label))
20088 (define (emit-branchfreg! as hwreg label)
20096 (define (emit-branch-with-setrtn! as label)
20108 (define (emit-jump! as m label)
20109 (let* ((r (emit-follow-chain! as m))
20117 (begin (emit-immediate->register! as v $r.tmp1)
20129 (define (emit-singlestep-instr! as funky? funkyloc cvlabel)
20150 (define (emit-return-address! as label)
20154 (define (emit-short val)
20158 (define (emit-long val)
20169 (emit-short target-rel-addr)
20170 (emit-long (- target-rel-addr 8)))))
20172 (emit-short `(- ,label ,loc 8)))
20174 (emit-long `(- ,label ,loc 16))))))
20188 (define (operand5 instruction)
20189 (car (cddddr (cdr instruction))))
20191 (define (operand6 instruction)
20192 (cadr (cddddr (cdr instruction))))
20194 (define (operand7 instruction)
20195 (caddr (cddddr (cdr instruction))))
20200 (define (emit-primop.1arg! as op)
20203 (define (emit-primop.2arg! as op r)
20206 (define (emit-primop.3arg! as a1 a2 a3)
20209 (define (emit-primop.4arg! as a1 a2 a3 a4)
20212 (define (emit-primop.5arg! as a1 a2 a3 a4 a5)
20215 (define (emit-primop.6arg! as a1 a2 a3 a4 a5 a6)
20218 (define (emit-primop.7arg! as a1 a2 a3 a4 a5 a6 a7)
20247 (emit-immediate->register! as $imm.unspecified $r.result)))
20251 (emit-immediate->register! as $imm.undefined $r.result)))
20255 (emit-immediate->register! as $imm.eof $r.result)))
20271 (emit-cmp-primop! as sparc.be.a $m.zerop $r.g0)))
20275 (emit-cmp-primop! as sparc.be.a $m.numeq r)))
20279 (emit-cmp-primop! as sparc.bl.a $m.numlt r)))
20283 (emit-cmp-primop! as sparc.ble.a $m.numle r)))
20287 (emit-cmp-primop! as sparc.bg.a $m.numgt r)))
20291 (emit-cmp-primop! as sparc.bge.a $m.numge r)))
20320 (emit-set-boolean! as)))
20324 (emit-primop.4arg! as 'internal:+ $r.result r $r.result)))
20328 (emit-primop.4arg! as 'internal:- $r.result r $r.result)))
20332 (emit-multiply-code as rs2 #f)))
20334 (define (emit-multiply-code as rs2 fixnum-arithmetic?)
20381 (emit-negate as $r.result $r.result)))
20394 (emit-assert-fixnum! as $r.result $ex.lognot))
20418 (emit-shift-operation as $ex.lsh $r.result x $r.result)))
20422 (emit-shift-operation as $ex.rshl $r.result x $r.result)))
20426 (emit-shift-operation as $ex.rsha $r.result x $r.result)))
20441 (emit-set-boolean! as)))
20445 (emit-single-tagcheck->bool! as $tag.pair-tag)))
20450 (emit-set-boolean! as)))
20456 (emit-double-tagcheck->bool! as $tag.bytevector-tag
20462 (emit-double-tagcheck->bool! as $tag.bytevector-tag
20468 (emit-double-tagcheck->bool! as $tag.vector-tag
20474 (emit-double-tagcheck->bool! as $tag.vector-tag
20480 (emit-double-tagcheck->bool! as $tag.vector-tag
20488 (emit-set-boolean! as)))
20492 (emit-double-tagcheck->bool! as
20499 (emit-double-tagcheck->bool! as
20506 (emit-single-tagcheck->bool! as $tag.bytevector-tag)))
20510 (emit-double-tagcheck->bool! as
20517 (emit-single-tagcheck->bool! as $tag.vector-tag)))
20521 (emit-single-tagcheck->bool! as $tag.procedure-tag)))
20525 (emit-primop.4arg! as 'internal:cons $r.result r $r.result)))
20529 (emit-primop.3arg! as 'internal:car $r.result $r.result)))
20533 (emit-primop.3arg! as 'internal:cdr $r.result $r.result)))
20546 (emit-single-tagcheck-assert! as $tag.pair-tag $ex.car #f))
20547 (emit-setcar/setcdr! as $r.result x 0)))
20552 (emit-single-tagcheck-assert! as $tag.pair-tag $ex.cdr #f))
20553 (emit-setcar/setcdr! as $r.result x 4)))
20560 (emit-primop.4arg! as 'internal:cons $r.result $r.g0 $r.result)))
20564 (emit-primop.3arg! as 'internal:cell-ref $r.result $r.result)))
20568 (emit-setcar/setcdr! as $r.result r 0)))
20613 (emit-assert-char! as $ex.char2int #f))
20619 (emit-assert-fixnum! as $r.result $ex.int2char))
20627 (emit-set-boolean! as)))
20631 (emit-primop.4arg! as 'internal:eq? $r.result x $r.result)))
20646 (emit-assert-positive-fixnum! as $r.result $ex.mkbvl))
20647 (emit-allocate-bytevector as
20655 (let* ((fault (emit-double-tagcheck-assert! as
20668 (emit-bytevector-fill as $r.tmp0 $r.tmp1 $r.tmp2))))
20672 (emit-get-length! as
20681 (emit-get-length! as
20691 (emit-double-tagcheck-assert!
20698 (emit-bytevector-like-ref! as $r.result r $r.result fault #f #t))))
20703 (emit-single-tagcheck-assert! as
20708 (emit-bytevector-like-ref! as $r.result r $r.result fault #f #f))))
20713 (emit-double-tagcheck-assert!
20720 (emit-bytevector-like-set! as r1 r2 fault #t))))
20725 (emit-single-tagcheck-assert! as
20730 (emit-bytevector-like-set! as r1 r2 fault #f))))
20765 (emit-allocate-bytevector as
20772 (emit-bytevector-fill as $r.tmp0 $r.result $r.tmp1)
20777 (emit-primop.3arg! as 'internal:string-length $r.result $r.result)))
20781 (emit-primop.4arg! as 'internal:string-ref $r.result r $r.result)))
20785 (emit-string-set! as $r.result r1 r2)))
20793 (emit-make-vector-like! as
20800 (emit-make-vector-like! as
20837 (emit-primop.3arg! as 'internal:vector-length $r.result $r.result)))
20841 (emit-get-length! as $tag.vector-tag #f $ex.vllen $r.result $r.result)))
20845 (emit-get-length-trusted! as $tag.vector-tag $r.result $r.result)))
20849 (emit-get-length! as $tag.procedure-tag #f $ex.plen $r.result $r.result)))
20853 (emit-primop.4arg! as 'internal:vector-ref $r.result r $r.result)))
20858 (emit-single-tagcheck-assert! as
20863 (emit-vector-like-ref!
20868 (emit-vector-like-ref-trusted!
20874 (emit-single-tagcheck-assert! as
20879 (emit-vector-like-ref!
20884 (emit-primop.4arg! as 'internal:vector-set! $r.result r1 r2)))
20889 (emit-single-tagcheck-assert! as
20894 (emit-vector-like-set! as $r.result r1 r2 fault $tag.vector-tag #f))))
20898 (emit-vector-like-set-trusted! as $r.result rs2 rs3 $tag.vector-tag)))
20903 (emit-single-tagcheck-assert! as
20908 (emit-vector-like-set! as $r.result r1 r2 fault $tag.procedure-tag #f))))
20912 (emit-char-cmp as x sparc.bl.a $ex.char<?)))
20916 (emit-char-cmp as x sparc.ble.a $ex.char<=?)))
20920 (emit-char-cmp as x sparc.be.a $ex.char=?)))
20924 (emit-char-cmp as x sparc.bg.a $ex.char>?)))
20928 (emit-char-cmp as x sparc.bge.a $ex.char>=?)))
20989 (emit-single-tagcheck-assert-reg! as
20997 (emit-single-tagcheck-assert-reg! as
21010 (emit-single-tagcheck-assert-reg! as $tag.pair-tag rs1 rs2 $ex.car))
21011 (emit-setcar/setcdr! as rs1 rs2 0)))
21017 (emit-single-tagcheck-assert-reg! as $tag.pair-tag rs1 rs2 $ex.cdr))
21018 (emit-setcar/setcdr! as rs1 rs2 4)))
21023 (emit-setcar/setcdr! as rs1 rs2 0)))
21027 ; One instruction reduced here translates into about 2.5KB reduction in the
21072 (emit-get-length! as
21083 (emit-double-tagcheck-assert-reg/reg!
21090 (emit-vector-like-ref! as rs1 rs2 rd fault $tag.vector-tag #t))))
21096 (emit-double-tagcheck-assert-reg/imm!
21103 (emit-vector-like-ref/imm! as rs1 imm rd fault $tag.vector-tag #t))))
21109 (emit-double-tagcheck-assert-reg/reg!
21116 (emit-vector-like-set! as rs1 rs2 rs3 fault $tag.vector-tag #t))))
21121 (emit-get-length-trusted! as $tag.vector-tag rs1 dst)))
21125 (emit-vector-like-ref-trusted! as rs1 rs2 dst $tag.vector-tag)))
21129 (emit-vector-like-ref-trusted! as rs1 rs2 rs3 $tag.vector-tag)))
21136 (emit-get-length! as
21147 (emit-double-tagcheck-assert-reg/reg!
21154 (emit-bytevector-like-ref! as rs1 rs2 rd fault #t #t))))
21160 (emit-double-tagcheck-assert-reg/imm!
21167 (emit-bytevector-like-ref/imm! as rs1 imm rd fault #t #t))))
21172 (emit-string-set! as rs1 rs2 rs3)))
21177 (emit-arith-primop! as sparc.taddrcc sparc.subr $m.add src1 src2 dest #t)))
21182 (emit-arith-primop! as sparc.taddicc sparc.subi $m.add src1 imm dest #f)))
21187 (emit-arith-primop! as sparc.tsubrcc sparc.addr $m.subtract
21193 (emit-arith-primop! as sparc.tsubicc sparc.addi $m.subtract
21199 (emit-negate as rs rd)))
21219 (emit-bcmp-primop! as sparc.bne.a reg $r.g0 label $m.zerop #t)))
21246 (emit-bcmp-primop! as sparc.bne.a src1 src2 label $m.numeq #t)))
21251 (emit-bcmp-primop! as sparc.bge.a src1 src2 label $m.numlt #t)))
21256 (emit-bcmp-primop! as sparc.bg.a src1 src2 label $m.numle #t)))
21261 (emit-bcmp-primop! as sparc.ble.a src1 src2 label $m.numgt #t)))
21266 (emit-bcmp-primop! as sparc.bl.a src1 src2 label $m.numge #t)))
21271 (emit-bcmp-primop! as sparc.bne.a src1 imm label $m.numeq #f)))
21276 (emit-bcmp-primop! as sparc.bge.a src1 imm label $m.numlt #f)))
21281 (emit-bcmp-primop! as sparc.bg.a src1 imm label $m.numle #f)))
21286 (emit-bcmp-primop! as sparc.ble.a src1 imm label $m.numgt #f)))
21291 (emit-bcmp-primop! as sparc.bl.a src1 imm label $m.numge #f)))
21296 (emit-char-bcmp-primop! as sparc.bne.a src1 src2 label $ex.char=?)))
21301 (emit-char-bcmp-primop! as sparc.bg.a src1 src2 label $ex.char<=?)))
21306 (emit-char-bcmp-primop! as sparc.bge.a src1 src2 label $ex.char<?)))
21311 (emit-char-bcmp-primop! as sparc.bl.a src1 src2 label $ex.char>=?)))
21316 (emit-char-bcmp-primop! as sparc.ble.a src1 src2 label $ex.char>?)))
21321 (emit-char-bcmp-primop! as sparc.bne.a src imm label $ex.char=?)))
21326 (emit-char-bcmp-primop! as sparc.bl.a src imm label $ex.char>=?)))
21331 (emit-char-bcmp-primop! as sparc.ble.a src imm label $ex.char>?)))
21336 (emit-char-bcmp-primop! as sparc.bg.a src imm label $ex.char<=?)))
21341 (emit-char-bcmp-primop! as sparc.bge.a src imm label $ex.char<?)))
21348 (emit-set-boolean-reg! as dest))))
21358 (emit-set-boolean-reg! as rd)))
21384 (emit-checkcc! as sparc.bne L1 liveregs)))
21390 (emit-checkcc! as sparc.bne L1 liveregs)))
21401 (emit-checkcc! as sparc.bne L1 liveregs)))
21460 (emit-store-reg! as $r.tmp0 dest))
21475 (emit-store-reg! as $r.tmp0 dest))))))
21491 (define (emit-shift-operation as exn rs1 rs2 rd)
21505 (emit-move2hwreg! as rs2 $r.argreg2))
21526 ; The processor's zero bit has been affected by a previous instruction.
21529 (define (emit-set-boolean! as)
21530 (emit-set-boolean-reg! as $r.result))
21535 ; The processor's zero bit has been affected by a previous instruction.
21539 (define (emit-set-boolean-reg! as dest)
21549 (define (emit-single-tagcheck->bool! as tag)
21552 (emit-set-boolean! as))
21554 (define (emit-single-tagcheck-assert! as tag1 excode reg2)
21555 (emit-single-tagcheck-assert-reg! as tag1 $r.result reg2 excode))
21557 (define (emit-single-tagcheck-assert-reg! as tag1 reg reg2 excode)
21569 (define (emit-assert-fixnum! as reg excode)
21580 (define (emit-assert-char! as excode fault-label)
21608 (emit-move2hwreg! as reg2 $r.argreg2))
21622 (emit-move2hwreg! as reg2 $r.argreg2))
21632 (define (emit-assert-positive-fixnum! as reg excode)
21653 (define (emit-cmp-primop! as branch_t.a generic r)
21684 (define (emit-bcmp-primop! as branch_f.a src1 src2 Lfalse generic src2isreg)
21732 '(define (emit-arith-primop! as op invop generic src1 src2 dest src2isreg)
21774 (define (emit-arith-primop! as op invop generic rs1 rs2/imm rd op2isreg)
21825 (define (emit-negate as rs rd)
21861 (define (emit-char-cmp as r btrue.a excode)
21862 (emit-charcmp! as (lambda ()
21875 (define (emit-char-bcmp-primop! as bfalse.a op1 op2 L0 excode)
21876 (emit-charcmp! as (lambda ()
21887 ; The branch-on-true instruction must have the annull bit set. (???)
21892 (define (emit-charcmp! as tail op1 op2 excode)
21919 (emit-immediate->register! as
21953 (define (emit-setcar/setcdr! as rs1 rs2 offs)
21960 (emit-move2hwreg! as rs2 $r.argreg2)
21966 (emit-move2hwreg! as rs2 $r.argreg2)
21978 (define (emit-double-tagcheck->bool! as tag1 tag2)
21997 ; up to return to the first instruction of the emitted code.
22011 ; falls off the end of the emitted instruction sequence, then the following
22033 (emit-move2hwreg! as rs2/imm $r.argreg2))))
22035 (emit-move2hwreg! as rs3 $r.argreg3))
22045 (define (emit-double-tagcheck-assert! as tag1 tag2 excode reg2)
22048 (define (emit-double-tagcheck-assert-reg/reg! as tag1 tag2 rs1 rs2 excode)
22051 (define (emit-double-tagcheck-assert-reg/imm! as tag1 tag2 rs1 imm excode)
22062 (define (emit-get-length! as tag1 tag2 excode rs rd)
22065 (emit-double-tagcheck-assert-reg/reg! as tag1 tag2 rs rd excode)
22066 (emit-single-tagcheck-assert-reg! as tag1 rs rd excode)))
22067 (emit-get-length-trusted! as tag1 rs rd))
22073 (define (emit-get-length-trusted! as tag1 rs rd)
22082 (define (emit-allocate-bytevector as hdr preserved-result)
22111 (define (emit-bytevector-fill as r-bytecount r-pointer r-value)
22132 (define (emit-bytevector-like-ref! as rs1 rs2 rd fault charize? header-loaded?)
22162 ; instruction's immediate field.
22164 (define (emit-bytevector-like-ref/imm! as rs1 imm rd fault charize?
22207 (define (emit-bytevector-like-set! as idx byte fault header-loaded?)
22219 ; No NOP -- next instruction is OK in slot.
22225 ; No NOP -- next instruction is OK in slot.
22238 (define (emit-string-set! as rs1 rs2 rs3)
22284 (emit-immediate->register! as (+ (* 256 (thefixnum length))
22296 ; emit-make-vector-like! assumes argreg3 is not destroyed by alloci.
22300 (define (emit-make-vector-like! as r hdr ptrtag)
22301 (let ((FAULT (emit-assert-positive-fixnum! as $r.result $ex.mkvl)))
22307 (emit-move2hwreg! as r $r.argreg2))
22319 (define (emit-vector-like-ref! as rs1 rs2 rd FAULT tag header-loaded?)
22332 ; No NOP; the following instruction is valid in the slot.
22334 (emit-vector-like-ref-trusted! as rs1 index rd tag)))
22336 (define (emit-vector-like-ref-trusted! as rs1 rs2 rd tag)
22352 (define (emit-vector-like-ref/imm! as rs1 imm rd FAULT tag header-loaded?)
22361 (emit-vector-like-ref/imm-trusted! as rs1 imm rd tag))
22369 (define (emit-vector-like-ref/imm-trusted! as rs1 imm rd tag)
22392 (define (emit-vector-like-set! as rs1 rs2 rs3 fault tag header-loaded?)
22404 (emit-vector-like-set-trusted! as rs1 rs2 rs3 tag)))
22409 (define (emit-vector-like-set-trusted! as rs1 rs2 rs3 tag)
22460 (emit-immediate->register! as (asm:signed #x80000000) $r.result)))
22464 (emit-immediate->register! as (asm:signed #x7FFFFFFC) $r.result)))
22471 (emit-fixnum-arithmetic as sparc.taddrcc sparc.addr $r.result rs2 $r.result
22476 (emit-fixnum-arithmetic as sparc.taddrcc sparc.addr rs1 rs2 rd $ex.fx+)))
22480 (emit-fixnum-arithmetic as sparc.tsubrcc sparc.subr $r.result rs2 $r.result
22485 (emit-fixnum-arithmetic as sparc.tsubrcc sparc.subr rs1 rs2 rd $ex.fx-)))
22489 (emit-fixnum-arithmetic as sparc.tsubrcc sparc.subr
22494 (emit-fixnum-arithmetic as sparc.tsubrcc sparc.subr $r.g0 rs rd $ex.fx--)))
22496 (define (emit-fixnum-arithmetic as op-check op-nocheck rs1 rs2 rd exn)
22521 (emit-multiply-code as rs2 #t)))
22527 (emit-fixnum-arithmetic/imm as sparc.taddicc sparc.addi
22532 (emit-fixnum-arithmetic/imm as sparc.tsubicc sparc.subi
22535 (define (emit-fixnum-arithmetic/imm as op-check op-nocheck rs imm rd exn)
22555 (emit-fixnum-compare as sparc.bne.a $r.result rs2 $r.result $ex.fx= #f)))
22559 (emit-fixnum-compare as sparc.bge.a $r.result rs2 $r.result $ex.fx< #f)))
22563 (emit-fixnum-compare as sparc.bg.a $r.result rs2 $r.result $ex.fx<= #f)))
22567 (emit-fixnum-compare as sparc.ble.a $r.result rs2 $r.result $ex.fx> #f)))
22571 (emit-fixnum-compare as sparc.bl.a $r.result rs2 $r.result $ex.fx>= #f)))
22575 (emit-fixnum-compare as sparc.bne.a rs1 rs2 rd $ex.fx= #f)))
22579 (emit-fixnum-compare as sparc.bge.a rs1 rs2 rd $ex.fx< #f)))
22583 (emit-fixnum-compare as sparc.bg.a rs1 rs2 rd $ex.fx<= #f)))
22587 (emit-fixnum-compare as sparc.ble.a rs1 rs2 rd $ex.fx> #f)))
22591 (emit-fixnum-compare as sparc.bl.a rs1 rs2 rd $ex.fx>= #f)))
22598 (emit-fixnum-compare/imm as sparc.ble.a $r.result 0 $r.result
22603 (emit-fixnum-compare/imm as sparc.bge.a $r.result 0 $r.result
22608 (emit-fixnum-compare/imm as sparc.bne.a $r.result 0 $r.result
22613 (emit-fixnum-compare/imm as sparc.ble.a rs 0 rd $ex.fxpositive? #f)))
22617 (emit-fixnum-compare/imm as sparc.bge.a rs 0 rd $ex.fxnegative? #f)))
22621 (emit-fixnum-compare/imm as sparc.bne.a rs 0 rd $ex.fxzero? #f)))
22628 (emit-fixnum-compare/imm as sparc.bne.a rs imm rd $ex.fx= #f)))
22632 (emit-fixnum-compare/imm as sparc.bge.a rs imm rd $ex.fx< #f)))
22636 (emit-fixnum-compare/imm as sparc.bg.a rs imm rd $ex.fx<= #f)))
22640 (emit-fixnum-compare/imm as sparc.ble.a rs imm rd $ex.fx> #f)))
22644 (emit-fixnum-compare/imm as sparc.bl.a rs imm rd $ex.fx>= #f)))
22651 (emit-fixnum-compare as sparc.bne.a rs1 rs2 #f $ex.fx= L)))
22655 (emit-fixnum-compare as sparc.bge.a rs1 rs2 #f $ex.fx< L)))
22659 (emit-fixnum-compare as sparc.bg.a rs1 rs2 #f $ex.fx<= L)))
22663 (emit-fixnum-compare as sparc.ble.a rs1 rs2 #f $ex.fx> L)))
22667 (emit-fixnum-compare as sparc.bl.a rs1 rs2 #f $ex.fx>= L)))
22671 (emit-fixnum-compare/imm as sparc.ble.a rs1 0 #f $ex.fxpositive? L)))
22675 (emit-fixnum-compare/imm as sparc.bge.a rs1 0 #f $ex.fxnegative? L)))
22679 (emit-fixnum-compare/imm as sparc.bne.a rs1 0 #f $ex.fxzero? L)))
22686 (emit-fixnum-compare/imm as sparc.bne.a rs imm #f $ex.fx= L)))
22690 (emit-fixnum-compare/imm as sparc.bge.a rs imm #f $ex.fx< L)))
22694 (emit-fixnum-compare/imm as sparc.bg.a rs imm #f $ex.fx<= L)))
22698 (emit-fixnum-compare/imm as sparc.ble.a rs imm #f $ex.fx> L)))
22702 (emit-fixnum-compare/imm as sparc.bl.a rs imm #f $ex.fx>= L)))
22709 (emit-fixnum-compare-trusted as sparc.bne.a $r.result rs2 $r.result #f)))
22713 (emit-fixnum-compare-trusted as sparc.bge.a $r.result rs2 $r.result #f)))
22717 (emit-fixnum-compare-trusted as sparc.bg.a $r.result rs2 $r.result #f)))
22721 (emit-fixnum-compare-trusted as sparc.ble.a $r.result rs2 $r.result #f)))
22725 (emit-fixnum-compare-trusted as sparc.bl.a $r.result rs2 $r.result #f)))
22729 (emit-fixnum-compare-trusted as sparc.bne.a rs1 rs2 rd #f)))
22733 (emit-fixnum-compare-trusted as sparc.bge.a rs1 rs2 rd #f)))
22737 (emit-fixnum-compare-trusted as sparc.bg.a rs1 rs2 rd #f)))
22741 (emit-fixnum-compare-trusted as sparc.ble.a rs1 rs2 rd #f)))
22745 (emit-fixnum-compare-trusted as sparc.bl.a rs1 rs2 rd #f)))
22751 (emit-fixnum-compare/imm-trusted as sparc.bne.a rs imm rd #f)))
22755 (emit-fixnum-compare/imm-trusted as sparc.bge.a rs imm rd #f)))
22759 (emit-fixnum-compare/imm-trusted as sparc.bg.a rs imm rd #f)))
22763 (emit-fixnum-compare/imm-trusted as sparc.ble.a rs imm rd #f)))
22767 (emit-fixnum-compare/imm-trusted as sparc.bl.a rs imm rd #f)))
22773 (emit-fixnum-compare-trusted as sparc.bne.a rs1 rs2 #f L)))
22777 (emit-fixnum-compare-trusted as sparc.bge.a rs1 rs2 #f L)))
22781 (emit-fixnum-compare-trusted as sparc.bg.a rs1 rs2 #f L)))
22785 (emit-fixnum-compare-trusted as sparc.ble.a rs1 rs2 #f L)))
22789 (emit-fixnum-compare-trusted as sparc.bl.a rs1 rs2 #f L)))
22795 (emit-fixnum-compare/imm-trusted as sparc.bne.a rs imm #f L)))
22799 (emit-fixnum-compare/imm-trusted as sparc.bge.a rs imm #f L)))
22803 (emit-fixnum-compare/imm-trusted as sparc.bg.a rs imm #f L)))
22807 (emit-fixnum-compare/imm-trusted as sparc.ble.a rs imm #f L)))
22811 (emit-fixnum-compare/imm-trusted as sparc.bl.a rs imm #f L)))
22818 (emit-fixnum-compare-check
22825 (emit-fixnum-compare-check
22830 (emit-fixnum-compare-check
22835 (emit-fixnum-compare-check
22840 (emit-fixnum-compare-check
22845 (emit-fixnum-compare-check
22850 (emit-fixnum-compare/imm-check
22855 (emit-fixnum-compare/imm-check
22860 (emit-fixnum-compare/imm-check
22865 (emit-fixnum-compare/imm-check
22870 (emit-fixnum-compare/imm-check
22876 (define (emit-fixnum-compare as branchf.a rs1 rs2 rd exn target)
22878 (emit-fixnum-compare-trusted as branchf.a rs1 rs2 rd target)
22892 (emit-evaluate-cc! as branchf.a rd target))))
22897 (define (emit-fixnum-compare-trusted as branchf.a rs1 rs2 rd target)
22900 (emit-evaluate-cc! as branchf.a rd target)))
22904 (define (emit-fixnum-compare/imm as branchf.a rs imm rd exn target)
22906 (emit-fixnum-compare/imm-trusted as branchf.a rs imm rd target)
22918 (emit-evaluate-cc! as branchf.a rd target))
22922 (define (emit-fixnum-compare/imm-trusted as branchf.a rs imm rd target)
22924 (emit-evaluate-cc! as branchf.a rd target))
22928 (define (emit-fixnum-compare-check
22930 (internal-primop-invariant1 'emit-fixnum-compare-check src1)
22933 (emit-checkcc! as branch-bad L1 liveregs)))
22935 (define (emit-fixnum-compare/imm-check
22937 (internal-primop-invariant1 'emit-fixnum-compare/imm-check src1)
22939 (emit-checkcc! as branch-bad L1 liveregs))
23043 ; (disassemble-instruction instruction address)
23044 ; => decoded-instruction
23047 ; => decoded-instruction-list
23049 ; (print-instructions decoded-instruction-list)
23053 ; (format-instruction decoded-instruction address larceny-names?)
23056 ; A `decoded-instruction' is a list where the car is a mnemonic and
23060 ; the instruction as well as its attributes (operand pattern and instruction
23068 (cons (disassemble-instruction (bytevector-word-ref cv addr)
23073 (define disassemble-instruction) ; Defined below.
23254 ;; Class 1 is the call instruction; there's no choice.
23331 (fpop-instruction ip instr)
23332 (nice-instruction op3-table ip instr))))))
23405 (nice-instruction op3-table ip instr))))
23409 (define (nice-instruction op3-table ip instr)
23422 (define (fpop-instruction ip instr)
23440 ;; The following procedures pick apart an instruction
23481 (set! disassemble-instruction
23486 'disassemble-instruction)
23491 ; It assumes that the first instruction comes from address 0, and prints
23505 (begin (display (format-instruction (car ilist) a larceny-names?)
23519 (define format-instruction) ; Defined below
23663 ;; If we want to handle instruction aliases (clr, mov, etc) then
23769 (set! format-instruction format-instr)
23770 'format-instruction)