From: Christophe Rhodes Date: Fri, 20 May 2005 09:45:14 +0000 (+0000) Subject: 0.9.0.39: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=449088454569070e400f9f562c247bdc17cf60b5;p=sbcl.git 0.9.0.39: Merge amended "64bit FFI for mips/mipsel" patch (Thiemo Seufer sbcl-devel 2005-05-09) ... including 64-bit return value in call_into_lisp. (Not currently used) ... other minor MIPS cleanups and bugfixes too as described in the mail message. --- diff --git a/NEWS b/NEWS index 7fe3b8b..4a1a28b 100644 --- a/NEWS +++ b/NEWS @@ -16,8 +16,11 @@ changes in sbcl-0.9.1 relative to sbcl-0.9.0: generic subtraction routines on x86/x86-64. (Thanks to Lutz Euler) * optimization: the code generated on x86-64 is more compact thanks to not outputting unneccessary prefix bytes. (Thanks to Lutz Euler) - * bug fix: floating-point exception handling now works on x86-64. - (Thanks to James Knight) + * bug fix: floating-point exception handling now partly works on + x86-64. (Thanks to James Knight) + * improvement to the MIPS backend from Thiemo Seufer: C-style + 64-bit long long arguments and return values to alien functions + are now supported. * fixed some bugs revealed by Paul Dietz' test suite: ** the type-error signalled from WARN has a filled-in DATUM slot. ** the type-error required when a stream is not associated with diff --git a/src/compiler/mips/c-call.lisp b/src/compiler/mips/c-call.lisp index cef3b3b..d020fce 100644 --- a/src/compiler/mips/c-call.lisp +++ b/src/compiler/mips/c-call.lisp @@ -90,28 +90,25 @@ (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) @@ -127,9 +124,12 @@ (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))) @@ -143,6 +143,88 @@ (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) diff --git a/src/runtime/mips-arch.c b/src/runtime/mips-arch.c index 4c91b74..b07d8da 100644 --- a/src/runtime/mips-arch.c +++ b/src/runtime/mips-arch.c @@ -44,30 +44,43 @@ emulate_branch(os_context_t *context, unsigned int inst) 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; @@ -76,33 +89,33 @@ emulate_branch(os_context_t *context, unsigned int inst) 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 @@ -121,9 +134,6 @@ arch_skip_instruction(os_context_t *context) = 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 * diff --git a/src/runtime/mips-assem.S b/src/runtime/mips-assem.S index b22bbd7..1c37e2e 100644 --- a/src/runtime/mips-assem.S +++ b/src/runtime/mips-assem.S @@ -176,13 +176,10 @@ lra: /* 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) @@ -208,6 +205,11 @@ lra: 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) @@ -283,6 +285,10 @@ lra: 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 */ @@ -339,7 +345,7 @@ lra: * The undefined-function trampoline. */ LEAF(undefined_tramp) - break 10 + break trap_Error .byte 4 .byte UNDEFINED_FUN_ERROR .byte 254 @@ -363,13 +369,14 @@ lra: /* * 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 @@ -384,9 +391,6 @@ multiple_value_return: 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) diff --git a/version.lisp-expr b/version.lisp-expr index 5adfde9..7e81fac 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.9.0.38" +"0.9.0.39"