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;;;; LAP Generation Rules: Interpreter Calls 28;;; package: (compiler lap-syntaxer) 29 30(declare (usual-integrations)) 31 32;;;; Variable cache trap handling. 33 34(define-rule statement 35 (INTERPRETER-CALL:CACHE-REFERENCE (? cont) (? extension) (? safe?)) 36 (QUALIFIER (interpreter-call-argument? extension)) 37 cont ; ignored 38 (let ((set-extension 39 (interpreter-call-argument->machine-register! extension d2))) 40 (let ((clear-map (clear-map!))) 41 (LAP ,@set-extension 42 ,@clear-map 43 (JSR ,(if safe? 44 entry:compiler-safe-reference-trap 45 entry:compiler-reference-trap)))))) 46 47(define-rule statement 48 (INTERPRETER-CALL:CACHE-ASSIGNMENT (? cont) (? extension) (? value)) 49 (QUALIFIER (and (interpreter-call-argument? extension) 50 (interpreter-call-argument? value))) 51 cont ; ignored 52 (let ((set-extension 53 (interpreter-call-argument->machine-register! extension d2))) 54 (let ((set-value (interpreter-call-argument->machine-register! value d3))) 55 (let ((clear-map (clear-map!))) 56 (LAP ,@set-extension 57 ,@set-value 58 ,@clear-map 59 (JSR ,entry:compiler-assignment-trap)))))) 60 61(define-rule statement 62 (INTERPRETER-CALL:CACHE-UNASSIGNED? (? cont) (? extension)) 63 (QUALIFIER (interpreter-call-argument? extension)) 64 cont ; ignored 65 (let ((set-extension 66 (interpreter-call-argument->machine-register! extension d2))) 67 (let ((clear-map (clear-map!))) 68 (LAP ,@set-extension 69 ,@clear-map 70 ,@(invoke-interface-jsr code:compiler-unassigned?-trap))))) 71 72;;;; Interpreter Calls 73 74;;; All the code that follows is obsolete. It hasn't been used in a while. 75;;; It is provided in case the relevant switches are turned off, but there 76;;; is no real reason to do this. Perhaps the switches should be removed. 77 78(define (interpreter-call-argument? expression) 79 (or (rtl:register? expression) 80 (rtl:constant? expression) 81 (and (rtl:cons-pointer? expression) 82 (rtl:machine-constant? (rtl:cons-pointer-type expression)) 83 (rtl:machine-constant? (rtl:cons-pointer-datum expression))) 84 (rtl:simple-offset? expression))) 85 86(define (interpreter-call-argument->machine-register! expression register) 87 (let ((target (register-reference register))) 88 (case (car expression) 89 ((REGISTER) 90 (load-machine-register! (rtl:register-number expression) register)) 91 ((CONSTANT) 92 (LAP ,@(clear-registers! register) 93 ,@(load-constant (rtl:constant-value expression) target))) 94 ((CONS-POINTER) 95 (LAP ,@(clear-registers! register) 96 ,@(load-non-pointer (rtl:machine-constant-value 97 (rtl:cons-pointer-type expression)) 98 (rtl:machine-constant-value 99 (rtl:cons-pointer-datum expression)) 100 target))) 101 ((OFFSET) 102 (let ((source-reference (offset->reference! expression))) 103 (LAP ,@(clear-registers! register) 104 (MOV L ,source-reference ,target)))) 105 (else 106 (error "Unknown expression type" (car expression)))))) 107 108(define-rule statement 109 (INTERPRETER-CALL:ACCESS (? cont) (? environment) (? name)) 110 (QUALIFIER (interpreter-call-argument? environment)) 111 cont ; ignored 112 (lookup-call code:compiler-access environment name)) 113 114(define-rule statement 115 (INTERPRETER-CALL:LOOKUP (? cont) (? environment) (? name) (? safe?)) 116 (QUALIFIER (interpreter-call-argument? environment)) 117 cont ; ignored 118 (lookup-call (if safe? code:compiler-safe-lookup code:compiler-lookup) 119 environment name)) 120 121(define-rule statement 122 (INTERPRETER-CALL:UNASSIGNED? (? cont) (? environment) (? name)) 123 (QUALIFIER (interpreter-call-argument? environment)) 124 cont ; ignored 125 (lookup-call code:compiler-unassigned? environment name)) 126 127(define-rule statement 128 (INTERPRETER-CALL:UNBOUND? (? cont) (? environment) (? name)) 129 (QUALIFIER (interpreter-call-argument? environment)) 130 cont ; ignored 131 (lookup-call code:compiler-unbound? environment name)) 132 133(define (lookup-call code environment name) 134 (let ((set-environment 135 (interpreter-call-argument->machine-register! environment d2))) 136 (let ((clear-map (clear-map!))) 137 (LAP ,@set-environment 138 ,@clear-map 139 ,@(load-constant name (INST-EA (D 3))) 140 ,@(invoke-interface-jsr code))))) 141 142(define-rule statement 143 (INTERPRETER-CALL:DEFINE (? cont) (? environment) (? name) (? value)) 144 (QUALIFIER (and (interpreter-call-argument? environment) 145 (interpreter-call-argument? value))) 146 cont ; ignored 147 (assignment-call code:compiler-define environment name value)) 148 149(define-rule statement 150 (INTERPRETER-CALL:SET! (? cont) (? environment) (? name) (? value)) 151 (QUALIFIER (and (interpreter-call-argument? environment) 152 (interpreter-call-argument? value))) 153 cont ; ignored 154 (assignment-call code:compiler-set! environment name value)) 155 156(define (assignment-call code environment name value) 157 (let ((set-environment 158 (interpreter-call-argument->machine-register! environment d2))) 159 (let ((set-value (interpreter-call-argument->machine-register! value d4))) 160 (let ((clear-map (clear-map!))) 161 (LAP ,@set-environment 162 ,@set-value 163 ,@clear-map 164 ,@(load-constant name (INST-EA (D 3))) 165 ,@(invoke-interface-jsr code))))))