← Back to branch summary

~ubuntu-branches/ubuntu/intrepid/ecl/intrepid

« back to all changes in this revision

Viewing changes to src/cmp/cmpexit.lsp

  • Committer: Bazaar Package Importer
  • Author(s): Peter Van Eynde
  • Date: 2006-05-17 02:46:26 UTC
  • Revision ID: james.westby@ubuntu.com-20060517024626-lljr08ftv9g9vefl
Tags: upstream-0.9h-20060510
Import upstream version 0.9h-20060510

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/cmp/cmpexit.lsp
 
1
;;;;  Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
 
2
;;;;  Copyright (c) 1990, Giuseppe Attardi.
 
3
;;;;
 
4
;;;;    This program is free software; you can redistribute it and/or
 
5
;;;;    modify it under the terms of the GNU Library General Public
 
6
;;;;    License as published by the Free Software Foundation; either
 
7
;;;;    version 2 of the License, or (at your option) any later version.
 
8
;;;;
 
9
;;;;    See file '../Copyright' for full details.
 
10
 
 
11
;;;; CMPEXIT  Exit manager.
 
12
 
 
13
(in-package "COMPILER")
 
14
 
 
15
(defun unwind-bds (bds-lcl bds-bind stack-pop)
 
16
  (declare (fixnum bds-bind))
 
17
  (when stack-pop
 
18
    (wt-nl "cl_stack_pop_n(" (car stack-pop))
 
19
    (dolist (f (cdr stack-pop))
 
20
      (wt "+" f))
 
21
    (wt ");"))
 
22
  (when bds-lcl (wt-nl "bds_unwind(" bds-lcl ");"))
 
23
  (if (< bds-bind 4)
 
24
      (dotimes (n bds-bind) (declare (fixnum n)) (wt-nl "bds_unwind1();"))
 
25
      (wt-nl "bds_unwind_n(" bds-bind ");")))
 
