← Back to branch summary

~ubuntu-branches/ubuntu/quantal/gclcvs/quantal

« back to all changes in this revision

Viewing changes to pcl/impl/gcl/gcl-low.lisp

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2004-06-24 15:13:46 UTC
  • Revision ID: james.westby@ubuntu.com-20040624151346-xh0xaaktyyp7aorc
Tags: 2.7.0-26
C_GC_OFFSET is 2 on m68k-linux

Show diffs side-by-side

added added

removed removed

Lines of Context:
pcl/impl/gcl/gcl-low.lisp
 
1
(in-package "SI")
 
2
(export '(%structure-name
 
3
          %compiled-function-name
 
4
          %set-compiled-function-name))
 
5
(in-package 'pcl)
 
6
(eval-when (compile eval load)
 
7
(setq  *EVAL-WHEN-COMPILE* t)
 
8
)
 
9
 
 
10
(defmacro memq (item list) `(member ,item ,list :test #'eq))
 
11
(defmacro assq (item list) `(assoc ,item ,list :test #'eq))
 
12
(defmacro posq (item list) `(position ,item ,list :test #'eq))
 
13
 
 
14
(defmacro dotimes ((var form &optional (val nil)) &rest body &environment env)
 
15
  (multiple-value-bind (doc decls bod)
 
16
      (extract-declarations body env)
 
17
    (declare (ignore doc))
 
18
    (let ((limit (gensym))
 
19
          (label (gensym)))
 
20
      `(let ((,limit ,form)
 
21
             (,var 0))
 
22
         (declare (fixnum ,limit ,var))
 
23
         ,@decls
 
24
         (block nil
 
25
           (tagbody
 
26
            ,label
 
27
              (when (>= ,var ,limit) (return-from nil ,val))
 
28
              ,@bod
 
29
              (setq ,var (the fixnum (1+ ,var)))
 
30
              (go ,label)))))))
 
31
 
 
32
(defun printing-random-thing-internal (thing stream)
 
33
  (format stream "~O" (si:address thing)))
 
34
 
 
35
(eval-when (compile load eval)
 
36
(pushnew :turbo-closure *features*)
 
37
(pushnew :turbo-closure-env-size *features*))
 
38
)
 
39
 
 
40
(defmacro %svref (vector index)
 
41
  `(svref (the simple-vector ,vector) (the fixnum ,index)))
 
42
 
 
43
(defsetf %svref (vector index) (new-value)
 
44
  `(setf (svref (the simple-vector ,vector) (the fixnum ,index))
 
45
         ,new-value))
 
