1#| -*-Scheme-*-
2
3Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
4    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
5    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 Massachusetts
6    Institute of Technology
7
8This file is part of MIT/GNU Scheme.
9
10MIT/GNU Scheme is free software; you can redistribute it and/or modify
11it under the terms of the GNU General Public License as published by
12the Free Software Foundation; either version 2 of the License, or (at
13your option) any later version.
14
15MIT/GNU Scheme is distributed in the hope that it will be useful, but
16WITHOUT ANY WARRANTY; without even the implied warranty of
17MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
18General Public License for more details.
19
20You should have received a copy of the GNU General Public License
21along with MIT/GNU Scheme; if not, write to the Free Software
22Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
23USA.
24
25|#
26
27;;;; Register Transfer Language: Object Datatypes
28
29(declare (usual-integrations))
30
31(define-structure (rtl-expr
32		   (conc-name rtl-expr/)
33		   (constructor make-rtl-expr
34				(rgraph label entry-edge debugging-info))
35		   (print-procedure
36		    (standard-unparser (symbol->string 'RTL-EXPR)
37		      (lambda (state expression)
38			(unparse-object state (rtl-expr/label expression))))))
39  (rgraph false read-only true)
40  (label false read-only true)
41  (entry-edge false read-only true)
42  (debugging-info false read-only true))
43
44(define-integrable (rtl-expr/entry-node expression)
45  (edge-right-node (rtl-expr/entry-edge expression)))
46
47(define-structure (rtl-procedure
48		   (conc-name rtl-procedure/)
49		   (constructor make-rtl-procedure
50				(rgraph label entry-edge name n-required
51					n-optional rest? closure?
52					dynamic-link? type
53					debugging-info
54					next-continuation-offset stack-leaf?))
55		   (print-procedure
56		    (standard-unparser (symbol->string 'RTL-PROCEDURE)
57		      (lambda (state procedure)
58			(unparse-object state
59					(rtl-procedure/label procedure))))))
60  (rgraph false read-only true)
61  (label false read-only true)
62  (entry-edge false read-only true)
63  (name false read-only true)
64  (n-required false read-only true)
65  (n-optional false read-only true)
66  (rest? false read-only true)
67  (closure? false read-only true)
68  (dynamic-link? false read-only true)
69  (type false read-only true)
70  (%external-label false)
71  (debugging-info false read-only true)
72  (next-continuation-offset false read-only true)
73  (stack-leaf? false read-only true))
74
75(define-integrable (rtl-procedure/entry-node procedure)
76  (edge-right-node (rtl-procedure/entry-edge procedure)))
77
78(define (rtl-procedure/external-label procedure)
79  (or (rtl-procedure/%external-label procedure)
80      (let ((label (generate-label (rtl-procedure/name procedure))))
81	(set-rtl-procedure/%external-label! procedure label)
82	label)))
83
84(define-structure (rtl-continuation
85		   (conc-name rtl-continuation/)
86		   (constructor make-rtl-continuation
87				(rgraph label entry-edge
88					next-continuation-offset
89					debugging-info))
90		   (print-procedure
91		    (standard-unparser (symbol->string 'RTL-CONTINUATION)
92		      (lambda (state continuation)
93			(unparse-object
94			 state
95			 (rtl-continuation/label continuation))))))
96  (rgraph false read-only true)
97  (label false read-only true)
98  (entry-edge false read-only true)
99  (next-continuation-offset false read-only true)
100  (debugging-info false read-only true))
101
102(define-integrable (rtl-continuation/entry-node continuation)
103  (edge-right-node (rtl-continuation/entry-edge continuation)))
104
105(define (make/label->object expression procedures continuations)
106  (let ((hash-table
107	 (make-strong-eq-hash-table
108	  (+ (if expression 1 0)
109	     (length procedures)
110	     (length continuations)))))
111    (if expression
112	(hash-table/put! hash-table
113			 (rtl-expr/label expression)
114			 expression))
115    (for-each (lambda (procedure)
116		(hash-table/put! hash-table
117				 (rtl-procedure/label procedure)
118				 procedure))
119	      procedures)
120    (for-each (lambda (continuation)
121		(hash-table/put! hash-table
122				 (rtl-continuation/label continuation)
123				 continuation))
124	      continuations)
125    (lambda (label)
126      (let ((datum (hash-table/get hash-table label #f)))
127	(if (not datum)
128	    (error "Undefined label:" label))
129	datum))))