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

Diff of /gcl/cmpnew/gcl_cmptop.lsp

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

revision 1.23 by camm, Wed Jun 22 01:37:25 2005 UTC revision 1.24 by camm, Wed Jun 29 04:20:25 2005 UTC
# Line 26  Line 26 
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
# Line 629  Line 636 
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)
# Line 817  Line 826 
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)
# Line 891  Line 894 
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    
# Line 953  Line 956 
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)
# Line 1249  Line 1252 
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 ",")))
# Line 1824  Line 1827 
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    

Legend:
Removed from v.1.23  
changed lines
  Added in v.1.24

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