/[cmucl]/src/pcl/fin.lisp
ViewVC logotype

Diff of /src/pcl/fin.lisp

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

revision 1.7 by ram, Sat Aug 1 15:28:45 1992 UTC revision 1.8 by ram, Mon Nov 9 15:19:28 1992 UTC
# Line 130  explicitly marked saying who wrote it. Line 130  explicitly marked saying who wrote it.
130            setting its funcallable-instance-function."))            setting its funcallable-instance-function."))
131    
132    
   
   
133  ;;;  ;;;
134  ;;; In Lucid Lisp, compiled functions and compiled closures have the same  ;;; In Lucid Lisp, compiled functions and compiled closures have the same
135  ;;; representation.  They are called procedures.  A procedure is a basically  ;;; representation.  They are called procedures.  A procedure is a basically
# Line 160  explicitly marked saying who wrote it. Line 158  explicitly marked saying who wrote it.
158  ;;;  optimized version of the code for this inner closure function.  ;;;  optimized version of the code for this inner closure function.
159  ;;;  ;;;
160  (defun make-trampoline (function)  (defun make-trampoline (function)
161    (declare (optimize (speed 3) (safety 0)(compilation-speed 0)(space 0)))    (declare (optimize (speed 3) (safety 0)))
162    #'(lambda (&rest args)    #'(lambda (&rest args)
163        (apply function args)))        (apply function args)))
164    
# Line 170  explicitly marked saying who wrote it. Line 168  explicitly marked saying who wrote it.
168    
169    
170  (defun binary-assemble (codes)  (defun binary-assemble (codes)
   (declare (list codes))  
171    (let* ((ncodes (length codes))    (let* ((ncodes (length codes))
172           (code-vec #-LCL3.0 (lucid::new-code ncodes)           (code-vec #-LCL3.0 (lucid::new-code ncodes)
173                     #+LCL3.0 (lucid::with-current-area                     #+LCL3.0 (lucid::with-current-area
174                                  lucid::*READONLY-NON-POINTER-AREA*                                  lucid::*READONLY-NON-POINTER-AREA*
175                                (lucid::new-code ncodes))))                                (lucid::new-code ncodes))))
176      (declare (type index ncodes))      (declare (fixnum ncodes))
177      (do ((l codes (cdr l))      (do ((l codes (cdr l))
178           (i 0 (the index (1+ i))))           (i 0 (1+ i)))
179          ((null l) nil)          ((null l) nil)
180        (declare (type index i))        (declare (fixnum i))
181        (setf (lucid::code-ref code-vec i) (car l)))        (setf (lucid::code-ref code-vec i) (car l)))
182      code-vec))      code-vec))
183    
# Line 224  explicitly marked saying who wrote it. Line 221  explicitly marked saying who wrote it.
221    (if (not (lucid::procedurep x))    (if (not (lucid::procedurep x))
222        (error "Can't make a non-procedure a fin.")        (error "Can't make a non-procedure a fin.")
223        (setf (lucid::procedure-ref x lucid::procedure-flags)        (setf (lucid::procedure-ref x lucid::procedure-flags)
224              (logior (the index              (logior (expt 2 procedure-is-funcallable-instance-bit-position)
225                           (expt 2 (the index                      (the fixnum
                                       procedure-is-funcallable-instance-bit-position)))  
                     (the index  
226                           (lucid::procedure-ref x lucid::procedure-flags))))))                           (lucid::procedure-ref x lucid::procedure-flags))))))
227    
228    
# Line 238  explicitly marked saying who wrote it. Line 233  explicitly marked saying who wrote it.
233                                                  ;incorrectly                                                  ;incorrectly
234    (let ((new-fin (lucid::new-procedure fin-size))    (let ((new-fin (lucid::new-procedure fin-size))
235          (fin-index fin-size))          (fin-index fin-size))
236      (declare (type index fin-index)      (declare (fixnum fin-index)
237               (type lucid::procedure new-fin))               (type lucid::procedure new-fin))
238      (dotimes (i (length (the list funcallable-instance-data)) )      (dotimes (i (length funcallable-instance-data))
239        ;; Initialize the new funcallable-instance.  As part of our contract,        ;; Initialize the new funcallable-instance.  As part of our contract,
240        ;; we have to make sure the initial value of all the funcallable        ;; we have to make sure the initial value of all the funcallable
241        ;; instance data slots is NIL.        ;; instance data slots is NIL.
242        (setf fin-index (the index (1- fin-index)))        (decf fin-index)
243        (setf (lucid::procedure-ref new-fin fin-index) nil))        (setf (lucid::procedure-ref new-fin fin-index) nil))
244      ;;      ;;
245      ;; "Assemble" the initial function by installing a fast "trampoline" code;      ;; "Assemble" the initial function by installing a fast "trampoline" code;
# Line 257  explicitly marked saying who wrote it. Line 252  explicitly marked saying who wrote it.
252      #+MIPS (progn      #+MIPS (progn
253               (setf (sys:procedure-ref new-fin lucid::procedure-min-args) 0)               (setf (sys:procedure-ref new-fin lucid::procedure-min-args) 0)
254               (setf (sys:procedure-ref new-fin lucid::procedure-max-args)               (setf (sys:procedure-ref new-fin lucid::procedure-max-args)
255                     (the index call-arguments-limit)))                     call-arguments-limit))
256      ;; but start out with the function to be run as an error call.      ;; but start out with the function to be run as an error call.
257      (setf (lucid::procedure-ref new-fin fin-trampoline-fun-index)      (setf (lucid::procedure-ref new-fin fin-trampoline-fun-index)
258            #'called-fin-without-function)            #'called-fin-without-function)
# Line 283  explicitly marked saying who wrote it. Line 278  explicitly marked saying who wrote it.
278  (defmacro funcallable-instance-data-1 (instance data)  (defmacro funcallable-instance-data-1 (instance data)
279    `(lucid::procedure-ref    `(lucid::procedure-ref
280             ,instance             ,instance
281             (the index             (the fixnum
282                  (- (the index (- (the index fin-size) 1))                  (- (- fin-size 1)
283                     (the index (funcallable-instance-data-position ,data))))))                     (the fixnum (funcallable-instance-data-position ,data))))))
284    
285  );end of #+Lucid  );end of #+Lucid
286    
287    
# Line 362  explicitly marked saying who wrote it. Line 357  explicitly marked saying who wrote it.
357                                              (make-trampoline new-value)))))                                              (make-trampoline new-value)))))
358    
359  (defun make-trampoline (function)  (defun make-trampoline (function)
360    (declare #.*optimize-speed*)    (declare (optimize (speed 3) (safety 0)))
361    #'(lambda (&rest args)    #'(lambda (&rest args)
362        #+Genera (declare (dbg:invisible-frame :pcl-internals))        #+Genera (declare (dbg:invisible-frame :pcl-internals))
363        (apply function args)))        (apply function args)))
# Line 886  dbg: Line 881  dbg:
881  ;; This function is never linked in and never appears on the stack.  ;; This function is never linked in and never appears on the stack.
882    
883  (defun funcallable-instance-mattress-pad ()  (defun funcallable-instance-mattress-pad ()
884    (declare #.*optimize-speed*)    (declare (optimize (speed 3) (safety 0)))
885    'nil)    'nil)
886    
887  (eval-when (eval)  (eval-when (eval)
# Line 1077  dbg: Line 1072  dbg:
1072  ;; This function is never linked in and never appears on the stack.  ;; This function is never linked in and never appears on the stack.
1073    
1074  (defun funcallable-instance-mattress-pad ()  (defun funcallable-instance-mattress-pad ()
1075    (declare #.*optimize-speed*)    (declare (optimize (speed 3) (safety 0)))
1076    'nil)    'nil)
1077    
1078  (eval-when (eval)  (eval-when (eval)
# Line 1166  dbg: Line 1161  dbg:
1161  (defun add-instance-vars (cvec old-cvec)  (defun add-instance-vars (cvec old-cvec)
1162    ;; create a constant vector containing everything in the given constant    ;; create a constant vector containing everything in the given constant
1163    ;; vector plus space for the instance variables    ;; vector plus space for the instance variables
1164    (let* ((nconstants (cond (cvec (length (the simple-vector cvec))) (t 0)))    (let* ((nconstants (cond (cvec (length cvec)) (t 0)))
1165           (ndata (length funcallable-instance-data))           (ndata (length funcallable-instance-data))
1166           (old-cvec-length (if old-cvec (length (the simple-vector old-cvec)) 0))           (old-cvec-length (if old-cvec (length old-cvec) 0))
1167           (new-cvec nil))           (new-cvec nil))
1168      (declare (fixnum nconstants ndate old-cvec-length))      (cond ((<= (+ nconstants ndata)  old-cvec-length)
     (cond ((<= (the fixnum (+ nconstants ndata))  old-cvec-length)  
1169             (setq new-cvec old-cvec))             (setq new-cvec old-cvec))
1170            (t            (t
1171             (setq new-cvec (make-array (the fixnum (+ nconstants ndata))))             (setq new-cvec (make-array (+ nconstants ndata)))
1172             (when old-cvec             (when old-cvec
1173               (dotimes (i ndata)               (dotimes (i ndata)
1174                 (declare (fixnum i))                 (setf (svref new-cvec (- (+ nconstants ndata) i 1))
                (setf (svref new-cvec (- (the fixnum (+ nconstants ndata)) i 1))  
1175                       (svref old-cvec (- old-cvec-length i 1)))))))                       (svref old-cvec (- old-cvec-length i 1)))))))
1176    
1177      (dotimes (i nconstants) (setf (svref new-cvec i) (svref cvec i)))      (dotimes (i nconstants) (setf (svref new-cvec i) (svref cvec i)))
# Line 1187  dbg: Line 1180  dbg:
1180    
1181  (defun funcallable-instance-data-1 (instance data)  (defun funcallable-instance-data-1 (instance data)
1182    (let ((constant (excl::fn_constant instance)))    (let ((constant (excl::fn_constant instance)))
1183      (declare (simple-vector constant))      (svref constant (- (length constant)
1184      (svref constant (- (the fixnum (length constant))                         (1+ (funcallable-instance-data-position data))))))
                        (the fixnum  
                             (1+ (the fixnum  
                                      (funcallable-instance-data-position data))))))))  
1185    
1186  (defsetf funcallable-instance-data-1 set-funcallable-instance-data-1)  (defsetf funcallable-instance-data-1 set-funcallable-instance-data-1)
1187    
# Line 1367  dbg: Line 1357  dbg:
1357  (defmacro funcallable-instance-data-1 (fin slot)  (defmacro funcallable-instance-data-1 (fin slot)
1358    (if (constantp slot)    (if (constantp slot)
1359        `(sys:%primitive c:closure-ref ,fin        `(sys:%primitive c:closure-ref ,fin
1360                         (+ (or (position ,slot funcallable-instance-data)                         ,(+ (or (position (eval slot) funcallable-instance-data)
1361                                (error "Unknown slot: ~S." ,slot))                                 (error "Unknown slot: ~S." (eval slot)))
1362                            fin-data-offset))                             fin-data-offset))
1363        (ext:once-only ((n-slot slot))        (ext:once-only ((n-slot slot))
1364          `(kernel:%closure-index-ref          `(kernel:%closure-index-ref
1365            ,fin            ,fin
# Line 1384  dbg: Line 1374  dbg:
1374      `(progn      `(progn
1375         (kernel:%set-funcallable-instance-info         (kernel:%set-funcallable-instance-info
1376          ,n-fin          ,n-fin
1377          (+ (or (position ,n-slot funcallable-instance-data)          ,(if (constantp slot)
1378                 (error "Unknown slot: ~S." ,n-slot))               (+ (or (position (eval slot) funcallable-instance-data)
1379             fin-data-offset)                      (error "Unknown slot: ~S." (eval slot)))
1380                    fin-data-offset)
1381                 `(+ (or (position ,n-slot funcallable-instance-data)
1382                         (error "Unknown slot: ~S." ,n-slot))
1383                     fin-data-offset))
1384          ,n-val)          ,n-val)
1385         ,n-val)))         ,n-val)))
1386  ;;;  ;;;
# Line 1452  dbg: Line 1446  dbg:
1446          ((not (functionp new-value))          ((not (functionp new-value))
1447           (error "~S is not a function." new-value))           (error "~S is not a function." new-value))
1448          ((and (cclosurep new-value)          ((and (cclosurep new-value)
1449                (<= (the index (length (the list (%cclosure-env new-value))))                (<= (length (%cclosure-env new-value))
1450                    (the index funcallable-instance-available-size)))                    funcallable-instance-available-size))
1451           (%set-cclosure fin new-value funcallable-instance-available-size))           (%set-cclosure fin new-value funcallable-instance-available-size))
1452          (t          (t
1453           (set-funcallable-instance-function           (set-funcallable-instance-function
# Line 1466  dbg: Line 1460  dbg:
1460    (let* ((pos-form (macroexpand `(funcallable-instance-data-position ,data)    (let* ((pos-form (macroexpand `(funcallable-instance-data-position ,data)
1461                                  env))                                  env))
1462           (index-form (if (constantp pos-form)           (index-form (if (constantp pos-form)
1463                           (the index                           (- funcallable-instance-closure-size
1464                                (- (the index funcallable-instance-closure-size)                              (eval pos-form)
1465                                   (the index (eval pos-form))                              2)
1466                                   2))                           `(- funcallable-instance-closure-size
1467                           `(the index                               (funcallable-instance-data-position ,data)
1468                                 (- (the index funcallable-instance-closure-size)                               2))))
                                   (the index (funcallable-instance-data-position ,data))  
                                   2)))))  
1469      `(car (%cclosure-env-nthcdr ,index-form ,fin))))      `(car (%cclosure-env-nthcdr ,index-form ,fin))))
1470    
1471    
# Line 1966  make_turbo_trampoline_internal(base0) Line 1958  make_turbo_trampoline_internal(base0)
1958  (defmacro fsc-instance-slots (fin)  (defmacro fsc-instance-slots (fin)
1959    `(funcallable-instance-data-1 ,fin 'slots))    `(funcallable-instance-data-1 ,fin 'slots))
1960    
1961  (defun allocate-funcallable-instance (wrapper allocate-static-slot-storage-copy)  
   (declare (type simple-vector allocate-static-slot-storage-copy))  
   (let ((fin (allocate-funcallable-instance-1))  
         (slots  
           (%allocate-static-slot-storage--class  
             allocate-static-slot-storage-copy)))  
     (setf (fsc-instance-wrapper fin) wrapper  
           (fsc-instance-slots fin) slots)  
     fin))  
1962    

Legend:
Removed from v.1.7  
changed lines
  Added in v.1.8

  ViewVC Help
Powered by ViewVC 1.1.5