Changeset 6562 for branches

Timestamp:

May 16, 2007, 3:21:18 AM (18 years ago)

Author:

Gary Byers

Message:

Add recent changes on tfe branch.

Location:

branches/tfe/ccl

Files:

• level-0/X86/x86-def.lisp (modified) (1 diff)
• level-0/l0-aprims.lisp (modified) (1 diff)
• level-1/l1-unicode.lisp (modified) (3 diffs)
• level-1/x86-error-signal.lisp (modified) (3 diffs)
• lib/macros.lisp (modified) (2 diffs)
• lib/sequences.lisp (modified) (1 diff)
• lisp-kernel/x86-exceptions.c (modified) (4 diffs)
• lisp-kernel/x86-spentry64.s (modified) (3 diffs)

branches/tfe/ccl/level-0/X86/x86-def.lisp

@@ -254 +254 @@
   (jne @fail)
   (negq (% imm0))
-  (leaq (@ (ash x8664::recover-fn-from-rip-length x8664::fixnumshift) (% imm0) 8) (% arg_z))
+  (leaq (@ (- (ash x8664::recover-fn-from-rip-length x8664::fixnumshift)) (% imm0) 8) (% arg_z))
   (single-value-return)
   @fail

branches/tfe/ccl/level-0/l0-aprims.lisp

