Changeset 11452
- Timestamp:
- 12/18/08 21:01:44 (14 years ago)
- File:
-
- 1 edited
-
trunk/j/src/org/armedbear/lisp/jvm.lisp (modified) (12 diffs)
Legend:
- Unmodified
- Added
- Removed
-
trunk/j/src/org/armedbear/lisp/jvm.lisp
r11396 r11452 62 62 (defmacro dformat (&rest ignored) 63 63 (declare (ignore ignored))) 64 65 66 (defmacro with-saved-compiler-policy (&body body) 67 "Saves compiler policy variables, restoring them after evaluating `body'." 68 `(let ((*speed* *speed*) 69 (*space* *space*) 70 (*safety* *safety*) 71 (*debug* *debug*) 72 (*explain* *explain*) 73 (*inline-declarations* *inline-declarations*)) 74 ,@body)) 75 64 76 65 77 (eval-when (:compile-toplevel :load-toplevel :execute) … … 786 798 (when variable 787 799 (push variable *visible-variables*)))) 788 (let ((*speed* *speed*) 789 (*safety* *safety*) 790 (*debug* *debug*) 791 (*explain* *explain*) 792 (*inline-declarations* *inline-declarations*)) 800 (with-saved-compiler-policy 793 801 (process-optimization-declarations (cddr form)) 794 802 (list* (car form) local-functions (p1-body (cddr form)))))) … … 5462 5470 (push variable *visible-variables*)) 5463 5471 ;; Body of LET/LET*. 5464 (let ((*speed* *speed*) 5465 (*space* *space*) 5466 (*safety* *safety*) 5467 (*debug* *debug*) 5468 (*explain* *explain*) 5469 (*inline-declarations* *inline-declarations*)) 5472 (with-saved-compiler-policy 5470 5473 (process-optimization-declarations (cddr form)) 5471 5474 (compile-progn-body (cddr form) target representation)) … … 5477 5480 5478 5481 (defun p2-locally (form target representation) 5479 (let ((*speed* *speed*) 5480 (*space* *space*) 5481 (*safety* *safety*) 5482 (*debug* *debug*) 5483 (*explain* *explain*) 5484 (*inline-declarations* *inline-declarations*) 5485 (body (cdr form))) 5486 (process-optimization-declarations body) 5487 (compile-progn-body body target representation))) 5482 (with-saved-compiler-policy 5483 (let ((body (cdr form))) 5484 (process-optimization-declarations body) 5485 (compile-progn-body body target representation)))) 5488 5486 5489 5487 (defknown find-tag (t) t) … … 6031 6029 (setf (compiland-class-file compiland) class-file) 6032 6030 (with-class-file class-file 6033 (let ((*current-compiland* compiland) 6034 (*speed* *speed*) 6035 (*safety* *safety*) 6036 (*debug* *debug*) 6037 (*explain* *explain*)) 6038 (p2-compiland compiland) 6039 (write-class-file (compiland-class-file compiland)))) 6031 (let ((*current-compiland* compiland)) 6032 (with-saved-compiler-policy 6033 (p2-compiland compiland) 6034 (write-class-file (compiland-class-file compiland))))) 6040 6035 ;; Verify that the class file is loadable. 6041 6036 (let ((*load-truename* (pathname pathname))) … … 6068 6063 (progn 6069 6064 (with-class-file class-file 6070 (let ((*current-compiland* compiland) 6071 (*speed* *speed*) 6072 (*safety* *safety*) 6073 (*debug* *debug*) 6074 (*explain* *explain*)) 6075 (p2-compiland compiland) 6076 (write-class-file (compiland-class-file compiland)))) 6065 (let ((*current-compiland* compiland)) 6066 (with-saved-compiler-policy 6067 (p2-compiland compiland) 6068 (write-class-file (compiland-class-file compiland))))) 6077 6069 (setf (local-function-class-file local-function) class-file) 6078 6070 (setf (local-function-function local-function) (load-compiled-function pathname)) … … 6105 6097 (setf (compiland-class-file compiland) class-file) 6106 6098 (with-class-file class-file 6107 (let ((*current-compiland* compiland) 6108 (*speed* *speed*) 6109 (*safety* *safety*) 6110 (*debug* *debug*) 6111 (*explain* *explain*)) 6112 (p2-compiland compiland) 6113 (write-class-file (compiland-class-file compiland)))) 6099 (let ((*current-compiland* compiland)) 6100 (with-saved-compiler-policy 6101 (p2-compiland compiland) 6102 (write-class-file (compiland-class-file compiland))))) 6114 6103 ;; Verify that the class file is loadable. 6115 6104 (let ((*load-truename* (pathname pathname))) … … 6140 6129 (progn 6141 6130 (with-class-file class-file 6142 (let ((*current-compiland* compiland) 6143 (*speed* *speed*) 6144 (*safety* *safety*) 6145 (*debug* *debug*) 6146 (*explain* *explain*)) 6147 (p2-compiland compiland) 6148 (write-class-file (compiland-class-file compiland)))) 6131 (let ((*current-compiland* compiland)) 6132 (with-saved-compiler-policy 6133 (p2-compiland compiland) 6134 (write-class-file (compiland-class-file compiland))))) 6149 6135 (setf (local-function-class-file local-function) class-file) 6150 6136 (let ((g (declare-object (load-compiled-function pathname)))) … … 6219 6205 :lambda-list lambda-list)) 6220 6206 (with-class-file (compiland-class-file compiland) 6221 (let ((*current-compiland* compiland) 6222 (*speed* *speed*) 6223 (*safety* *safety*) 6224 (*debug* *debug*) 6225 (*explain* *explain*)) 6226 (p2-compiland compiland) 6227 (write-class-file (compiland-class-file compiland)))) 6207 (let ((*current-compiland* compiland)) 6208 (with-saved-compiler-policy 6209 (p2-compiland compiland) 6210 (write-class-file (compiland-class-file compiland))))) 6228 6211 (let ((class-file (compiland-class-file compiland))) 6229 6212 (emit 'getstatic *this-class* … … 6238 6221 (progn 6239 6222 (with-class-file (compiland-class-file compiland) 6240 (let ((*current-compiland* compiland) 6241 (*speed* *speed*) 6242 (*safety* *safety*) 6243 (*debug* *debug*) 6244 (*explain* *explain*)) 6245 (p2-compiland compiland) 6246 (write-class-file (compiland-class-file compiland)))) 6223 (let ((*current-compiland* compiland)) 6224 (with-saved-compiler-policy 6225 (p2-compiland compiland) 6226 (write-class-file (compiland-class-file compiland))))) 6247 6227 (emit 'getstatic *this-class* 6248 6228 (declare-object (load-compiled-function pathname)) … … 10262 10242 (*undefined-variables* nil) 10263 10243 (*local-functions* nil) 10264 (*current-compiland* compiland) 10265 (*speed* *speed*) 10266 (*safety* *safety*) 10267 (*debug* *debug*) 10268 (*explain* *explain*) 10269 (*inline-declarations* *inline-declarations*)) 10270 ;; Pass 1. 10271 (p1-compiland compiland) 10272 (setf *closure-variables* 10273 (remove-if-not #'variable-used-non-locally-p *all-variables*)) 10274 (when *closure-variables* 10244 (*current-compiland* compiland)) 10245 (with-saved-compiler-policy 10246 ;; Pass 1. 10247 (p1-compiland compiland) 10275 10248 (setf *closure-variables* 10276 (remove-if #'variable-special-p *closure-variables*))10249 (remove-if-not #'variable-used-non-locally-p *all-variables*)) 10277 10250 (when *closure-variables* 10278 (let ((i 0)) 10279 (dolist (var (reverse *closure-variables*)) 10280 (setf (variable-closure-index var) i) 10281 (dformat t "var = ~S closure index = ~S~%" (variable-name var) 10282 (variable-closure-index var)) 10283 (incf i))))) 10284 ;; Pass 2. 10285 (with-class-file (compiland-class-file compiland) 10286 (p2-compiland compiland) 10287 (write-class-file (compiland-class-file compiland))) 10288 (class-file-pathname (compiland-class-file compiland)))) 10251 (setf *closure-variables* 10252 (remove-if #'variable-special-p *closure-variables*)) 10253 (when *closure-variables* 10254 (let ((i 0)) 10255 (dolist (var (reverse *closure-variables*)) 10256 (setf (variable-closure-index var) i) 10257 (dformat t "var = ~S closure index = ~S~%" (variable-name var) 10258 (variable-closure-index var)) 10259 (incf i))))) 10260 ;; Pass 2. 10261 (with-class-file (compiland-class-file compiland) 10262 (p2-compiland compiland) 10263 (write-class-file (compiland-class-file compiland))) 10264 (class-file-pathname (compiland-class-file compiland))))) 10289 10265 10290 10266 (defvar *compiler-error-bailout*) … … 10382 10358 (failure-p t)) 10383 10359 (with-compilation-unit () 10384 (let* ((*speed* *speed*) 10385 (*space* *space*) 10386 (*safety* *safety*) 10387 (*debug* *debug*) 10388 (*explain* *explain*) 10389 (tempfile (make-temp-file))) 10390 (unwind-protect 10391 (setf compiled-function 10392 (load-compiled-function (compile-defun name expr env tempfile))) 10393 (delete-file tempfile))) 10360 (with-saved-compiler-policy 10361 (let* ((tempfile (make-temp-file))) 10362 (unwind-protect 10363 (setf compiled-function 10364 (load-compiled-function (compile-defun name expr env tempfile))) 10365 (delete-file tempfile)))) 10394 10366 (when (and name (functionp compiled-function)) 10395 10367 (sys::%set-lambda-name compiled-function name)
Note: See TracChangeset
for help on using the changeset viewer.
