(defstruct result-state
(num-results 0))
-(defun offset-for-result (n)
- (+ n 2)
- #+nil
- (if (= n 0)
- cfunc-offset
- (+ n 2)))
+(defun result-reg-offset (slot)
+ (ecase slot
+ (0 nl0-offset)
+ (1 nl1-offset)))
(define-alien-type-method (integer :result-tn) (type state)
(let ((num-results (result-state-num-results state)))
(setf (result-state-num-results state) (1+ num-results))
- (multiple-value-bind
- (ptype reg-sc)
+ (multiple-value-bind (ptype reg-sc)
(if (alien-integer-type-signed type)
(values 'signed-byte-32 'signed-reg)
(values 'unsigned-byte-32 'unsigned-reg))
- (my-make-wired-tn ptype reg-sc (offset-for-result num-results)))))
+ (my-make-wired-tn ptype reg-sc (result-reg-offset num-results)))))
(define-alien-type-method (system-area-pointer :result-tn) (type state)
(declare (ignore type))
(let ((num-results (result-state-num-results state)))
(setf (result-state-num-results state) (1+ num-results))
- (my-make-wired-tn 'system-area-pointer 'sap-reg (offset-for-result num-results))))
+ (my-make-wired-tn 'system-area-pointer 'sap-reg (result-reg-offset num-results))))
;;; FIXME: do these still work? -- CSR, 2002-08-28
(define-alien-type-method (double-float :result-tn) (type state)
(my-make-wired-tn 'single-float 'single-reg (* num-results 2))))
(define-alien-type-method (values :result-tn) (type state)
- (mapcar #'(lambda (type)
- (invoke-alien-type-method :result-tn type state))
- (alien-values-type-values type)))
+ (let ((values (alien-values-type-values type)))
+ (when (> (length values) 2)
+ (error "Too many result values from c-call."))
+ (mapcar #'(lambda (type)
+ (invoke-alien-type-method :result-tn type state))
+ values)))
(!def-vm-support-routine make-call-out-tns (type)
(let ((arg-state (make-arg-state)))
(alien-fun-type-result-type type)
(make-result-state))))))
+(deftransform %alien-funcall ((function type &rest args))
+ (aver (sb!c::constant-lvar-p type))
+ (let* ((type (sb!c::lvar-value type))
+ (env (sb!kernel:make-null-lexenv))
+ (arg-types (alien-fun-type-arg-types type))
+ (result-type (alien-fun-type-result-type type)))
+ (aver (= (length arg-types) (length args)))
+ ;; We need to do something special for 64-bit integer arguments
+ ;; and results.
+ (if (or (some #'(lambda (type)
+ (and (alien-integer-type-p type)
+ (> (sb!alien::alien-integer-type-bits type) 32)))
+ arg-types)
+ (and (alien-integer-type-p result-type)
+ (> (sb!alien::alien-integer-type-bits result-type) 32)))
+ (collect ((new-args) (lambda-vars) (new-arg-types))
+ (dolist (type arg-types)
+ (let ((arg (gensym)))
+ (lambda-vars arg)
+ (cond ((and (alien-integer-type-p type)
+ (> (sb!alien::alien-integer-type-bits type) 32))
+ ;; 64-bit long long types are stored in
+ ;; consecutive locations, endian word order,
+ ;; aligned to 8 bytes.
+ (if (oddp (length (new-args)))
+ (new-args nil))
+ #!-little-endian
+ (progn (new-args `(ash ,arg -32))
+ (new-args `(logand ,arg #xffffffff))
+ (if (oddp (length (new-arg-types)))
+ (new-arg-types (parse-alien-type '(unsigned 32) env)))
+ (if (alien-integer-type-signed type)
+ (new-arg-types (parse-alien-type '(signed 32) env))
+ (new-arg-types (parse-alien-type '(unsigned 32) env)))
+ (new-arg-types (parse-alien-type '(unsigned 32) env)))
+ #!+little-endian
+ (progn (new-args `(logand ,arg #xffffffff))
+ (new-args `(ash ,arg -32))
+ (if (oddp (length (new-arg-types)))
+ (new-arg-types (parse-alien-type '(unsigned 32) env)))
+ (new-arg-types (parse-alien-type '(unsigned 32) env))
+ (if (alien-integer-type-signed type)
+ (new-arg-types (parse-alien-type '(signed 32) env))
+ (new-arg-types (parse-alien-type '(unsigned 32) env)))))
+ (t
+ (new-args arg)
+ (new-arg-types type)))))
+ (cond ((and (alien-integer-type-p result-type)
+ (> (sb!alien::alien-integer-type-bits result-type) 32))
+ (let ((new-result-type
+ (let ((sb!alien::*values-type-okay* t))
+ (parse-alien-type
+ (if (alien-integer-type-signed result-type)
+ #!-little-endian
+ '(values (signed 32) (unsigned 32))
+ #!+little-endian
+ '(values (unsigned 32) (signed 32))
+ '(values (unsigned 32) (unsigned 32)))
+ env))))
+ `(lambda (function type ,@(lambda-vars))
+ (declare (ignore type))
+ (multiple-value-bind
+ #!-little-endian
+ (high low)
+ #!+little-endian
+ (low high)
+ (%alien-funcall function
+ ',(make-alien-fun-type
+ :arg-types (new-arg-types)
+ :result-type new-result-type)
+ ,@(new-args))
+ (logior low (ash high 32))))))
+ (t
+ `(lambda (function type ,@(lambda-vars))
+ (declare (ignore type))
+ (%alien-funcall function
+ ',(make-alien-fun-type
+ :arg-types (new-arg-types)
+ :result-type result-type)
+ ,@(new-args))))))
+ (sb!c::give-up-ir1-transform))))
+
(define-vop (foreign-symbol-address)
(:translate foreign-symbol-address)
(:policy :fast-safe)
unsigned int opcode = inst >> 26;
unsigned int r1 = (inst >> 21) & 0x1f;
unsigned int r2 = (inst >> 16) & 0x1f;
- unsigned int bdisp = ((inst&(1<<15)) ? inst | (-1 << 16) : inst&0x7fff) << 2;
- unsigned int jdisp = (inst&0x3ffffff) << 2;
- unsigned int disp = 0;
+ unsigned int r3 = (inst >> 11) & 0x1f;
+ unsigned int disp = ((inst&(1<<15)) ? inst | (-1 << 16) : inst&0x7fff) << 2;
+ unsigned int jtgt = (*os_context_pc_addr(context) & ~0x0fffffff) | (inst&0x3ffffff) << 2;
+ unsigned int tgt = *os_context_pc_addr(context);
switch(opcode) {
+ case 0x0: /* jr, jalr */
+ switch(inst & 0x3f) {
+ case 0x08: /* jr */
+ tgt = *os_context_register_addr(context, r1);
+ break;
+ case 0x09: /* jalr */
+ tgt = *os_context_register_addr(context, r1);
+ *os_context_register_addr(context, r3)
+ = *os_context_pc_addr(context) + 4;
+ break;
+ }
+ break;
case 0x1: /* bltz, bgez, bltzal, bgezal */
switch((inst >> 16) & 0x1f) {
case 0x00: /* bltz */
if(*os_context_register_addr(context, r1) < 0)
- disp = bdisp;
+ tgt += disp;
break;
case 0x01: /* bgez */
if(*os_context_register_addr(context, r1) >= 0)
- disp = bdisp;
+ tgt += disp;
break;
case 0x10: /* bltzal */
if(*os_context_register_addr(context, r1) < 0)
- disp = bdisp;
+ tgt += disp;
*os_context_register_addr(context, 31)
= *os_context_pc_addr(context) + 4;
break;
case 0x11: /* bgezal */
if(*os_context_register_addr(context, r1) >= 0)
- disp = bdisp;
+ tgt += disp;
*os_context_register_addr(context, 31)
= *os_context_pc_addr(context) + 4;
break;
case 0x4: /* beq */
if(*os_context_register_addr(context, r1)
== *os_context_register_addr(context, r2))
- disp = bdisp;
+ tgt += disp;
break;
case 0x5: /* bne */
if(*os_context_register_addr(context, r1)
!= *os_context_register_addr(context, r2))
- disp = bdisp;
+ tgt += disp;
break;
case 0x6: /* blez */
if(*os_context_register_addr(context, r1)
<= *os_context_register_addr(context, r2))
- disp = bdisp;
+ tgt += disp;
break;
case 0x7: /* bgtz */
if(*os_context_register_addr(context, r1)
> *os_context_register_addr(context, r2))
- disp = bdisp;
+ tgt += disp;
break;
case 0x2: /* j */
- disp = jdisp;
+ tgt = jtgt;
break;
case 0x3: /* jal */
- disp = jdisp;
+ tgt = jtgt;
*os_context_register_addr(context, 31)
= *os_context_pc_addr(context) + 4;
break;
}
- return *os_context_pc_addr(context) + disp;
+ return tgt;
}
void
= emulate_branch(context, *os_context_pc_addr(context));
} else
*os_context_pc_addr(context) += 4;
-
- os_flush_icache((os_vm_address_t)*os_context_pc_addr(context),
- sizeof(unsigned int));
}
unsigned char *
/* Multiple value return spot, clear stack. */
move reg_CSP, reg_OCFP
- nop
+ nop
/* Single value return spot. */
- /* Pass one return value back to C land. */
- move v0, reg_A0 # reg_CFUNC
-
/* Nested lisp -> C calls may have clobbered gp. */
lw gp, framesize-16(sp)
break 0x10
1: .set reorder
+ /* Pass one return value back to C land. For a 64bit value, we may
+ need to clobber v1 aka reg_NL4. */
+ move v0, reg_A0 # reg_CFUNC
+ move v1, reg_A1 # reg_NL4
+
/* Restore C regs */
lw ra, framesize-8(sp)
lw s8, framesize-12(sp)
lw gp, 8(reg_CFP)
+ /* Pass 64bit return value to lisp land. */
+ move reg_NL0, v0 # reg_CFUNC
+ move reg_NL1, v1 # reg_NL4
+
li reg_NIL, NIL
/* Clear unsaved boxed descriptor regs */
* The undefined-function trampoline.
*/
LEAF(undefined_tramp)
- break 10
+ break trap_Error
.byte 4
.byte UNDEFINED_FUN_ERROR
.byte 254
/*
* Function-end breakpoint magic.
*/
+ .align 3
LEAF(fun_end_breakpoint_guts)
.set noreorder
- .align 3
.word RETURN_PC_HEADER_WIDETAG
-
+
b multiple_value_return
nop
+ .set reorder
move reg_OCFP, reg_CSP
addu reg_CSP, 4
FEXPORT(fun_end_breakpoint_trap)
break trap_FunEndBreakpoint
-1: b 1b
- nop
-
+ b multiple_value_return
EXPORT(fun_end_breakpoint_end)
- .set reorder
END(fun_end_breakpoint_guts)
projects / sbcl.git / commitdiff