/[gcl]/gcl/cmpnew/gcl_cmpinline.lsp
ViewVC logotype

Diff of /gcl/cmpnew/gcl_cmpinline.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.20 by camm, Wed Jun 29 04:17:20 2005 UTC revision 1.21 by camm, Fri Jul 8 06:02:47 2005 UTC
# Line 1  Line 1 
1    ;;-*-Lisp-*-
2  ;;; CMPINLINE  Open coding optimizer.  ;;; CMPINLINE  Open coding optimizer.
3  ;;;  ;;;
4  ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa  ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
# Line 42  Line 43 
43    (changed-array (mia 10 0))     ;;; List of var-objects changed by the form.    (changed-array (mia 10 0))     ;;; List of var-objects changed by the form.
44    (referred-array (mia 10 0)))   ;;; List of var-objects referred in the form.    (referred-array (mia 10 0)))   ;;; List of var-objects referred in the form.
45    
46    ;; This is the begininng of the long-awaited type-handling
47    ;; centralization.  +c-global-arg-types+ can be passed unboxed to the
48    ;; interpreter -- there are at most three (encoded in a two bit field)
49    ;; of these which must be coordinated with the enum ftype definined in
50    ;; object.h. +c-local-arg-types+ is a larger set which can be passed
51    ;; unboxed to and from compiled functions in the same lisp source file
52    ;; -- these must be passable in total on the C stack by value, i.e. no
53    ;; pointers.  +c-local-var-types+ is a larger set which can be
54    ;; manipulated unboxed within compiled functions, presumably to
55    ;; allocate them on the local stack and save gc, but cannot be passed
56    ;; as function arguments or returned therefrom.  20050707 CM.
57    
58    (defconstant +c-global-arg-types+   `(fixnum)) ;FIXME (long-float short-float) later
59    (defconstant +c-local-arg-types+    (union +c-global-arg-types+ '(fixnum character long-float short-float)))
60    (defconstant +c-local-var-types+    (union +c-local-arg-types+ '(fixnum character long-float short-float integer)))
61    
62    (defun get-sym (args)
63      (intern (apply 'concatenate 'string (mapcar 'string args))))
64    
65    (defconstant +set-return-alist+
66      (mapcar (lambda (x) (cons (get-sym `("RETURN-" ,x)) (get-sym `("SET-RETURN-" ,x)))) +c-local-arg-types+))
67    (defconstant +return-alist+
68      (mapcar (lambda (x) (cons x (get-sym `("RETURN-" ,x)))) (cons 'object +c-local-arg-types+)))
69    (defconstant +wt-loc-alist+
70      `((object . wt-loc)
71        ,@(mapcar (lambda (x) (cons x (get-sym `("WT-" ,x "-LOC")))) +c-local-var-types+)))
72    (defconstant +coersion-alist+
73      (mapcar (lambda (x) (cons x (get-sym `(,x "-LOC")))) +c-local-var-types+))
74    (defconstant +inline-types-alist+
75      `((boolean . inline-cond) (t . inline)
76        ,@(mapcar (lambda (x) (cons x (get-sym `("INLINE-" ,x)))) +c-local-var-types+)))
77    
78  (defun copy-array (array)  (defun copy-array (array)
79    (declare ((vector t) array))    (declare ((vector t) array))
80    (let ((new-array (mia (the fixnum (array-total-size array)) (length array))))    (let ((new-array (mia (the fixnum (array-total-size array)) (length array))))
# Line 245  Line 278 
278  ;;; This variable is used to close up blocks introduced to declare static  ;;; This variable is used to close up blocks introduced to declare static
279  ;;; c variables.  ;;; c variables.
280    
 (defvar *special-types* '(FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT integer))  
   
281  (defun inc-inline-blocks()  (defun inc-inline-blocks()
282    (cond ((consp *inline-blocks*)    (cond ((consp *inline-blocks*)
283           (incf (car *inline-blocks*)))           (incf (car *inline-blocks*)))
# Line 264  Line 295 
295                (LOCATION (push (coerce-loc (caddr form) type) locs))                (LOCATION (push (coerce-loc (caddr form) type) locs))
296                (VAR                (VAR
297                 (cond ((args-info-changed-vars (caaddr form) (cdr forms))                 (cond ((args-info-changed-vars (caaddr form) (cdr forms))
298                        (cond ((and (member (var-kind (caaddr form))                        (cond ((and (member (var-kind (caaddr form)) +c-local-var-types+)
                                          *special-types*)  
299                                    (eq type (var-kind (caaddr form))))                                    (eq type (var-kind (caaddr form))))
300                               (let ((cvar (cs-push type t)))                               (let ((cvar (cs-push type t)))
301                                 (wt-nl "{" (rep-type type) "V" cvar "= V"                                 (wt-nl "{" (rep-type type) "V" cvar "= V"
# Line 278  Line 308 
308                                 (wt-var (caaddr form) (cadr (caddr form)))                                 (wt-var (caaddr form) (cadr (caddr form)))
309                                 (wt ";")                                 (wt ";")
310                                 (push (coerce-loc temp type) locs)))))                                 (push (coerce-loc temp type) locs)))))
311                       ((and (member (var-kind (caaddr form))                       ((and (member (var-kind (caaddr form)) +c-local-var-types+)
312                                         '(FIXNUM LONG-FLOAT SHORT-FLOAT INTEGER))                             (not (eq type (var-kind (caaddr form)))))
                                (not (eq type (var-kind (caaddr form)))))  
313                        (let ((temp (cs-push type)))                        (let ((temp (cs-push type)))
314                          (wt-nl "V" temp " = "                          (wt-nl "V" temp " = "
315                                 (coerce-loc (cons 'var (caddr form)) type) ";")                                 (coerce-loc (cons 'var (caddr form)) type) ";")
# Line 328  Line 357 
357                                 (wt-loc loc))                                 (wt-loc loc))
358                                (t (setq cvar (cs-push type t))                                (t (setq cvar (cs-push type t))
359                                   (wt-nl "{" (rep-type type) "V" cvar "= ")                                   (wt-nl "{" (rep-type type) "V" cvar "= ")
360                                   (case (promoted-c-type type)                                   (funcall (or (cdr (assoc (promoted-c-type type) +wt-loc-alist+)) 'wt-loc) loc)
                                    (fixnum (wt-fixnum-loc loc))  
                                    (integer (wt-integer-loc loc 'inline-args))  
                                    (character (wt-character-loc loc))  
                                    (long-float (wt-long-float-loc loc))  
                                    (short-float (wt-short-float-loc loc))  
                                    (otherwise (wt-loc loc)))  
361                                   (inc-inline-blocks)))                                   (inc-inline-blocks)))
362                              (wt ";")                              (wt ";")
363                              (push (list 'cvar cvar 'inline-args) locs)                              (push (list 'cvar cvar 'inline-args) locs)
# Line 365  Line 388 
388                               ((eq type t) (list 'cvar (cs-push)))                               ((eq type t) (list 'cvar (cs-push)))
389                               ((list 'var                               ((list 'var
390                                      (make-var :type type :loc (cs-push type)                                      (make-var :type type :loc (cs-push type)
391                                                :kind (or (car (member (promoted-c-type type) *special-types*)) 'object))                                                :kind (or (car (member (promoted-c-type type) +c-local-var-types+)) 'object))
392                                      nil)))))                                      nil)))))
393                     (let ((*value-to-go* temp))                     (let ((*value-to-go* temp))
394                       (c2expr* form)                       (c2expr* form)
395                       (push (coerce-loc temp type) locs))))))))                       (push (coerce-loc temp type) locs))))))))
396    
 ;;FIXME mapcar  
 (defvar *coersion-alist* '((fixnum . fixnum-loc)  
                            (integer . integer-loc)  
                            (character . character-loc)  
                            (short-float . short-float-loc)  
                            (long-float . long-float-loc)))  
   
397  (defun coerce-loc (loc type)  (defun coerce-loc (loc type)
398    (let ((tl (cdr (assoc (promoted-c-type type) *coersion-alist*))))    (let ((tl (cdr (assoc (promoted-c-type type) +coersion-alist+))))
399      (if tl (list tl loc) loc)))      (if tl (list tl loc) loc)))
400    
401  (defun get-inline-loc (ii args &aux (fun (car (cdddr ii))) locs)  (defun get-inline-loc (ii args &aux (fun (car (cdddr ii))) locs)
# Line 400  Line 416 
416            ((endp l) (setq locs (reverse locs1)))            ((endp l) (setq locs (reverse locs1)))
417            (declare (fixnum n) (object l))            (declare (fixnum n) (object l))
418            (if (member n saves)            (if (member n saves)
419                (let* ((loc1 (car l)) (loc loc1) (coersion nil))                (let* ((loc (car l)) (loc1 loc)
420                      (declare (object loc loc1))                       (coersion (and (consp loc) (cdr (rassoc (car loc) +coersion-alist+))))
421                  (when (and (consp loc1)                       (loc (if coersion (cadr loc) loc))); remove coersion
                            (member (car loc1)  
                                    '(FIXNUM-LOC integer-loc CHARACTER-LOC  
                                      LONG-FLOAT-LOC SHORT-FLOAT-LOC)))  
                       (setq coersion (car loc1))  
                       (setq loc (cadr loc1))  ; remove coersion  
                       )  
422                  (cond                  (cond
423                   ((and (consp loc)                   ((and (consp loc)
424                         (or                         (rassoc (car loc) +inline-types-alist+)
425                           (member (car loc)                         (or (member (car loc) '(inline inline-cond))
426                                      '(INLINE INLINE-COND))                             (flag-p (cadr loc) allocates-new-storage)
427                           (and    (member (car loc)                             (flag-p (cadr loc) side-effect-p)))
                                          '(  
                                            INLINE-FIXNUM inline-integer  
                                            INLINE-CHARACTER INLINE-LONG-FLOAT  
                                            INLINE-SHORT-FLOAT))  
                                  (or (flag-p (cadr loc) allocates-new-storage)  
                                      (flag-p (cadr loc) side-effect-p))  
                                     )))  
428                    (wt-nl "{")                    (wt-nl "{")
429                    (inc-inline-blocks) ;;FIXME -- make sure not losing specificity in coersion                    (inc-inline-blocks) ;;FIXME -- make sure not losing specificity in coersion
430                    (let ((cvar (cs-push (car (rassoc coersion *coersion-alist*)) t)))                    (let* ((ck (or (car (rassoc coersion +coersion-alist+)) 'object))
431                             (cvar (cs-push ck t)))
432                      (push (list 'CVAR cvar) locs1)                      (push (list 'CVAR cvar) locs1)
433                      (case coersion                      (unless ck (baboon))
434                       ((nil) (wt "object V" cvar "= ") (wt-loc loc1))                      (wt (rep-type ck) "V" cvar "= ")
435                       (FIXNUM-LOC (wt "fixnum V" cvar "= ") (wt-fixnum-loc loc))                      (funcall (cdr (assoc ck +wt-loc-alist+)) loc))
436                       (integer-loc (wt "GEN V" cvar "= ") (wt-integer-loc loc 'get-inline-locs))                    (wt ";"))
                      (CHARACTER-LOC  
                       (wt "unsigned char V" cvar "= ") (wt-character-loc loc))  
                      (LONG-FLOAT-LOC  
                       (wt "double V" cvar "= ") (wt-long-float-loc loc))  
                      (SHORT-FLOAT-LOC  
                       (wt "float V" cvar "= ") (wt-short-float-loc loc))  
                      (t (baboon))))  
                   (wt ";")  
                   )  
437                   (t (push loc1 locs1))))                   (t (push loc1 locs1))))
438                (push (car l) locs1)))))                (push (car l) locs1)))))
439    
# Line 450  Line 445 
445            locs            locs
446            ))            ))
447    )    )
 (defvar *inline-types*  
   '((boolean . INLINE-COND)  
     (fixnum . INLINE-FIXNUM)  
     (character . INLINE-CHARACTER)  
     (long-float . INLINE-LONG-FLOAT)  
     (short-float . INLINE-SHORT-FLOAT)  
     (integer . INLINE-INTEGER)  
     (t . INLINE)))  
448    
449  (defun inline-type (type)  (defun inline-type (type)
450    (or (cdr (assoc (promoted-c-type type) *inline-types*)) 'inline))    (or (cdr (assoc (promoted-c-type type) +inline-types-alist+)) 'inline))
451    
452  (defun get-inline-info (fname args return-type &aux x ii)  (defun get-inline-info (fname args return-type &aux x ii)
453    (and  (fast-link-proclaimed-type-p fname args)    (and  (fast-link-proclaimed-type-p fname args)

Legend:
Removed from v.1.20  
changed lines
  Added in v.1.21

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26