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 / back / lapgn2.scm < prev    next >
Encoding:
Text File  |  1999-01-02  |  19.1 KB  |  482 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: lapgn2.scm,v 1.21 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 1987-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 Generator: High-Level Register Assignment
  23. ;;; package: (compiler lap-syntaxer)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. ;; `*register-map*' holds the current register map.  The operations
  28. ;; that follow use and update this map appropriately, so that the
  29. ;; writer of LAP generator rules need not pass it around.
  30.  
  31. (define *register-map*)
  32.  
  33. ;; `*needed-registers*' contains a set of machine registers that is
  34. ;; in use during the LAP generation of a single RTL instruction.  The
  35. ;; value of this variable is automatically supplied to many low level
  36. ;; register map operations.  The set is initialized to the empty set
  37. ;; at the beginning of each instruction.  Typically, each alias
  38. ;; register is added to this set as it is allocated.  This informs the
  39. ;; register map operations that it is unreasonable to reallocate that
  40. ;; alias for some other purpose for this instruction.
  41.  
  42. ;; The operations that modify `*needed-registers*' assume that `eqv?'
  43. ;; can be used to compare machine registers.
  44.  
  45. (define *needed-registers*)
  46.  
  47. (define (need-register! register)
  48.   (set! *needed-registers* (cons register *needed-registers*)))
  49.  
  50. (define (need-registers! registers)
  51.   (set! *needed-registers* (eqv-set-union registers *needed-registers*)))
  52.  
  53. (define (dont-need-register! register)
  54.   (set! *needed-registers* (delv! register *needed-registers*)))
  55.  
  56. (define (dont-need-registers! registers)
  57.   (set! *needed-registers* (eqv-set-difference *needed-registers* registers)))
  58.  
  59. ;; `*dead-registers*' is initialized at the beginning of each RTL
  60. ;; instruction to the set of pseudo registers that become dead during
  61. ;; that instruction.  This information is used to decide whether or
  62. ;; not to keep the contents of a particular pseudo register in a
  63. ;; machine register.
  64.  
  65. (define *dead-registers*)
  66.  
  67. (define (dead-register? register)
  68.   (memv register *dead-registers*))
  69.  
  70. ;; `*registers-to-delete*' is also initialized to the set of pseudo
  71. ;; registers that are dead after the current RTL instruction; these
  72. ;; registers are deleted from the register map after the LAP
  73. ;; generation for that instruction.  The LAP generation rules can
  74. ;; cause these deletions to happen at any time by calling
  75. ;; `delete-dead-registers!'.
  76.  
  77. ;; RTL instructions that alter the contents of any pseudo register
  78. ;; must follow this pattern: (1) generate the source operands for the
  79. ;; instruction, (2) delete the dead registers from the register map,
  80. ;; and (3) generate the code for the assignment.
  81.  
  82. (define *registers-to-delete*)
  83.  
  84. (define (delete-dead-registers!)
  85.   (set! *register-map*
  86.     (delete-pseudo-registers *register-map* *registers-to-delete*))
  87.   (set! *registers-to-delete* '())
  88.   unspecific)
  89.  
  90. ;; `*prefix-instructions*' is used to accumulate LAP instructions to
  91. ;; be inserted before the instructions that are the result of the
  92. ;; rule for this RTL instruction.  The register map operations
  93. ;; generate these automatically whenever alias registers need to be
  94. ;; loaded or stored, or when the aliases need to be shuffled in some
  95. ;; way.
  96.  
  97. (define *prefix-instructions*)
  98. (define *suffix-instructions*)
  99.  
  100. (define (prefix-instructions! instructions)
  101.   (set! *prefix-instructions* (LAP ,@*prefix-instructions* ,@instructions)))
  102.  
  103. (define (suffix-instructions! instructions)
  104.   (set! *suffix-instructions* (LAP ,@instructions ,@*suffix-instructions*)))
  105.  
  106. ;; Register map operations that return `allocator-values' eventually
  107. ;; pass those values to `store-allocator-values!', perhaps after some
  108. ;; tweaking.
  109.  
  110. (define (store-allocator-values! allocator-values)
  111.   (bind-allocator-values allocator-values
  112.     (lambda (alias map instructions)
  113.       (need-register! alias)
  114.       (set! *register-map* map)
  115.       (prefix-instructions! instructions)
  116.       alias)))
  117.  
  118. ;; Register map operations that return either an alias register or #F
  119. ;; typically are wrapped with a call to `maybe-need-register!' to
  120. ;; record the fact that the returned alias is in use.
  121.  
  122. (define (maybe-need-register! register)
  123.   (if register (need-register! register))
  124.   register)
  125.  
  126. (define (register-has-alias? register type)
  127.   ;; True iff `register' has an alias of the given `type'.
  128.   ;; `register' may be any kind of register.
  129.   (if (machine-register? register)
  130.       (register-type? register type)
  131.       (pseudo-register-alias *register-map* type register)))
  132.  
  133. (define (alias-is-unique? alias)
  134.   ;; `alias' must be a valid alias for some pseudo register.  This
  135.   ;; predicate is true iff the pseudo register has no other aliases.
  136.   (machine-register-is-unique? *register-map* alias))
  137.  
  138. (define (alias-holds-unique-value? alias)
  139.   ;; `alias' must be a valid alias for some pseudo register.  This
  140.   ;; predicate is true iff the contents of the pseudo register are not
  141.   ;; stored anywhere else that the register map knows of.
  142.   (machine-register-holds-unique-value? *register-map* alias))
  143.  
  144. (define (is-alias-for-register? potential-alias register)
  145.   ;; True iff `potential-alias' is a valid alias for `register'.
  146.   ;; `register' must be a pseudo register, and `potential-alias' must
  147.   ;; be a machine register.
  148.   (is-pseudo-register-alias? *register-map* potential-alias register))
  149.  
  150. (define (register-saved-into-home? register)
  151.   ;; True iff `register' is known to be saved in its spill temporary.
  152.   (and (not (machine-register? register))
  153.        (pseudo-register-saved-into-home? *register-map* register)))
  154.  
  155. (define (register-alias register type)
  156.   ;; Returns an alias for `register', of the given `type', if one
  157.   ;; exists.  Otherwise returns #F.
  158.   (if (machine-register? register)
  159.       (and (register-type? register type) register)
  160.       (maybe-need-register!
  161.        (pseudo-register-alias *register-map* type register))))
  162.  
  163. (define (load-alias-register! register type)
  164.   ;; Returns an alias for `register', of the given `type'.  If no such
  165.   ;; alias exists, a new alias is assigned and loaded with the correct
  166.   ;; value, and that alias is returned.
  167.   (if (machine-register? register)
  168.       (if (register-type? register type)
  169.       register
  170.       (let ((temp (allocate-temporary-register! type)))
  171.         (prefix-instructions! (register->register-transfer register temp))
  172.         temp))
  173.       (store-allocator-values!
  174.        (load-alias-register *register-map* type *needed-registers* register))))
  175.  
  176. (define (reference-alias-register! register type)
  177.   (register-reference (load-alias-register! register type)))
  178.  
  179. (define (allocate-alias-register! register type)
  180.   ;; This operation is used to allocate an alias for `register',
  181.   ;; assuming that it is about to be assigned.  It first deletes any
  182.   ;; other aliases for register, then allocates and returns an alias
  183.   ;; for `register', of the given `type'.
  184.   (delete-register! register)
  185.   (if (machine-register? register)
  186.       (if (register-type? register type)
  187.       register
  188.       (let ((temp (allocate-temporary-register! type)))
  189.         (suffix-instructions! (register->register-transfer temp register))
  190.         temp))
  191.       (store-allocator-values!
  192.        (allocate-alias-register *register-map*
  193.                 type
  194.                 *needed-registers*
  195.                 register))))
  196.  
  197. (define (reference-target-alias! register type)
  198.   (register-reference (allocate-alias-register! register type)))
  199.  
  200. (define (allocate-temporary-register! type)
  201.   ;; Allocates a machine register of the given `type' and returns it.
  202.   ;; This register is not associated with any pseudo register, and can
  203.   ;; be reallocated for other purposes as soon as it is no longer a
  204.   ;; member of `*needed-registers*'.
  205.   (store-allocator-values!
  206.    (allocate-temporary-register *register-map* type *needed-registers*)))
  207.  
  208. (define (reference-temporary-register! type)
  209.   (register-reference (allocate-temporary-register! type)))
  210.  
  211. (define (add-pseudo-register-alias! register alias)
  212.   ;; This operation records `alias' as a valid alias for `register'.
  213.   ;; No instructions are generated.  `register' must be a pseudo
  214.   ;; register, and `alias' must be a previously allocated register
  215.   ;; (typically for some other pseudo register).  Additionally,
  216.   ;; `alias' must no longer be a valid alias, that is, it must have
  217.   ;; been deleted from the register map after it was allocated.
  218.  
  219.   ;; This is extremely useful when performing assignments that move
  220.   ;; the value of one pseudo register into another, where the former
  221.   ;; register becomes dead.  In this case, since no further reference
  222.   ;; is made to the source register, it no longer requires any
  223.   ;; aliases.  Thus the target register can "inherit" the alias, which
  224.   ;; means that the assignment is accomplished without moving any
  225.   ;; data.
  226.   (set! *register-map*
  227.     (add-pseudo-register-alias *register-map* register alias false))
  228.   (need-register! alias))
  229.  
  230. (define (delete-register! register)
  231.   ;; Deletes `register' from the register map.  No instructions are
  232.   ;; generated.
  233.   (if (machine-register? register)
  234.       (begin
  235.     (set! *register-map* (delete-machine-register *register-map* register))
  236.     (dont-need-register! register))
  237.       (delete-pseudo-register *register-map* register
  238.     (lambda (map aliases)
  239.       (set! *register-map* map)
  240.       (dont-need-registers! aliases)))))
  241.  
  242. (define (save-register! register)
  243.   ;; Deletes `register' from the register map, saving it to its home
  244.   ;; if it is a live pseudo register.
  245.   (let ((save-pseudo
  246.      (lambda (register)
  247.        (if (not (dead-register? register))
  248.            (save-pseudo-register *register-map* register
  249.          (lambda (map instructions)
  250.            (set! *register-map* map)
  251.            (prefix-instructions! instructions)))))))
  252.     (if (machine-register? register)
  253.     (let ((contents (machine-register-contents *register-map* register)))
  254.       (if contents
  255.           (save-pseudo contents)))
  256.     (save-pseudo register))))
  257.  
  258. (define (clear-map!)
  259.   ;; Deletes all registers from the register map.  Generates and
  260.   ;; returns instructions to save pseudo registers into their homes,
  261.   ;; if necessary.  This is typically used just before a control
  262.   ;; transfer to somewhere that can potentially flush the contents of
  263.   ;; the machine registers.
  264.   (delete-dead-registers!)
  265.   (let ((instructions (clear-map)))
  266.     (set! *register-map* (empty-register-map))
  267.     (set! *needed-registers* '())
  268.     instructions))
  269.  
  270. (define (clear-map)
  271.   (clear-map-instructions *register-map*))
  272.  
  273. (define (clear-registers! . registers)
  274.   (if (null? registers)
  275.       '()
  276.       (let loop ((map *register-map*) (registers registers))
  277.     (save-machine-register map (car registers)
  278.       (lambda (map instructions)
  279.         (let ((map (delete-machine-register map (car registers))))
  280.           (if (null? (cdr registers))
  281.           (begin
  282.             (set! *register-map* map)
  283.             instructions)
  284.           (append! instructions (loop map (cdr registers))))))))))
  285.  
  286. (define (standard-register-reference register preferred-type alternate-types?)
  287.   ;; Generate a standard reference for `register'.  This procedure
  288.   ;; uses a number of heuristics, aided by `preferred-type', to
  289.   ;; determine the optimum reference.  This should be used only when
  290.   ;; the reference need not have any special properties, as the result
  291.   ;; is not even guaranteed to be a register reference.
  292.   (if (machine-register? register)
  293.       (if alternate-types?
  294.       (register-reference register)
  295.       (reference-alias-register! register preferred-type))
  296.       (let ((no-reuse-possible
  297.          (lambda ()
  298.            ;; If there are no aliases, and the register is not dead,
  299.            ;; allocate an alias of the preferred type.  This is
  300.            ;; desirable because the register will be used again.
  301.            ;; Otherwise, this is the last use of this register, so we
  302.            ;; might as well just use the register's home.
  303.            (if (and (register-saved-into-home? register)
  304.             (or (dead-register? register)
  305.                 (not (allocate-register-without-unload?
  306.                   *register-map*
  307.                   preferred-type
  308.                   *needed-registers*))))
  309.            (pseudo-register-home register)
  310.            (reference-alias-register! register preferred-type)))))
  311.     (let ((no-preference
  312.            (lambda ()
  313.          ;; Next, attempt to find an alias of any type.
  314.          (let ((alias (register-alias register false)))
  315.            (if alias
  316.                (register-reference alias)
  317.                (no-reuse-possible))))))
  318.       ;; First, attempt to find an alias of the preferred type.
  319.       (if preferred-type
  320.           (let ((alias (register-alias register preferred-type)))
  321.         (cond (alias (register-reference alias))
  322.               (alternate-types? (no-preference))
  323.               (else (no-reuse-possible))))
  324.           (no-preference))))))
  325.  
  326. (define (load-machine-register! source-register machine-register)
  327.   ;; Copy the contents of `source-register' to `machine-register'.
  328.   (if (machine-register? source-register)
  329.       (LAP ,@(clear-registers! machine-register)
  330.        ,@(if (eqv? source-register machine-register)
  331.          (LAP)
  332.          (register->register-transfer source-register
  333.                           machine-register)))
  334.       (if (is-alias-for-register? machine-register source-register)
  335.       (clear-registers! machine-register)
  336.       (let ((source-reference
  337.          (if (register-value-class=word? source-register)
  338.              (standard-register-reference source-register false true)
  339.              (standard-register-reference
  340.               source-register
  341.               (register-type source-register)
  342.               false))))
  343.         (LAP ,@(clear-registers! machine-register)
  344.          ,@(reference->register-transfer source-reference
  345.                          machine-register))))))
  346.  
  347. (define (move-to-alias-register! source type target)
  348.   ;; Performs an assignment from register `source' to register
  349.   ;; `target', allocating an alias for `target' of the given `type';
  350.   ;; returns that alias.  If `source' has a reusable alias of the
  351.   ;; appropriate type, that is used, in which case no instructions are
  352.   ;; generated.
  353.   (if (and (machine-register? target)
  354.        (register-type? target type))
  355.       (begin
  356.     (prefix-instructions!
  357.      (reference->register-transfer
  358.       (standard-register-reference source type true)
  359.       target))
  360.     target)
  361.       (reuse-pseudo-register-alias! source type
  362.     (lambda (alias)
  363.       (delete-dead-registers!)
  364.       (if (machine-register? target)
  365.           (suffix-instructions! (register->register-transfer alias target))
  366.           (add-pseudo-register-alias! target alias))
  367.       alias)
  368.     (lambda ()
  369.       (let ((source (standard-register-reference source type true)))
  370.         (delete-dead-registers!)
  371.         (let ((target (allocate-alias-register! target type)))
  372.           (prefix-instructions!
  373.            (reference->register-transfer source target))
  374.           target))))))
  375.  
  376. (define (move-to-temporary-register! source type)
  377.   ;; Allocates a temporary register, of the given `type', and loads
  378.   ;; the contents of the register `source' into it.  Returns a
  379.   ;; reference to that temporary.  If `source' has a reusable alias of
  380.   ;; the appropriate type, that is used, in which case no instructions
  381.   ;; are generated.
  382.   (reuse-pseudo-register-alias! source type
  383.     (lambda (alias)
  384.       (need-register! alias)
  385.       alias)
  386.     (lambda ()
  387.       (let ((target (allocate-temporary-register! type)))
  388.     (prefix-instructions!
  389.      (reference->register-transfer
  390.       (standard-register-reference source type true)
  391.       target))
  392.     target))))
  393.  
  394. (define (reuse-pseudo-register-alias! source type if-reusable if-not)
  395.   (reuse-pseudo-register-alias source type
  396.     (lambda (alias)
  397.       (delete-register! alias)
  398.       (if-reusable alias))
  399.     if-not))
  400.  
  401. (define (reuse-pseudo-register-alias source type if-reusable if-not)
  402.   ;; Attempts to find a reusable alias for `source', of the given
  403.   ;; `type'.  If one is found, `if-reusable' is tail-recursively
  404.   ;; invoked on it.  Otherwise, `if-not' is tail-recursively invoked
  405.   ;; with no arguments.  The heuristics used to decide if an alias is
  406.   ;; reusable are as follows: (1) if `source' is dead, any of its
  407.   ;; aliases may be reused, and (2) if `source' is live with multiple
  408.   ;; aliases, then one of its aliases may be reused.
  409.   (if (machine-register? source)
  410.       (if-not)
  411.       (let ((alias (register-alias source type)))
  412.     (cond ((not alias)
  413.            (if-not))
  414.           ((dead-register? source)
  415.            (if-reusable alias))
  416.           ((not (alias-is-unique? alias))
  417.            (if-reusable alias))
  418.           (else
  419.            (if-not))))))
  420.  
  421. ;;; The following procedures are used when the copy is going to be
  422. ;;; transformed, and the machine has 3 operand instructions, which
  423. ;;; allow an implicit motion in the transformation operation.
  424.  
  425. ;;; For example, on the DEC VAX it is cheaper to do
  426. ;;;    bicl3    op1,source,target
  427. ;;; than
  428. ;;;     movl    source,target
  429. ;;;     bicl2    op1,target
  430.  
  431. ;;; The extra arguments are
  432. ;;; REC1, invoked if we are reusing an alias of source.
  433. ;;;      It already contains the data to operate on.
  434. ;;; REC2, invoked if a `brand-new' alias for target has been allocated.
  435. ;;;      We must take care of moving the data ourselves.
  436.  
  437. (define (with-register-copy-alias! source type target rec1 rec2)
  438.   (if (and (machine-register? target)
  439.        (register-type? target type))
  440.       (let* ((source (standard-register-reference source type true))
  441.          (target (register-reference target)))
  442.     (rec2 source target))
  443.       (reuse-pseudo-register-alias! source type
  444.        (lambda (alias)
  445.      (delete-dead-registers!)
  446.      (if (machine-register? target)
  447.          (suffix-instructions! (register->register-transfer alias target))
  448.          (add-pseudo-register-alias! target alias))
  449.      (rec1 (register-reference alias)))
  450.        (lambda ()
  451.      (let ((source (standard-register-reference source type true)))
  452.        (delete-dead-registers!)
  453.        (rec2 source (reference-target-alias! target type)))))))
  454.  
  455. (define (with-temporary-register-copy! source type rec1 rec2)
  456.   (reuse-pseudo-register-alias! source type
  457.     (lambda (alias)
  458.       (need-register! alias)
  459.       (rec1 (register-reference alias)))
  460.     (lambda ()
  461.       (rec2 (standard-register-reference source type true)
  462.         (reference-temporary-register! type)))))
  463.  
  464. (define (register-copy-if-available source type target)
  465.   (and (not (machine-register? target))
  466.        (reuse-pseudo-register-alias source type
  467.     (lambda (reusable-alias)
  468.       (lambda ()
  469.         (delete-register! reusable-alias)
  470.         (delete-dead-registers!)
  471.         (add-pseudo-register-alias! target reusable-alias)
  472.         (register-reference reusable-alias)))
  473.     (lambda () false))))
  474.  
  475. (define (temporary-copy-if-available source type)
  476.   (reuse-pseudo-register-alias source type
  477.     (lambda (reusable-alias)
  478.       (lambda ()
  479.     (delete-register! reusable-alias)
  480.     (need-register! reusable-alias)
  481.     (register-reference reusable-alias)))
  482.     (lambda () false)))