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 / base / proced.scm < prev    next >
Text File  |  1999-01-02  |  13KB  |  347 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: proced.scm,v 4.20 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 1988, 1989, 1990, 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. ;;;; Procedure datatype
  23. ;;; package: (compiler)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define-rvalue procedure
  28.   type            ;either PROCEDURE or a continuation type
  29.   block            ;model of invocation environment [block]
  30.   name            ;name of procedure [symbol]
  31.   required        ;list of required parameters [variables]
  32.   optional        ;list of optional parameters [variables]
  33.   rest            ;"rest" parameter, if any [variable or false]
  34.   names            ;list of internal letrec names [variables]
  35.   values        ;list of internal letrec values [rvalues]
  36.   entry-edge        ;body of procedure [cfg edge]
  37.   original-required    ;like `required' but never changed
  38.   original-optional    ;like `optional' but never changed
  39.   original-rest        ;like `rest' but never changed
  40.   label            ;label to identify procedure entry point [symbol]
  41.   applications        ;list of applications for which this is an operator
  42.   always-known-operator? ;always known operator of application? [boolean]
  43.   closure-cons        ;for closure, how it is to be consed.
  44.   closure-context    ;for closure, where procedure is closed [block]
  45.   closure-offset    ;for closure, offset of procedure in stack frame
  46.   register        ;for continuation, argument register
  47.   closure-size        ;for closure, virtual size of frame [integer or false]
  48.   target-block        ;where procedure is "really" closed [block]
  49.   initial-callees    ;procs. invoked by me directly
  50.   (free-callees        ;procs. invoked by means of free variables (1)
  51.    callees)        ;procs. invoked by me (transitively)
  52.   (free-callers        ;procs. that invoke me by means of free variables (1)
  53.    callers)        ;procs. that invoke me (transitively)
  54.   virtual-closure?    ;need entry point but no environment? [boolean]
  55.   closure-reasons    ;reasons why a procedure is closed.
  56.   (variables        ;variables which may be bound to this procedure (1)
  57.    side-effects)    ;classes of side-effects performed by this procedure
  58.   alist            ;random bits of information [assq list]
  59.   debugging-info    ;[dbg-procedure or dbg-continuation]
  60.   )
  61.  
  62. ;; (1) The first meaning is used during closure analysis.
  63. ;;     The second meaning is used during side-effect analysis.
  64.  
  65. (define *procedures*)
  66.  
  67. (define (make-procedure type block name required optional rest names values
  68.             scfg)
  69.   (map lvalue-connect! names values)
  70.   (let ((procedure
  71.      (make-rvalue procedure-tag
  72.               type block name required optional rest names values
  73.               (node->edge (cfg-entry-node scfg))
  74.               (list-copy required)
  75.               (list-copy optional)
  76.               (if (eq? type continuation-type/procedure)
  77.               rest
  78.               '())        ;initial continuation/combinations
  79.               (generate-label name)
  80.               '()        ;applications
  81.               false        ;always-known-operator?
  82.               false        ;closure-cons
  83.               false        ;closure-context
  84.               false        ;closure-offset
  85.               false        ;register
  86.               false        ;closure-size
  87.               false        ;target-block
  88.               '()               ;initial-callees
  89.               '()        ;[free-]callees
  90.               '()        ;[free-]callers
  91.               false        ;virtual-closure?
  92.               '()        ;closure-reasons
  93.               '()        ;variables or side-effects
  94.               '()        ;alist
  95.               false        ;debugging-info
  96.               )))
  97.     (set! *procedures* (cons procedure *procedures*))
  98.     (set-block-procedure! block procedure)
  99.     procedure))
  100.  
  101. (define-vector-tag-unparser procedure-tag
  102.   (lambda (state procedure)
  103.     ((let ((type
  104.         (enumeration/index->name continuation-types
  105.                      (procedure-type procedure))))
  106.        (if (eq? type 'PROCEDURE)
  107.        (standard-unparser (symbol->string 'PROCEDURE)
  108.          (lambda (state procedure)
  109.            (unparse-label state (procedure-label procedure))))
  110.        (standard-unparser (symbol->string (procedure-label procedure))
  111.          (lambda (state procedure)
  112.            procedure
  113.            (unparse-object state type)))))
  114.      state procedure)))
  115.  
  116. (define-integrable (unparse-label state label)
  117.   (unparse-string state (symbol->string label)))
  118.  
  119. (define-integrable (rvalue/procedure? rvalue)
  120.   (eq? (tagged-vector/tag rvalue) procedure-tag))
  121.  
  122. (define (procedure-arity-correct? procedure argument-count)
  123.   (let ((number-required (length (procedure-required procedure))))
  124.     (and (>= argument-count number-required)
  125.      (if (procedure-rest procedure)
  126.          true
  127.          (<= argument-count
  128.          (+ number-required
  129.             (length (procedure-optional procedure))))))))
  130.  
  131. (define (procedure-arity-encoding procedure)
  132.   (let* ((min (1+ (length (procedure-required-arguments procedure))))
  133.      (max (+ min (length (procedure-optional procedure)))))
  134.     (values min (if (procedure-rest procedure) (- (1+ max)) max))))
  135.  
  136. (define-integrable (procedure-closing-block procedure)
  137.   (block-parent (procedure-block procedure)))
  138.  
  139. (define-integrable (procedure-continuation-lvalue procedure)
  140.   ;; Valid only if (not (procedure-continuation? procedure))
  141.   (car (procedure-required procedure)))
  142.  
  143. (define-integrable (procedure-required-arguments procedure)
  144.   ;; Valid only if (not (procedure-continuation? procedure))
  145.   (cdr (procedure-required procedure)))
  146.  
  147. (define-integrable (procedure-entry-node procedure)
  148.   (edge-next-node (procedure-entry-edge procedure)))
  149.  
  150. (define (set-procedure-entry-node! procedure node)
  151.   (let ((edge (procedure-entry-edge procedure)))
  152.     (edge-disconnect-right! edge)
  153.     (edge-connect-right! edge node)))
  154.  
  155. (define-integrable procedure-passed-out?
  156.   rvalue-%passed-out?)
  157.  
  158. (define-integrable set-procedure-passed-out?!
  159.   set-rvalue-%passed-out?!)
  160.  
  161. (define-integrable (closure-procedure-needs-operator? procedure)
  162.   ;; This must be true if the closure needs its parent frame since the
  163.   ;; parent frame is found from the operator.  Currently only avoided
  164.   ;; for trivial closures.
  165.   (not (procedure/trivial-closure? procedure)))
  166.  
  167. (define-integrable (procedure-application-unique? procedure)
  168.   (null? (cdr (procedure-applications procedure))))
  169.  
  170. (define (delete-procedure-application! procedure application)
  171.   (let ((applications (delq! application (procedure-applications procedure))))
  172.     (set-procedure-applications! procedure applications)
  173.     (if (null? applications)
  174.     (set-procedure-always-known-operator?! procedure false))))
  175.  
  176. (define (procedure-get procedure key)
  177.   (let ((entry (assq key (procedure-alist procedure))))
  178.     (and entry
  179.      (cdr entry))))
  180.  
  181. (define (procedure-put! procedure key item)
  182.   (let ((entry (assq key (procedure-alist procedure))))
  183.     (if entry
  184.     (set-cdr! entry item)
  185.     (set-procedure-alist! procedure
  186.                   (cons (cons key item) (procedure-alist procedure))))))
  187.  
  188. (define (procedure-remove! procedure key)
  189.   (set-procedure-alist! procedure (del-assq! key (procedure-alist procedure))))
  190.  
  191. (define-integrable (procedure/simplified? procedure)
  192.   (procedure-get procedure 'SIMPLIFIED))
  193.  
  194. (define-integrable (procedure/trivial? procedure)
  195.   (procedure-get procedure 'TRIVIAL))
  196.  
  197. (define (procedure-inline-code? procedure)
  198.   (and (not (procedure-rest procedure))
  199.        (or (procedure/trivial? procedure)
  200.        (and (procedure-always-known-operator? procedure)
  201.         (procedure-application-unique? procedure)
  202.         (procedure/virtually-open? procedure)))))
  203.  
  204. (define-integrable (open-procedure-needs-static-link? procedure)
  205.   (stack-block/static-link? (procedure-block procedure)))
  206.  
  207. (define-integrable (open-procedure-needs-dynamic-link? procedure)
  208.   (stack-block/dynamic-link? (procedure-block procedure)))
  209.  
  210. ;;;; Procedure Types
  211.  
  212. ;;; IC ("interpreter compatible") procedures are closed procedures
  213. ;;; whose environment frames are compatible with those generated by
  214. ;;; the interpreter.  Both the procedure's frame and all of its
  215. ;;; ancestors are interpreter compatible.
  216.  
  217. ;;; CLOSURE procedures are closed procedures whose frame is a stack
  218. ;;; frame.  The parent frame of such a procedure may be null, an IC
  219. ;;; frame, or a CLOSURE frame (which is a compiler generated, heap
  220. ;;; allocated frame).
  221.  
  222. ;;; OPEN-EXTERNAL procedures are open procedures whose frame is a
  223. ;;; stack frame, and whose parent frame is either null, or an IC
  224. ;;; frame.  These are treated similarly to CLOSURE procedures except
  225. ;;; that the stack frame is laid out differently.
  226.  
  227. ;;; OPEN-INTERNAL procedures are open procedures whose frame and
  228. ;;; parent are both stack frames.  The parent frame of such a
  229. ;;; procedure is created by either a closure or open-external
  230. ;;; procedure.
  231.  
  232. (define (procedure/type procedure)
  233.   (let ((block (procedure-block procedure)))
  234.     (enumeration-case block-type (block-type block)
  235.       ((STACK)
  236.        (if (procedure-closure-context procedure)
  237.        (if (procedure/trivial-closure? procedure)
  238.            'TRIVIAL-CLOSURE
  239.            'CLOSURE)
  240.        (if (stack-parent? block)
  241.            'OPEN-INTERNAL
  242.            'OPEN-EXTERNAL)))
  243.       ((IC) 'IC)
  244.       ((CLOSURE) (error "Illegal occurrence of CLOSURE block" procedure))
  245.       (else (error "Unknown block type" block)))))
  246.  
  247. (define-integrable (procedure/ic? procedure)
  248.   (ic-block? (procedure-block procedure)))
  249.  
  250. (define (procedure/closure? procedure)
  251.   (and (procedure/closed? procedure)
  252.        (not (procedure/ic? procedure))))
  253.  
  254. (define (procedure/trivial-closure? procedure)
  255.   (let ((enclosing (procedure-closing-block procedure)))
  256.     (or (not enclosing)
  257.     (and (ic-block? enclosing)
  258.          (not (ic-block/use-lookup? enclosing))))))
  259.  
  260. (define-integrable procedure/closed?
  261.   procedure-closure-context)
  262.  
  263. (define-integrable (procedure/open? procedure)
  264.   (not (procedure/closed? procedure)))
  265.  
  266. (define-integrable (procedure/external? procedure)
  267.   (block/external? (procedure-block procedure)))
  268.  
  269. (define-integrable (procedure/internal? procedure)
  270.   (block/internal? (procedure-block procedure)))
  271.  
  272. (define (procedure/open-external? procedure)
  273.   (and (procedure/open? procedure)
  274.        (procedure/external? procedure)))
  275.  
  276. (define (procedure/open-internal? procedure)
  277.   (and (procedure/open? procedure)
  278.        (procedure/internal? procedure)))
  279.  
  280. (define (procedure/virtually-open? procedure)
  281.   (or (procedure/open? procedure)
  282.       (and (procedure/closure? procedure)
  283.        (procedure/trivial-closure? procedure))))
  284.  
  285. (define (procedure/trivial-or-virtual? procedure)
  286.   (or (procedure-virtual-closure? procedure)
  287.       (and (procedure/closure? procedure)
  288.        (procedure/trivial-closure? procedure))))
  289.  
  290. (define (add-closure-reason! procedure reason1 reason2)
  291.   (let ((reasons (procedure-closure-reasons procedure)))
  292.     (let ((slot (assq reason1 reasons)))
  293.       (cond ((false? slot)
  294.          (set-procedure-closure-reasons!
  295.           procedure
  296.           (cons (cons reason1
  297.               (if (false? reason2)
  298.                   '()
  299.                   (list reason2)))
  300.             reasons)))
  301.         ((and (not (false? reason2))
  302.           (not (memq reason2 (cdr slot))))
  303.          (set-cdr! slot (cons reason2 (cdr slot))))))))
  304.  
  305. ;; The possible reasons are
  306. ;;
  307. ;; - passed-out : procedure is available from outside block
  308. ;;   (usually an upwards funarg).
  309. ;;
  310. ;; - argument : procedure is given as an argument to a procedure does not
  311. ;;   share its lexical chain.  Some of these cases of downward funargs
  312. ;;   could be stack allocated.
  313. ;;
  314. ;; - assignment: procedure is assigned to some variable outside its closing
  315. ;;   block. 
  316. ;;
  317. ;; - contagion: procedure is called by some other closure.
  318. ;;
  319. ;; - compatibility: procedure is called from a location which may have more
  320. ;;   than one operator, but the complete set of possibilities is known and
  321. ;;   they are compatible closures.
  322. ;;
  323. ;; - apply-compatibility: procedure is called from a location which may have
  324. ;;   move than one operator, but the complete set of possibilities is now known
  325. ;;   or they are incompatible, so (internal) apply has to be used.
  326.  
  327. (define (closure-procedure-needs-external-descriptor? procedure)
  328.   (let loop ((reasons (procedure-closure-reasons procedure)))
  329.     (and (not (null? reasons))
  330.      (or (memq (caar reasons)
  331.            '(PASSED-OUT ARGUMENT ASSIGNMENT
  332.                 COMPATIBILITY APPLY-COMPATIBILITY))
  333.          (loop (cdr reasons))))))
  334.  
  335. (define (procedure-maybe-registerizable? procedure)
  336. ;;; yields true if the procedure might be able to have some of its
  337. ;;; parameters in registers.  Note: This does not mean that the
  338. ;;; procedure WILL have its parameters in registers, or that ALL its
  339. ;;; parameters will be in registers. Which parameters will actually be
  340. ;;; in registers depends on the procedure's argument subproblems, as
  341. ;;; well as the parameter lvalues themselves.
  342.   (and
  343.    (procedure-always-known-operator? procedure)
  344.    (procedure-application-unique? procedure)
  345.    (procedure/virtually-open? procedure)
  346.    (not (block-layout-frozen? (procedure-block procedure)))))
  347.