@@ -57 +57 @@
 
 (defun %cstr-pointer (string pointer &optional (nul-terminated t))
-  (multiple-value-bind (s o n) (dereference-base-string string)
-    (declare (fixnum o n))
-    (do* ((i 0 (1+ i))
-          (o o (1+ o)))
-         ((= i n))
-      (declare (fixnum i o))
-      (setf (%get-unsigned-byte pointer i)
-            (let* ((code (char-code (schar s o))))
-              (declare (type (mod #x110000) code))
-              (if (< code 256)
-                code
-                (char-code #\Sub)))))
-    (when nul-terminated
-      (setf (%get-byte pointer n) 0)))
-  nil)
+  (if (typep string 'simple-base-string)
+    (locally (declare (simple-base-string string)
+                      (optimize (speed 3) (safety 0)))
+      (let* ((n (length string)))
+        (declare (fixnum n))
+        (dotimes (i n)
+          (setf (%get-unsigned-byte pointer i)
+                (let* ((code (%scharcode string i)))
+                  (declare (type (mod #x110000) code))
+                  (if (< code 256)
+                    code
+                    (char-code #\Sub)))))
+        (when nul-terminated
+          (setf (%get-byte pointer n) 0)))
+      nil))
+  (%cstr-segment-pointer string pointer 0 (length string) nul-terminated))
 
-(defun %cstr-segment-pointer (string pointer start end)
+(defun %cstr-segment-pointer (string pointer start end &optional (nul-terminated t))
   (declare (fixnum start end))
   (let* ((n (- end start)))
     (multiple-value-bind (s o) (dereference-base-string string)
       (declare (fixnum o))
-          (do* ((i 0 (1+ i))
-          (o (the fixnum (+ o start)) (1+ o)))
-         ((= i n))
-      (declare (fixnum i o))
-      (setf (%get-unsigned-byte pointer i)
-            (logand #xff (char-code (schar s o)))))
-    (setf (%get-byte pointer n) 0)
-    nil)))
+      (do* ((i 0 (1+ i))
+            (o (the fixnum (+ o start)) (1+ o)))
+           ((= i n))
+        (declare (fixnum i o))
+        (setf (%get-unsigned-byte pointer i)
+              (let* ((code (char-code (schar s o))))
+                (declare (type (mod #x110000) code))
+                (if (< code 256)
+                  code
+                  (char-code #\Sub))))))
+    (when nul-terminated
+      (setf (%get-byte pointer n) 0))
+    nil))
 
 (defun string (thing)

branches/tfe/ccl/level-1/l1-unicode.lisp

@@ -81 +81 @@
   length-of-vector-encoding-function    ;(VECTOR START END) 
 
-  ;; Returns the number of (full) characters encoded in memort at (+ POINTER START)
+  ;; Returns the number of (full) characters encoded in memory at (+ POINTER START)
   ;; and the number of octets used to encode them.  (The second value may be less
   ;; than NOCTETS.)
@@ -4362 +4362 @@
    (lambda (string pointer idx start end)
      (declare (fixnum idx))
-     (when (> end start)
-       (setf (%get-unsigned-long pointer idx)
-             byte-order-mark-char-code)
-       (incf idx 4))
+
      (do* ((i start (1+ i)))
           ((>= i end) idx)
@@ -4618 +4615 @@
       
                               
-                                     
+(defun string-encoded-length-in-bytes (encoding string start end)
+  (if (typep string 'simple-base-string)
+    (funcall (character-encoding-octets-in-string-function encoding)
+             string
+             (or start 0)
+             (or end (length string)))
+    (let* ((s (string string)))
+      (multiple-value-bind (data offset) (array-data-and-offset s)
+        (funcall (character-encoding-octets-in-string-function encoding)
+                 data
+                 (+ offset (or start 0))
+                 (+ offset (or end (length s))))))))
+
+;;; Same as above, but add the length of a trailing 0 code-unit.
 (defun cstring-encoded-length-in-bytes (encoding string start end)
-  (+ (length (character-encoding-nul-encoding encoding))                             ; NUL terminator
-     (funcall (character-encoding-octets-in-string-function encoding)
-              string
-              (or start 0)
-              (or end (length string)))))
-
-
+  (+ (ash (character-encoding-code-unit-size encoding) -3) ; NUL terminator
+     (string-encoded-length-in-bytes string start end)))
+
+                   
 
 (defun encode-string-to-memory (encoding pointer offset string start end)
-  (funcall (character-encoding-memory-encode-function encoding)
-           string pointer offset (or start 0) (or end (length string))))
+  (if (typep string 'simple-base-string)
+    (funcall (character-encoding-memory-encode-function encoding)
+             string pointer offset (or start 0) (or end (length string)))
+    (let* ((s (string string)))
+      (multiple-value-bind (data data-offset)
+          (array-data-and-offset s)
+        (funcall (character-encoding-memory-encode-function encoding)
+                 data pointer offset (+ data-offset (or start 0)) (+ data-offset (or end (length s))))))))
+      

branches/tfe/ccl/level-1/x86-error-signal.lisp

@@ -21 +21 @@
   (ldb (byte (- 16 x8664::fixnumshift) 0)
                     (encoded-gpr-lisp xp x8664::nargs.q)))
+
+
 
 (defun xp-argument-list (xp)
@@ -30 +32 @@
           ((eql nargs 1) (list arg-z))
           ((eql nargs 2) (list arg-y arg-z))
-          (t (let ((args (list arg-x arg-y arg-z)))
-               (if (eql nargs 3)
-                 args
-                 (let ((sp (encoded-gpr-macptr xp x8664::rsp)))
-                   (dotimes (i (- nargs 3))
-                     (push (%get-object sp (* i target::node-size)) args))
-                   args)))))))
-
+          (t
+           (let ((args (list arg-x arg-y arg-z)))
+             (if (eql nargs 3)
+               args
+               (let ((sp (%inc-ptr (encoded-gpr-macptr xp x8664::rsp)
+                                   (+ x8664::node-size x8664::xcf.size))))
+                 (dotimes (i (- nargs 3))
+                   (push (%get-object sp (* i x8664::node-size)) args))
+                 args)))))))
+                          
+;;; Making this be continuable is hard, because of the xcf on the
+;;; stack and the way that the kernel saves/restores rsp and rbp
+;;; before calling out.  If we get around those problems, then
+;;; we have to also deal with the fact that the return address
+;;; is on the stack.  Easiest to make the kernel deal with that,
+;;; and just set %fn to the function that returns the values
+;;; returned by the (newly defined) function and %arg_z to
+;;; that list of values.
 (defun handle-udf-call (xp frame-ptr)
   (let* ((args (xp-argument-list xp))
@@ -45 +57 @@
                    (list (encoded-gpr-lisp xp x8664::fname) args)
                    frame-ptr)))
-         (stack-argcnt (max 0 (- (length args) 3)))
-         (rsp (%i+ (encoded-gpr-lisp xp x8664::rsp)
-                   (if (zerop stack-argcnt)
-                     0
-                     (+ stack-argcnt 2))))
          (f #'(lambda (values) (apply #'values values))))
-    (setf (encoded-gpr-lisp xp x8664::rsp) rsp
-          (encoded-gpr-lisp xp x8664::nargs.q) 1
-          (encoded-gpr-lisp xp x8664::arg_z) values
-          (encoded-gpr-lisp xp x8664::fn) f)
-    (setf (indexed-gpr-lisp xp rip-register-offset) f)))
+    (setf (encoded-gpr-lisp xp x8664::arg_z) values
+          (encoded-gpr-lisp xp x8664::fn) f)))
   
 (defcallback %xerr-disp (:address xp :address xcf :int)

branches/tfe/ccl/lib/macros.lisp

@@ -1593 +1593 @@
    (with-specs-aux 'with-cstr speclist body))
 
-(defmacro with-encoded-cstr (encoding-name (sym string &optional start end)
-                                 &rest body &environment env)
+(defmacro with-encoded-cstr ((encoding-name (sym string &optional start end))
+                             &rest body &environment env)
   (let* ((encoding (get-character-encoding encoding-name))
-         (nul-vector (character-encoding-nul-encoding encoding))
          (str (gensym))
          (len (gensym))
-         (i (gensym)))
-    (multiple-value-bind (body decls) (parse-body body env nil)
-      `(let* ((,str ,string))
-        (%stack-block ((,sym (cstring-encoded-length-in-bytes ,encoding ,str ,start ,end) :clear t))
-          ,@decls
-          (let* ((,len (encode-string-to-memory ,encoding ,sym 0 ,str ,start ,end)))
-            (declare (fixnum ,len))
-            (dotimes (,i (length ,nul-vector))
-              (setf (%get-unsigned-byte ,sym ,len) (aref ,nul-vector ,i))
-              (incf ,len)))
-          ,@body)))))
+         (nzeros (floor (character-encoding-code-unit-size encoding) 8)))
+    (collect ((trailing-zeros))
+      (case nzeros
+        (1 (trailing-zeros `(setf (%get-unsigned-byte ,sym ,len) 0)))
+        (2 (trailing-zeros `(setf (%get-unsigned-word ,sym ,len) 0)))
+        (4 (trailing-zeros `(setf (%get-unsigned-long ,sym ,len) 0)))
+        (t 
+         (dotimes (i nzeros)
+           (trailing-zeros `(setf (%get-unsigned-byte ,sym (the fixnum (+ ,len ,i))) 0)))))
+      (multiple-value-bind (body decls) (parse-body body env nil)
+        `(let* ((,str ,string))
+          (%stack-block ((,sym (cstring-encoded-length-in-bytes ,encoding ,str ,start ,end)))
+            ,@decls
+            (let* ((,len (encode-string-to-memory ,encoding ,sym 0 ,str ,start ,end)))
+              (declare (fixnum ,len))
+              ,@(trailing-zeros)
+              ,@body)))))))
 
 (defmacro with-encoded-cstrs (encoding-name bindings &body body)
@@ -1617 +1622 @@
 
 
-(defun with-specs-aux (name spec-list body)
-  (setq body (cons 'progn body))
-  (dolist (spec (reverse spec-list))
-     (setq body (list name spec body)))
-  body)
+(defun with-specs-aux (name spec-list original-body)
+  (multiple-value-bind (body decls) (parse-body original-body nil)
+    (when decls (error "declarations not allowed in ~s" original-body))
+    (setq body (cons 'progn body))
+    (dolist (spec (reverse spec-list))
+      (setq body (list name spec body)))
+    body))
 
 

branches/tfe/ccl/lib/sequences.lisp

@@ -1891 +1891 @@
   (unless vectorp1
     (setq seq1 (nthcdr start1 seq1))
-    (when from-end (setq seq1 (reverse seq1))))
+    (if from-end
+      (do* ((s1 ())
+            (i start1 (1+ i)))
+           ((= i end1) (setq seq1 s1))
+        (push (pop seq1) s1))))
   (unless vectorp2
     (setq seq2 (nthcdr start2 seq2))
-    (when from-end (setq seq2 (reverse seq2))))
+    (if from-end
+      (do* ((s2 ())
+            (i start2 (1+ i)))
+           ((= i end2) (setq seq2 s2))
+        (push (pop seq2) s2))))
   (when test-not (setq test test-not))
   (if from-end

branches/tfe/ccl/lisp-kernel/x86-exceptions.c

@@ -274 +274 @@
   natural nargs = (xpGPR(xp,Inargs)&0xffff)>> fixnumshift;
   signed_natural disp = nargs-3;
-  LispObj *vsp =  (LispObj *) xpGPR(xp,Isp);
+  LispObj *vsp =  (LispObj *) xpGPR(xp,Isp), ra = *vsp++;
    
   
   if (disp > 0) {               /* implies that nargs > 3 */
     vsp[disp] = xpGPR(xp,Irbp);
-    vsp[disp+1] = xpGPR(xp,Ira0);
+    vsp[disp+1] = ra;
     xpGPR(xp,Irbp) = (LispObj)(vsp+disp);
+    xpGPR(xp,Isp) = (LispObj)vsp;
     push_on_lisp_stack(xp,xpGPR(xp,Iarg_x));
     push_on_lisp_stack(xp,xpGPR(xp,Iarg_y));
     push_on_lisp_stack(xp,xpGPR(xp,Iarg_z));
   } else {
-    push_on_lisp_stack(xp,xpGPR(xp,Ira0));
+    push_on_lisp_stack(xp,ra);
     push_on_lisp_stack(xp,xpGPR(xp,Irbp));
     xpGPR(xp,Irbp) = xpGPR(xp,Isp);
@@ -322 +323 @@
 
   f = xpGPR(xp,Ifn);
-  tra = xpGPR(xp,Ira0);
+  tra = *(LispObj*)(xpGPR(xp,Isp));
   if (tag_of(tra) == tag_tra) {
     if ((*((unsigned short *)tra) == RECOVER_FN_FROM_RIP_WORD0) &&
@@ -332 +333 @@
       tra_f = 0;
     }
+  } else {
+    tra = 0;
   }
 
@@ -484 +487 @@
     xpGPR(xp,Irbp) = save_rbp;
     xpGPR(xp,Isp) = save_vsp;
-    xpPC(xp) += skip;
+    if ((op0 == 0xcd) && (op1 == 0xc7)) {
+      /* Continue after an undefined function call. The function
+         that had been undefined has already been called (in the
+         break loop), and a list of the values that it returned
+         in in the xp's %arg_z.  A function that returns those
+         values in in the xp's %fn; we just have to adjust the
+         stack (keeping the return address in the right place
+         and discarding any stack args/reserved stack frame),
+         then set nargs and the PC so that that function's
+         called when we resume.
+      */
+      LispObj *vsp =(LispObj *)save_vsp, ra = *vsp;
+      int nargs = (xpGPR(xp, Inargs) & 0xffff)>>fixnumshift;
+      
+      if (nargs > 3) {
+        xpGPR(xp,Isp)=(LispObj) (vsp + (1 + 2 + (nargs - 3)));
+        push_on_lisp_stack(xp,ra);
+      }
+      xpPC(xp) = xpGPR(xp,Ifn);
+      xpGPR(xp,Inargs) = 1<<fixnumshift;
+    } else {
+      xpPC(xp) += skip;
+    }
     return true;
   } else {

branches/tfe/ccl/lisp-kernel/x86-spentry64.s

@@ -1204 +1204 @@
         __(testq %imm1,%imm1)
         __(jne local_label(_throw_loop))
+        __(push %ra0)
         __(uuo_error_reg_not_tag(Rtemp0,subtag_catch_frame))
+        __(pop %ra0)
         __(jmp _SPthrow)
 local_label(_throw_found):      
@@ -1631 +1633 @@
         __(movq %arg_y,(%temp1,%temp0))
         __(jmp *%ra0)
-8:      __(uuo_error_reg_unbound(Rarg_z))
+8:      __(push %ra0)
+        __(uuo_error_reg_unbound(Rarg_z))
         
 9:      __(movq $XSYMNOBIND,%arg_y)
@@ -4468 +4471 @@
 _endsubp(aset2)
 
-/* temp1 = array, %temp0 = i, %arg_x = j, %arg_y = k, %arg_y = newval. */
+/* %temp1 = array, %temp0 = i, %arg_x = j, %arg_y = k, %arg_y = newval. */
 
 _spentry(aset3)