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 / i386 / rules2.scm < prev    next >
Text File  |  1999-01-02  |  5KB  |  140 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: rules2.scm,v 1.9 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 1992-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: Predicates
  23. ;;; package: (compiler lap-syntaxer)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define (set-equal-branches!)
  28.   (set-current-branches! (lambda (label)
  29.                (LAP (JE (@PCR ,label))))
  30.              (lambda (label)
  31.                (LAP (JNE (@PCR ,label))))))
  32.  
  33. (define-rule predicate
  34.   (TYPE-TEST (REGISTER (? register)) (? type))
  35.   (set-equal-branches!)
  36.   (LAP (CMP B ,(reference-alias-register! register 'GENERAL) (&U ,type))))
  37.  
  38. (define-rule predicate
  39.   (EQ-TEST (REGISTER (? register-1)) (REGISTER (? register-2)))
  40.   (set-equal-branches!)
  41.   (compare/register*register register-1 register-2))
  42.  
  43. (define-rule predicate
  44.   (EQ-TEST (REGISTER (? register)) (? expression rtl:simple-offset?))
  45.   (set-equal-branches!)
  46.   (LAP (CMP W ,(source-register-reference register)
  47.         ,(offset->reference! expression))))
  48.  
  49. (define-rule predicate
  50.   (EQ-TEST (? expression rtl:simple-offset?) (REGISTER (? register)))
  51.   (set-equal-branches!)
  52.   (LAP (CMP W ,(offset->reference! expression)
  53.         ,(source-register-reference register))))
  54.  
  55. (define-rule predicate
  56.   (EQ-TEST (CONSTANT (? constant)) (REGISTER (? register)))
  57.   (QUALIFIER (non-pointer-object? constant))
  58.   (set-equal-branches!)
  59.   (LAP (CMP W ,(any-reference register)
  60.         (&U ,(non-pointer->literal constant)))))
  61.  
  62. (define-rule predicate
  63.   (EQ-TEST (REGISTER (? register)) (CONSTANT (? constant)))
  64.   (QUALIFIER (non-pointer-object? constant))
  65.   (set-equal-branches!)
  66.   (LAP (CMP W ,(any-reference register)
  67.         (&U ,(non-pointer->literal constant)))))
  68.  
  69. (define-rule predicate
  70.   (EQ-TEST (CONSTANT (? constant)) (? expression rtl:simple-offset?))
  71.   (QUALIFIER (non-pointer-object? constant))
  72.   (set-equal-branches!)
  73.   (LAP (CMP W ,(offset->reference! expression)
  74.         (&U ,(non-pointer->literal constant)))))
  75.  
  76. (define-rule predicate
  77.   (EQ-TEST (? expression rtl:simple-offset?) (CONSTANT (? constant)))
  78.   (QUALIFIER (non-pointer-object? constant))
  79.   (set-equal-branches!)
  80.   (LAP (CMP W ,(offset->reference! expression)
  81.         (&U ,(non-pointer->literal constant)))))
  82.  
  83. (define-rule predicate
  84.   (EQ-TEST (CONSTANT (? constant-1)) (CONSTANT (? constant-2)))
  85.   (let ((always-jump
  86.      (lambda (label)
  87.        (LAP (JMP (@PCR ,label)))))
  88.     (always-fall-through
  89.      (lambda (label)
  90.        label            ; ignored
  91.        (LAP))))
  92.     (if (eq? constant-1 constant-2)
  93.     (set-current-branches! always-jump always-fall-through)
  94.     (set-current-branches! always-fall-through always-jump)))
  95.   (LAP))
  96.  
  97. (define-rule predicate
  98.   (EQ-TEST (CONS-POINTER (MACHINE-CONSTANT (? type))
  99.              (MACHINE-CONSTANT (? datum)))
  100.        (REGISTER (? register)))
  101.   (set-equal-branches!)
  102.   (LAP (CMP W ,(any-reference register)
  103.         (&U ,(make-non-pointer-literal type datum)))))
  104.  
  105. (define-rule predicate
  106.   (EQ-TEST (REGISTER (? register))
  107.        (CONS-POINTER (MACHINE-CONSTANT (? type))
  108.              (MACHINE-CONSTANT (? datum))))
  109.   (set-equal-branches!)
  110.   (LAP (CMP W ,(any-reference register)
  111.         (&U ,(make-non-pointer-literal type datum)))))
  112.  
  113. (define-rule predicate
  114.   (EQ-TEST (CONS-POINTER (MACHINE-CONSTANT (? type))
  115.              (MACHINE-CONSTANT (? datum)))
  116.        (? expression rtl:simple-offset?))
  117.   (set-equal-branches!)
  118.   (LAP (CMP W ,(offset->reference! expression)
  119.         (&U ,(make-non-pointer-literal type datum)))))
  120.  
  121. (define-rule predicate
  122.   (EQ-TEST (? expression rtl:simple-offset?)
  123.        (CONS-POINTER (MACHINE-CONSTANT (? type))
  124.              (MACHINE-CONSTANT (? datum))))
  125.   (set-equal-branches!)
  126.   (LAP (CMP W ,(offset->reference! expression)
  127.         (&U ,(make-non-pointer-literal type datum)))))
  128.  
  129.  
  130. ;; Combine tests for fixnum and non-negative by extracting the type
  131. ;; bits and the sign bit.
  132.  
  133. (define-rule predicate
  134.   (PRED-1-ARG INDEX-FIXNUM?
  135.           (REGISTER (? register)))
  136.   (let ((temp (standard-move-to-temporary! register)))
  137.     (set-equal-branches!)
  138.     (LAP (SHR W ,temp (& ,(- scheme-datum-width 1)))
  139.      (CMP B ,temp (&U ,(* 2 (ucode-type fixnum)))))))
  140.