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 / rtlgen / rgproc.scm < prev    next >
Text File  |  1999-01-02  |  9KB  |  248 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: rgproc.scm,v 4.14 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 1988-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. ;;;; RTL Generation: Procedure Headers
  23. ;;; package: (compiler rtl-generator generate/procedure-header)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define (generate/procedure-header procedure body inline?)
  28.   (scfg*scfg->scfg!
  29.    (let ((context (make-reference-context (procedure-block procedure))))
  30.      (set-reference-context/offset! context 0)
  31.      (if (procedure/ic? procedure)
  32.      (scfg*scfg->scfg!
  33.       (if inline?
  34.           (make-null-cfg)
  35.           (rtl:make-ic-procedure-header (procedure-label procedure)))
  36.       (setup-ic-frame procedure context))
  37.      (scfg*scfg->scfg!
  38.       (cond (inline?
  39.          ;; Paranoia
  40.          (if (not (procedure/virtually-open? procedure))
  41.              (error "Inlining a real closure!" procedure))
  42.          (make-null-cfg))
  43.         ((procedure/closure? procedure)
  44.          (let ((needs-entry?
  45.             (or (procedure-rest procedure)
  46.                 (closure-procedure-needs-external-descriptor?
  47.                  procedure))))
  48.            (cond ((not (procedure/trivial-closure? procedure))
  49.               (let* ((block (procedure-closing-block procedure))
  50.                  (nentries (block-entry-number
  51.                         (block-shared-block block))))
  52.                 (if (or (not needs-entry?) (zero? nentries))
  53.                 ;; It's not an open procedure but it looks like
  54.                 ;; one at the rtl level.
  55.                 (rtl:make-open-procedure-header
  56.                  (procedure-label procedure))
  57.                 (rtl:make-closure-header
  58.                  (procedure-label procedure)
  59.                  nentries
  60.                  (closure-block-entry-number block)))))
  61.              (needs-entry?
  62.               (with-values
  63.                   (lambda () (procedure-arity-encoding procedure))
  64.                 (lambda (min max)
  65.                   (rtl:make-procedure-header
  66.                    (procedure-label procedure)
  67.                    min max))))
  68.              (else
  69.               ;; It's not an open procedure but it looks like one
  70.               ;; at the rtl level.
  71.               (rtl:make-open-procedure-header
  72.                (procedure-label procedure))))))
  73.         ((procedure-rest procedure)
  74.          (with-values (lambda () (procedure-arity-encoding procedure))
  75.            (lambda (min max)
  76.              (if (open-procedure-needs-dynamic-link? procedure)
  77.              (scfg*scfg->scfg!
  78.               (rtl:make-procedure-header
  79.                (procedure-label procedure)
  80.                (1+ min)
  81.                (-1+ max))
  82.               (rtl:make-pop-link))
  83.              (rtl:make-procedure-header (procedure-label procedure)
  84.                             min max)))))
  85.         (else
  86.          (rtl:make-open-procedure-header (procedure-label procedure))))
  87.       (setup-stack-frame procedure context))))
  88.    body))
  89.  
  90. (define (setup-ic-frame procedure context)
  91.   (scfg*->scfg!
  92.    (map (let ((block (procedure-block procedure)))
  93.       (lambda (name value)
  94.         (generate/rvalue value scfg*scfg->scfg!
  95.          (lambda (expression)
  96.            (load-temporary-register scfg*scfg->scfg! expression
  97.         (lambda (expression)
  98.           (wrap-with-continuation-entry
  99.            context
  100.            (lambda (cont-label)
  101.              (rtl:make-interpreter-call:set!
  102.               cont-label
  103.               (rtl:make-fetch register:environment)
  104.               (intern-scode-variable! block (variable-name name))
  105.               expression)))))))))
  106.     (procedure-names procedure)
  107.     (procedure-values procedure))))
  108.  
  109. (define (setup-stack-frame procedure context)
  110.   (let ((block (procedure-block procedure)))
  111.     (define (cellify-variables variables)
  112.       (scfg*->scfg! (map cellify-variable variables)))
  113.  
  114.     (define (cellify-variable variable)
  115.       (if (and (variable-in-cell? variable)
  116.            (not (and (variable-source-node variable)
  117.              (procedure-inline-code? procedure))))
  118.       (let ((locative
  119.          (let ((register (variable/register variable)))
  120.            (or register
  121.                (stack-locative-offset
  122.             (rtl:make-fetch register:stack-pointer)
  123.             (variable-offset block variable))))))
  124.         (rtl:make-assignment
  125.          locative
  126.          (rtl:make-cell-cons (rtl:make-fetch locative))))
  127.       (make-null-cfg)))
  128.  
  129.     (let ((names (procedure-names procedure))
  130.       (values (procedure-values procedure)))
  131.       (scfg-append!
  132.        (setup-bindings names values '())
  133.        (cellify-variables (procedure-required-arguments procedure))
  134.        (cellify-variables (procedure-optional procedure))
  135.        (let ((rest (procedure-rest procedure)))
  136.      (if rest
  137.          (cellify-variable rest)
  138.          (make-null-cfg)))
  139.        (scfg*->scfg! (map (lambda (name value)
  140.                 (close-binding context name value))
  141.               names values))))))
  142.  
  143. (define (setup-bindings names values pushes)
  144.   (if (null? names)
  145.       (scfg*->scfg! pushes)
  146.       (setup-bindings (cdr names)
  147.               (cdr values)
  148.               (letrec-value (car names) (car values)
  149.                (lambda (scfg expression)
  150.              (cons (scfg*scfg->scfg!
  151.                 scfg
  152.                 (make-auxiliary-push (car names) expression))
  153.                    pushes))))))
  154.  
  155. (define (make-auxiliary-push variable value)
  156.   (rtl:make-push (if (variable-in-cell? variable)
  157.              (rtl:make-cell-cons value)
  158.              value)))
  159.  
  160. (define (letrec-value name value recvr)
  161.   (cond ((constant? value)
  162.      (recvr (make-null-cfg)
  163.         (rtl:make-constant (constant-value value))))
  164.     ((procedure? value)
  165.      (enqueue-procedure! value)
  166.      (case (procedure/type value)
  167.        ((CLOSURE)
  168.         (let ((closing-block (procedure-closing-block value)))
  169.           (recvr
  170.            (make-null-cfg)
  171.            (if (eq? closing-block (block-shared-block closing-block))
  172.            (make-non-trivial-closure-cons value false)
  173.            (let ((how (procedure-closure-cons value)))
  174.              (cond ((or (not (eq? (car how) 'INDIRECTED))
  175.                 (not (eq? (variable-block (cdr how))
  176.                       (variable-block name))))
  177.                 (make-cons-closure-redirection value))
  178.                ((not (variable-in-cell? name))
  179.                 (error "letrec-value: Non-indirected shared sibling!"
  180.                    value))
  181.                (else
  182.                 (rtl:make-constant
  183.                  (make-unassigned-reference-trap)))))))))
  184.        ((IC)
  185.         (with-values (lambda () (make-ic-cons value 'USE-ENV)) recvr))
  186.        ((TRIVIAL-CLOSURE)
  187.         ;; This is not an error.
  188.         ;; It can be the consequence of bad style.
  189.         (warn "Letrec value is trivial closure" value)
  190.         (recvr (make-null-cfg)
  191.            (make-trivial-closure-cons value)))
  192.        ((OPEN-EXTERNAL OPEN-INTERNAL)
  193.         (error "Letrec value is open procedure" value))
  194.        (else
  195.         (error "Unknown procedure type" value))))
  196.     ((block? value)
  197.      (for-each
  198.       (lambda (block*)
  199.         (enqueue-procedure!
  200.          (block-procedure (car (block-children block*)))))
  201.       (block-grafted-blocks value))
  202.      (recvr (make-null-cfg)
  203.         (make-non-trivial-closure-cons
  204.          (indirection-block-procedure value)
  205.          value)))
  206.     (else
  207.      (error "Unknown letrec binding value" value))))
  208.  
  209. (define (close-binding context name value)
  210.   (cond ((block? value)
  211.      (letrec-close context name
  212.                (indirection-block-procedure value)))
  213.     ((and (procedure? value)
  214.           (not (procedure/trivial-or-virtual? value)))
  215.      (let ((closing-block (procedure-closing-block value)))
  216.        (if (eq? closing-block (block-shared-block closing-block))
  217.            (letrec-close context name value)
  218.            (let ((how (procedure-closure-cons value)))
  219.          (cond ((or (not (eq? (car how) 'INDIRECTED))
  220.                 (not (eq? (variable-block (cdr how))
  221.                       (variable-block name))))
  222.             (make-null-cfg))
  223.                ((not (variable-in-cell? name))
  224.             (error "close-binding: Non-indirected shared sibling!"
  225.                    value))
  226.                (else
  227.             (find-variable/locative
  228.              context name
  229.              (lambda (locative)
  230.                (rtl:make-assignment
  231.                 locative
  232.                 (make-cons-closure-indirection value)))
  233.              (lambda (environment name)
  234.                environment
  235.                (error "close-binding: IC letrec name" name))
  236.              (lambda (name)
  237.                (error "close-binding: cached letrec name"
  238.                   name)))))))))
  239.     (else
  240.      (make-null-cfg))))
  241.  
  242. (define (letrec-close context variable value)
  243.   (load-closure-environment
  244.    value
  245.    (find-variable/value/simple
  246.     context variable
  247.     "letrec-close: Missing closure variable")
  248.    context))