46
 
 
47
(si::freeze-defstruct 'pcl::std-instance)
 
48
 
 
49
(si::freeze-defstruct 'method-call)
 
50
(si::freeze-defstruct 'fast-method-call)
 
51
 
 
52
(defvar *pcl-funcall*  `(lambda (loc)
 
53
          (compiler::wt-nl
 
54
           "{object _funobj = " loc ";"
 
55
           "if(type_of(_funobj)==t_cclosure && (_funobj->cc.cc_turbo))
 
56
                   (*(_funobj->cc.cc_self))(_funobj->cc.cc_turbo);
 
57
               else if (type_of(_funobj)==t_cfun) (*(_funobj->cc.cc_self))();
 
58
               else super_funcall_no_event(_funobj);}")))
 
59
 
 
60
(setq compiler::*super-funcall* *pcl-funcall*)
 
61
 
 
62
(defmacro fmc-funcall (fn pv-cell next-method-call &rest args)
 
63
  `(funcall ,fn ,pv-cell ,next-method-call ,@args))
 
64
 
 
65
(defun pcl::proclaim-defmethod (x y) y
 
66
  (and (symbolp x)
 
67
       (setf (get x 'compiler::proclaimed-closure ) t)))
 
68
 
 
69
 
 
70
 
 
71
;#+turbo-closure-env-size
 
72
(clines "
 
73
static
 
74
object cclosure_env_nthcdr (n,cc)
 
75
int n; object cc;
 
76
{  object env,*turbo;
 
77
   if(n<0)return Cnil;
 
78
   if(type_of(cc)!=t_cclosure)return Cnil;
 
79
   if((turbo=cc->cc.cc_turbo)==NULL)
 
80
     {env=cc->cc.cc_env;
 
81
      while(n-->0)
 
82
        {if(type_of(env)!=t_cons)return Cnil;
 
83
         env=env->c.c_cdr;}
 
84
      return env;}
 
85
   else
 
86
     {if(n>=fix(*(turbo-1)))return Cnil;
 
87
      return turbo[n];}
 
88
}")
 
89
 
 
90
(defentry cclosure-env-nthcdr (int object) (object cclosure_env_nthcdr))
 
91
;; This is the unsafe but fast version.
 
92
(defentry %cclosure-env-nthcdr (int object) (object cclosure_env_nthcdr))
 
93
 
 
94
(eval-when (compile eval load)
 
95
(defparameter *gcl-function-inlines*
 
96
  '( (%fboundp (t) compiler::boolean nil nil "(#0)->s.s_gfdef!=OBJNULL")
 
97
     (%symbol-function (t) t nil nil "(#0)->s.s_gfdef")
 
98
     (si:%structure-name (t) t nil nil "(#0)->str.str_def->str.str_self[0]")
 
99
    (si:%compiled-function-name (t) t nil nil "(#0)->cf.cf_name")
 
100
    (si:%set-compiled-function-name (t t) t t nil "((#0)->cf.cf_name)=(#1)")
 
101
    (cclosurep (t) compiler::boolean nil nil "type_of(#0)==t_cclosure")
 
102
    (sfun-p (t) compiler::boolean nil nil "type_of(#0)==t_sfun")
 
103
    (%cclosure-env (t) t nil nil "(#0)->cc.cc_env")
 
104
    (%set-cclosure-env (t t) t t nil "((#0)->cc.cc_env)=(#1)")
 
105
    #+turbo-closure
 
106
    (%cclosure-env-nthcdr (fixnum t) t nil nil "(#1)->cc.cc_turbo[#0]")
 
107
    
 
108
    (logxor (fixnum fixnum) fixnum nil nil "((#0) ^ (#1))")))
 
109
 
 
110
(defun make-function-inline (inline)
 
111
  (setf (get (car inline) 'compiler::inline-always)
 
112
        (list (if (fboundp 'compiler::flags)
 
113
                  (let ((opt (cdr inline)))
 
114
                    (list (first opt) (second opt)
 
115
                          (logior (if (fourth opt) 1 0) ; allocates-new-storage
 
116
                                  (if (third opt) 2 0)  ; side-effect
 
117
                                  (if nil 4 0) ; constantp
 
118
                                  (if (eq (car inline) 'logxor)
 
119
                                      8 0)) ;result type from args
 
120
                          (fifth opt)))
 
121
                  (cdr inline)))))
 
122
)
 
123
 
 
124
 
 
125
(defmacro define-inlines ()
 
126
  `(progn
 
127
    ,@(mapcan #'(lambda (inline)
 
128
                  (let ((name (intern (format nil "~S inline" (car inline))))
 
129
                        (vars (mapcar #'(lambda (type)
 
130
                                          (declare (ignore type))
 
131
                                          (gensym))
 
132
                                      (cadr inline))))
 
133
                    `((eval-when (compile eval load)
 
134
                                 (make-function-inline
 
135
                                  ',(cons name (cdr inline))))
 
136
                      ,@(when (or (every #'(lambda (type) (eq type 't))
 
137
                                         (cadr inline))
 
138
                                  (char= #\% (aref (symbol-name (car inline)) 0)))
 
139
                          `((defun ,(car inline) ,vars
 
140
                              ,@(mapcan #'(lambda (var var-type)
 
141
                                            (unless (eq var-type 't)
 
142
                                              `((declare (type ,var-type ,var)))))
 
143
                                        vars (cadr inline))
 
144
                              (the ,(caddr inline) (,name ,@vars)))
 
145
                            (make-function-inline ',inline))))))
 
146
              *gcl-function-inlines*)))
 
147
 
 
148
(define-inlines)
 
149
 
 
150
(defsetf si:%compiled-function-name si:%set-compiled-function-name)
 
151
(defsetf %cclosure-env %set-cclosure-env)
 
152
 
 
153
(defun set-function-name-1 (fn new-name ignore)
 
154
  (declare (ignore ignore))
 
155
  (cond ((compiled-function-p fn)
 
156
         (si::turbo-closure fn)
 
157
         (when (symbolp new-name) (pcl::proclaim-defmethod new-name nil))
 
158
         (setf (si:%compiled-function-name fn) new-name))
 
159
        ((and (listp fn)
 
160
              (eq (car fn) 'lambda-block))
 
161
         (setf (cadr fn) new-name))
 
162
        ((and (listp fn)
 
163
              (eq (car fn) 'lambda))
 
164
         (setf (car fn) 'lambda-block
 
165
               (cdr fn) (cons new-name (cdr fn)))))
 
166
  fn)
 
167
 
 
168
 
 
169
(clines "
 
170
 
 
171
 
 
172
 
 
173
object fSuse_fast_links();
 
174
static
 
175
object set_cclosure (result_cc,value_cc,available_size)
 
176
  object result_cc,value_cc; int available_size;
 
177
{
 
178
  object result_env_tail,value_env_tail; int i;
 
179
 
 
180
  /* If we are currently using fast linking,     */
 
181
  /* make sure to remove the link for result_cc. */
 
182
  (VFUN_NARGS=2,fSuse_fast_links(sLnil,result_cc));
 
183
 
 
184
/*  use_fast_links(3,Cnil,result_cc); */
 
185
 
 
186
  result_env_tail=result_cc->cc.cc_env;
 
187
  value_env_tail=value_cc->cc.cc_env;
 
188
  for(i=available_size;
 
189
      result_env_tail!=Cnil && i>0;
 
190
      result_env_tail=CMPcdr(result_env_tail), value_env_tail=CMPcdr(value_env_tail))
 
191
    CMPcar(result_env_tail)=CMPcar(value_env_tail), i--;
 
192
  result_cc->cc.cc_self=value_cc->cc.cc_self;
 
193
  result_cc->cc.cc_data=value_cc->cc.cc_data;
 
194
 
 
195
 
 
196
  return result_cc;
 
197
}")
 
198
 
 
199
(defentry %set-cclosure (object object int) (object set_cclosure))
 
200
 
 
201
 
 
202
(defun structure-functions-exist-p ()
 
203
  t)
 
204
 
 
205
(si:define-compiler-macro structure-instance-p (x)
 
206
  (once-only (x)
 
207
    `(and (si:structurep ,x)
 
208
          (not (eq (si:%structure-name ,x) 'std-instance)))))
 
209
 
 
210
(defun structure-type (x)
 
211
  (and (si:structurep x)
 
212
       (si:%structure-name x)))
 
213
 
 
214
(si:define-compiler-macro structure-type (x)
 
215
  (once-only (x)
 
216
    `(and (si:structurep ,x)
 
217
          (si:%structure-name ,x))))
 
218
 
 
219
(defun structure-type-p (type)
 
220
  (or (not (null (gethash type *structure-table*)))
 
221
      (let (#+akcl(s-data nil))
 
222
        (and (symbolp type)
 
223
              (setq s-data (get type 'si::s-data))
 
224
             
 
225
             (null  (si::s-data-type s-data)
 
226
                   )))))
 
227
 
 
228
 
 
229
(defun structure-type-included-type-name (type)
 
230
  (or (car (gethash type *structure-table*))
 
231
      (let ((includes (si::s-data-includes (get type 'si::s-data))))
 
232
        (when includes
 
233
          (si::s-data-name includes)))))
 
234
 
 
235
(defun structure-type-internal-slotds (type)
 
236
   (si::s-data-slot-descriptions (get type 'si::s-data))
 
237
  )
 
238
 
 
239
(defun structure-type-slot-description-list (type)
 
240
  (or (cdr (gethash type *structure-table*))
 
241
      (mapcan #'(lambda (slotd)
 
242
                  (when (and slotd (car slotd))
 
243
                    (let ((offset (fifth slotd)))
 
244
                      (let ((reader #'(lambda (x)
 
245
                                         (si:structure-ref1 x offset)
 
246
                                         ))
 
247
                            (writer #'(lambda (v x)
 
248
                                        (si:structure-set x type offset v))))
 
249
                        #+turbo-closure (si:turbo-closure reader)
 
250
                        #+turbo-closure (si:turbo-closure writer)
 
251
                        (let* ((reader-sym 
 
252
                                (let ((*package* *the-pcl-package*))
 
253
                                  (intern (format nil "~s SLOT~D" type offset))))
 
254
                               (writer-sym (get-setf-function-name reader-sym))
 
255
                               (slot-name (first slotd))
 
256
                               (read-only-p (fourth slotd)))
 
257
                          (setf (symbol-function reader-sym) reader)
 
258
                          (setf (symbol-function writer-sym) writer)
 
259
                          (do-standard-defsetf-1 reader-sym)
 
260
                          (list (list slot-name
 
261
                                      reader-sym
 
262
                                      (and (not read-only-p) writer))))))))
 
263
              (let ((slotds (structure-type-internal-slotds type))
 
264
                    (inc (structure-type-included-type-name type)))
 
265
                (if inc
 
266
                    (nthcdr (length (structure-type-internal-slotds inc))
 
267
                            slotds)
 
268
                    slotds)))))
 
269
 
 
270
(defun structure-slotd-name (slotd)
 
271
  (first slotd))
 
272
 
 
273
(defun structure-slotd-accessor-symbol (slotd)
 
274
  (second slotd))
 
275
 
 
276
;(defun structure-slotd-writer-function (slotd)
 
277
;  (third slotd))
 
278
 
 
279
(defun structure-slotd-reader-function (slotd)
 
280
  (third slotd))
 
281
 
 
282
(defun structure-slotd-writer-function (slotd)
 
283
  (fourth slotd))
 
284
 
 
285
(defun renew-sys-files()
 
286
  ;; packages:
 
287
  (compiler::get-packages "sys-package.lisp")
 
288
  (with-open-file (st "sys-package.lisp"
 
289
                          :direction :output
 
290
                          :if-exists :append)
 
291
        (format st "(lisp::in-package \"SI\")
 
292
(export '(%structure-name
 
293
          %compiled-function-name
 
294
          %set-compiled-function-name))
 
295
(in-package \"PCL\")
 
296
"))
 
297
 
 
298
  ;; proclaims
 
299
  (compiler::make-all-proclaims "*.fn")
 
300
  (with-open-file (st "sys-proclaim.lisp"
 
301
                      :direction :output
 
302
                      :if-exists :append)
 
303
    (format st "~%(IN-PACKAGE \"PCL\")~%")
 
304
    (print
 
305
     `(dolist (v ',
 
306
     
 
307
               (sloop::sloop for v in-package "PCL"
 
308
                             when (get v 'compiler::proclaimed-closure)
 
309
                             collect v))
 
310
        (setf (get v 'compiler::proclaimed-closure) t))
 
311
     st)
 
312
    (format st "~%")
 
313
))
 
314
 
 
315
        
 
316