Changeset 11521

Timestamp:

Dec 15, 2008, 7:47:12 AM (11 years ago)

Author:

gb

Message:

x86 support for %ALLOCATE-LIST.

Location:

trunk/source

Files:

• level-0/X86/X8632/x8632-utils.lisp (modified) (1 diff)
• level-0/X86/x86-utils.lisp (modified) (1 diff)
• lisp-kernel/x86-exceptions.c (modified) (4 diffs)
• lisp-kernel/x86-exceptions.h (modified) (1 diff)

trunk/source/level-0/X86/X8632/x8632-utils.lisp

@@ -386 +386 @@
   (jmp-subprim .SPmakeu32))
 
+(defx8632lapfunction %allocate-list ((initial-element arg_y) (nconses arg_z))
+  (check-nargs 2)
+  (save-simple-frame)
+  (ud2a)
+  (:byte 10)
+  (push (% arg_z))
+  (push (% allocptr))
+  (set-nargs 2)
+  (jmp-subprim .SPnvalret))
+
 ;;; offset is a fixnum, one of the x8632::kernel-import-xxx constants.
 ;;; Returns that kernel import, a fixnum.

trunk/source/level-0/X86/x86-utils.lisp

@@ -439 +439 @@
   (jmp-subprim .SPmakeu64))
 
-  
+(defx86lapfunction %allocate-list ((initial-element arg_y) (nconses arg_z))
+  (check-nargs 2)
+  (save-simple-frame)
+  (ud2a)
+  (:byte 10)
+  (push (% arg_z))
+  (push (% allocptr))
+  (set-nargs 2)
+  (jmp-subprim .SPnvalret))
+
   
 

trunk/source/lisp-kernel/x86-exceptions.c

@@ -418 +418 @@
 
 #ifdef X8664
-  if (fulltag_of(f) == fulltag_function) {
-#else
-  if (fulltag_of(f) == fulltag_misc &&
-      header_subtag(header_of(f)) == subtag_function) {
-#endif
-    nominal_function = f;
-  } else {
-    if (tra_f) {
-      nominal_function = tra_f;
-    }
-  }
+  if (fulltag_of(f) == fulltag_function) 
+#else
+    if (fulltag_of(f) == fulltag_misc &&
+        header_subtag(header_of(f)) == subtag_function) 
+#endif
+      {
+        nominal_function = f;
+      } else {
+      if (tra_f) {
+        nominal_function = tra_f;
+      }
+    }
   
   f = xpGPR(xp,Ifn);
@@ -475 +476 @@
 #endif
 
+void
+lisp_allocation_failure(ExceptionInformation *xp, TCR *tcr, natural bytes_needed )
+{
+  LispObj xcf = create_exception_callback_frame(xp, tcr),
+    cmain = nrs_CMAIN.vcell;
+  int skip;
+    
+  tcr->save_allocptr = tcr->save_allocbase = (void *)VOID_ALLOCPTR;
+  xpGPR(xp,Iallocptr) = VOID_ALLOCPTR;
+
+  skip = callback_to_lisp(tcr, cmain, xp, xcf, -1, XMEMFULL, 0, 0);
+  xpPC(xp) += skip;
+}
+
+/*
+  Allocate a large list, where "large" means "large enough to
+  possibly trigger the EGC several times if this was done
+  by individually allocating each CONS."  The number of 
+  ocnses in question is in arg_z; on successful return,
+  the list will be in arg_z 
+*/
+
+Boolean
+allocate_list(ExceptionInformation *xp, TCR *tcr)
+{
+  natural 
+    nconses = (unbox_fixnum(xpGPR(xp,Iarg_z))),
+    bytes_needed = (nconses << dnode_shift);
+  LispObj
+    prev = lisp_nil,
+    current,
+    initial = xpGPR(xp,Iarg_y);
+
+  if (nconses == 0) {
+    /* Silly case */
+    xpGPR(xp,Iarg_z) = lisp_nil;
+    xpGPR(xp,Iallocptr) = lisp_nil;
+    return true;
+  }
+  update_bytes_allocated(tcr, (void *)(void *) tcr->save_allocptr);
+  if (allocate_object(xp,bytes_needed,bytes_needed-fulltag_cons,tcr)) {
+    tcr->save_allocptr -= fulltag_cons;
+    for (current = xpGPR(xp,Iallocptr);
+         nconses;
+         prev = current, current+= dnode_size, nconses--) {
+      deref(current,0) = prev;
+      deref(current,1) = initial;
+    }
+    xpGPR(xp,Iarg_z) = prev;
+  } else {
+    lisp_allocation_failure(xp,tcr,bytes_needed);
+  }
+  return true;
+}
+
 Boolean
 handle_alloc_trap(ExceptionInformation *xp, TCR *tcr)
@@ -500 +556 @@
   }
   
-  {
-    LispObj xcf = create_exception_callback_frame(xp, tcr),
-      cmain = nrs_CMAIN.vcell;
-    int skip;
-    
-    tcr->save_allocptr = tcr->save_allocbase = (void *)VOID_ALLOCPTR;
-    xpGPR(xp,Iallocptr) = VOID_ALLOCPTR;
-
-    skip = callback_to_lisp(tcr, cmain, xp, xcf, -1, XMEMFULL, 0, 0);
-    xpPC(xp) += skip;
-  }
+  lisp_allocation_failure(xp,tcr,bytes_needed);
 
   return true;
@@ -1086 +1132 @@
       case XUUO_KILL:
         xpGPR(context,Iimm0) = (LispObj)kill_tcr(target);
+        xpPC(context)+=3;
+        return true;
+
+      case XUUO_ALLOCATE_LIST:
+        allocate_list(context,tcr);
         xpPC(context)+=3;
         return true;

trunk/source/lisp-kernel/x86-exceptions.h

@@ -145 +145 @@
 #define XUUO_RESUME_ALL 8
 #define XUUO_KILL 9
+#define XUUO_ALLOCATE_LIST 10
 
 void