[Git][cmucl/cmucl][sparc64-dev] 6 commits: WIP: Add support for not-implmeented
Raymond Toy
rtoy at common-lisp.net
Fri Jan 20 03:55:30 UTC 2017
Raymond Toy pushed to branch sparc64-dev at cmucl / cmucl
Commits:
794b815a by Raymond Toy at 2017-01-17T20:33:48-08:00
WIP: Add support for not-implmeented
Add support for not-implemented trap where a VOP can mark itself as
not implemented. This causes a illtrap instruction to be inserted
followed by a branch always followed by a string (not necessarily nul
terminated) that represents the name of the VOP.
The signal handler currently catches the signal and sends prints out
the string and then continues.
Not yet debugged and definitely does not yet work.
We're just saving this in safe place for now.
- - - - -
155b792b by Raymond Toy at 2017-01-17T20:34:36-08:00
Registers are longs, not ints.
Fixes a couple of compiler warnings.
- - - - -
87731e87 by Raymond Toy at 2017-01-17T20:35:03-08:00
Add EMIT-NOT-IMPLEMENTED in a few interesting vops.
- - - - -
67a3752d by Raymond Toy at 2017-01-18T19:29:29-08:00
Don't allow scheduling of not-implemented.
We want everything here to be emitted in exactly this way.
- - - - -
3f4030a7 by Raymond Toy at 2017-01-18T20:50:48-08:00
Bump the start of the object-not- enum
This was overlapping the trap- enum.
- - - - -
06617844 by Raymond Toy at 2017-01-18T20:53:28-08:00
Correct the implementation of the not-implmeented handler.
The location of the string was off by one word and the length was
incorrectly calculated because we have a 19-bit word displacement for
the ba,pt instruction.
- - - - -
8 changed files:
- src/compiler/backend.lisp
- src/compiler/meta-vmdef.lisp
- src/compiler/sparc64/call.lisp
- src/compiler/sparc64/insts.lisp
- src/compiler/sparc64/move.lisp
- src/compiler/sparc64/parms.lisp
- src/lisp/solaris-os.c
- src/lisp/sparc-arch.c
Changes:
=====================================
src/compiler/backend.lisp
=====================================
--- a/src/compiler/backend.lisp
+++ b/src/compiler/backend.lisp
@@ -114,6 +114,24 @@
(backend-support-routines *target-backend*))
#',local-name))))
+(defmacro def-vm-support-routine (name ll &body body)
+ (unless (member (intern (string name) (find-package "C"))
+ vm-support-routines)
+ (warn (intl:gettext "Unknown VM support routine: ~A") name))
+ (let ((local-name (symbolicate (backend-name *target-backend*) "-" name)))
+ `(progn
+ (defun ,local-name
+ ,ll
+ (macrolet ((vm::emit-not-implemented ()
+ `(vm::not-implemented ,',local-name)))
+ , at body))
+ (setf (,(intern (concatenate 'simple-string
+ "VM-SUPPORT-ROUTINES-"
+ (string name))
+ (find-package "C"))
+ (backend-support-routines *target-backend*))
+ #',local-name))))
+
;;;; The backend structure.
=====================================
src/compiler/meta-vmdef.lisp
=====================================
--- a/src/compiler/meta-vmdef.lisp
+++ b/src/compiler/meta-vmdef.lisp
@@ -937,8 +937,10 @@
,@(binds))
(declare (ignore ,@(vop-parse-ignores parse)))
,@(loads)
- (new-assem:assemble (*code-segment* ,n-vop)
- ,@(vop-parse-body parse))
+ (macrolet ((vm::emit-not-implemented ()
+ `(vm::not-implemented ,',(vop-parse-name parse))))
+ (new-assem:assemble (*code-segment* ,n-vop)
+ ,@(vop-parse-body parse)))
,@(saves))))))
=====================================
src/compiler/sparc64/call.lisp
=====================================
--- a/src/compiler/sparc64/call.lisp
+++ b/src/compiler/sparc64/call.lisp
@@ -179,6 +179,9 @@
(dotimes (i (1- vm:function-code-offset))
(inst word 0)
(inst word 0))
+
+ (emit-not-implemented)
+
;; The start of the actual code.
;; Fix CODE, cause the function object was passed in.
(inst compute-code-from-fn code-tn code-tn start-lab temp)
=====================================
src/compiler/sparc64/insts.lisp
=====================================
--- a/src/compiler/sparc64/insts.lisp
+++ b/src/compiler/sparc64/insts.lisp
@@ -1534,6 +1534,31 @@ about function addresses and register values.")
(sc-offsets)
(lengths))))))))
+(defun snarf-not-implemented-name (stream dstate)
+ (let* ((sap (disassem:dstate-segment-sap dstate))
+ (offset (disassem:dstate-next-offs dstate))
+ (branch-inst (sys:sap-ref-32 sap offset)))
+ ;; sap + offset should point to the branch instruction after the
+ ;; illtrap (unimp) instruction. Make sure it's an unconditional
+ ;; branch instrution.
+ #+nil
+ (unless (= (ldb (byte 8 24) branch-inst) #xea)
+ (return-from snarf-not-implemented-name ""))
+ ;; From the offset in the branch instruction, compute the max
+ ;; length of the string that was encoded.
+ (let ((max-length (+ (ash (ldb (byte 24 0) branch-inst) 2) 4)))
+ ;; Skip the branch instruction
+ (incf offset 4)
+ ;; Print each following byte until max-length is reached or we
+ ;; get a 0 byte.
+ (with-output-to-string (s)
+ (do* ((k 0 (+ k 1))
+ (octet (sys:sap-ref-8 sap (+ offset k))
+ (sys:sap-ref-8 sap (+ offset k))))
+ ((or (>= k max-length)
+ (zerop octet)))
+ (write-char (code-char octet) s))))))
+
(defun unimp-control (chunk inst stream dstate)
(declare (ignore inst))
(flet ((nt (x) (if stream (disassem:note x dstate))))
@@ -1556,6 +1581,10 @@ about function addresses and register values.")
(nt "Function end breakpoint trap"))
(#.vm:object-not-instance-trap
(nt "Object not instance trap"))
+ (#.vm::not-implemented-trap
+ (nt (concatenate 'string
+ "Not-implemented trap: "
+ (snarf-not-implemented-name stream dstate))))
)))
(eval-when (compile load eval)
@@ -2252,6 +2281,26 @@ about function addresses and register values.")
+(defmacro not-implemented (&optional name)
+ (let ((string (string name)))
+ `(let ((length-label (gen-label)))
+ (new-assem:without-scheduling ()
+ (inst unimp not-implemented-trap)
+ ;; NOTE: The branch offset helps estimate the length of the
+ ;; string. The actual length of the string may be equal to the
+ ;; displacement or it may be up to three bytes shorter at the
+ ;; first trailing NUL byte. The string may or may not be
+ ;; 0-terminated.
+ (inst b length-label)
+ (inst nop)
+ ,@(map 'list #'(lambda (c)
+ `(inst byte ,(char-code c)))
+ string)
+ ;; Append enough zeros to end on a word boundary.
+ ,@(make-list (mod (- (length string)) 4)
+ :initial-element '(inst byte 0))
+ (emit-label length-label)))))
+
;;;; Instructions for dumping data and header objects.
(define-instruction word (segment word)
=====================================
src/compiler/sparc64/move.lisp
=====================================
--- a/src/compiler/sparc64/move.lisp
+++ b/src/compiler/sparc64/move.lisp
@@ -74,6 +74,7 @@
(define-move-function (store-stack 5) (vop x y)
((any-reg descriptor-reg) (control-stack))
+ (not-implemented "DEFINE-MOVE STORE-STACK")
(store-stack-tn y x))
(define-move-function (store-number-stack 5) (vop x y)
=====================================
src/compiler/sparc64/parms.lisp
=====================================
--- a/src/compiler/sparc64/parms.lisp
+++ b/src/compiler/sparc64/parms.lisp
@@ -243,6 +243,7 @@
after-breakpoint-trap allocation-trap
pseudo-atomic-trap
object-not-list-trap object-not-instance-trap
+ not-implemented-trap
trace-table-normal trace-table-call-site
trace-table-function-prologue trace-table-function-epilogue))
@@ -263,10 +264,11 @@
dynamic-space-overflow-warning
#+heap-overflow-check
dynamic-space-overflow-error
+ not-implemented
)
;; Make sure this starts AFTER the last element of the above enum!
-(defenum (:prefix object-not- :suffix -trap :start 16)
+(defenum (:prefix object-not- :suffix -trap :start 20)
list
instance)
=====================================
src/lisp/solaris-os.c
=====================================
--- a/src/lisp/solaris-os.c
+++ b/src/lisp/solaris-os.c
@@ -315,7 +315,7 @@ long *
solaris_register_address(struct ucontext *context, int reg)
{
if (reg == 0) {
- static int zero;
+ static long zero;
zero = 0;
@@ -323,7 +323,7 @@ solaris_register_address(struct ucontext *context, int reg)
} else if (reg < 16) {
return &context->uc_mcontext.gregs[reg + 3];
} else if (reg < 32) {
- int *sp = (int *) context->uc_mcontext.gregs[REG_SP];
+ long *sp = (long *) context->uc_mcontext.gregs[REG_SP];
return &sp[reg - 16];
} else
=====================================
src/lisp/sparc-arch.c
=====================================
--- a/src/lisp/sparc-arch.c
+++ b/src/lisp/sparc-arch.c
@@ -510,6 +510,53 @@ sigill_handler(HANDLER_ARGS)
os_context);
break;
#endif
+#ifdef trap_NotImplemented
+ case trap_NotImplemented:
+ {
+ /*
+ * Print out the name. The next instruction MUST be a
+ * branch immediate.
+ */
+ unsigned char *string;
+ int length;
+
+ /*
+ * Compute the maximum length of the string from the
+ * offset in the branch instruction. This code assumes
+ * a ba,pt instruction which has a 19-bit word offset in
+ * the low part of the instruction. Because branches
+ * have a delay slot, the string starts two words past
+ * the branch instruction.
+ */
+ string = (unsigned char *) &pc[3];
+ /*
+ * The offset is in 32-bit words, so subtract one for
+ * the instruction in the branch delay slot and scale up
+ * the offet to be in bytes.
+ */
+ length = 4 * ((pc[1] & 0x7FFFF) - 1);
+
+ while (string[length - 1] == '\0') {
+ --length;
+ }
+
+ /*
+ * Don't want to use NOT_IMPLEMENTED here because we
+ * don't actually want to abort. We want to continue,
+ * but print out a useful message.
+ */
+ printf("NOT-IMPLEMENTED: %p: \"%.*s\"\n", pc, length, string);
+
+ /*
+ * Skip over the illtrap instruction so if we can
+ * continue. This will execute the branch, skipping
+ * over the string too.
+ */
+ SC_PC(os_context) = (unsigned long) (pc + 1);
+
+ }
+ break;
+#endif
default:
interrupt_handle_now(signal, code, os_context);
break;
View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/585895ac72b27299e4d5dd269914a51e26bee02a...0661784461fda653dfb2fc155c6e7cf89e46fbbc
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://mailman.common-lisp.net/pipermail/cmucl-cvs/attachments/20170120/d1d1643f/attachment-0001.html>
More information about the cmucl-cvs
mailing list