1 ;;; This file contains the PPC specific runtime stuff.
6 "Returns a string describing the type of the local machine."
10 (defun return-machine-address (scp)
11 (sap-int (context-lr scp
)))
15 ;;;; "Sigcontext" access functions, cut & pasted from x86-vm.lisp then
16 ;;;; hacked for types.
18 (define-alien-routine ("os_context_lr_addr" context-lr-addr
) (* unsigned-long
)
19 (context (* os-context-t
)))
21 (defun context-lr (context)
22 (declare (type (alien (* os-context-t
)) context
))
23 (int-sap (deref (context-lr-addr context
))))
24 ;;; This is like CONTEXT-REGISTER, but returns the value of a float
25 ;;; register. FORMAT is the type of float to return.
27 ;;; FIXME: Whether COERCE actually knows how to make a float out of a
28 ;;; long is another question. This stuff still needs testing.
30 (define-alien-routine ("os_context_fpregister_addr" context-float-register-addr
)
32 (context (* os-context-t
))
34 (defun context-float-register (context index format
)
35 (declare (type (alien (* os-context-t
)) context
))
36 (error "context-float-register not working yet? ~S" (list context index format
))
38 (coerce (deref (context-float-register-addr context index
)) format
))
39 (defun %set-context-float-register
(context index format new
)
40 (declare (type (alien (* os-context-t
)) context
))
41 (error "%set-context-float-register not working yet? ~S" (list context index format new
))
43 (setf (deref (context-float-register-addr context index
))
46 ;;; Given a signal context, return the floating point modes word in
47 ;;; the same format as returned by FLOATING-POINT-MODES.
49 ;;; FIXME: surely this must be accessible under some other operating systems?
51 (define-alien-routine ("os_context_fp_control" context-floating-point-modes
)
53 (context (* os-context-t
)))
56 ;;;; INTERNAL-ERROR-ARGS.
58 ;;; GIVEN a (POSIX) signal context, extract the internal error
59 ;;; arguments from the instruction stream. This is e.g.
61 ;;; INTERNAL-ERROR-ARGS -- interface.
63 ;;; Given the sigcontext, extract the internal error arguments from the
64 ;;; instruction stream.
66 (defun internal-error-args (context)
67 (declare (type (alien (* os-context-t
)) context
))
68 (let* ((pc (context-pc context
))
69 (bad-inst (sap-ref-32 pc
0))
70 (op (ldb (byte 16 16) bad-inst
))
71 (regnum (ldb (byte 5 0) op
)))
72 (declare (type system-area-pointer pc
))
74 (logior (ash 2 10) (ash 1 5) null-offset
) ;; TDI LGT,$NULL
76 (logior (ash 3 10) (ash 6 5))) ;; twllei r0
77 (let ((trap-number (ldb (byte 8 0) bad-inst
)))
78 (sb-kernel::decode-internal-error-args
(sap+ pc
4) trap-number
)))
79 ((and (= (ldb (byte 6 10) op
) 3) ;; twi
80 (or (= regnum
#.
(sc+offset-offset arg-count-sc
))
81 (= (ldb (byte 5 5) op
) 24))) ;; :ne
82 ;; Type errors are encoded as
83 ;; twi 0 value-register error-code
84 ;; twi :ne temp-register x
85 (let ((prev (sap-ref-32 (int-sap (- (sap-int pc
) 4)) 0)))
86 (if (and (= (ldb (byte 5 5) op
) 24) ;; is the condition :ne?
87 (= (ldb (byte 6 26) prev
) 3) ;; is it twi?
88 (= (ldb (byte 5 21) prev
) 0)) ;; is it non-trapping?
89 (values (ldb (byte 16 0) prev
)
90 (list (make-sc+offset any-reg-sc-number
91 (ldb (byte 5 16) prev
))))
92 ;; arg-count errors are encoded as
93 ;; twi {:ne :llt :lgt} nargs arg-count
94 (values #.
(error-number-or-lose 'invalid-arg-count-error
)
97 (values #.
(error-number-or-lose 'unknown-error
) nil
)))))
99 ;;; To support linkage-space as efficiently as on x86-64, these
100 ;;; things have to happen:
101 ;;; * funcallable-instances must become directly callable objects
102 ;;; * simple-fun-self, closure-fun, fin-fun must be raw addresses
103 ;;; * LRAs should be removed
104 ;;; For now, I'm using a hand-assembled simple-fun as simplifying wrapper
105 ;;; since executable funinstances are not supported.
108 (defun ensure-simplistic (function name
)
109 (when (simple-fun-p function
)
110 (return-from ensure-simplistic function
))
112 ((nraw (* 8 n-word-bytes
))
113 (code (sb-c:allocate-code-object nil
4 nraw
))
114 ;; FIXME: why does an undef FUNCTION come in as either/or? Can I settle on just one?
115 (undef (or (eql function
0) (null function
)))
116 ;; It's nice if these blobs of code are all the same size but the funinstance case
117 ;; doesn't fit entirely within NRAW bytes, so it calls an ASM routine.
121 #(#xE95FFFD8
; LD $FDEFN,-40($LIP) ; [debug-info] = the function name
122 #x3BF20000
; ADDI $LIP,$NULL,x ; UNDEFINED-TRAMP
123 #x7FE903A6
; MTCTR $LIP
126 ((funcallable-instance-p function
)
128 #(#xEABFFFD8
; LD $LEXENV,-40($LIP) ; [debug-info] = the funinstance
129 #x3BF20000
; ADDI $LIP,$NULL,x ; FUNCALLABLE-INSTANCE-TRAMP
130 #x7FE903A6
; MTCTR $LIP
132 'funcallable-instance-tramp
))
134 #(#xEABFFFD8
; LD $LEXENV,-40($LIP) ; [debug-info] = the closure
135 #x38000002
; ADDI $ZERO,$ZERO,2
136 #x7FF5002A
; LDX $LIP,$LEXENV,$ZERO ; get closure's simple-fun entrypoint
137 #x7FE903A6
; MTCTR $LIP
138 #x4E800420
))))) ; BCTR
139 (with-pinned-objects (code)
140 (let ((self (sap+ (code-instructions code
) 16)))
141 (setf (sap-ref-word self
(ash -
2 word-shift
)) 1 ; jump table word count
142 (sap-ref-word self
(ash -
1 word-shift
)) 0 ; unused
143 (sap-ref-word self
0) (logior #x600 simple-fun-widetag
)
144 (sap-ref-sap self
8) (sap+ self
16))
145 (let ((start (sap+ self
16)))
146 (dotimes (i (length insts
))
147 (setf (sap-ref-32 start
(ash i
2)) (aref insts i
)))
149 (let ((imm (- (sb-fasl:get-asm-routine helper
) nil-value
)))
150 (setf (sap-ref-32 start
4) (logior (sap-ref-32 start
4) imm
)))))
151 ;; Store trailing data
152 (let ((end (sap+ self
(- nraw
16)))) ; undo 16 added above
153 (setf (sap-ref-32 end -
8) #x10
; code-instructions to fun-base offset
154 (sap-ref-16 end -
4) (ash 1 5) ; simple-fun count
155 (sap-ref-16 end -
2) 8)))) ; trailer len in bytes
156 (code-header-set code code-debug-info-slot
(if undef name function
))
157 (%code-entry-point code
0)))
159 (defun stepper-fun (closure) (ensure-simplistic closure nil
))