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 / lapgn1.scm < prev    next >
Encoding:
Text File  |  1999-01-02  |  10.3 KB  |  315 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: lapgn1.scm,v 4.18 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: top level
  23. ;;; package: (compiler lap-syntaxer)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define *current-bblock*)
  28. (define *pending-bblocks*)
  29. (define *insert-rtl?*)
  30.  
  31. (define (generate-lap rgraphs remote-links process-constants-block)
  32.   (pre-lapgen-analysis rgraphs)
  33.   (fluid-let ((*insert-rtl?*
  34.            (and compiler:generate-lap-files?
  35.             compiler:intersperse-rtl-in-lap?)))
  36.     (with-new-node-marks
  37.       (lambda ()
  38.     (for-each cgen-rgraph rgraphs)
  39.     (let ((link-info
  40.            (and compiler:compress-top-level?
  41.             (not (null? remote-links))
  42.             (not (null? (cdr remote-links)))
  43.             (let* ((index->vector
  44.                 (lambda (index)
  45.                   (list->vector
  46.                    (map (lambda (remote-link)
  47.                       (vector-ref remote-link index))
  48.                     remote-links))))
  49.                (index->constant-label
  50.                 (lambda (index)
  51.                   (constant->label (index->vector index)))))
  52.               (list (length remote-links)
  53.                 ;; cc blocks
  54.                 (index->constant-label 0)
  55.                 ;; number of linker sections
  56.                 (index->vector 3))))))
  57.  
  58.       (if (not link-info)
  59.           (for-each (lambda (remote-link)
  60.               (vector-set! remote-link
  61.                        0
  62.                        (constant->label
  63.                     (vector-ref remote-link 0)))
  64.               unspecific)
  65.             remote-links))
  66.         
  67.       (with-values prepare-constants-block
  68.         (or process-constants-block
  69.         (lambda (constants-code environment-label free-ref-label
  70.                     n-sections)
  71.           (LAP ,@constants-code
  72.                ,@(generate/quotation-header environment-label
  73.                             (or free-ref-label
  74.                             environment-label)
  75.                             n-sections)
  76.                ,@(if link-info
  77.                  (generate/remote-links (car link-info)
  78.                             (cadr link-info)
  79.                             (caddr link-info))
  80.                  (let loop ((remote-links remote-links))
  81.                    (if (null? remote-links)
  82.                    (LAP)
  83.                    (LAP
  84.                     ,@(let ((remote-link (car remote-links)))
  85.                     (generate/remote-link
  86.                      (vector-ref remote-link 0)
  87.                      (vector-ref remote-link 1)
  88.                      (or (vector-ref remote-link 2)
  89.                          (vector-ref remote-link 1))
  90.                      (vector-ref remote-link 3)))
  91.                     ,@(loop (cdr remote-links)))))))))))))))
  92.  
  93. (define (cgen-rgraph rgraph)
  94.   (fluid-let ((*current-rgraph* rgraph)
  95.           (*pending-bblocks* '()))
  96.     (for-each (lambda (edge)
  97.         (if (not (node-marked? (edge-right-node edge)))
  98.             (cgen-entry rgraph edge)))
  99.           (rgraph-entry-edges rgraph))
  100.     (if (not (null? *pending-bblocks*))
  101.     (error "CGEN-RGRAPH: pending blocks left at end of pass"))))
  102.  
  103. (define (cgen-entry rgraph edge)
  104.   (define (loop bblock map)
  105.     (cgen-bblock bblock map)
  106.     (if (sblock? bblock)
  107.     (cgen-right (snode-next-edge bblock))
  108.     (begin
  109.       (cgen-right (pnode-consequent-edge bblock))
  110.       (cgen-right (pnode-alternative-edge bblock)))))
  111.  
  112.   (define (cgen-right edge)
  113.     (let ((next (edge-next-node edge)))
  114.       (if (and next (not (node-marked? next)))
  115.       (let ((previous (node-previous-edges next)))
  116.         (cond ((for-all? previous
  117.              (lambda (edge)
  118.                (memq edge (rgraph-entry-edges rgraph))))
  119.            ;; Assumption: no action needed to clear existing
  120.            ;; register map at this point.
  121.            (loop next (empty-register-map)))
  122.           ((and (null? (cdr previous))
  123.             (edge-left-node (car previous)))
  124.            (loop
  125.             next
  126.             (let ((previous (edge-left-node edge)))
  127.               (delete-pseudo-registers
  128.                (bblock-register-map previous)
  129.                (regset->list
  130.             (regset-difference (bblock-live-at-exit previous)
  131.                        (bblock-live-at-entry next)))))))
  132.           (else
  133.            (let ((entry
  134.               (or (assq next *pending-bblocks*)
  135.                   (let ((entry
  136.                      (cons next
  137.                        (list-transform-positive
  138.                            previous
  139.                          edge-left-node))))
  140.                 (set! *pending-bblocks*
  141.                       (cons entry
  142.                         *pending-bblocks*))
  143.                 entry))))
  144.              (let ((dependencies (delq! edge (cdr entry))))
  145.                (if (not (null? dependencies))
  146.                (set-cdr! entry dependencies)
  147.                (begin
  148.                  (set! *pending-bblocks*
  149.                    (delq! entry *pending-bblocks*))
  150.                  (loop next (adjust-maps-at-merge! next))))))))))))
  151.  
  152.   (loop (edge-right-node edge) (empty-register-map)))
  153.  
  154. (define (cgen-bblock bblock map)
  155.   ;; This procedure is coded out of line to facilitate debugging.
  156.   (node-mark! bblock)
  157.   (fluid-let ((*current-bblock* bblock)
  158.           (*register-map* map))
  159.     (set-bblock-instructions! bblock
  160.                   (let loop ((rinst (bblock-instructions bblock)))
  161.                 (if (rinst-next rinst)
  162.                     (let ((instructions (cgen-rinst rinst)))
  163.                       (LAP ,@instructions
  164.                        ,@(loop (rinst-next rinst))))
  165.                     (cgen-rinst rinst))))
  166.     (set-bblock-register-map! bblock *register-map*)))
  167.  
  168. (define (cgen-rinst rinst)
  169.   (let ((rtl (rinst-rtl rinst)))
  170.     ;; LOOP is for easy restart while debugging.
  171.     (let loop ()
  172.       (let ((match-result (lap-generator/match-rtl-instruction rtl)))
  173.     (if match-result
  174.         (let ((dead-registers (rinst-dead-registers rinst)))
  175.           (fluid-let ((*dead-registers* dead-registers)
  176.               (*registers-to-delete* dead-registers)
  177.               (*prefix-instructions* (LAP))
  178.               (*suffix-instructions* (LAP))
  179.               (*needed-registers* '()))
  180.         (let ((instructions (match-result)))
  181.           (delete-dead-registers!)
  182.           (LAP ,@(if *insert-rtl?*
  183.                  (LAP (COMMENT (RTL ,rtl)))
  184.                  (LAP))
  185.                ,@*prefix-instructions*
  186.                ,@instructions
  187.                ,@*suffix-instructions*))))
  188.         (begin (error "CGEN-RINST: No matching rules" rtl)
  189.            (loop)))))))
  190.  
  191. (define (adjust-maps-at-merge! bblock)
  192.   (let ((edges
  193.      (list-transform-positive (node-previous-edges bblock)
  194.        edge-left-node)))
  195.     (let ((maps
  196.        (map
  197.         (let ((live-registers (bblock-live-at-entry bblock)))
  198.           (lambda (edge)
  199.         (register-map:keep-live-entries
  200.          (bblock-register-map (edge-left-node edge))
  201.          live-registers)))
  202.         edges)))
  203.       (let ((target-map (merge-register-maps maps false)))
  204.     (for-each
  205.      (lambda (class)
  206.        (let ((instructions
  207.           (coerce-map-instructions (cdar class) target-map)))
  208.          (if (not (null? instructions))
  209.          (let ((sblock (make-sblock instructions)))
  210.            (node-mark! sblock)
  211.            (edge-insert-snode! (caar class) sblock)
  212.            (for-each (lambda (x)
  213.                    (let ((edge (car x)))
  214.                  (edge-disconnect-right! edge)
  215.                  (edge-connect-right! edge sblock)))
  216.                  (cdr class))))))
  217.      (equivalence-classes (map cons edges maps)
  218.                   (lambda (x y) (map-equal? (cdr x) (cdr y)))))
  219.     target-map))))
  220.  
  221. (define (equivalence-classes objects predicate)
  222.   (let ((find-class (association-procedure predicate car)))
  223.     (let loop ((objects objects) (classes '()))
  224.       (if (null? objects)
  225.       classes
  226.       (let ((class (find-class (car objects) classes)))
  227.         (if (not class)
  228.         (loop (cdr objects)
  229.               (cons (list (car objects)) classes))
  230.         (begin
  231.           (set-cdr! class (cons (car objects) (cdr class)))
  232.           (loop (cdr objects) classes))))))))
  233.  
  234. (define *cgen-rules* '())
  235. (define *assign-rules* '())
  236. (define *assign-variable-rules* '())
  237.  
  238. (define (add-statement-rule! pattern result-procedure)
  239.   (let ((result (cons pattern result-procedure)))
  240.     (cond ((not (eq? (car pattern) 'ASSIGN))
  241.        (let ((entry (assq (car pattern) *cgen-rules*)))
  242.          (if entry
  243.          (set-cdr! entry (cons result (cdr entry)))
  244.          (set! *cgen-rules*
  245.                (cons (list (car pattern) result)
  246.                  *cgen-rules*)))))
  247.       ((not (pattern-variable? (cadr pattern)))
  248.        (let ((entry (assq (caadr pattern) *assign-rules*)))
  249.          (if entry
  250.          (set-cdr! entry (cons result (cdr entry)))
  251.          (set! *assign-rules*
  252.                (cons (list (caadr pattern) result)
  253.                  *assign-rules*)))))
  254.       (else
  255.        (set! *assign-variable-rules*
  256.          (cons result *assign-variable-rules*)))))
  257.   pattern)
  258.  
  259. (define (lap-generator/match-rtl-instruction rtl)
  260.   ;; Match a single RTL instruction, returning a thunk to generate the
  261.   ;; LAP.  This is used in the RTL optimizer at certain points to
  262.   ;; determine if a rewritten instruction is valid.
  263.   (if (not (rtl:assign? rtl))
  264.       (let ((rules (assq (rtl:expression-type rtl) *cgen-rules*)))
  265.     (and rules (pattern-lookup (cdr rules) rtl)))
  266.       (let ((rules
  267.          (assq (rtl:expression-type (rtl:assign-address rtl))
  268.            *assign-rules*)))
  269.     (or (and rules (pattern-lookup (cdr rules) rtl))
  270.         (pattern-lookup *assign-variable-rules* rtl)))))
  271.  
  272. ;;; Instruction sequence sharing mechanisms
  273.  
  274. (define *block-associations*)
  275.  
  276. (define (block-association token)
  277.   (let ((place (assq token *block-associations*)))
  278.     (and place (cdr place))))
  279.  
  280. (define (block-associate! token frob)
  281.   (set! *block-associations*
  282.     (cons (cons token frob)
  283.           *block-associations*))
  284.   unspecific)
  285.  
  286. ;; This can only be used when the instruction sequences are bit-wise identical.
  287. ;; In other words, no variable registers, constants, etc.
  288.  
  289. (define (share-instruction-sequence! name if-shared generator)
  290.   (cond ((block-association name)
  291.      => if-shared)
  292.     (else
  293.      (let ((label (generate-label name)))
  294.        (block-associate! name label)
  295.        (generator label)))))
  296.  
  297. (define (make-new-sblock instructions)
  298.   (let ((bblock (make-sblock instructions)))
  299.     (node-mark! bblock)
  300.     bblock))
  301.  
  302. (define (current-bblock-continue! bblock)
  303.   (let ((current-bblock *current-bblock*))
  304.     (if (sblock-continuation current-bblock)
  305.     (error "current-bblock-continue! bblock already has a continuation"
  306.            current-bblock)
  307.     (begin
  308.       (create-edge! current-bblock set-snode-next-edge! bblock)
  309.       (set-bblock-continuations! current-bblock (list bblock))
  310.       (set-sblock-continuation! current-bblock bblock)))))
  311.  
  312. (define (lap:comment comment)
  313.   (if compiler:generate-lap-files?
  314.       (LAP (COMMENT (LAP ,comment)))
  315.       (LAP)))