home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / compiler / machines / sparc / rulfix.scm < prev    next >
Encoding:
Text File  |  1999-01-02  |  18.9 KB  |  552 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: rulfix.scm,v 1.2 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 1989-1999 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; LAP Generation Rules: Fixnum Rules
  23. ;;; package: (compiler lap-syntaxer)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. ;;;; Conversions
  28.  
  29. (define-rule statement
  30.   ;; convert a fixnum object to a "fixnum integer"
  31.   (ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (REGISTER (? source))))
  32.   (standard-unary-conversion source target object->fixnum))
  33.  
  34. (define-rule statement
  35.   ;; load a fixnum constant as a "fixnum integer"
  36.   (ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (CONSTANT (? constant))))
  37.   (load-immediate (standard-target! target) (* constant fixnum-1) #T))
  38.  
  39. (define-rule statement
  40.   ;; convert a memory address to a "fixnum integer"
  41.   (ASSIGN (REGISTER (? target)) (ADDRESS->FIXNUM (REGISTER (? source))))
  42.   (standard-unary-conversion source target address->fixnum))
  43.  
  44. (define-rule statement
  45.   ;; convert an object's address to a "fixnum integer"
  46.   (ASSIGN (REGISTER (? target))
  47.       (ADDRESS->FIXNUM (OBJECT->ADDRESS (REGISTER (? source)))))
  48.   (standard-unary-conversion source target object->fixnum))
  49.  
  50. (define-rule statement
  51.   ;; convert a "fixnum integer" to a fixnum object
  52.   (ASSIGN (REGISTER (? target)) (FIXNUM->OBJECT (REGISTER (? source))))
  53.   (standard-unary-conversion source target fixnum->object))
  54.  
  55. (define-rule statement
  56.   ;; convert a "fixnum integer" to a memory address
  57.   (ASSIGN (REGISTER (? target)) (FIXNUM->ADDRESS (REGISTER (? source))))
  58.   (standard-unary-conversion source target fixnum->address))
  59.  
  60. (define-rule statement
  61.   (ASSIGN (REGISTER (? target))
  62.       (FIXNUM-2-ARGS MULTIPLY-FIXNUM
  63.              (OBJECT->FIXNUM (CONSTANT 4))
  64.              (OBJECT->FIXNUM (REGISTER (? source)))
  65.              #F))
  66.   (standard-unary-conversion source target object->index-fixnum))
  67.  
  68. (define-rule statement
  69.   (ASSIGN (REGISTER (? target))
  70.       (FIXNUM-2-ARGS MULTIPLY-FIXNUM
  71.              (OBJECT->FIXNUM (REGISTER (? source)))
  72.              (OBJECT->FIXNUM (CONSTANT 4))
  73.              #F))
  74.   (standard-unary-conversion source target object->index-fixnum))
  75.  
  76. ;; This is a patch for the time being.  Probably only one of these pairs
  77. ;; of rules is needed.
  78.  
  79. (define-rule statement
  80.   (ASSIGN (REGISTER (? target))
  81.       (FIXNUM-2-ARGS MULTIPLY-FIXNUM
  82.              (OBJECT->FIXNUM (CONSTANT 4))
  83.              (REGISTER (? source))
  84.              #F))
  85.   (standard-unary-conversion source target fixnum->index-fixnum))
  86.  
  87. (define-rule statement
  88.   (ASSIGN (REGISTER (? target))
  89.       (FIXNUM-2-ARGS MULTIPLY-FIXNUM
  90.              (REGISTER (? source))
  91.              (OBJECT->FIXNUM (CONSTANT 4))
  92.              #F))
  93.   (standard-unary-conversion source target fixnum->index-fixnum))
  94.  
  95. ;; "Fixnum" in this context means an integer left shifted so that
  96. ;; the sign bit is the leftmost bit of the word, i.e., the datum
  97. ;; has been left shifted by scheme-type-width bits.
  98.  
  99. (define-integrable (fixnum->index-fixnum src tgt)
  100.   ; Shift left 2 bits
  101.   (LAP (SLL ,tgt ,src 2)))
  102.  
  103. (define-integrable (object->fixnum src tgt)
  104.   ; Shift left by scheme-type-width
  105.   (LAP (SLL ,tgt ,src ,scheme-type-width)))
  106.  
  107. (define-integrable (object->index-fixnum src tgt)
  108.   ; Shift left by scheme-type-width+2
  109.   (LAP (SLL ,tgt ,src ,(+ scheme-type-width 2))))
  110.  
  111. (define-integrable (address->fixnum src tgt)
  112.   ; Strip off type bits, just like object->fixnum
  113.   (LAP (SLL ,tgt ,src ,scheme-type-width)))
  114.  
  115. (define-integrable (fixnum->object src tgt)
  116.   ; Move right by type code width and put on fixnum type code
  117.   (LAP (SRL ,tgt ,src ,scheme-type-width)
  118.        ,@(deposit-type-datum (ucode-type fixnum) tgt tgt)))
  119.  
  120. (define (fixnum->address src tgt)
  121.   ; Move right by type code width and put in address bits
  122.   (LAP (SRL ,tgt ,src ,scheme-type-width)
  123.        (OR ,tgt ,tgt ,regnum:quad-bits)))
  124.  
  125. (define-integrable fixnum-1
  126.   (expt 2 scheme-type-width))
  127.  
  128. (define-integrable -fixnum-1
  129.   (- fixnum-1))
  130.  
  131. (define (no-overflow-branches!)
  132.   (set-current-branches!
  133.    (lambda (if-overflow)
  134.      if-overflow
  135.      (LAP))
  136.    (lambda (if-no-overflow)
  137.      (LAP (BA (@PCR ,if-no-overflow))
  138.       (NOP)))))
  139.  
  140. (define (guarantee-signed-fixnum n)
  141.   (if (not (signed-fixnum? n)) (error "Not a signed fixnum" n))
  142.   n)
  143.  
  144. (define (signed-fixnum? n)
  145.   (and (exact-integer? n)
  146.        (>= n signed-fixnum/lower-limit)
  147.        (< n signed-fixnum/upper-limit)))
  148.  
  149. ;;;; Arithmetic Operations
  150.  
  151. (define-rule statement
  152.   ;; execute a unary fixnum operation
  153.   (ASSIGN (REGISTER (? target))
  154.       (FIXNUM-1-ARG (? operation)
  155.             (REGISTER (? source))
  156.             (? overflow?)))
  157.   (standard-unary-conversion source target
  158.     (lambda (source target)
  159.       ((fixnum-1-arg/operator operation) target source overflow?))))
  160.  
  161. (define (fixnum-1-arg/operator operation)
  162.   (lookup-arithmetic-method operation fixnum-methods/1-arg))
  163.  
  164. (define fixnum-methods/1-arg
  165.   (list 'FIXNUM-METHODS/1-ARG))
  166.  
  167. (define-arithmetic-method 'ONE-PLUS-FIXNUM fixnum-methods/1-arg
  168.   (lambda (tgt src overflow?)
  169.     (fixnum-add-constant tgt src 1 overflow?)))
  170.  
  171. (define-arithmetic-method 'MINUS-ONE-PLUS-FIXNUM fixnum-methods/1-arg
  172.   (lambda (tgt src overflow?)
  173.     (fixnum-add-constant tgt src -1 overflow?)))
  174.  
  175. (define (fixnum-add-constant tgt src constant overflow?)
  176.   (let ((constant (* fixnum-1 constant)))
  177.     (cond ((not overflow?)
  178.        (add-immediate constant src tgt))
  179.       ((= constant 0)
  180.        (no-overflow-branches!)
  181.        (LAP (ADDIU ,tgt ,src 0)))
  182.       (else
  183.        (let ((bcc (if (> constant 0) 'BLE 'BGE)))
  184.          (let ((prefix
  185.             (if (fits-in-16-bits-signed? constant)
  186.             (lambda (label)
  187.               (LAP (SUBCCI ,regnum:assembler-temp 0 ,src)
  188.                    (,bcc ,regnum:assembler-temp (@PCR ,label))
  189.                    (ADDIU ,tgt ,src ,constant)))
  190.             (with-values (lambda () (immediate->register constant))
  191.               (lambda (prefix alias)
  192.                 (lambda (label)
  193.                   (LAP ,@prefix
  194.                    (,bcc ,src (@PCR ,label))
  195.                    (ADDU ,tgt ,src ,alias))))))))
  196.            (if (> constant 0)
  197.            (set-current-branches!
  198.             (lambda (if-overflow)
  199.               (let ((if-no-overflow (generate-label)))
  200.             (LAP ,@(prefix if-no-overflow)
  201.                  (SUBCCI ,regnum:assembler-temp 0 ,tgt)               
  202.                  (BLT ,tgt (@PCR ,if-overflow))
  203.                  (NOP)
  204.                  (LABEL ,if-no-overflow))))
  205.             (lambda (if-no-overflow)
  206.               (LAP ,@(prefix if-no-overflow)
  207.                (SUBCCI ,regnum:assembler-temp 0 ,tgt)               
  208.                (BGE ,tgt (@PCR ,if-no-overflow))
  209.                (NOP))))
  210.            (set-current-branches!
  211.             (lambda (if-overflow)
  212.               (let ((if-no-overflow (generate-label)))
  213.             (LAP ,@(prefix if-no-overflow)
  214.                  (SUBCCI ,regnum:assembler-temp 0 ,tgt)               
  215.                  (BGE ,tgt (@PCR ,if-overflow))
  216.                  (NOP)
  217.                  (LABEL ,if-no-overflow))))
  218.             (lambda (if-no-overflow)
  219.               (LAP ,@(prefix if-no-overflow)
  220.                (BLTZ ,tgt (@PCR ,if-no-overflow))
  221.                (NOP)))))))
  222.        (LAP)))))
  223.  
  224. (define-rule statement
  225.   ;; execute a binary fixnum operation
  226.   (ASSIGN (REGISTER (? target))
  227.       (FIXNUM-2-ARGS (? operation)
  228.              (REGISTER (? source1))
  229.              (REGISTER (? source2))
  230.              (? overflow?)))
  231.   (standard-binary-conversion source1 source2 target
  232.     (lambda (source1 source2 target)
  233.       ((fixnum-2-args/operator operation) target source1 source2 overflow?))))
  234.  
  235. (define (fixnum-2-args/operator operation)
  236.   (lookup-arithmetic-method operation fixnum-methods/2-args))
  237.  
  238. (define fixnum-methods/2-args
  239.   (list 'FIXNUM-METHODS/2-ARGS))
  240.  
  241. (define-arithmetic-method 'PLUS-FIXNUM fixnum-methods/2-args
  242.   (lambda (tgt src1 src2 overflow?)
  243.     (if overflow?
  244.     (do-overflow-addition tgt src1 src2)
  245.     (LAP (ADDU ,tgt ,src1 ,src2)))))
  246.  
  247. ;;; Use of REGNUM:ASSEMBLER-TEMP is OK here, but only because its
  248. ;;; value is not used after the branch instruction that tests it.
  249. ;;; The long form of the @PCR branch will test it correctly, but
  250. ;;; clobbers it after testing.
  251.  
  252. (define (do-overflow-addition tgt src1 src2)
  253.   (cond ((not (= src1 src2))
  254.      (set-current-branches!
  255.       (lambda (if-overflow)
  256.         (let ((if-no-overflow (generate-label)))
  257.           (LAP (XOR  ,regnum:assembler-temp ,src1 ,src2)
  258.            (BLTZ ,regnum:assembler-temp (@PCR ,if-no-overflow))
  259.            (ADDU ,tgt ,src1 ,src2)
  260.            (XOR  ,regnum:assembler-temp
  261.              ,tgt
  262.              ,(if (= tgt src1) src2 src1))
  263.            (BLTZ ,regnum:assembler-temp (@PCR ,if-overflow))
  264.            (NOP)
  265.            (LABEL ,if-no-overflow))))
  266.       (lambda (if-no-overflow)
  267.         (LAP (XOR  ,regnum:assembler-temp ,src1 ,src2)
  268.          (SUBCCI ,regnum:assembler-temp ,regnum:assembler-temp 0)           
  269.          (BLT ,regnum:assembler-temp (@PCR ,if-no-overflow))
  270.          (ADDU ,tgt ,src1 ,src2)
  271.          (XOR  ,regnum:assembler-temp
  272.                ,tgt
  273.                ,(if (= tgt src1) src2 src1))
  274.          (SUBCCI ,regnum:assembler-temp ,regnum:assembler-temp 0)           
  275.          (BGE ,regnum:assembler-temp (@PCR ,if-no-overflow))
  276.          (NOP)))))
  277.     ((not (= tgt src1))
  278.      (set-current-branches!
  279.       (lambda (if-overflow)
  280.         (LAP (ADDU ,tgt ,src1 ,src1)
  281.          (XOR  ,regnum:assembler-temp ,tgt ,src1)
  282.          (SUBCCI ,regnum:assembler-temp ,regnum:assembler-temp 0)           
  283.          (BLT ,regnum:assembler-temp (@PCR ,if-overflow))
  284.          (NOP)))
  285.       (lambda (if-no-overflow)
  286.         (LAP (ADDU ,tgt ,src1 ,src1)
  287.          (XOR  ,regnum:assembler-temp ,tgt ,src1)
  288.          (SUBCCI ,regnum:assembler-temp ,regnum:assembler-temp 0)           
  289.          (BGE ,regnum:assembler-temp (@PCR ,if-no-overflow))
  290.          (NOP)))))
  291.     (else
  292.      (let ((temp (standard-temporary!)))
  293.        (set-current-branches!
  294.         (lambda (if-overflow)
  295.           (LAP (ADDU ,temp ,src1 ,src1)
  296.            (XOR  ,regnum:assembler-temp ,temp ,src1)
  297.            (SUBCCI ,regnum:assembler-temp ,regnum:assembler-temp 0)           
  298.            (BLT ,regnum:assembler-temp (@PCR ,if-overflow))
  299.            (ADD  ,tgt 0 ,temp)))
  300.         (lambda (if-no-overflow)
  301.           (LAP (ADDU ,temp ,src1 ,src1)
  302.            (XOR  ,regnum:assembler-temp ,temp ,src1)
  303.            (SUBCCI ,regnum:assembler-temp ,regnum:assembler-temp 0)           
  304.            (BGE ,regnum:assembler-temp (@PCR ,if-no-overflow))
  305.            (ADD  ,tgt 0 ,temp)))))))
  306.   (LAP))
  307.  
  308. (define-arithmetic-method 'MINUS-FIXNUM fixnum-methods/2-args
  309.   (lambda (tgt src1 src2 overflow?)
  310.     (if overflow?
  311.     (if (= src1 src2)        ;probably won't ever happen.
  312.         (begin
  313.           (no-overflow-branches!)
  314.           (LAP (SUBU ,tgt ,src1 ,src1)))
  315.         (do-overflow-subtraction tgt src1 src2))
  316.     (LAP (SUB ,tgt ,src1 ,src2)))))
  317.  
  318. (define (do-overflow-subtraction tgt src1 src2)
  319.   (set-current-branches!
  320.    (lambda (if-overflow)
  321.      (let ((if-no-overflow (generate-label)))
  322.        (LAP (XOR  ,regnum:assembler-temp ,src1 ,src2)
  323.         (SUBCCI ,regnum:assembler-temp ,regnum:assembler-temp 0)           
  324.         (BGE ,regnum:assembler-temp (@PCR ,if-no-overflow))
  325.         (SUBU ,tgt ,src1 ,src2)
  326.         ,@(if (not (= tgt src1))
  327.           (LAP (XOR  ,regnum:assembler-temp ,tgt ,src1)
  328.                (SUBCCI ,regnum:assembler-temp ,regnum:assembler-temp 0)           
  329.                (BLT ,regnum:assembler-temp (@PCR ,if-overflow)))
  330.           (LAP (XOR  ,regnum:assembler-temp ,tgt ,src2)
  331.                (SUBCCI ,regnum:assembler-temp ,regnum:assembler-temp 0)           
  332.                (BGE ,regnum:assembler-temp (@PCR ,if-overflow))))
  333.         (NOP)
  334.         (LABEL ,if-no-overflow))))
  335.    (lambda (if-no-overflow)
  336.      (LAP (XOR  ,regnum:assembler-temp ,src1 ,src2)
  337.       (SUBCCI ,regnum:assembler-temp ,regnum:assembler-temp 0)           
  338.       (BGE ,regnum:assembler-temp (@PCR ,if-no-overflow))
  339.       (SUBU ,tgt ,src1 ,src2)
  340.       ,@(if (not (= tgt src1))
  341.         (LAP (XOR  ,regnum:assembler-temp ,tgt ,src1)
  342.              (SUBCCI ,regnum:assembler-temp ,regnum:assembler-temp 0)           
  343.              (BGE ,regnum:assembler-temp (@PCR ,if-no-overflow)))
  344.         (LAP (XOR  ,regnum:assembler-temp ,tgt ,src2)
  345.              (SUBCCI ,regnum:assembler-temp ,regnum:assembler-temp 0g)           
  346.              (BLT ,regnum:assembler-temp (@PCR ,if-no-overflow))))
  347.       (NOP))))
  348.   (LAP))
  349.  
  350. (define (do-multiply tgt src1 src2 overflow?)
  351.   (if overflow?
  352.       (let ((temp (standard-temporary!)))
  353.     (set-current-branches!
  354.      (lambda (if-overflow)
  355.        (LAP (MFHI ,temp)
  356.         (SRA  ,regnum:assembler-temp ,tgt 31)
  357.         (BNE  ,temp ,regnum:assembler-temp
  358.               (@PCR ,if-overflow))
  359.         (NOP)))
  360.      (lambda (if-no-overflow)
  361.        (LAP (MFHI ,temp)
  362.         (SRA  ,regnum:assembler-temp ,tgt 31)
  363.         (BEQ  ,temp ,regnum:assembler-temp
  364.               (@PCR ,if-no-overflow))
  365.         (NOP))))))
  366.   (LAP (SRA  ,regnum:assembler-temp ,src1 ,scheme-type-width)
  367.        (MULT ,regnum:assembler-temp ,src2)
  368.        (MFLO ,tgt)))
  369.  
  370. (define-arithmetic-method 'MULTIPLY-FIXNUM fixnum-methods/2-args do-multiply)
  371.  
  372. (define-rule statement
  373.   ;; execute binary fixnum operation with constant second arg
  374.   (ASSIGN (REGISTER (? target))
  375.       (FIXNUM-2-ARGS (? operation)
  376.              (REGISTER (? source))
  377.              (OBJECT->FIXNUM (CONSTANT (? constant)))
  378.              (? overflow?)))
  379.   (standard-unary-conversion source target
  380.     (lambda (source target)
  381.       ((fixnum-2-args/operator/register*constant operation)
  382.        target source constant overflow?))))
  383.  
  384. (define-rule statement
  385.   ;; execute binary fixnum operation with constant first arg
  386.   (ASSIGN (REGISTER (? target))
  387.       (FIXNUM-2-ARGS (? operation)
  388.              (OBJECT->FIXNUM (CONSTANT (? constant)))
  389.              (REGISTER (? source))
  390.              (? overflow?)))
  391.   (standard-unary-conversion source target
  392.     (lambda (source target)
  393.       (if (fixnum-2-args/commutative? operation)
  394.       ((fixnum-2-args/operator/register*constant operation)
  395.        target source constant overflow?)
  396.       ((fixnum-2-args/operator/constant*register operation)
  397.        target constant source overflow?)))))
  398.  
  399. (define (fixnum-2-args/commutative? operator)
  400.   (memq operator '(PLUS-FIXNUM MULTIPLY-FIXNUM)))
  401.  
  402. (define (fixnum-2-args/operator/register*constant operation)
  403.   (lookup-arithmetic-method operation fixnum-methods/2-args/register*constant))
  404.  
  405. (define fixnum-methods/2-args/register*constant
  406.   (list 'FIXNUM-METHODS/2-ARGS/REGISTER*CONSTANT))
  407.  
  408. (define (fixnum-2-args/operator/constant*register operation)
  409.   (lookup-arithmetic-method operation
  410.                 fixnum-methods/2-args/constant*register))
  411.  
  412. (define fixnum-methods/2-args/constant*register
  413.   (list 'FIXNUM-METHODS/2-ARGS/CONSTANT*REGISTER))
  414.  
  415. (define-arithmetic-method 'PLUS-FIXNUM
  416.   fixnum-methods/2-args/register*constant
  417.   (lambda (tgt src constant overflow?)
  418.     (guarantee-signed-fixnum constant)
  419.     (fixnum-add-constant tgt src constant overflow?)))
  420.  
  421. (define-arithmetic-method 'MINUS-FIXNUM
  422.   fixnum-methods/2-args/register*constant
  423.   (lambda (tgt src constant overflow?)
  424.     (guarantee-signed-fixnum constant)
  425.     (fixnum-add-constant tgt src (- constant) overflow?)))
  426.  
  427. (define-arithmetic-method 'MULTIPLY-FIXNUM
  428.   fixnum-methods/2-args/register*constant
  429.   (lambda (tgt src constant overflow?)
  430.     (cond ((zero? constant)
  431.        (if overflow? (no-overflow-branches!))
  432.        (LAP (ADDI ,tgt 0 0)))
  433.       ((= constant 1) 
  434.        (if overflow? (no-overflow-branches!))
  435.        (LAP (ADD ,tgt 0 ,src)))
  436.       ((let loop ((n constant))
  437.          (and (> n 0)
  438.           (if (= n 1)
  439.               0
  440.               (and (even? n)
  441.                (let ((m (loop (quotient n 2))))
  442.                  (and m
  443.                   (+ m 1)))))))
  444.        =>
  445.        (lambda (power-of-two)
  446.          (if overflow?
  447.          (do-left-shift-overflow tgt src power-of-two)
  448.          (LAP (SLL ,tgt ,src ,power-of-two)))))
  449.       (else
  450.        (with-values (lambda () (immediate->register (* constant fixnum-1)))
  451.          (lambda (prefix alias)
  452.            (LAP ,@prefix
  453.             ,@(do-multiply tgt src alias overflow?))))))))
  454.  
  455. (define (do-left-shift-overflow tgt src power-of-two)
  456.   (if (= tgt src)
  457.       (let ((temp (standard-temporary!)))
  458.     (set-current-branches!
  459.      (lambda (if-overflow)
  460.        (LAP (SLL  ,temp ,src ,power-of-two)
  461.         (SRA  ,regnum:assembler-temp ,temp ,power-of-two)
  462.         (BNE  ,regnum:assembler-temp ,src (@PCR ,if-overflow))
  463.         (ADD  ,tgt 0 ,temp)))
  464.      (lambda (if-no-overflow)
  465.        (LAP (SLL  ,temp ,src ,power-of-two)
  466.         (SRA  ,regnum:assembler-temp ,temp ,power-of-two)
  467.         (BEQ  ,regnum:assembler-temp ,src (@PCR ,if-no-overflow))
  468.         (ADD  ,tgt 0 ,temp)))))
  469.       (set-current-branches!
  470.        (lambda (if-overflow)
  471.      (LAP (SLL  ,tgt ,src ,power-of-two)
  472.           (SRA  ,regnum:assembler-temp ,tgt ,power-of-two)
  473.           (BNE  ,regnum:assembler-temp ,src (@PCR ,if-overflow))
  474.           (NOP)))
  475.        (lambda (if-no-overflow)
  476.      (LAP (SLL  ,tgt ,src ,power-of-two)
  477.           (SRA  ,regnum:assembler-temp ,tgt ,power-of-two)
  478.           (BEQ  ,regnum:assembler-temp ,src (@PCR ,if-no-overflow))
  479.           (NOP)))))
  480.   (LAP))
  481.  
  482. (define-arithmetic-method 'MINUS-FIXNUM
  483.   fixnum-methods/2-args/constant*register
  484.   (lambda (tgt constant src overflow?)
  485.     (guarantee-signed-fixnum constant)
  486.     (with-values (lambda () (immediate->register (* constant fixnum-1)))
  487.       (lambda (prefix alias)
  488.     (LAP ,@prefix
  489.          ,@(if overflow?
  490.            (do-overflow-subtraction tgt alias src)
  491.            (LAP (SUB ,tgt ,alias ,src))))))))
  492.  
  493. ;;;; Predicates
  494.  
  495. (define-rule predicate
  496.   (OVERFLOW-TEST)
  497.   ;; The RTL code generate guarantees that this instruction is always
  498.   ;; immediately preceded by a fixnum operation with the OVERFLOW?
  499.   ;; flag turned on.  Furthermore, it also guarantees that there are
  500.   ;; no other fixnum operations with the OVERFLOW? flag set.  So all
  501.   ;; the processing of overflow tests has been moved into the fixnum
  502.   ;; operations.
  503.   (LAP))
  504.  
  505. (define-rule predicate
  506.   (FIXNUM-PRED-1-ARG (? predicate) (REGISTER (? source)))
  507.   (compare-immediate (fixnum-pred-1->cc predicate)
  508.              0
  509.              (standard-source! source)))
  510.  
  511. (define (fixnum-pred-1->cc predicate)
  512.   (case predicate
  513.     ((ZERO-FIXNUM?) '=)
  514.     ((NEGATIVE-FIXNUM?) '>)
  515.     ((POSITIVE-FIXNUM?) '<)
  516.     (else (error "unknown fixnum predicate" predicate))))
  517.  
  518. (define-rule predicate
  519.   (FIXNUM-PRED-2-ARGS (? predicate)
  520.               (REGISTER (? source1))
  521.               (REGISTER (? source2)))
  522.   (compare (fixnum-pred-2->cc predicate)
  523.        (standard-source! source1)
  524.        (standard-source! source2)))
  525.  
  526. (define-rule predicate
  527.   (FIXNUM-PRED-2-ARGS (? predicate)
  528.               (REGISTER (? source))
  529.               (OBJECT->FIXNUM (CONSTANT (? constant))))
  530.   (compare-fixnum/constant*register (invert-condition-noncommutative
  531.                      (fixnum-pred-2->cc predicate))
  532.                     constant
  533.                     (standard-source! source)))
  534.  
  535. (define-rule predicate
  536.   (FIXNUM-PRED-2-ARGS (? predicate)
  537.               (OBJECT->FIXNUM (CONSTANT (? constant)))
  538.               (REGISTER (? source)))
  539.   (compare-fixnum/constant*register (fixnum-pred-2->cc predicate)
  540.                     constant
  541.                     (standard-source! source)))
  542.  
  543. (define-integrable (compare-fixnum/constant*register cc n r)
  544.   (guarantee-signed-fixnum n)
  545.   (compare-immediate cc (* n fixnum-1) r))
  546.  
  547. (define (fixnum-pred-2->cc predicate)
  548.   (case predicate
  549.     ((EQUAL-FIXNUM?) '=)
  550.     ((LESS-THAN-FIXNUM?) '<)
  551.     ((GREATER-THAN-FIXNUM?) '>)
  552.     (else (error "unknown fixnum predicate" predicate))))