Changeset 6562 for branches/tfe


Ignore:
Timestamp:
May 16, 2007, 10:21:18 AM (13 years ago)
Author:
gb
Message:

Add recent changes on tfe branch.

Location:
branches/tfe/ccl
Files:
8 edited

Legend:

Unmodified
Added
Removed
  • branches/tfe/ccl/level-0/X86/x86-def.lisp

    r6478 r6562  
    254254  (jne @fail)
    255255  (negq (% imm0))
    256   (leaq (@ (ash x8664::recover-fn-from-rip-length x8664::fixnumshift) (% imm0) 8) (% arg_z))
     256  (leaq (@ (- (ash x8664::recover-fn-from-rip-length x8664::fixnumshift)) (% imm0) 8) (% arg_z))
    257257  (single-value-return)
    258258  @fail
  • branches/tfe/ccl/level-0/l0-aprims.lisp

    r5384 r6562  
    5757
    5858(defun %cstr-pointer (string pointer &optional (nul-terminated t))
    59   (multiple-value-bind (s o n) (dereference-base-string string)
    60     (declare (fixnum o n))
    61     (do* ((i 0 (1+ i))
    62           (o o (1+ o)))
    63          ((= i n))
    64       (declare (fixnum i o))
    65       (setf (%get-unsigned-byte pointer i)
    66             (let* ((code (char-code (schar s o))))
    67               (declare (type (mod #x110000) code))
    68               (if (< code 256)
    69                 code
    70                 (char-code #\Sub)))))
    71     (when nul-terminated
    72       (setf (%get-byte pointer n) 0)))
    73   nil)
     59  (if (typep string 'simple-base-string)
     60    (locally (declare (simple-base-string string)
     61                      (optimize (speed 3) (safety 0)))
     62      (let* ((n (length string)))
     63        (declare (fixnum n))
     64        (dotimes (i n)
     65          (setf (%get-unsigned-byte pointer i)
     66                (let* ((code (%scharcode string i)))
     67                  (declare (type (mod #x110000) code))
     68                  (if (< code 256)
     69                    code
     70                    (char-code #\Sub)))))
     71        (when nul-terminated
     72          (setf (%get-byte pointer n) 0)))
     73      nil))
     74  (%cstr-segment-pointer string pointer 0 (length string) nul-terminated))
    7475
    75 (defun %cstr-segment-pointer (string pointer start end)
     76(defun %cstr-segment-pointer (string pointer start end &optional (nul-terminated t))
    7677  (declare (fixnum start end))
    7778  (let* ((n (- end start)))
    7879    (multiple-value-bind (s o) (dereference-base-string string)
    7980      (declare (fixnum o))
    80           (do* ((i 0 (1+ i))
    81           (o (the fixnum (+ o start)) (1+ o)))
    82          ((= i n))
    83       (declare (fixnum i o))
    84       (setf (%get-unsigned-byte pointer i)
    85             (logand #xff (char-code (schar s o)))))
    86     (setf (%get-byte pointer n) 0)
    87     nil)))
     81      (do* ((i 0 (1+ i))
     82            (o (the fixnum (+ o start)) (1+ o)))
     83           ((= i n))
     84        (declare (fixnum i o))
     85        (setf (%get-unsigned-byte pointer i)
     86              (let* ((code (char-code (schar s o))))
     87                (declare (type (mod #x110000) code))
     88                (if (< code 256)
     89                  code
     90                  (char-code #\Sub))))))
     91    (when nul-terminated
     92      (setf (%get-byte pointer n) 0))
     93    nil))
    8894
    8995(defun string (thing)
  • branches/tfe/ccl/level-1/l1-unicode.lisp

    r6538 r6562  
    8181  length-of-vector-encoding-function    ;(VECTOR START END)
    8282
    83   ;; Returns the number of (full) characters encoded in memort at (+ POINTER START)
     83  ;; Returns the number of (full) characters encoded in memory at (+ POINTER START)
    8484  ;; and the number of octets used to encode them.  (The second value may be less
    8585  ;; than NOCTETS.)
     
    43624362   (lambda (string pointer idx start end)
    43634363     (declare (fixnum idx))
    4364      (when (> end start)
    4365        (setf (%get-unsigned-long pointer idx)
    4366              byte-order-mark-char-code)
    4367        (incf idx 4))
     4364
    43684365     (do* ((i start (1+ i)))
    43694366          ((>= i end) idx)
     
    46184615     
    46194616                             
    4620                                      
     4617(defun string-encoded-length-in-bytes (encoding string start end)
     4618  (if (typep string 'simple-base-string)
     4619    (funcall (character-encoding-octets-in-string-function encoding)
     4620             string
     4621             (or start 0)
     4622             (or end (length string)))
     4623    (let* ((s (string string)))
     4624      (multiple-value-bind (data offset) (array-data-and-offset s)
     4625        (funcall (character-encoding-octets-in-string-function encoding)
     4626                 data
     4627                 (+ offset (or start 0))
     4628                 (+ offset (or end (length s))))))))
     4629
     4630;;; Same as above, but add the length of a trailing 0 code-unit.
    46214631(defun cstring-encoded-length-in-bytes (encoding string start end)
    4622   (+ (length (character-encoding-nul-encoding encoding))                             ; NUL terminator
    4623      (funcall (character-encoding-octets-in-string-function encoding)
    4624               string
    4625               (or start 0)
    4626               (or end (length string)))))
    4627 
    4628 
     4632  (+ (ash (character-encoding-code-unit-size encoding) -3) ; NUL terminator
     4633     (string-encoded-length-in-bytes string start end)))
     4634
     4635                   
    46294636
    46304637(defun encode-string-to-memory (encoding pointer offset string start end)
    4631   (funcall (character-encoding-memory-encode-function encoding)
    4632            string pointer offset (or start 0) (or end (length string))))
     4638  (if (typep string 'simple-base-string)
     4639    (funcall (character-encoding-memory-encode-function encoding)
     4640             string pointer offset (or start 0) (or end (length string)))
     4641    (let* ((s (string string)))
     4642      (multiple-value-bind (data data-offset)
     4643          (array-data-and-offset s)
     4644        (funcall (character-encoding-memory-encode-function encoding)
     4645                 data pointer offset (+ data-offset (or start 0)) (+ data-offset (or end (length s))))))))
     4646     
  • branches/tfe/ccl/level-1/x86-error-signal.lisp

    r6004 r6562  
    2121  (ldb (byte (- 16 x8664::fixnumshift) 0)
    2222                    (encoded-gpr-lisp xp x8664::nargs.q)))
     23
     24
    2325
    2426(defun xp-argument-list (xp)
     
    3032          ((eql nargs 1) (list arg-z))
    3133          ((eql nargs 2) (list arg-y arg-z))
    32           (t (let ((args (list arg-x arg-y arg-z)))
    33                (if (eql nargs 3)
    34                  args
    35                  (let ((sp (encoded-gpr-macptr xp x8664::rsp)))
    36                    (dotimes (i (- nargs 3))
    37                      (push (%get-object sp (* i target::node-size)) args))
    38                    args)))))))
    39 
     34          (t
     35           (let ((args (list arg-x arg-y arg-z)))
     36             (if (eql nargs 3)
     37               args
     38               (let ((sp (%inc-ptr (encoded-gpr-macptr xp x8664::rsp)
     39                                   (+ x8664::node-size x8664::xcf.size))))
     40                 (dotimes (i (- nargs 3))
     41                   (push (%get-object sp (* i x8664::node-size)) args))
     42                 args)))))))
     43                         
     44;;; Making this be continuable is hard, because of the xcf on the
     45;;; stack and the way that the kernel saves/restores rsp and rbp
     46;;; before calling out.  If we get around those problems, then
     47;;; we have to also deal with the fact that the return address
     48;;; is on the stack.  Easiest to make the kernel deal with that,
     49;;; and just set %fn to the function that returns the values
     50;;; returned by the (newly defined) function and %arg_z to
     51;;; that list of values.
    4052(defun handle-udf-call (xp frame-ptr)
    4153  (let* ((args (xp-argument-list xp))
     
    4557                   (list (encoded-gpr-lisp xp x8664::fname) args)
    4658                   frame-ptr)))
    47          (stack-argcnt (max 0 (- (length args) 3)))
    48          (rsp (%i+ (encoded-gpr-lisp xp x8664::rsp)
    49                    (if (zerop stack-argcnt)
    50                      0
    51                      (+ stack-argcnt 2))))
    5259         (f #'(lambda (values) (apply #'values values))))
    53     (setf (encoded-gpr-lisp xp x8664::rsp) rsp
    54           (encoded-gpr-lisp xp x8664::nargs.q) 1
    55           (encoded-gpr-lisp xp x8664::arg_z) values
    56           (encoded-gpr-lisp xp x8664::fn) f)
    57     (setf (indexed-gpr-lisp xp rip-register-offset) f)))
     60    (setf (encoded-gpr-lisp xp x8664::arg_z) values
     61          (encoded-gpr-lisp xp x8664::fn) f)))
    5862 
    5963(defcallback %xerr-disp (:address xp :address xcf :int)
  • branches/tfe/ccl/lib/macros.lisp

    r6504 r6562  
    15931593   (with-specs-aux 'with-cstr speclist body))
    15941594
    1595 (defmacro with-encoded-cstr (encoding-name (sym string &optional start end)
    1596                                  &rest body &environment env)
     1595(defmacro with-encoded-cstr ((encoding-name (sym string &optional start end))
     1596                             &rest body &environment env)
    15971597  (let* ((encoding (get-character-encoding encoding-name))
    1598          (nul-vector (character-encoding-nul-encoding encoding))
    15991598         (str (gensym))
    16001599         (len (gensym))
    1601          (i (gensym)))
    1602     (multiple-value-bind (body decls) (parse-body body env nil)
    1603       `(let* ((,str ,string))
    1604         (%stack-block ((,sym (cstring-encoded-length-in-bytes ,encoding ,str ,start ,end) :clear t))
    1605           ,@decls
    1606           (let* ((,len (encode-string-to-memory ,encoding ,sym 0 ,str ,start ,end)))
    1607             (declare (fixnum ,len))
    1608             (dotimes (,i (length ,nul-vector))
    1609               (setf (%get-unsigned-byte ,sym ,len) (aref ,nul-vector ,i))
    1610               (incf ,len)))
    1611           ,@body)))))
     1600         (nzeros (floor (character-encoding-code-unit-size encoding) 8)))
     1601    (collect ((trailing-zeros))
     1602      (case nzeros
     1603        (1 (trailing-zeros `(setf (%get-unsigned-byte ,sym ,len) 0)))
     1604        (2 (trailing-zeros `(setf (%get-unsigned-word ,sym ,len) 0)))
     1605        (4 (trailing-zeros `(setf (%get-unsigned-long ,sym ,len) 0)))
     1606        (t
     1607         (dotimes (i nzeros)
     1608           (trailing-zeros `(setf (%get-unsigned-byte ,sym (the fixnum (+ ,len ,i))) 0)))))
     1609      (multiple-value-bind (body decls) (parse-body body env nil)
     1610        `(let* ((,str ,string))
     1611          (%stack-block ((,sym (cstring-encoded-length-in-bytes ,encoding ,str ,start ,end)))
     1612            ,@decls
     1613            (let* ((,len (encode-string-to-memory ,encoding ,sym 0 ,str ,start ,end)))
     1614              (declare (fixnum ,len))
     1615              ,@(trailing-zeros)
     1616              ,@body)))))))
    16121617
    16131618(defmacro with-encoded-cstrs (encoding-name bindings &body body)
     
    16171622
    16181623
    1619 (defun with-specs-aux (name spec-list body)
    1620   (setq body (cons 'progn body))
    1621   (dolist (spec (reverse spec-list))
    1622      (setq body (list name spec body)))
    1623   body)
     1624(defun with-specs-aux (name spec-list original-body)
     1625  (multiple-value-bind (body decls) (parse-body original-body nil)
     1626    (when decls (error "declarations not allowed in ~s" original-body))
     1627    (setq body (cons 'progn body))
     1628    (dolist (spec (reverse spec-list))
     1629      (setq body (list name spec body)))
     1630    body))
    16241631
    16251632
  • branches/tfe/ccl/lib/sequences.lisp

    r5679 r6562  
    18911891  (unless vectorp1
    18921892    (setq seq1 (nthcdr start1 seq1))
    1893     (when from-end (setq seq1 (reverse seq1))))
     1893    (if from-end
     1894      (do* ((s1 ())
     1895            (i start1 (1+ i)))
     1896           ((= i end1) (setq seq1 s1))
     1897        (push (pop seq1) s1))))
    18941898  (unless vectorp2
    18951899    (setq seq2 (nthcdr start2 seq2))
    1896     (when from-end (setq seq2 (reverse seq2))))
     1900    (if from-end
     1901      (do* ((s2 ())
     1902            (i start2 (1+ i)))
     1903           ((= i end2) (setq seq2 s2))
     1904        (push (pop seq2) s2))))
    18971905  (when test-not (setq test test-not))
    18981906  (if from-end
  • branches/tfe/ccl/lisp-kernel/x86-exceptions.c

    r6540 r6562  
    274274  natural nargs = (xpGPR(xp,Inargs)&0xffff)>> fixnumshift;
    275275  signed_natural disp = nargs-3;
    276   LispObj *vsp =  (LispObj *) xpGPR(xp,Isp);
     276  LispObj *vsp =  (LispObj *) xpGPR(xp,Isp), ra = *vsp++;
    277277   
    278278 
    279279  if (disp > 0) {               /* implies that nargs > 3 */
    280280    vsp[disp] = xpGPR(xp,Irbp);
    281     vsp[disp+1] = xpGPR(xp,Ira0);
     281    vsp[disp+1] = ra;
    282282    xpGPR(xp,Irbp) = (LispObj)(vsp+disp);
     283    xpGPR(xp,Isp) = (LispObj)vsp;
    283284    push_on_lisp_stack(xp,xpGPR(xp,Iarg_x));
    284285    push_on_lisp_stack(xp,xpGPR(xp,Iarg_y));
    285286    push_on_lisp_stack(xp,xpGPR(xp,Iarg_z));
    286287  } else {
    287     push_on_lisp_stack(xp,xpGPR(xp,Ira0));
     288    push_on_lisp_stack(xp,ra);
    288289    push_on_lisp_stack(xp,xpGPR(xp,Irbp));
    289290    xpGPR(xp,Irbp) = xpGPR(xp,Isp);
     
    322323
    323324  f = xpGPR(xp,Ifn);
    324   tra = xpGPR(xp,Ira0);
     325  tra = *(LispObj*)(xpGPR(xp,Isp));
    325326  if (tag_of(tra) == tag_tra) {
    326327    if ((*((unsigned short *)tra) == RECOVER_FN_FROM_RIP_WORD0) &&
     
    332333      tra_f = 0;
    333334    }
     335  } else {
     336    tra = 0;
    334337  }
    335338
     
    484487    xpGPR(xp,Irbp) = save_rbp;
    485488    xpGPR(xp,Isp) = save_vsp;
    486     xpPC(xp) += skip;
     489    if ((op0 == 0xcd) && (op1 == 0xc7)) {
     490      /* Continue after an undefined function call. The function
     491         that had been undefined has already been called (in the
     492         break loop), and a list of the values that it returned
     493         in in the xp's %arg_z.  A function that returns those
     494         values in in the xp's %fn; we just have to adjust the
     495         stack (keeping the return address in the right place
     496         and discarding any stack args/reserved stack frame),
     497         then set nargs and the PC so that that function's
     498         called when we resume.
     499      */
     500      LispObj *vsp =(LispObj *)save_vsp, ra = *vsp;
     501      int nargs = (xpGPR(xp, Inargs) & 0xffff)>>fixnumshift;
     502     
     503      if (nargs > 3) {
     504        xpGPR(xp,Isp)=(LispObj) (vsp + (1 + 2 + (nargs - 3)));
     505        push_on_lisp_stack(xp,ra);
     506      }
     507      xpPC(xp) = xpGPR(xp,Ifn);
     508      xpGPR(xp,Inargs) = 1<<fixnumshift;
     509    } else {
     510      xpPC(xp) += skip;
     511    }
    487512    return true;
    488513  } else {
  • branches/tfe/ccl/lisp-kernel/x86-spentry64.s

    r6531 r6562  
    12041204        __(testq %imm1,%imm1)
    12051205        __(jne local_label(_throw_loop))
     1206        __(push %ra0)
    12061207        __(uuo_error_reg_not_tag(Rtemp0,subtag_catch_frame))
     1208        __(pop %ra0)
    12071209        __(jmp _SPthrow)
    12081210local_label(_throw_found):     
     
    16311633        __(movq %arg_y,(%temp1,%temp0))
    16321634        __(jmp *%ra0)
    1633 8:      __(uuo_error_reg_unbound(Rarg_z))
     16358:      __(push %ra0)
     1636        __(uuo_error_reg_unbound(Rarg_z))
    16341637       
    163516389:      __(movq $XSYMNOBIND,%arg_y)
     
    44684471_endsubp(aset2)
    44694472
    4470 /* temp1 = array, %temp0 = i, %arg_x = j, %arg_y = k, %arg_y = newval. */
     4473/* %temp1 = array, %temp0 = i, %arg_x = j, %arg_y = k, %arg_y = newval. */
    44714474
    44724475_spentry(aset3)
Note: See TracChangeset for help on using the changeset viewer.