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 / vax / rules1.scm < prev    next >
Encoding:
Text File  |  1999-01-02  |  16.7 KB  |  475 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: rules1.scm,v 4.8 1999/01/02 06:06:43 cph Exp $
  4. $MC68020-Header: rules1.scm,v 4.34 1991/01/23 21:34:30 jinx Exp $
  5.  
  6. Copyright (c) 1987, 1989, 1991, 1999 Massachusetts Institute of Technology
  7.  
  8. This program is free software; you can redistribute it and/or modify
  9. it under the terms of the GNU General Public License as published by
  10. the Free Software Foundation; either version 2 of the License, or (at
  11. your option) any later version.
  12.  
  13. This program is distributed in the hope that it will be useful, but
  14. WITHOUT ANY WARRANTY; without even the implied warranty of
  15. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  16. General Public License for more details.
  17.  
  18. You should have received a copy of the GNU General Public License
  19. along with this program; if not, write to the Free Software
  20. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  21. |#
  22.  
  23. ;;;; LAP Generation Rules: Data Transfers.
  24. ;;; Note: All fixnum code is in rulfix.scm
  25. ;;; package: (compiler lap-syntaxer)
  26.  
  27. (declare (usual-integrations))
  28.  
  29. ;;;; Register Assignments
  30.  
  31. ;;; All assignments to pseudo registers are required to delete the
  32. ;;; dead registers BEFORE performing the assignment.  However, it is
  33. ;;; necessary to derive the effective address of the source
  34. ;;; expression(s) before deleting the dead registers.  Otherwise any
  35. ;;; source expression containing dead registers might refer to aliases
  36. ;;; which have been reused.
  37.  
  38. (define-rule statement
  39.   (ASSIGN (REGISTER (? target)) (REGISTER (? source)))
  40.   (assign-register->register target source))
  41.  
  42. (define-rule statement
  43.   (ASSIGN (REGISTER (? target)) (OFFSET-ADDRESS (REGISTER (? source)) (? n)))
  44.   (load-displaced-register target source (* 4 n)))
  45.  
  46. (define-rule statement
  47.   ;; This is an intermediate rule -- not intended to produce code.
  48.   (ASSIGN (REGISTER (? target))
  49.       (CONS-POINTER (MACHINE-CONSTANT (? type))
  50.             (OFFSET-ADDRESS (REGISTER (? source)) (? n))))
  51.   (load-displaced-register/typed target source type (* 4 n)))
  52.  
  53. (define-rule statement
  54.   (ASSIGN (REGISTER (? target))
  55.       (BYTE-OFFSET-ADDRESS (REGISTER (? source)) (? n)))
  56.   (load-displaced-register target source n))
  57.  
  58. (define-rule statement
  59.   (ASSIGN (REGISTER (? target))
  60.       (CONS-POINTER (MACHINE-CONSTANT (? type))
  61.             (BYTE-OFFSET-ADDRESS (REGISTER (? source)) (? n))))
  62.   (load-displaced-register/typed target source type n))
  63.  
  64. (define-rule statement
  65.   (ASSIGN (REGISTER (? target)) (OBJECT->TYPE (REGISTER (? source))))
  66.   (convert-object/register->register target source object->type))
  67.  
  68. (define-rule statement
  69.   (ASSIGN (REGISTER (? target))
  70.       (CONS-POINTER (REGISTER (? type)) (REGISTER (? datum))))
  71.   (cond ((register-copy-if-available datum 'GENERAL target)
  72.      =>
  73.      (lambda (get-datum-alias)
  74.        (let* ((type (any-register-reference type))
  75.           (datum&target (get-datum-alias)))
  76.          (set-type/ea type datum&target))))
  77.     ((register-copy-if-available type 'GENERAL target)
  78.      =>
  79.      (lambda (get-type-alias)
  80.        (let* ((datum (any-register-reference datum))
  81.           (type&target (get-type-alias)))
  82.          (cons-pointer/ea type&target datum type&target))))
  83.     (else
  84.      (let* ((type (any-register-reference type))
  85.         (datum (any-register-reference datum))
  86.         (target (standard-target-reference target)))
  87.        (cons-pointer/ea type datum target)))))
  88.  
  89. (define-rule statement
  90.   (ASSIGN (REGISTER (? target))
  91.       (CONS-POINTER (MACHINE-CONSTANT (? type)) (REGISTER (? datum))))
  92.   (if (zero? type)
  93.       (assign-register->register target datum)
  94.       (with-register-copy-alias! datum 'GENERAL target
  95.     (lambda (alias)
  96.       (set-type/constant type alias))
  97.     (lambda (datum target)
  98.       (cons-pointer/constant type datum target)))))
  99.  
  100. (define-rule statement
  101.   (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (REGISTER (? source))))
  102.   (convert-object/register->register target source object->datum))
  103.  
  104. (define-rule statement
  105.   (ASSIGN (REGISTER (? target)) (OBJECT->ADDRESS (REGISTER (? source))))
  106.   (convert-object/register->register target source object->address))
  107.  
  108. ;;;; Loading Constants
  109.  
  110. (define-rule statement
  111.   (ASSIGN (REGISTER (? target)) (CONSTANT (? source)))
  112.   (load-constant source (standard-target-reference target)))
  113.  
  114. (define-rule statement
  115.   (ASSIGN (REGISTER (? target)) (MACHINE-CONSTANT (? n)))
  116.   (load-immediate n (standard-target-reference target)))
  117.  
  118. (define-rule statement
  119.   (ASSIGN (REGISTER (? target))
  120.       (CONS-POINTER (MACHINE-CONSTANT (? type))
  121.             (MACHINE-CONSTANT (? datum))))
  122.   (load-non-pointer type datum (standard-target-reference target)))
  123.  
  124. (define-rule statement
  125.   (ASSIGN (REGISTER (? target)) (ENTRY:PROCEDURE (? label)))
  126.   (load-pc-relative-address
  127.    target
  128.    (rtl-procedure/external-label (label->object label))))
  129.  
  130. (define-rule statement
  131.   (ASSIGN (REGISTER (? target)) (ENTRY:CONTINUATION (? label)))
  132.   (load-pc-relative-address target label))
  133.  
  134. (define-rule statement
  135.   ;; This is an intermediate rule -- not intended to produce code.
  136.   (ASSIGN (REGISTER (? target))
  137.       (CONS-POINTER (MACHINE-CONSTANT (? type))
  138.             (ENTRY:PROCEDURE (? label))))
  139.   (load-pc-relative-address/typed target
  140.                   type
  141.                   (rtl-procedure/external-label
  142.                    (label->object label))))
  143.  
  144. (define-rule statement
  145.   ;; This is an intermediate rule -- not intended to produce code.
  146.   (ASSIGN (REGISTER (? target))
  147.       (CONS-POINTER (MACHINE-CONSTANT (? type))
  148.             (ENTRY:CONTINUATION (? label))))
  149.   (load-pc-relative-address/typed target type label))
  150.  
  151. (define-rule statement
  152.   (ASSIGN (REGISTER (? target)) (VARIABLE-CACHE (? name)))
  153.   (load-pc-relative target (free-reference-label name)))
  154.  
  155. (define-rule statement
  156.   (ASSIGN (REGISTER (? target)) (ASSIGNMENT-CACHE (? name)))
  157.   (load-pc-relative target (free-assignment-label name)))
  158.  
  159. (define-rule statement
  160.   (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (CONSTANT (? constant))))
  161.   (convert-object/constant->register target constant
  162.                      object->datum ct/object->datum))
  163.  
  164. (define-rule statement
  165.   (ASSIGN (REGISTER (? target)) (OBJECT->ADDRESS (CONSTANT (? constant))))
  166.   (convert-object/constant->register target constant
  167.                      object->address ct/object->address))
  168.  
  169. ;;;; Transfers from Memory
  170.  
  171. (define-rule statement
  172.   (ASSIGN (REGISTER (? target))
  173.       (OBJECT->TYPE (OFFSET (REGISTER (? address)) (? offset))))
  174.   (convert-object/offset->register target address offset object->type))
  175.  
  176. (define-rule statement
  177.   (ASSIGN (REGISTER (? target))
  178.       (OBJECT->DATUM (OFFSET (REGISTER (? address)) (? offset))))
  179.   (convert-object/offset->register target address offset object->datum))
  180.  
  181. (define-rule statement
  182.   (ASSIGN (REGISTER (? target))
  183.       (OBJECT->ADDRESS (OFFSET (REGISTER (? address)) (? offset))))
  184.   (convert-object/offset->register target address offset object->address))
  185.  
  186. (define-rule statement
  187.   (ASSIGN (REGISTER (? target)) (OFFSET (REGISTER (? address)) (? offset)))
  188.   (let ((source (indirect-reference! address offset)))
  189.     (LAP (MOV L ,source ,(standard-target-reference target)))))
  190.  
  191. (define-rule statement
  192.   (ASSIGN (REGISTER (? target)) (POST-INCREMENT (REGISTER 14) 1))
  193.   (LAP (MOV L (@R+ 14) ,(standard-target-reference target))))
  194.  
  195. ;;;; Transfers to Memory
  196.  
  197. (define-rule statement
  198.   (ASSIGN (OFFSET (REGISTER (? a)) (? n))
  199.       (CONSTANT (? object)))
  200.   (load-constant object (indirect-reference! a n)))
  201.  
  202. (define-rule statement
  203.   (ASSIGN (OFFSET (REGISTER (? a)) (? n))
  204.       (CONS-POINTER (MACHINE-CONSTANT (? type))
  205.             (MACHINE-CONSTANT (? datum))))
  206.   (load-non-pointer type datum (indirect-reference! a n)))
  207.  
  208. (define-rule statement
  209.   (ASSIGN (OFFSET (REGISTER (? a)) (? n)) (REGISTER (? r)))
  210.   (QUALIFIER (register-value-class=word? r))
  211.   (LAP (MOV L
  212.         ,(any-register-reference r)
  213.         ,(indirect-reference! a n))))
  214.  
  215. (define-rule statement
  216.   (ASSIGN (OFFSET (REGISTER (? a)) (? n))
  217.       (POST-INCREMENT (REGISTER 14) 1))
  218.   (LAP (MOV L (@R+ 14) ,(indirect-reference! a n))))
  219.  
  220. (define-rule statement
  221.   (ASSIGN (OFFSET (REGISTER (? address)) (? offset))
  222.       (CONS-POINTER (MACHINE-CONSTANT (? type)) (REGISTER (? datum))))
  223.   (let ((target (indirect-reference! address offset)))
  224.     (cons-pointer/constant type
  225.                (any-register-reference datum)
  226.                target)))
  227.  
  228. (define-rule statement
  229.   (ASSIGN (OFFSET (REGISTER (? address)) (? offset))
  230.       (CONS-POINTER (MACHINE-CONSTANT (? type))
  231.             (OFFSET-ADDRESS (REGISTER (? source)) (? n))))
  232.   (store-displaced-register/typed address offset type source (* 4 n)))
  233.  
  234. (define-rule statement
  235.   (ASSIGN (OFFSET (REGISTER (? address)) (? offset))
  236.       (CONS-POINTER (MACHINE-CONSTANT (? type))
  237.             (BYTE-OFFSET-ADDRESS (REGISTER (? source)) (? n))))
  238.   (store-displaced-register/typed address offset type source n))
  239.  
  240. ;; Common case that can be done cheaply:
  241.  
  242. (define-rule statement
  243.   (ASSIGN (OFFSET (REGISTER (? address)) (? offset))
  244.       (BYTE-OFFSET-ADDRESS (OFFSET (REGISTER (? address)) (? offset))
  245.                    (? n)))
  246.   (if (zero? n)
  247.       (LAP)
  248.       (increment/ea (indirect-reference! address offset) n)))
  249.  
  250. (define-rule statement
  251.   (ASSIGN (OFFSET (REGISTER (? address)) (? offset))
  252.       (CONS-POINTER (MACHINE-CONSTANT (? type))
  253.             (ENTRY:PROCEDURE (? label))))
  254.   (let ((target (indirect-reference! address offset))
  255.     (label (rtl-procedure/external-label (label->object label))))
  256.     #|
  257.     (LAP (MOVA B (@PCR ,label) ,target)
  258.      ,@(set-type/constant type target))
  259.     |#
  260.     (LAP (MOVA B (@PCRO ,label ,(make-non-pointer-literal type 0)) ,target))))
  261.  
  262. (define-rule statement
  263.   (ASSIGN (OFFSET (REGISTER (? a0)) (? n0))
  264.       (OFFSET (REGISTER (? a1)) (? n1)))
  265.   (if (and (= a0 a1) (= n0 n1))
  266.       (LAP)
  267.       (let ((source (indirect-reference! a1 n1)))
  268.     (LAP (MOV L ,source ,(indirect-reference! a0 n0))))))
  269.  
  270. ;;;; Consing
  271.  
  272. (define-rule statement
  273.   (ASSIGN (POST-INCREMENT (REGISTER 12) 1) (CONSTANT (? object)))
  274.   (load-constant object (INST-EA (@R+ 12))))
  275.  
  276. (define-rule statement
  277.   (ASSIGN (POST-INCREMENT (REGISTER 12) 1)
  278.       (CONS-POINTER (MACHINE-CONSTANT (? type))
  279.             (MACHINE-CONSTANT (? datum))))
  280.   (load-non-pointer type datum (INST-EA (@R+ 12))))
  281.  
  282. (define-rule statement
  283.   (ASSIGN (POST-INCREMENT (REGISTER 12) 1) (REGISTER (? r)))
  284.   (QUALIFIER (register-value-class=word? r))
  285.   (LAP (MOV L ,(any-register-reference r) (@R+ 12))))
  286.  
  287. (define-rule statement
  288.   (ASSIGN (POST-INCREMENT (REGISTER 12) 1) (OFFSET (REGISTER (? r)) (? n)))
  289.   (LAP (MOV L ,(indirect-reference! r n) (@R+ 12))))
  290.  
  291. (define-rule statement
  292.   ;; This pops the top of stack into the heap
  293.   (ASSIGN (POST-INCREMENT (REGISTER 12) 1) (POST-INCREMENT (REGISTER 14) 1))
  294.   (LAP (MOV L (@R+ 14) (@R+ 12))))
  295.  
  296. ;;;; Pushes
  297.  
  298. (define-rule statement
  299.   (ASSIGN (PRE-INCREMENT (REGISTER 14) -1) (REGISTER (? r)))
  300.   (QUALIFIER (register-value-class=word? r))
  301.   (LAP (PUSHL ,(any-register-reference r))))
  302.  
  303. (define-rule statement
  304.   (ASSIGN (PRE-INCREMENT (REGISTER 14) -1) (CONSTANT (? object)))
  305.   (LAP (PUSHL ,(constant->ea object))))
  306.  
  307. (define-rule statement
  308.   (ASSIGN (PRE-INCREMENT (REGISTER 14) -1)
  309.       (CONS-POINTER (MACHINE-CONSTANT (? type)) (REGISTER (? datum))))
  310.   (LAP (PUSHL ,(any-register-reference datum))
  311.        ,@(set-type/constant type (INST-EA (@R 14)))))
  312.  
  313. (define-rule statement
  314.   (ASSIGN (PRE-INCREMENT (REGISTER 14) -1)
  315.       (CONS-POINTER (MACHINE-CONSTANT (? type))
  316.             (MACHINE-CONSTANT (? datum))))
  317.   (LAP (PUSHL ,(non-pointer->ea type datum))))
  318.  
  319. (define-rule statement
  320.   (ASSIGN (PRE-INCREMENT (REGISTER 14) -1)
  321.       (CONS-POINTER (MACHINE-CONSTANT (? type))
  322.             (ENTRY:PROCEDURE (? label))))
  323.   (push-pc-relative-address/typed type
  324.                   (rtl-procedure/external-label
  325.                    (label->object label))))
  326.  
  327. (define-rule statement
  328.   (ASSIGN (PRE-INCREMENT (REGISTER 14) -1)
  329.       (CONS-POINTER (MACHINE-CONSTANT (? type))
  330.             (ENTRY:CONTINUATION (? label))))
  331.   (push-pc-relative-address/typed type label))
  332.  
  333. (define-rule statement
  334.   (ASSIGN (PRE-INCREMENT (REGISTER 14) -1)
  335.       (CONS-POINTER (MACHINE-CONSTANT (? type))
  336.             (OFFSET-ADDRESS (REGISTER (? r)) (? n))))
  337.   (push-displaced-register/typed type r (* 4 n)))
  338.  
  339. (define-rule statement
  340.   (ASSIGN (PRE-INCREMENT (REGISTER 14) -1)
  341.       (CONS-POINTER (MACHINE-CONSTANT (? type))
  342.             (BYTE-OFFSET-ADDRESS (REGISTER (? r)) (? n))))
  343.   (push-displaced-register/typed type r n))
  344.  
  345. (define-rule statement
  346.   (ASSIGN (PRE-INCREMENT (REGISTER 14) -1) (OFFSET (REGISTER (? r)) (? n)))
  347.   (LAP (PUSHL ,(indirect-reference! r n))))
  348.  
  349. ;;;; CHAR->ASCII/BYTE-OFFSET
  350.  
  351. (define-rule statement
  352.   (ASSIGN (REGISTER (? target))
  353.       (CHAR->ASCII (OFFSET (REGISTER (? address)) (? offset))))
  354.   (load-char-into-register 0
  355.                (indirect-char/ascii-reference! address offset)
  356.                target))
  357.  
  358. (define-rule statement
  359.   (ASSIGN (REGISTER (? target))
  360.       (CHAR->ASCII (REGISTER (? source))))
  361.   (load-char-into-register 0
  362.                (reference-alias-register! source 'GENERAL)
  363.                target))
  364.  
  365. (define-rule statement
  366.   (ASSIGN (REGISTER (? target))
  367.       (BYTE-OFFSET (REGISTER (? address)) (? offset)))
  368.   (load-char-into-register 0
  369.                (indirect-byte-reference! address offset)
  370.                target))
  371.  
  372. (define-rule statement
  373.   (ASSIGN (REGISTER (? target))
  374.       (CONS-POINTER (MACHINE-CONSTANT (? type))
  375.             (BYTE-OFFSET (REGISTER (? address)) (? offset))))
  376.   (load-char-into-register type
  377.                (indirect-byte-reference! address offset)
  378.                target))
  379.  
  380. (define-rule statement
  381.   (ASSIGN (BYTE-OFFSET (REGISTER (? address)) (? offset))
  382.       (CHAR->ASCII (CONSTANT (? character))))
  383.   (LAP (MOV B
  384.         (& ,(char->signed-8-bit-immediate character))
  385.         ,(indirect-byte-reference! address offset))))
  386.  
  387. (define-rule statement
  388.   (ASSIGN (BYTE-OFFSET (REGISTER (? address)) (? offset))
  389.       (REGISTER (? source)))
  390.   (let ((source (coerce->any/byte-reference source)))
  391.     (let ((target (indirect-byte-reference! address offset)))
  392.       (LAP (MOV B ,source ,target)))))
  393.  
  394. (define-rule statement
  395.   (ASSIGN (BYTE-OFFSET (REGISTER (? address)) (? offset))
  396.       (CHAR->ASCII (REGISTER (? source))))
  397.   (let ((source (coerce->any/byte-reference source)))
  398.     (let ((target (indirect-byte-reference! address offset)))
  399.       (LAP (MOV B ,source ,target)))))
  400.  
  401. (define-rule statement
  402.   (ASSIGN (BYTE-OFFSET (REGISTER (? target)) (? target-offset))
  403.       (CHAR->ASCII (OFFSET (REGISTER (? source)) (? source-offset))))
  404.   (let ((source (indirect-char/ascii-reference! source source-offset)))
  405.     (LAP (MOV B ,source ,(indirect-byte-reference! target target-offset)))))
  406.  
  407. ;;;; Utilities specific to rules1 (others in lapgen)
  408.  
  409. (define (load-displaced-register target source n)
  410.   (if (zero? n)
  411.       (assign-register->register target source)
  412.       (with-register-copy-alias! source 'GENERAL target
  413.     (lambda (reusable-alias)
  414.       (increment/ea reusable-alias n))
  415.     (lambda (source target)
  416.       (add-constant/ea source n target)))))
  417.  
  418. (define (load-displaced-register/typed target source type n)
  419.   (if (zero? type)
  420.       (load-displaced-register target source n)
  421.       (let ((unsigned-offset (+ (make-non-pointer-literal type 0) n)))
  422.     (with-register-copy-alias! source 'GENERAL target
  423.       (lambda (reusable-alias)
  424.         (LAP (ADD L (&U ,unsigned-offset) ,reusable-alias)))
  425.       (lambda (source target)
  426.         (LAP (ADD L (&U ,unsigned-offset) ,source ,target)))))))
  427.  
  428. (define (store-displaced-register/typed address offset type source n)
  429.   (let* ((source (any-register-reference source))
  430.      (target (indirect-reference! address offset)))
  431.     (if (zero? type)
  432.     (add-constant/ea source n target)
  433.     (LAP (ADD L (&U ,(+ (make-non-pointer-literal type 0) n))
  434.           ,source ,target)))))
  435.  
  436. (define (push-displaced-register/typed type r n)
  437.   (if (zero? type)
  438.       (LAP (PUSHA B ,(indirect-byte-reference! r n)))
  439.       #|
  440.       (LAP (PUSHA B ,(indirect-byte-reference! r n))
  441.        (set-type/constant type (INST-EA (@R 14))))
  442.       |#
  443.       (let ((reg (allocate-indirection-register! r)))
  444.     (LAP (PUSHA B (@RO UL ,reg ,(+ (make-non-pointer-literal type 0)
  445.                        n)))))))
  446.  
  447. (define (assign-register->register target source)
  448.   (move-to-alias-register! source (register-type target) target)
  449.   (LAP))
  450.  
  451. (define (load-pc-relative target label)
  452.   (LAP (MOV L (@PCR ,label) ,(standard-target-reference target))))
  453.  
  454. (define (load-pc-relative-address target label)
  455.   (LAP (MOVA B (@PCR ,label) ,(standard-target-reference target))))
  456.  
  457. (define (load-pc-relative-address/typed target type label)
  458.   (let ((target (standard-target-reference target)))
  459.     #|
  460.     (LAP (MOVA B (@PCR ,label) ,target)
  461.      ,@(set-type/constant type target))
  462.     |#
  463.     (LAP (MOVA B (@PCRO ,label ,(make-non-pointer-literal type 0)) ,target))))
  464.  
  465. (define (push-pc-relative-address/typed type label)
  466.   #|
  467.   (LAP (PUSHA B (@PCR ,label))
  468.        ,@(set-type/constant type (INST-EA (@R 14))))
  469.   |#
  470.   (LAP (PUSHA B (@PCRO ,label ,(make-non-pointer-literal type 0)))))
  471.  
  472. (define (load-char-into-register type source target)
  473.   (let ((target (standard-target-reference target)))
  474.     (LAP ,@(load-non-pointer type 0 target)
  475.      (MOV B ,source ,target))))