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))))