Changeset 11829 for trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
- Timestamp:
- 05/04/09 19:43:30 (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
r11828 r11829 8161 8161 (*visible-variables* *visible-variables*) 8162 8162 8163 (parameters ())8164 8165 8163 (*thread* nil) 8166 8164 (*initialize-thread-var* nil) … … 8172 8170 (dolist (var (compiland-arg-vars compiland)) 8173 8171 (push var *visible-variables*)) 8172 (dolist (var (compiland-free-specials compiland)) 8173 (push var *visible-variables*)) 8174 8174 8175 8175 (setf (method-name-index execute-method) … … 8178 8178 (pool-name (method-descriptor execute-method))) 8179 8179 (cond (*hairy-arglist-p* 8180 (let* ((closure (make-closure p1-result nil)) 8181 (parameter-names (sys::varlist closure)) 8182 (index 0)) 8183 (dolist (name parameter-names) 8184 (let ((variable (find-visible-variable name))) 8185 (unless variable 8186 (format t "1: unable to find variable ~S~%" name) 8187 (aver nil)) 8188 (aver (null (variable-register variable))) 8189 (aver (null (variable-index variable))) 8190 (setf (variable-index variable) index) 8191 (push variable parameters) 8192 (incf index))))) 8180 (let ((index 0)) 8181 (dolist (variable (compiland-arg-vars compiland)) 8182 (aver (null (variable-register variable))) 8183 (aver (null (variable-index variable))) 8184 (setf (variable-index variable) index) 8185 (incf index)))) 8193 8186 (t 8194 8187 (let ((register (if (and *closure-variables* *child-p*) … … 8196 8189 1)) 8197 8190 (index 0)) 8198 (dolist (arg args) 8199 (let ((variable (find-visible-variable arg))) 8200 (when (null variable) 8201 (format t "2: unable to find variable ~S~%" arg) 8202 (aver nil)) 8203 (aver (null (variable-register variable))) 8204 (setf (variable-register variable) (if *using-arg-array* nil register)) 8205 (aver (null (variable-index variable))) 8206 (if *using-arg-array* 8207 (setf (variable-index variable) index)) 8208 (push variable parameters) 8209 (incf register) 8210 (incf index)))))) 8211 8212 (let ((specials (process-special-declarations body))) 8213 (dolist (name specials) 8214 (dformat t "recognizing ~S as special~%" name) 8215 (let ((variable (find-visible-variable name))) 8216 (cond ((null variable) 8217 (setf variable (make-variable :name name 8218 :special-p t)) 8219 (push variable *visible-variables*)) 8220 (t 8221 (setf (variable-special-p variable) t)))))) 8191 (dolist (variable (compiland-arg-vars compiland)) 8192 (aver (null (variable-register variable))) 8193 (setf (variable-register variable) 8194 (if *using-arg-array* nil register)) 8195 (aver (null (variable-index variable))) 8196 (if *using-arg-array* 8197 (setf (variable-index variable) index)) 8198 (incf register) 8199 (incf index))))) 8222 8200 8223 8201 (p2-compiland-process-type-declarations body) … … 8233 8211 (unless (or *closure-variables* *child-p*) 8234 8212 ;; Reserve a register for each parameter. 8235 (dolist (variable ( reverse parameters))8213 (dolist (variable (compiland-arg-vars compiland)) 8236 8214 (aver (null (variable-register variable))) 8237 8215 (aver (null (variable-reserved-register variable))) … … 8240 8218 (t 8241 8219 ;; Otherwise, one register for each argument. 8242 (dolist ( arg args)8243 (declare (ignore arg))8220 (dolist (variable (compiland-arg-vars compiland)) 8221 (declare (ignore variable)) 8244 8222 (allocate-register)))) 8245 8223 (when (and *closure-variables* (not *child-p*)) … … 8256 8234 (cond (*child-p* 8257 8235 (aver (eql (compiland-closure-register compiland) 1)) 8258 (when (some #'variable-closure-index parameters) 8236 (when (some #'variable-closure-index 8237 (compiland-arg-vars compiland)) 8259 8238 (aload (compiland-closure-register compiland)))) 8260 8239 (t … … 8262 8241 (dformat t "p2-compiland ~S anewarray 1~%" (compiland-name compiland)) 8263 8242 (emit 'anewarray "org/armedbear/lisp/LispObject"))) 8264 (dolist (variable parameters)8243 (dolist (variable (compiland-arg-vars compiland)) 8265 8244 (dformat t "considering ~S ...~%" (variable-name variable)) 8266 8245 (when (variable-closure-index variable) … … 8288 8267 (aver (not (null (compiland-closure-register compiland)))) 8289 8268 (cond (*child-p* 8290 (when (some #'variable-closure-index parameters) 8269 (when (some #'variable-closure-index 8270 (compiland-arg-vars compiland)) 8291 8271 (emit 'pop))) 8292 8272 (t … … 8298 8278 (when *using-arg-array* 8299 8279 (unless (or *closure-variables* *child-p*) 8300 (dolist (variable ( reverse parameters))8280 (dolist (variable (compiland-arg-vars compiland)) 8301 8281 (when (variable-reserved-register variable) 8302 8282 (aver (not (variable-special-p variable))) … … 8308 8288 (setf (variable-index variable) nil))))) 8309 8289 8310 (generate-type-checks-for-variables ( reverse parameters))8290 (generate-type-checks-for-variables (compiland-arg-vars compiland)) 8311 8291 8312 8292 ;; Unbox variables. 8313 (dolist (variable ( reverse parameters))8293 (dolist (variable (compiland-arg-vars compiland)) 8314 8294 (p2-compiland-unbox-variable variable)) 8315 8295 8316 8296 ;; Establish dynamic bindings for any variables declared special. 8317 (when (some #'variable-special-p parameters)8297 (when (some #'variable-special-p (compiland-arg-vars compiland)) 8318 8298 ;; Save the dynamic environment 8319 8299 (setf (compiland-environment-register compiland) … … 8323 8303 +lisp-special-binding+) 8324 8304 (astore (compiland-environment-register compiland)) 8325 (label label-START) )8326 (dolist (variable parameters)8327 (when (variable-special-p variable)8328 (cond ((variable-register variable)8329 (emit-push-current-thread)8330 (emit-push-variable-name variable)8331 (aload (variable-register variable))8332 (emit-invokevirtual +lisp-thread-class+ "bindSpecial"8333 (list +lisp-symbol+ +lisp-object+) nil)8334 (setf (variable-register variable) nil))8335 ((variable-index variable)8336 (emit-push-current-thread)8337 (emit-push-variable-name variable)8338 (aload (compiland-argument-register compiland))8339 (emit-push-constant-int (variable-index variable))8340 (emit 'aaload)8341 (emit-invokevirtual +lisp-thread-class+ "bindSpecial"8342 (list +lisp-symbol+ +lisp-object+) nil)8343 (setf (variable-index variable) nil)))))8305 (label label-START) 8306 (dolist (variable (compiland-arg-vars compiland)) 8307 (when (variable-special-p variable) 8308 (cond ((variable-register variable) 8309 (emit-push-current-thread) 8310 (emit-push-variable-name variable) 8311 (aload (variable-register variable)) 8312 (emit-invokevirtual +lisp-thread-class+ "bindSpecial" 8313 (list +lisp-symbol+ +lisp-object+) nil) 8314 (setf (variable-register variable) nil)) 8315 ((variable-index variable) 8316 (emit-push-current-thread) 8317 (emit-push-variable-name variable) 8318 (aload (compiland-argument-register compiland)) 8319 (emit-push-constant-int (variable-index variable)) 8320 (emit 'aaload) 8321 (emit-invokevirtual +lisp-thread-class+ "bindSpecial" 8322 (list +lisp-symbol+ +lisp-object+) nil) 8323 (setf (variable-index variable) nil)))))) 8344 8324 8345 8325 (compile-progn-body body 'stack)
Note: See TracChangeset
for help on using the changeset viewer.