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 / spectrum / rules1.scm < prev    next >
Encoding:
Text File  |  1999-01-02  |  15.0 KB  |  420 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: rules1.scm,v 4.36 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: Data Transfers
  23. ;;; package: (compiler lap-syntaxer)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. ;;;; Simple Operations
  28.  
  29. ;;; All assignments to pseudo registers are required to delete the
  30. ;;; dead registers BEFORE performing the assignment.  However, it is
  31. ;;; necessary to derive the effective address of the source
  32. ;;; expression(s) before deleting the dead registers.  Otherwise any
  33. ;;; source expression containing dead registers might refer to aliases
  34. ;;; which have been reused.
  35.  
  36. (define-rule statement
  37.   (ASSIGN (REGISTER (? target)) (REGISTER (? source)))
  38.   (standard-move-to-target! source target)
  39.   (LAP))
  40.  
  41. (define-rule statement
  42.   ;; tag the contents of a register
  43.   (ASSIGN (REGISTER (? target))
  44.       (CONS-POINTER (REGISTER (? type)) (REGISTER (? datum))))
  45.   (let* ((type (standard-source! type))
  46.      (target (standard-move-to-target! datum target)))
  47.     (LAP (DEP () ,type ,(-1+ scheme-type-width) ,scheme-type-width ,target))))
  48.  
  49. (define-rule statement
  50.   ;; tag the contents of a register
  51.   (ASSIGN (REGISTER (? target))
  52.       (CONS-POINTER (MACHINE-CONSTANT (? type)) (REGISTER (? source))))
  53.   ;; (QUALIFIER (fits-in-5-bits-signed? type))
  54.   ;; This qualifier does not work because the qualifiers are not
  55.   ;; tested in the rtl compressor.  The qualifier is combined with
  56.   ;; the rule body into a single procedure, and the rtl compressor
  57.   ;; cannot invoke it since it is not in the context of the lap
  58.   ;; generator.  Thus the qualifier is not checked, the RTL instruction
  59.   ;; is compressed, and then the lap generator fails when the qualifier
  60.   ;; fails.
  61.   (deposit-type type (standard-move-to-target! source target)))
  62.  
  63. (define-rule statement
  64.   ;; extract the type part of a register's contents
  65.   (ASSIGN (REGISTER (? target)) (OBJECT->TYPE (REGISTER (? source))))
  66.   (standard-unary-conversion source target object->type))
  67.  
  68. (define-rule statement
  69.   ;; extract the datum part of a register's contents
  70.   (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (REGISTER (? source))))
  71.   (standard-unary-conversion source target object->datum))
  72.  
  73. (define-rule statement
  74.   ;; convert the contents of a register to an address
  75.   (ASSIGN (REGISTER (? target)) (OBJECT->ADDRESS (REGISTER (? source))))
  76.   (object->address (standard-move-to-target! source target)))
  77.  
  78. (define-rule statement
  79.   ;; pop an object off the stack
  80.   (ASSIGN (REGISTER (? target)) (POST-INCREMENT (REGISTER (? reg)) 1))
  81.   (QUALIFIER (= reg regnum:stack-pointer))
  82.   (LAP
  83.    (LDWM () (OFFSET 4 0 ,regnum:stack-pointer) ,(standard-target! target))))
  84.  
  85. ;;;; Indexed modes
  86.  
  87. (define-rule statement
  88.   ;; read an object from memory
  89.   (ASSIGN (REGISTER (? target))
  90.       (OFFSET (REGISTER (? base)) (MACHINE-CONSTANT (? offset))))
  91.   (standard-unary-conversion base target
  92.     (lambda (base target)
  93.       (load-word (* 4 offset) base target))))
  94.  
  95. (define-rule statement
  96.   ;; read an object from memory
  97.   (ASSIGN (REGISTER (? target))
  98.       (OFFSET (REGISTER (? base)) (REGISTER (? offset))))
  99.   (let ((base (standard-source! base))
  100.     (offset (standard-source! offset)))
  101.     (let ((target (standard-target! target)))
  102.       (LAP (LDWX (S) (INDEX ,offset 0 ,base) ,target)))))
  103.  
  104. ;;;; Address manipulation
  105.  
  106. (define-rule statement
  107.   ;; add a constant offset (in long words) to a register's contents
  108.   (ASSIGN (REGISTER (? target))
  109.       (OFFSET-ADDRESS (REGISTER (? base))
  110.               (MACHINE-CONSTANT (? offset))))
  111.   (standard-unary-conversion base target
  112.     (lambda (base target)
  113.       (load-offset (* 4 offset) base target))))
  114.  
  115. (define-rule statement
  116.   ;; add a constant offset (in bytes) to a register's contents
  117.   (ASSIGN (REGISTER (? target))
  118.       (BYTE-OFFSET-ADDRESS (REGISTER (? base))
  119.                    (MACHINE-CONSTANT (? offset))))
  120.   (standard-unary-conversion base target
  121.     (lambda (base target)
  122.       (load-offset offset base target))))
  123.  
  124. (define-rule statement
  125.   ;; add a constant offset (in bytes) to a register's contents
  126.   (ASSIGN (REGISTER (? target))
  127.       (FLOAT-OFFSET-ADDRESS (REGISTER (? base))
  128.                 (MACHINE-CONSTANT (? offset))))
  129.   (standard-unary-conversion base target
  130.     (lambda (base target)
  131.       (load-offset (* 8 offset) base target))))
  132.  
  133. (define-rule statement
  134.   ;; add a computed offset (in long words) to a register's contents
  135.   (ASSIGN (REGISTER (? target))
  136.       (OFFSET-ADDRESS (REGISTER (? base))
  137.               (REGISTER (? offset))))
  138.   (indexed-load-address target base offset 4))
  139.  
  140. (define-rule statement
  141.   ;; add a computed offset (in long words) to a register's contents
  142.   (ASSIGN (REGISTER (? target))
  143.       (BYTE-OFFSET-ADDRESS (REGISTER (? base))
  144.                    (REGISTER (? offset))))
  145.   (indexed-load-address target base offset 1))
  146.  
  147. (define-rule statement
  148.   ;; add a computed offset (in long words) to a register's contents
  149.   (ASSIGN (REGISTER (? target))
  150.       (FLOAT-OFFSET-ADDRESS (REGISTER (? base))
  151.                 (REGISTER (? offset))))
  152.   (indexed-load-address target base offset 8))
  153.  
  154. ;;; Optimized address operations
  155.  
  156. (define-rule statement
  157.   (ASSIGN (REGISTER (? target))
  158.       (OFFSET-ADDRESS (OBJECT->ADDRESS (REGISTER (? base)))
  159.               (OBJECT->DATUM (REGISTER (? index)))))
  160.   (indexed-object->address target base index 4))
  161.  
  162. (define-rule statement
  163.   (ASSIGN (REGISTER (? target))
  164.       (BYTE-OFFSET-ADDRESS (OBJECT->ADDRESS (REGISTER (? base)))
  165.                    (OBJECT->DATUM (REGISTER (? index)))))
  166.   (indexed-object->address target base index 1))
  167.  
  168. ;; These have to be here because the instruction combiner
  169. ;; operates by combining one piece at a time, and the intermediate
  170. ;; pieces can be generated.
  171.  
  172. (define-rule statement
  173.   (ASSIGN (REGISTER (? target))
  174.       (OFFSET-ADDRESS (OBJECT->ADDRESS (REGISTER (? base)))
  175.               (REGISTER (? index))))
  176.   (indexed-object->address target base index 4))
  177.  
  178. (define-rule statement
  179.   (ASSIGN (REGISTER (? target))
  180.       (BYTE-OFFSET-ADDRESS (OBJECT->ADDRESS (REGISTER (? base)))
  181.                    (REGISTER (? index))))
  182.   (indexed-object->address target base index 1))
  183.  
  184. (define-rule statement
  185.   (ASSIGN (REGISTER (? target))
  186.       (OFFSET-ADDRESS (REGISTER (? base))
  187.               (OBJECT->DATUM (REGISTER (? index)))))
  188.   (indexed-object->datum target base index 4))
  189.  
  190. (define-rule statement
  191.   (ASSIGN (REGISTER (? target))
  192.       (BYTE-OFFSET-ADDRESS (REGISTER (? base))
  193.                    (OBJECT->DATUM (REGISTER (? index)))))
  194.   (indexed-object->datum target base index 1))
  195.  
  196. (define (indexed-load-address target base index scale)
  197.   (let ((base (standard-source! base))
  198.     (index (standard-source! index)))
  199.     (%indexed-load-address (standard-target! target) base index scale)))
  200.  
  201. (define (indexed-object->datum target base index scale)
  202.   (let ((base (standard-source! base))
  203.     (index (standard-source! index))
  204.     (temp (standard-temporary!)))
  205.     (let ((target (standard-target! target)))
  206.       (LAP ,@(object->datum index temp)
  207.        ,@(%indexed-load-address target base temp scale)))))
  208.  
  209. (define (indexed-object->address target base index scale)
  210.   (let ((base (standard-source! base))
  211.     (index (standard-source! index)))
  212.     (let ((target (standard-target! target)))
  213.       (LAP ,@(%indexed-load-address target base index scale)
  214.        ,@(object->address target)))))
  215.  
  216. (define (%indexed-load-address target base index scale)
  217.   (case scale
  218.     ((4)
  219.      (LAP (SH2ADDL () ,index ,base ,target)))
  220.     ((8)
  221.      (LAP (SH3ADDL () ,index ,base ,target)))
  222.     ((1)
  223.      (LAP (ADDL () ,index ,base ,target)))
  224.     ((2)
  225.      (LAP (SH1ADDL () ,index ,base ,target)))
  226.     (else
  227.      (error "%indexed-load-address: Unknown scale"))))
  228.  
  229. ;;;; Loading of Constants
  230.  
  231. (define-rule statement
  232.   ;; load a machine constant
  233.   (ASSIGN (REGISTER (? target)) (MACHINE-CONSTANT (? source)))
  234.   (load-immediate source (standard-target! target)))
  235.  
  236. (define-rule statement
  237.   ;; load a Scheme constant
  238.   (ASSIGN (REGISTER (? target)) (CONSTANT (? source)))
  239.   (load-constant source (standard-target! target)))
  240.  
  241. (define-rule statement
  242.   ;; load the type part of a Scheme constant
  243.   (ASSIGN (REGISTER (? target)) (OBJECT->TYPE (CONSTANT (? constant))))
  244.   (load-non-pointer 0 (object-type constant) (standard-target! target)))
  245.  
  246. (define-rule statement
  247.   ;; load the datum part of a Scheme constant
  248.   (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (CONSTANT (? constant))))
  249.   (QUALIFIER (non-pointer-object? constant))
  250.   (load-non-pointer 0
  251.             (careful-object-datum constant)
  252.             (standard-target! target)))
  253.  
  254. (define-rule statement
  255.   ;; load a synthesized constant
  256.   (ASSIGN (REGISTER (? target))
  257.       (CONS-POINTER (MACHINE-CONSTANT (? type))
  258.             (MACHINE-CONSTANT (? datum))))
  259.   (load-non-pointer type datum (standard-target! target)))
  260.  
  261. (define-rule statement
  262.   ;; load the address of a variable reference cache
  263.   (ASSIGN (REGISTER (? target)) (VARIABLE-CACHE (? name)))
  264.   (load-pc-relative (free-reference-label name) 
  265.             (standard-target! target)
  266.             'CONSTANT))
  267.  
  268. (define-rule statement
  269.   ;; load the address of an assignment cache
  270.   (ASSIGN (REGISTER (? target)) (ASSIGNMENT-CACHE (? name)))
  271.   (load-pc-relative (free-assignment-label name)
  272.             (standard-target! target)
  273.             'CONSTANT))
  274.  
  275. (define-rule statement
  276.   ;; load the address of a procedure's entry point
  277.   (ASSIGN (REGISTER (? target)) (ENTRY:PROCEDURE (? label)))
  278.   (load-pc-relative-address label (standard-target! target) 'CODE))
  279.  
  280. (define-rule statement
  281.   ;; load the address of a continuation
  282.   (ASSIGN (REGISTER (? target)) (ENTRY:CONTINUATION (? label)))
  283.   (load-pc-relative-address label (standard-target! target) 'CODE))
  284.  
  285. ;;; Spectrum optimizations
  286.  
  287. (define (load-entry label target)
  288.   (let ((target (standard-target! target)))
  289.     (LAP ,@(load-pc-relative-address label target 'CODE)
  290.      ,@(address->entry target))))
  291.  
  292. (define-rule statement
  293.   ;; load a procedure object
  294.   (ASSIGN (REGISTER (? target))
  295.       (CONS-POINTER (MACHINE-CONSTANT (? type))
  296.             (ENTRY:PROCEDURE (? label))))
  297.   (QUALIFIER (= type (ucode-type compiled-entry)))
  298.   (load-entry label target))
  299.  
  300. (define-rule statement
  301.   ;; load a return address object
  302.   (ASSIGN (REGISTER (? target))
  303.       (CONS-POINTER (MACHINE-CONSTANT (? type))
  304.             (ENTRY:CONTINUATION (? label))))
  305.   (QUALIFIER (= type (ucode-type compiled-entry)))
  306.   (load-entry label target))
  307.  
  308. ;;;; Transfers to Memory
  309.  
  310. (define-rule statement
  311.   ;; store an object in memory
  312.   (ASSIGN (OFFSET (REGISTER (? base)) (MACHINE-CONSTANT (? offset)))
  313.       (? source register-expression))
  314.   (QUALIFIER (word-register? source))
  315.   (store-word (standard-source! source)
  316.           (* 4 offset)
  317.           (standard-source! base)))
  318.  
  319. (define-rule statement
  320.   ;; Push an object register on the heap
  321.   ;; *** IMPORTANT: This uses a STWS instruction with the cache hint set.
  322.   ;; The cache hint prevents newer HP PA processors from loading a cache
  323.   ;; line from memory when it is about to be overwritten.
  324.   ;; In theory this could cause a problem at the very end (64 bytes) of the
  325.   ;; heap, since the last cache line may overlap the next area (the stack).
  326.   ;; ***
  327.   (ASSIGN (POST-INCREMENT (REGISTER (? reg)) 1) (? source register-expression))
  328.   (QUALIFIER (and (= reg regnum:free-pointer)
  329.           (word-register? source)))
  330.   (LAP
  331.    (STWS (MA C) ,(standard-source! source) (OFFSET 4 0 ,regnum:free-pointer))))
  332.  
  333. (define-rule statement
  334.   ;; Push an object register on the stack
  335.   (ASSIGN (PRE-INCREMENT (REGISTER (? reg)) -1) (? source register-expression))
  336.   (QUALIFIER (and (word-register? source)
  337.           (= reg regnum:stack-pointer)))
  338.   (LAP
  339.    (STWM () ,(standard-source! source) (OFFSET -4 0 ,regnum:stack-pointer))))
  340.  
  341. ;; Cheaper, common patterns.
  342.  
  343. (define-rule statement
  344.   (ASSIGN (OFFSET (REGISTER (? base)) (MACHINE-CONSTANT (? offset)))
  345.       (MACHINE-CONSTANT 0))
  346.   (store-word 0
  347.           (* 4 offset)
  348.           (standard-source! base)))
  349.  
  350. (define-rule statement
  351.   (ASSIGN (POST-INCREMENT (REGISTER (? reg)) 1) (MACHINE-CONSTANT 0))
  352.   (QUALIFIER (= reg regnum:free-pointer))
  353.   (LAP (STWS (MA C) 0 (OFFSET 4 0 ,regnum:free-pointer))))
  354.  
  355. (define-rule statement
  356.   (ASSIGN (PRE-INCREMENT (REGISTER (? reg)) -1) (MACHINE-CONSTANT 0))
  357.   (QUALIFIER (= reg regnum:stack-pointer))
  358.   (LAP (STWM () 0 (OFFSET -4 0 ,regnum:stack-pointer))))
  359.  
  360. ;;;; CHAR->ASCII/BYTE-OFFSET
  361.  
  362. (define-rule statement
  363.   ;; load char object from memory and convert to ASCII byte
  364.   (ASSIGN (REGISTER (? target))
  365.       (CHAR->ASCII (OFFSET (REGISTER (? base))
  366.                    (MACHINE-CONSTANT (? offset)))))
  367.   (standard-unary-conversion base target
  368.     (lambda (base target)
  369.       (load-byte (+ 3 (* 4 offset)) base target))))
  370.  
  371. (define-rule statement
  372.   ;; load ASCII byte from memory
  373.   (ASSIGN (REGISTER (? target))
  374.       (BYTE-OFFSET (REGISTER (? base))
  375.                (MACHINE-CONSTANT (? offset))))
  376.   (standard-unary-conversion base target
  377.     (lambda (base target)
  378.       (load-byte offset base target))))
  379.  
  380. (define-rule statement
  381.   ;; load ASCII byte from memory
  382.   (ASSIGN (REGISTER (? target))
  383.       (BYTE-OFFSET (REGISTER (? base))
  384.                (REGISTER (? offset))))
  385.   (let ((base (standard-source! base))
  386.     (offset (standard-source! offset)))
  387.     (let ((target (standard-target! target)))
  388.       (LAP (LDBX () (INDEX ,offset 0 ,base) ,target)))))
  389.  
  390. (define-rule statement
  391.   ;; convert char object to ASCII byte
  392.   ;; Missing optimization: If source is home and this is the last
  393.   ;; reference (it is dead afterwards), an LDB could be done instead
  394.   ;; of an LDW followed by an object->datum.  This is unlikely since
  395.   ;; the value will be home only if we've spilled it, which happens
  396.   ;; rarely.
  397.   (ASSIGN (REGISTER (? target))
  398.       (CHAR->ASCII (REGISTER (? source))))
  399.   (standard-unary-conversion source target
  400.     (lambda (source target)
  401.       (LAP (EXTRU () ,source 31 8 ,target)))))
  402.  
  403. (define-rule statement
  404.   ;; store null byte in memory
  405.   (ASSIGN (BYTE-OFFSET (REGISTER (? base)) (MACHINE-CONSTANT (? offset)))
  406.       (CHAR->ASCII (CONSTANT #\NUL)))
  407.   (store-byte 0 offset (standard-source! base)))
  408.  
  409. (define-rule statement
  410.   ;; store ASCII byte in memory
  411.   (ASSIGN (BYTE-OFFSET (REGISTER (? base)) (MACHINE-CONSTANT (? offset)))
  412.       (REGISTER (? source)))
  413.   (store-byte (standard-source! source) offset (standard-source! base)))
  414.  
  415. (define-rule statement
  416.   ;; convert char object to ASCII byte and store it in memory
  417.   ;; register + byte offset <- contents of register (clear top bits)
  418.   (ASSIGN (BYTE-OFFSET (REGISTER (? base)) (MACHINE-CONSTANT (? offset)))
  419.       (CHAR->ASCII (REGISTER (? source))))
  420.   (store-byte (standard-source! source) offset (standard-source! base)))