26
 
 
27
(defun unwind-exit (loc &optional (jump-p nil)
 
28
                        &aux (bds-lcl nil) (bds-bind 0) (stack-pop nil))
 
29
  (declare (fixnum bds-bind))
 
30
  (when (consp *destination*)
 
31
    (case (car *destination*)
 
32
      (JUMP-TRUE
 
33
       (set-jump-true loc (second *destination*))
 
34
       (when (eq loc t) (return-from unwind-exit)))
 
35
      (JUMP-FALSE
 
36
       (set-jump-false loc (second *destination*))
 
37
       (when (eq loc nil) (return-from unwind-exit)))))
 
38
  (dolist (ue *unwind-exit* (baboon))
 
39
    ;; perform all unwind-exit's which precede *exit*
 
40
    (cond
 
41
      ((consp ue)                   ; ( label# . ref-flag )| (STACK n) |(LCL n)
 
42
       (cond ((eq (car ue) 'STACK)
 
43
              (push (second ue) stack-pop))
 
44
             ((eq (car ue) 'LCL)
 
45
              (setq bds-lcl ue bds-bind 0))
 
46
             ((eq ue *exit*)
 
47
              ;; all body forms except the last (returning) are dealt here
 
48
              (cond ((and (consp *destination*)
 
49
                          (or (eq (car *destination*) 'JUMP-TRUE)
 
50
                              (eq (car *destination*) 'JUMP-FALSE)))
 
51
                     (unwind-bds bds-lcl bds-bind stack-pop))
 
52
                    ((not (or bds-lcl (plusp bds-bind) stack-pop))
 
53
                     (set-loc loc))
 
54
                    ;; Save the value if LOC may possibly refer
 
55
                    ;; to special binding.
 
56
                    ((or (loc-refers-to-special loc)
 
57
                         (loc-refers-to-special *destination*))
 
58
                     (let* ((*temp* *temp*)
 
59
                            (temp (make-temp-var)))
 
60
                       (let ((*destination* temp))
 
61
                         (set-loc loc)) ; temp <- loc
 
62
                       (unwind-bds bds-lcl bds-bind stack-pop)
 
63
                       (set-loc temp))) ; *destination* <- temp
 
64
                    (t
 
65
                     (set-loc loc)
 
66
                     (unwind-bds bds-lcl bds-bind stack-pop)))
 
67
              (when jump-p (wt-nl) (wt-go *exit*))
 
68
              (return))
 
69
             (t (setq jump-p t))))
 
70
      ((numberp ue) (baboon)
 
71
       (setq bds-lcl ue bds-bind 0))
 
72
      (t (case ue
 
73
           (BDS-BIND (incf bds-bind))
 
74
           (RETURN
 
75
             (unless (eq *exit* 'RETURN) (baboon))
 
76
             ;; *destination* must be either RETURN or TRASH.
 
77
             (cond ((eq loc 'VALUES)
 
78
                    ;; from multiple-value-prog1 or values
 
79
                    (unwind-bds bds-lcl bds-bind stack-pop)
 
80
                    (wt-nl "return VALUES(0);"))
 
81
                   ((eq loc 'RETURN)
 
82
                    ;; from multiple-value-prog1 or values
 
83
                    (unwind-bds bds-lcl bds-bind stack-pop)
 
84
                    (wt-nl "return value0;"))      
 
85
                   (t
 
86
                    (let* ((*destination* 'RETURN))
 
87
                      (set-loc loc))
 
88
                    (unwind-bds bds-lcl bds-bind stack-pop)
 
89
                    (wt-nl "return value0;")))
 
90
             (return))
 
91
           ((RETURN-FIXNUM RETURN-CHARACTER RETURN-LONG-FLOAT
 
92
             RETURN-SHORT-FLOAT RETURN-OBJECT)
 
93
            (when (eq *exit* ue)
 
94
              ;; *destination* must be RETURN-FIXNUM
 
95
              (setq loc (list 'COERCE-LOC
 
96
                              (getf '(RETURN-FIXNUM :fixnum
 
97
                                      RETURN-CHARACTER :char
 
98
                                      RETURN-LONG-FLOAT :float
 
99
                                      RETURN-DOUBLE-FLOAT :double
 
100
                                      RETURN-OBJECT :object)
 
101
                                    ue)
 
102
                              loc))
 
103
              (if (or bds-lcl (plusp bds-bind))
 
104
                  (let ((lcl (make-lcl-var :type (second loc))))
 
105
                    (wt-nl "{cl_fixnum " lcl "= " loc ";")
 
106
                    (unwind-bds bds-lcl bds-bind stack-pop)
 
107
                    (wt-nl "return(" lcl ");}"))
 
108
                  (progn
 
109
                    (wt-nl "return(" loc ");")))
 
110
              (return)))
 
111
           (FRAME
 
112
            (let ((*destination* (tmp-destination loc)))
 
113
              (set-loc loc)
 
114
              (setq loc *destination*))
 
115
            (wt-nl "frs_pop();"))
 
116
           (TAIL-RECURSION-MARK)
 
117
           (JUMP (setq jump-p t))
 
118
           (t (baboon))))))
 
119
  ;;; Never reached
 
120
  )
 
121
 
 
122
(defun unwind-no-exit (exit &aux (bds-lcl nil) (bds-bind 0) (stack-pop nil))
 
123
  (declare (fixnum bds-bind))
 
124
  (dolist (ue *unwind-exit* (baboon))
 
125
    (cond
 
126
       ((consp ue)
 
127
        (cond ((eq ue exit)
 
128
               (unwind-bds bds-lcl bds-bind stack-pop)
 
129
               (return))
 
130
              ((eq (first ue) 'STACK)
 
131
               (push (second ue) stack-pop))))
 
132
       ((numberp ue) (setq bds-lcl ue bds-bind 0))
 
133
       ((eq ue 'BDS-BIND) (incf bds-bind))
 
134
       ((member ue '(RETURN RETURN-OBJECT RETURN-FIXNUM RETURN-CHARACTER
 
135
                            RETURN-LONG-FLOAT RETURN-SHORT-FLOAT))
 
136
        (if (eq exit ue)
 
137
          (progn (unwind-bds bds-lcl bds-bind stack-pop)
 
138
                 (return))
 
139
          (baboon))
 
140
        ;;; Never reached
 
141
        )
 
142
       ((eq ue 'FRAME) (wt-nl "frs_pop();"))
 
143
       ((eq ue 'TAIL-RECURSION-MARK)
 
144
        (if (eq exit 'TAIL-RECURSION-MARK)
 
145
          (progn (unwind-bds bds-lcl bds-bind stack-pop)
 
146
                 (return))
 
147
          (baboon))
 
148
        ;;; Never reached
 
149
        )
 
150
       ((eq ue 'JUMP))
 
151
       (t (baboon))
 
152
       ))
 
153
  ;;; Never reached
 
154
  )
 
155
 
 
156
;;; Tail-recursion optimization for a function F is possible only if
 
157
;;;     1. F receives only required parameters, and
 
158
;;;     2. no required parameter of F is enclosed in a closure.
 
159
;;;
 
160
;;; A recursive call (F e1 ... en) may be replaced by a loop only if
 
161
;;;     1. F is not declared as NOTINLINE,
 
162
;;;     2. n is equal to the number of required parameters of F,
 
163
;;;     3. the form is a normal function call (i.e. args are not ARGS-PUSHED),
 
164
;;;     4. (F e1 ... en) is not surrounded by a form that causes dynamic
 
165
;;;        binding (such as LET, LET*, PROGV),
 
166
;;;     5. (F e1 ... en) is not surrounded by a form that that pushes a frame
 
167
;;;        onto the frame-stack (such as BLOCK and TAGBODY whose tags are
 
168
;;;        enclosed in a closure, and CATCH),
 
169
 
 
170
(defun tail-recursion-possible ()
 
171
  (dolist (ue *unwind-exit* (baboon))
 
172
    (cond ((eq ue 'TAIL-RECURSION-MARK) (return t))
 
173
          ((or (numberp ue) (eq ue 'BDS-BIND) (eq ue 'FRAME))
 
174
           (return nil))
 
175
          ((or (consp ue) (eq ue 'JUMP)))
 
176
          (t (baboon)))))
 
177
 
 
178
(defun c2try-tail-recursive-call (fun args)
 
179
  (when (and (listp args) ;; ARGS can be also 'ARGS-PUSHED
 
180
             *tail-recursion-info*
 
181
             (eq fun (first *tail-recursion-info*))
 
182
             (last-call-p)
 
183
             (tail-recursion-possible)
 
184
             (inline-possible (fun-name fun))
 
185
             (= (length args) (length (rest *tail-recursion-info*))))
 
186
    (let* ((*destination* 'TRASH)
 
187
           (*exit* (next-label))
 
188
           (*unwind-exit* (cons *exit* *unwind-exit*)))
 
189
      (c2psetq (cdr *tail-recursion-info*) args)
 
190
      (wt-label *exit*))
 
191
    (unwind-no-exit 'TAIL-RECURSION-MARK)
 
192
    (wt-nl "goto TTL;")
 
193
    (cmpnote "Tail-recursive call of ~s was replaced by iteration."
 
194
             (fun-name fun))
 
195
    t))