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 |
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)))) |
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*))) |
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" |
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) ";") |
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) |
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) |
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 |
|
|
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) |