26 |
(defvar *sharp-commas* nil) |
(defvar *sharp-commas* nil) |
27 |
(defvar *function-links* nil) |
(defvar *function-links* nil) |
28 |
(defvar *c-gc* t) ;if we gc the c stack. |
(defvar *c-gc* t) ;if we gc the c stack. |
29 |
|
|
30 |
|
;; We are expanding the use of *c-vars* to hold type information for C |
31 |
|
;; stack variables initialized in inline blocks too. conses of form |
32 |
|
;; type . num get initialized at function top as before. conses of |
33 |
|
;; this form and the alternate form (num . type) are searched for |
34 |
|
;; inline matching late in pass2, e.g. cmp-aref-inline. 20060627 CM |
35 |
(defvar *c-vars*) ;list of *c-vars* to put at beginning of function. |
(defvar *c-vars*) ;list of *c-vars* to put at beginning of function. |
36 |
|
|
37 |
;;number of address registers available not counting the |
;;number of address registers available not counting the |
38 |
;;frame pointer and the stack pointer |
;;frame pointer and the stack pointer |
39 |
;;If sup and base are used, then their are even 2 less |
;;If sup and base are used, then their are even 2 less |
636 |
|
|
637 |
|
|
638 |
|
|
639 |
(defun cs-push (&optional type) |
(defun cs-push (&optional type local) |
640 |
(let ((tem (next-cvar))) |
(let ((tem (cs-push t t))) |
641 |
(push (if type (cons type tem) tem) *c-vars*) |
(let ((type (or type t))) |
642 |
|
(when (or (not local) (not (eq type t))) |
643 |
|
(push (if local (cons tem type) (cons type tem)) *c-vars*))) |
644 |
tem)) |
tem)) |
645 |
; For the moment only two types are recognized. |
; For the moment only two types are recognized. |
646 |
(defun f-type (x) |
(defun f-type (x) |
826 |
(let-pass3 () (apply f lis))) |
(let-pass3 () (apply f lis))) |
827 |
|
|
828 |
(defun t3defun-local-entry (fname cfun lambda-expr sp inline-info |
(defun t3defun-local-entry (fname cfun lambda-expr sp inline-info |
829 |
&aux specials |
&aux specials (requireds (caaddr lambda-expr))) |
|
(requireds (caaddr lambda-expr))) |
|
830 |
(do ((vl requireds (cdr vl)) |
(do ((vl requireds (cdr vl)) |
831 |
(types (cadr inline-info) (cdr types))) |
(types (cadr inline-info) (cdr types))) |
832 |
((endp vl)) |
((endp vl)) |
833 |
(declare (object vl types)) |
; (declare (object vl types)) |
834 |
(cond ((eq (var-kind (car vl)) 'special) |
(if (eq (var-kind (car vl)) 'special) |
835 |
(push (cons (car vl) (var-loc (car vl))) specials)) |
(push (cons (car vl) (var-loc (car vl))) specials) |
836 |
(t |
(setf (var-kind (car vl)) |
837 |
(setf (var-kind (car vl)) |
(case (promoted-c-type (car types)) |
838 |
(case (promoted-c-type (car types)) |
(fixnum 'FIXNUM) |
839 |
(fixnum 'FIXNUM) |
(integer 'integer) |
840 |
(integer 'integer) |
(character 'CHARACTER) |
841 |
(character 'CHARACTER) |
(long-float 'LONG-FLOAT) |
842 |
(long-float 'LONG-FLOAT) |
(short-float 'SHORT-FLOAT) |
843 |
(short-float 'SHORT-FLOAT) |
(otherwise 'OBJECT)))) |
844 |
(otherwise 'OBJECT)))) |
(setf (var-loc (car vl)) (cs-push (var-type (car vl)) t))) |
845 |
) |
(wt-comment "local entry for function " (function-string fname)) |
846 |
(setf (var-loc (car vl)) (next-cvar))) |
(wt-h "static " (declaration-type (rep-type (caddr inline-info))) (c-function-name "LI" cfun fname) "();") |
847 |
(wt-comment "local entry for function " (function-string fname)) |
(wt-nl1 "static " (declaration-type (rep-type (caddr inline-info))) (c-function-name "LI" cfun fname) "(") |
848 |
(wt-h "static " (declaration-type (rep-type (caddr inline-info))) (c-function-name "LI" cfun fname) "();") |
(wt-requireds requireds |
849 |
(wt-nl1 "static " (declaration-type (rep-type (caddr inline-info))) (c-function-name "LI" cfun fname) "(") |
(cadr inline-info)) |
|
(wt-requireds requireds |
|
|
(cadr inline-info)) |
|
850 |
;;; Now the body. |
;;; Now the body. |
851 |
(let ((cm *reservation-cmacro*) |
(let ((cm *reservation-cmacro*) |
852 |
(*tail-recursion-info* |
(*tail-recursion-info* |
853 |
(if *do-tail-recursion* (cons fname requireds) nil)) |
(if *do-tail-recursion* (cons fname requireds) nil)) |
854 |
(*unwind-exit* *unwind-exit*)) |
(*unwind-exit* *unwind-exit*)) |
855 |
(wt-nl1 "{ ") |
(wt-nl1 "{ ") |
856 |
(assign-down-vars (cadr lambda-expr) cfun |
(assign-down-vars (cadr lambda-expr) cfun |
857 |
't3defun) |
't3defun) |
858 |
(wt " VMB" cm " VMS" cm " VMV" cm) |
(wt " VMB" cm " VMS" cm " VMV" cm) |
859 |
|
|
860 |
(when sp (wt-nl "bds_check;")) |
(when sp (wt-nl "bds_check;")) |
861 |
(when *compiler-push-events* (wt-nl "ihs_check;")) |
(when *compiler-push-events* (wt-nl "ihs_check;")) |
862 |
(when *tail-recursion-info* |
(when *tail-recursion-info* |
863 |
(push 'tail-recursion-mark *unwind-exit*) |
(push 'tail-recursion-mark *unwind-exit*) |
864 |
(wt-nl "goto TTL;") (wt-nl1 "TTL:;")) |
(wt-nl "goto TTL;") (wt-nl1 "TTL:;")) |
865 |
(dolist |
(dolist |
866 |
(v specials) |
(v specials) |
867 |
(wt-nl "bds_bind(VV[" (cdr v)"],V" (var-loc (car v))");") |
(wt-nl "bds_bind(VV[" (cdr v)"],V" (var-loc (car v))");") |
868 |
(push 'bds-bind *unwind-exit*) |
(push 'bds-bind *unwind-exit*) |
869 |
(setf (var-kind (car v)) 'SPECIAL) |
(setf (var-kind (car v)) 'SPECIAL) |
870 |
(setf (var-loc (car v)) (cdr v))) |
(setf (var-loc (car v)) (cdr v))) |
871 |
(c2expr (caddr (cddr lambda-expr))) |
(c2expr (caddr (cddr lambda-expr))) |
872 |
|
|
873 |
;;; Use base if defined for lint |
;;; Use base if defined for lint |
874 |
(if (and (zerop *max-vs*) (not *sup-used*) (not *base-used*)) t (wt-nl "base[0]=base[0];")) |
(if (and (zerop *max-vs*) (not *sup-used*) (not *base-used*)) t (wt-nl "base[0]=base[0];")) |
875 |
|
|
876 |
;;; Make sure to return object if necessary |
;;; Make sure to return object if necessary |
877 |
(if (equal "object " (rep-type (caddr inline-info))) (wt-nl "return Cnil;")) |
(if (equal "object " (rep-type (caddr inline-info))) (wt-nl "return Cnil;")) |
878 |
|
|
879 |
(wt-nl1 "}") |
(wt-nl1 "}") |
880 |
(wt-V*-macros cm (caddr inline-info)) |
(wt-V*-macros cm (caddr inline-info)))) |
|
)) |
|
|
|
|
|
|
|
881 |
|
|
882 |
(defvar *vararg-use-vs* nil) |
(defvar *vararg-use-vs* nil) |
883 |
(defun set-up-var-cvs (var) |
(defun set-up-var-cvs (var) |
894 |
(ll-optionals ll) |
(ll-optionals ll) |
895 |
(ll-keywords-p ll)))) |
(ll-keywords-p ll)))) |
896 |
(dolist (v (car ll)) |
(dolist (v (car ll)) |
897 |
(push (list 'cvar (next-cvar)) reqs)) |
(push (list 'cvar (cs-push t t)) reqs)) |
898 |
|
|
899 |
(wt-comment "local entry for function " (function-string fname)) |
(wt-comment "local entry for function " (function-string fname)) |
900 |
|
|
956 |
(let ((kind (c2var-kind var))) |
(let ((kind (c2var-kind var))) |
957 |
(declare (object kind)) |
(declare (object kind)) |
958 |
(when kind |
(when kind |
959 |
(let ((cvar (next-cvar))) |
(let ((cvar (cs-push (var-type var) t))) |
960 |
(setf (var-kind var) kind) |
(setf (var-kind var) kind) |
961 |
(setf (var-loc var) cvar) |
(setf (var-loc var) cvar) |
962 |
(wt-nl) |
(wt-nl) |
1252 |
(defun wt-requireds (requireds arg-types) |
(defun wt-requireds (requireds arg-types) |
1253 |
(do ((vl requireds (cdr vl))) |
(do ((vl requireds (cdr vl))) |
1254 |
((endp vl)) |
((endp vl)) |
1255 |
(declare (object vl)) |
; (declare (object vl)) |
1256 |
(let ((cvar (next-cvar))) |
(let ((cvar (cs-push (var-type (car vl)) t))) |
1257 |
(setf (var-loc (car vl)) cvar) |
(setf (var-loc (car vl)) cvar) |
1258 |
(wt "V" cvar)) |
(wt "V" cvar)) |
1259 |
(unless (endp (cdr vl)) (wt ","))) |
(unless (endp (cdr vl)) (wt ","))) |
1827 |
) |
) |
1828 |
|
|
1829 |
(defun wt-cvars( &aux type ) |
(defun wt-cvars( &aux type ) |
1830 |
(dolist (v *c-vars*) |
(let (vars) |
1831 |
(let ((t1 (if (consp v) (prog1 (car v) (setq v (cdr v))) t))) |
(dolist (v *c-vars*) |
1832 |
(cond ((eq type t1)(format *compiler-output2* " ,V~a" v)) |
(when (integerp (cdr v)) |
1833 |
(t (or (null type) |
(setq vars t) |
1834 |
(format *compiler-output2* ";")) |
(let* ((t1 (car v)) |
1835 |
(setq type t1) |
(v (cdr v))) |
1836 |
(if (eq (promoted-c-type type) 'integer) |
(cond ((eq type t1)(format *compiler-output2* " ,V~a" v)) |
1837 |
(format *compiler-output2* "IDECL1(V~a,V~abody,V~aalloc)" v v v) |
(t (or (null type) |
1838 |
(format *compiler-output2* " ~a V~a" (rep-type type) v)))))) |
(format *compiler-output2* ";")) |
1839 |
(and *c-vars* (format *compiler-output2* ";")) |
(setq type t1) |
1840 |
(unless (or (not *vcs-used*) (eql *cs* 0)) |
(if (eq (promoted-c-type type) 'integer) |
1841 |
|
(format *compiler-output2* "IDECL1(V~a,V~abody,V~aalloc)" v v v) |
1842 |
|
(format *compiler-output2* " ~a V~a" (rep-type type) v))))))) |
1843 |
|
(when vars (format *compiler-output2* ";"))) |
1844 |
|
(unless (or (not *vcs-used*) (eql *cs* 0)) |
1845 |
; (format *compiler-output2* " object Vcs[~a]={Cnil" *cs*) |
; (format *compiler-output2* " object Vcs[~a]={Cnil" *cs*) |
1846 |
; (dotimes (temp (- *cs* 1) t) (format *compiler-output2* ",Cnil")) |
; (dotimes (temp (- *cs* 1) t) (format *compiler-output2* ",Cnil")) |
1847 |
; (format *compiler-output2* "};")) |
; (format *compiler-output2* "};")) |
1848 |
(format *compiler-output2* " object Vcs[~a];" *cs*))) |
(format *compiler-output2* " object Vcs[~a];" *cs*))) |
1849 |
|
|
1850 |
|
|
1851 |
|
|