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 / linear.scm < prev    next >
Encoding:
Text File  |  1999-01-02  |  8.1 KB  |  259 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: linear.scm,v 4.17 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 linearizer
  23. ;;; package: (compiler lap-syntaxer linearizer)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define (bblock-linearize-lap bblock queue-continuations!)
  28.   (define (linearize-bblock bblock)
  29.     (LAP ,@(linearize-bblock-1 bblock)
  30.      ,@(linearize-next bblock)))
  31.  
  32.   (define (linearize-bblock-1 bblock)
  33.     (node-mark! bblock)
  34.     (queue-continuations! bblock)
  35.     (if (and (not (bblock-label bblock))
  36.          (let loop ((bblock bblock))
  37.            (or (node-previous>1? bblock)
  38.            (and (node-previous=1? bblock)
  39.             (let ((previous (node-previous-first bblock)))
  40.               (and (sblock? previous)
  41.                    (null? (bblock-instructions previous))
  42.                    (loop previous)))))))
  43.     (bblock-label! bblock))
  44.     (let ((kernel
  45.        (lambda ()
  46.          (bblock-instructions bblock))))
  47.       (if (bblock-label bblock)
  48.       (LAP ,@(lap:make-label-statement (bblock-label bblock)) ,@(kernel))
  49.       (kernel))))
  50.  
  51.   (define (linearize-next bblock)
  52.     (if (sblock? bblock)
  53.     (let ((next (find-next (snode-next bblock))))
  54.       (if next
  55.           (linearize-sblock-next next (bblock-label next))
  56.           (let ((bblock (sblock-continuation bblock)))
  57.         (if (and bblock (not (node-marked? bblock)))
  58.             (linearize-bblock bblock)
  59.             (LAP)))))
  60.     (linearize-pblock
  61.      bblock
  62.      (find-next (pnode-consequent bblock))
  63.      (find-next (pnode-alternative bblock)))))
  64.  
  65.   (define (linearize-sblock-next bblock label)
  66.     (if (node-marked? bblock)
  67.     (lap:make-unconditional-branch label)
  68.     (linearize-bblock bblock)))
  69.  
  70.   (define (linearize-pblock pblock cn an)
  71.     (if (node-marked? cn)
  72.     (if (node-marked? an)
  73.         (heed-preference pblock cn an
  74.           (lambda (generator cn an)
  75.         (LAP ,@(generator (bblock-label cn))
  76.              ,@(lap:make-unconditional-branch (bblock-label an)))))
  77.         (LAP ,@((pblock-consequent-lap-generator pblock)
  78.             (bblock-label cn))
  79.          ,@(linearize-bblock an)))
  80.     (if (node-marked? an)
  81.         (LAP ,@((pblock-alternative-lap-generator pblock)
  82.             (bblock-label an))
  83.          ,@(linearize-bblock cn))
  84.         (linearize-pblock-1 pblock cn an))))
  85.  
  86.   (define (linearize-pblock-1 pblock cn an)
  87.     (let ((finish
  88.        (lambda (generator cn an)
  89.          (let ((clabel (bblock-label! cn))
  90.            (alternative (linearize-bblock an)))
  91.            (LAP ,@(generator clabel)
  92.             ,@alternative
  93.             ,@(if (node-marked? cn)
  94.               (LAP)
  95.               (linearize-bblock cn)))))))
  96.       (let ((consequent-first
  97.          (lambda ()
  98.            (finish (pblock-alternative-lap-generator pblock) an cn)))
  99.         (alternative-first
  100.          (lambda ()
  101.            (finish (pblock-consequent-lap-generator pblock) cn an)))
  102.         (unspecial
  103.          (lambda ()
  104.            (heed-preference pblock cn an finish)))
  105.         (diamond
  106.          (lambda ()
  107.            (let ((jlabel (generate-label)))
  108.          (heed-preference pblock cn an
  109.            (lambda (generator cn an)
  110.              (let ((clabel (bblock-label! cn)))
  111.                (let ((consequent (linearize-bblock-1 cn))
  112.                  (alternative (linearize-bblock-1 an)))
  113.              (LAP ,@(generator clabel)
  114.                   ,@alternative
  115.                   ,@(lap:make-unconditional-branch jlabel)
  116.                   ,@consequent
  117.                   ,@(lap:make-label-statement jlabel)
  118.                   ,@(linearize-next cn))))))))))
  119.     (cond ((eq? cn an)
  120.            (warn "bblock-linearize-lap: Identical branches" pblock)
  121.            (unspecial))
  122.           ((sblock? cn)
  123.            (let ((cnn (find-next (snode-next cn))))
  124.          (cond ((eq? cnn an)
  125.             (consequent-first))
  126.                ((sblock? an)
  127.             (let ((ann (find-next (snode-next an))))
  128.               (cond ((eq? ann cn)
  129.                  (alternative-first))
  130.                 ((not cnn)
  131.                  (if ann
  132.                      (consequent-first)
  133.                      (if (null? (bblock-continuations cn))
  134.                      (if (null? (bblock-continuations an))
  135.                          (unspecial)
  136.                          (consequent-first))
  137.                      (if (null? (bblock-continuations an))
  138.                          (alternative-first)
  139.                          (unspecial)))))
  140.                 ((not ann)
  141.                  (alternative-first))
  142.                 ((eq? cnn ann)
  143.                  (diamond))
  144.                 (else
  145.                  (unspecial)))))
  146.                ((not cnn)
  147.             (consequent-first))
  148.                (else
  149.             (unspecial)))))
  150.           ((and (sblock? an)
  151.             (let ((ann (find-next (snode-next an))))
  152.               (or (not ann)
  153.               (eq? ann cn))))
  154.            (alternative-first))
  155.           (else
  156.            (unspecial))))))
  157.  
  158.   (define (heed-preference pblock cn an finish)
  159.     (if (eq? 'CONSEQUENT (pnode/preferred-branch pblock))
  160.     (finish (pblock-alternative-lap-generator pblock) an cn)
  161.     (finish (pblock-consequent-lap-generator pblock) cn an)))
  162.  
  163.   (define (find-next bblock)
  164.     (let loop ((bblock bblock) (previous false))
  165.       (cond ((not bblock)
  166.          previous)
  167.         ((and (sblock? bblock)
  168.           (null? (bblock-instructions bblock)))
  169.          (loop (snode-next bblock) bblock))
  170.         (else
  171.          bblock))))
  172.  
  173.   (linearize-bblock bblock))
  174.  
  175. (define-integrable (set-current-branches! consequent alternative)
  176.   (set-pblock-consequent-lap-generator! *current-bblock* consequent)
  177.   (set-pblock-alternative-lap-generator! *current-bblock* alternative))
  178.  
  179. (define *end-of-block-code*)
  180.  
  181. (define-structure (extra-code-block
  182.            (conc-name extra-code-block/)
  183.            (constructor extra-code-block/make
  184.                 (name constraint xtra)))
  185.   (name false read-only true)
  186.   (constraint false read-only true)
  187.   (code (LAP) read-only false)
  188.   (xtra false read-only false))
  189.  
  190. (define linearize-lap
  191.   (make-linearizer bblock-linearize-lap
  192.     (lambda () (LAP))
  193.     (lambda (x y) (LAP ,@x ,@y))
  194.     (lambda (linearized-lap)
  195.       (let ((end-code *end-of-block-code*))
  196.     (set! *end-of-block-code* '())
  197.     (LAP ,@linearized-lap
  198.          ,@(let process ((end-code end-code))
  199.          (if (null? end-code)
  200.              (LAP)
  201.              (LAP ,@(extra-code-block/code (car end-code))
  202.               ,@(process (cdr end-code))))))))))
  203.  
  204. (define (find-extra-code-block name)
  205.   (let loop ((end-code *end-of-block-code*))
  206.     (cond ((null? end-code) false)
  207.       ((eq? name (extra-code-block/name (car end-code)))
  208.        (car end-code))
  209.       (else
  210.        (loop (cdr end-code))))))
  211.  
  212. (define (declare-extra-code-block! name constraint xtra)
  213.   (if (find-extra-code-block name)
  214.       (error "declare-extra-code-block!: Multiply defined block"
  215.          name)
  216.       (let ((new (extra-code-block/make name constraint xtra))
  217.         (all *end-of-block-code*))
  218.  
  219.     (define (constraint-violation new old)
  220.       (error "declare-extra-code-block!: Inconsistent constraints"
  221.          new old))
  222.  
  223.     (case constraint
  224.       ((FIRST)
  225.        (if (and (not (null? all))
  226.             (eq? 'FIRST
  227.              (extra-code-block/constraint (car all))))
  228.            (constraint-violation new (car all)))
  229.        (set! *end-of-block-code* (cons new all)))
  230.       ((ANYWHERE)
  231.        (if (or (null? all)
  232.            (not (eq? 'FIRST
  233.                  (extra-code-block/constraint (car all)))))
  234.            (set! *end-of-block-code* (cons new all))
  235.            (set-cdr! all (cons new (cdr all)))))
  236.       ((LAST)
  237.        (if (null? all)
  238.            (set! *end-of-block-code* (list new))
  239.            (let* ((lp (last-pair all))
  240.               (old (car lp)))
  241.          (if (eq? 'LAST (extra-code-block/constraint old))
  242.              (constraint-violation new old))
  243.          (set-cdr! lp (cons new '())))))
  244.       (else
  245.        (error "declare-extra-code-block!: Unknown constraint"
  246.           constraint)))
  247.     new)))
  248.  
  249. (define (add-extra-code! block new-code)
  250.   (set-extra-code-block/code!
  251.    block
  252.    (LAP ,@(extra-code-block/code block)
  253.     ,@new-code)))
  254.  
  255. (define (add-end-of-block-code! code-thunk)
  256.   (add-extra-code!
  257.    (or (find-extra-code-block 'END-OF-BLOCK)
  258.        (declare-extra-code-block! 'END-OF-BLOCK 'ANYWHERE false))
  259.    (code-thunk)))