Changeset 13158


Ignore:
Timestamp:
01/19/11 21:07:53 (12 years ago)
Author:
ehuelsmann
Message:

Further transition to unsafety detection in pass2.

Location:
branches/unsafe-p-removal/abcl/src/org/armedbear/lisp
Files:
2 edited

Legend:

Unmodified
Added
Removed

  • branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass1.lisp

    r13157 r13158  
    11541154  '(
    11551155
    1156      char
    11571156     char-code
    11581157     java:jclass
    … …  
    11921191     or
    11931192     puthash
    1194      quote
    11951193     read-line
    1196      rplacd
    1197      schar
    1198      set
    1199      set-car
    1200      set-cdr
    1201        set-char
    1202        set-schar
    1203        set-std-slot-value
    1204        setq
    1205        std-slot-value
    12061194       stream-element-type
    1207        structure-ref
    1208        structure-set
    1209        svref
    1210        svset
    12111195       sxhash
    12121196       symbol-name

  • branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

    r13157 r13158  
    40314031(define-inlined-function p2-rplacd (form target representation)
    40324032  ((check-arg-count form 2))
    4033   (let ((args (cdr form)))
    4034     (compile-form (first args) 'stack nil)
    4035     (when target
    4036       (emit 'dup))
    4037     (compile-form (second args) 'stack nil)
     4033  (let* ((args (cdr form))
     4034         (*register* *register*)
     4035         (target-register (allocate-register nil)))
     4036    (with-operand-accumulation
     4037        ((accumulate-operand (nil
     4038                              :unsafe-p (some-nested-block
     4039                                         #'node-opstack-unsafe-p
     4040                                         (find-enclosed-blocks (first args))))
     4041          (compile-form (first args) 'stack nil)
     4042          (when target-register
     4043            (emit 'dup)
     4044            (astore target-register)))
     4045         (compile-operand (second args) nil)))
     4046    (maybe-emit-clear-values (car args) (cadr args))
    40384047    (emit-invokevirtual +lisp-object+
    40394048                        "setCdr"
    40404049                        (lisp-object-arg-types 1)
    40414050                        nil)
    4042     (when target
     4051    (when target-register
     4052      (aload target-register)
    40434053      (fix-boxing representation nil)
    40444054      (emit-move-from-stack target representation))))
    … …  
    40464056(define-inlined-function p2-set-car/cdr (form target representation)
    40474057  ((check-arg-count form 2))
    4048   (let ((op (%car form))
    4049         (args (%cdr form)))
    4050     (compile-form (%car args) 'stack nil)
    4051     (compile-form (%cadr args) 'stack nil)
    4052     (when target
    4053       (emit-dup nil :past nil))
     4058  (let* ((op (%car form))
     4059         (args (%cdr form))
     4060         (*register* *register*)
     4061         (target-register (when target (allocate-register nil))))
     4062    (with-operand-accumulation
     4063         ((compile-operand (%car args) nil)
     4064          (accumulate-operand (nil
     4065                               :unsafe-p (some-nested-block
     4066                                          #'node-opstack-unsafe-p
     4067                                          (find-enclosed-blocks (cadr args))))
     4068           (compile-form (%cadr args) 'stack nil)
     4069           (when target-register
     4070             (emit 'dup)
     4071             (astore target-register)))
     4072          (maybe-emit-clear-values (car args) (cadr args))))
    40544073    (emit-invokevirtual +lisp-object+
    40554074                        (if (eq op 'sys:set-car) "setCar" "setCdr")
    40564075                        (lisp-object-arg-types 1)
    40574076                        nil)
    4058     (when target
     4077    (when target-register
     4078      (aload target-register)
    40594079      (fix-boxing representation nil)
    40604080      (emit-move-from-stack target representation))))
    … …  
    48114831         (arg1 (first args))
    48124832         (arg2 (second args)))
    4813     (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    4814                                                arg2 'stack nil)
     4833    (with-operand-accumulation
     4834        ((compile-operand arg1 nil)
     4835         (compile-operand arg2 nil)))
     4836    (maybe-emit-clear-values arg1 arg2)
    48154837    (emit-invokevirtual +lisp-object+ "SLOT_VALUE"
    48164838                        (lisp-object-arg-types 1) +lisp-object+)
    … …  
    48284850         (*register* *register*)
    48294851         (value-register (when target (allocate-register nil))))
    4830     (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    4831                                                arg2 'stack nil
    4832                                                arg3 'stack nil)
     4852    (with-operand-accumulation
     4853        ((compile-operand arg1 nil)
     4854         (compile-operand arg2 nil)
     4855         (compile-operand arg3 nil)))
    48334856    (when value-register
    48344857      (emit 'dup)
    48354858      (astore value-register))
     4859    (maybe-emit-clear-values arg1 arg2 arg3)
    48364860    (emit-invokevirtual +lisp-object+ "setSlotValue"
    48374861                        (lisp-object-arg-types 2) nil)
    … …  
    57935817         (type1 (derive-compiler-type arg1))
    57945818         (type2 (derive-compiler-type arg2)))
    5795     (cond ((and (eq representation :char)
    5796                 (zerop *safety*))
    5797            (compile-form arg1 'stack nil)
    5798            (emit-checkcast +lisp-abstract-string+)
    5799            (compile-form arg2 'stack :int)
    5800            (maybe-emit-clear-values arg1 arg2)
    5801            (emit-invokevirtual +lisp-abstract-string+ "charAt"
    5802                                '(:int) :char)
    5803            (emit-move-from-stack target representation))
    5804           ((and (eq representation :char)
     5819    (cond ((or (and (eq representation :char)
     5820                    (zerop *safety*))
     5821               (and (eq representation :char)
    58055822                (or (eq op 'CHAR) (< *safety* 3))
    58065823                (compiler-subtypep type1 'STRING)
    5807                 (fixnum-type-p type2))
    5808            (compile-form arg1 'stack nil)
    5809            (emit-checkcast +lisp-abstract-string+)
    5810            (compile-form arg2 'stack :int)
     5824                (fixnum-type-p type2)))
     5825           (with-operand-accumulation
     5826               ((compile-operand arg1 nil +lisp-abstract-string+)
     5827                (compile-operand arg2 :int)))
    58115828           (maybe-emit-clear-values arg1 arg2)
    58125829           (emit-invokevirtual +lisp-abstract-string+ "charAt"
    … …  
    58145831           (emit-move-from-stack target representation))
    58155832          ((fixnum-type-p type2)
    5816            (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    5817                                                       arg2 'stack :int)
     5833           (with-operand-accumulation
     5834               ((compile-operand arg1 nil)
     5835                (compile-operand arg2 :int)
     5836                (maybe-emit-clear-values arg1 arg2)))
    58185837           (emit-invokevirtual +lisp-object+
    58195838                               (symbol-name op) ;; "CHAR" or "SCHAR"
    … …  
    58475866                             +lisp-simple-string+
    58485867                             +lisp-abstract-string+)))
    5849              (compile-form arg1 'stack nil)
    5850              (emit-checkcast class)
    5851              (compile-form arg2 'stack :int)
    5852              (compile-form arg3 'stack :char)
    5853              (when target
    5854                (emit 'dup)
    5855                (emit-move-from-stack value-register :char))
     5868             (with-operand-accumulation
     5869                  ((compile-operand arg1 nil class)
     5870                   (compile-operand arg2 :int)
     5871                   (accumulate-operand (:char
     5872                                        :unsafe-p (some-nested-block
     5873                                                   #'node-opstack-unsafe-p
     5874                                                   (find-enclosed-blocks arg3)))
     5875                      (compile-form arg3 'stack :char)
     5876                      (when target
     5877                        (emit 'dup)
     5878                        (emit-move-from-stack value-register :char)))))
    58565879             (maybe-emit-clear-values arg1 arg2 arg3)
    58575880             (emit-invokevirtual class "setCharAt" '(:int :char) nil)
    … …  
    58695892         (let ((arg1 (%cadr form))
    58705893               (arg2 (%caddr form)))
    5871            (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    5872                                                       arg2 'stack :int)
     5894           (with-operand-accumulation
     5895               ((compile-operand arg1 nil)
     5896                (compile-operand arg2 :int)))
     5897           (maybe-emit-clear-values arg1 arg2)
    58735898           (emit-invokevirtual +lisp-object+ "SVREF" '(:int) +lisp-object+)
    58745899           (fix-boxing representation nil)
    … …  
    58845909                (*register* *register*)
    58855910                (value-register (when target (allocate-register nil))))
    5886            (compile-form arg1 'stack nil) ;; vector
    5887            (compile-form arg2 'stack :int) ;; index
    5888            (compile-form arg3 'stack nil) ;; new value
     5911           (with-operand-accumulation
     5912               ((compile-operand arg1 nil) ;; vector
     5913                (compile-operand arg2 :int) ;; intex
     5914                (compile-operand arg3 nil) ;; new value
     5915                ))
    58895916           (when value-register
    58905917             (emit 'dup)
    … …  
    60736100          (let* ((*register* *register*)
    60746101                 (value-register (when target (allocate-register nil))))
    6075             (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    6076                                                        arg3 'stack nil)
     6102            (with-operand-accumulation
     6103                ((compile-operand arg1 nil)
     6104                 (compile-operand arg3 nil)))
    60776105            (when value-register
    60786106              (emit 'dup)
    60796107              (astore value-register))
     6108            (maybe-emit-clear-values arg1 arg3)
    60806109            (emit-invokevirtual +lisp-object+
    60816110                                (format nil "setSlotValue_~D" arg2)
    … …  
    60886117          (let* ((*register* *register*)
    60896118                 (value-register (when target (allocate-register nil))))
    6090             (compile-form arg1 'stack nil)
    6091             (emit-push-constant-int arg2)
    6092             (compile-form arg3 'stack nil)
     6119            (with-operand-accumulation
     6120                ((compile-operand arg1 nil)
     6121                 (compile-operand arg3 nil)))
    60936122            (maybe-emit-clear-values arg1 arg3)
    60946123            (when value-register
    60956124              (emit 'dup)
    60966125              (astore value-register))
     6126            (emit-push-constant-int arg2)
     6127            (emit 'swap)  ;; prevent the integer
     6128                          ;; from being pushed, saved and restored
    60976129            (emit-invokevirtual +lisp-object+ "setSlotValue"
    60986130                                (list :int +lisp-object+) nil)
    … …  
    63366368  (cond ((and (check-arg-count form 2)
    63376369              (eq (derive-type (%cadr form)) 'SYMBOL))
    6338          (emit-push-current-thread)
    6339          (compile-form (%cadr form) 'stack nil)
    6340          (emit-checkcast +lisp-symbol+)
    6341          (compile-form (%caddr form) 'stack nil)
     6370         (with-operand-accumulation
     6371             ((emit-thread-operand)
     6372              (compile-operand (%cadr form) nil +lisp-symbol+)
     6373              (compile-operand (%caddr form) nil)))
    63426374         (maybe-emit-clear-values (%cadr form) (%caddr form))
    63436375         (emit-invokevirtual +lisp-thread+ "setSpecialVariable"
    … …  
    63566388         (value-form (%caddr form)))
    63576389    (when (or (null variable)
    6358         (variable-special-p variable))
     6390              (variable-special-p variable))
    63596391      ;; We're setting a special variable.
    63606392      (cond ((and variable
    … …  
    63636395                  (not (enclosed-by-runtime-bindings-creating-block-p
    63646396                        (variable-block variable))))
    6365        ;; ### choose this compilation order to prevent
    6366        ;; with-operand-accumulation
     6397             ;; choose this compilation order to prevent
     6398             ;; with-operand-accumulation
    63676399             (compile-forms-and-maybe-emit-clear-values value-form 'stack nil)
    6368        (emit 'dup)
     6400             (emit 'dup)
    63696401             (aload (variable-binding-register variable))
    63706402             (emit 'swap)
    … …  
    63766408                  (var-ref-p (third value-form))
    63776409                  (eq (variable-name (var-ref-variable (third value-form)))
    6378           name))
    6379        (with-operand-accumulation
    6380            ((emit-thread-operand)
    6381       (emit-load-externalized-object-operand name)
    6382       (compile-operand (second value-form) nil)
    6383       (maybe-emit-clear-values (second value-form)))
    6384     (emit-invokevirtual +lisp-thread+ "pushSpecial"
    6385             (list +lisp-symbol+ +lisp-object+)
    6386             +lisp-object+)))
     6410                      name))
     6411             (with-operand-accumulation
     6412                 ((emit-thread-operand)
     6413                  (emit-load-externalized-object-operand name)
     6414                  (compile-operand (second value-form) nil)
     6415                  (maybe-emit-clear-values (second value-form)))
     6416                 (emit-invokevirtual +lisp-thread+ "pushSpecial"
     6417                                     (list +lisp-symbol+ +lisp-object+)
     6418                                     +lisp-object+)))
    63876419            (t
    6388        (with-operand-accumulation
    6389            ((emit-thread-operand)
    6390       (emit-load-externalized-object-operand name)
    6391       (compile-operand value-form nil)
    6392       (maybe-emit-clear-values value-form))
    6393          (emit-invokevirtual +lisp-thread+ "setSpecialVariable"
    6394            (list +lisp-symbol+ +lisp-object+)
    6395            +lisp-object+))))
     6420             (with-operand-accumulation
     6421                 ((emit-thread-operand)
     6422                  (emit-load-externalized-object-operand name)
     6423                  (compile-operand value-form nil)
     6424                  (maybe-emit-clear-values value-form))
     6425                 (emit-invokevirtual +lisp-thread+ "setSpecialVariable"
     6426                                     (list +lisp-symbol+ +lisp-object+)
     6427                                     +lisp-object+))))
    63966428      (fix-boxing representation nil)
    63976429      (emit-move-from-stack target representation)
Note: See TracChangeset for help on using the changeset viewer.