From b8f0c96756f99aa67fe4d3ea0321f7fcebae3b25 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 22 Dec 2020 05:27:40 -0700 Subject: [PATCH] Chez Scheme: repair i386 Mac OS __collect_safe ABI A wrapper to align the stack during activation was dropped if the return type was `void` for a foreign callable, and a callee-popped argument was not handled right for a foreign call. --- racket/src/ChezScheme/c/thread.c | 12 +++-- racket/src/ChezScheme/s/cmacros.ss | 2 +- racket/src/ChezScheme/s/np-languages.ss | 1 + racket/src/ChezScheme/s/x86.ss | 62 ++++++++++++++++--------- 4 files changed, 51 insertions(+), 26 deletions(-) diff --git a/racket/src/ChezScheme/c/thread.c b/racket/src/ChezScheme/c/thread.c index 35b74281a7..eafad66dfd 100644 --- a/racket/src/ChezScheme/c/thread.c +++ b/racket/src/ChezScheme/c/thread.c @@ -64,6 +64,8 @@ ptr S_create_thread_object(who, p_tc) const char *who; ptr p_tc; { if (S_threads == Snil) { tc = TO_PTR(S_G.thread_context); tgc = &S_G.main_thread_gc; + GCDATA(tc) = TO_PTR(tgc); + tgc->tc = tc; } else { /* clone parent */ ptr p_v = PARAMETERS(p_tc); iptr i, n = Svector_length(p_v); @@ -80,6 +82,9 @@ ptr S_create_thread_object(who, p_tc) const char *who; ptr p_tc; { S_error(who, "unable to malloc thread data structure"); memcpy(TO_VOIDP(tc), TO_VOIDP(p_tc), size_tc); + GCDATA(tc) = TO_PTR(tgc); + tgc->tc = tc; + { IGEN g; ISPC s; for (g = 0; g <= static_generation; g++) { @@ -109,9 +114,6 @@ ptr S_create_thread_object(who, p_tc) const char *who; ptr p_tc; { CODERANGESTOFLUSH(tc) = Snil; } - GCDATA(tc) = TO_PTR(tgc); - tgc->tc = tc; - tgc->sweeper = main_sweeper_index; /* override nonclonable tc fields */ @@ -171,6 +173,8 @@ ptr S_create_thread_object(who, p_tc) const char *who; ptr p_tc; { LZ4OUTBUFFER(tc) = 0; + CP(tc) = 0; + tc_mutex_release(); return thread; @@ -183,7 +187,7 @@ IBOOL Sactivate_thread() { /* create or reactivate current thread */ if (tc == (ptr)0) { /* thread created by someone else */ ptr thread; - /* borrow base thread for now */ + /* borrow base thread to clone */ thread = S_create_thread_object("Sactivate_thread", TO_PTR(S_G.thread_context)); s_thread_setspecific(S_tc_key, TO_VOIDP(THREADTC(thread))); return 1; diff --git a/racket/src/ChezScheme/s/cmacros.ss b/racket/src/ChezScheme/s/cmacros.ss index d0aeee7d76..3e89a8f94d 100644 --- a/racket/src/ChezScheme/s/cmacros.ss +++ b/racket/src/ChezScheme/s/cmacros.ss @@ -1,4 +1,4 @@ -<;;; Copyright 1984-2017 Cisco Systems, Inc. +;;; Copyright 1984-2017 Cisco Systems, Inc. ;;; ;;; Licensed under the Apache License, Version 2.0 (the "License"); ;;; you may not use this file except in compliance with the License. diff --git a/racket/src/ChezScheme/s/np-languages.ss b/racket/src/ChezScheme/s/np-languages.ss index e471c4e897..3ce3a8bb68 100644 --- a/racket/src/ChezScheme/s/np-languages.ss +++ b/racket/src/ChezScheme/s/np-languages.ss @@ -535,6 +535,7 @@ (declare-primitive c-call effect #f) (declare-primitive c-simple-call effect #f) (declare-primitive c-simple-return effect #f) + (declare-primitive check-stack-align effect #f) ; x86 (declare-primitive deactivate-thread effect #f) ; threaded version only (declare-primitive fldl effect #f) ; x86 (declare-primitive flds effect #f) ; x86 diff --git a/racket/src/ChezScheme/s/x86.ss b/racket/src/ChezScheme/s/x86.ss index 4289bc3086..774713cd37 100644 --- a/racket/src/ChezScheme/s/x86.ss +++ b/racket/src/ChezScheme/s/x86.ss @@ -728,6 +728,9 @@ (define-instruction effect (push) [(op (x ur)) `(asm ,info ,asm-push ,x)]) + (define-instruction effect (check-stack-align) + [(op) `(asm ,info ,asm-check-stack-align)]) + (define-instruction effect save-flrv [(op) `(asm ,info ,asm-save-flrv)]) @@ -755,7 +758,7 @@ asm-fl-cvt asm-store-single asm-fpt asm-fptrunc asm-fpsingle asm-div asm-exchange asm-pause asm-locked-incr asm-locked-decr asm-locked-cmpxchg asm-fpop-2 asm-fpmove asm-fpmovefrom asm-fpcastfrom asm-fpcastto asm-fpsqrt asm-c-simple-call - asm-save-flrv asm-restore-flrv asm-return asm-c-return asm-size + asm-save-flrv asm-restore-flrv asm-return asm-c-return asm-size asm-check-stack-align asm-enter asm-foreign-call asm-foreign-callable asm-inc-profile-counter asm-inc-cc-counter asm-read-time-stamp-counter asm-read-performance-monitoring-counter @@ -890,6 +893,8 @@ (define-op sahf byte-op #b10011110) (define-op extad byte-op #b10011001) ; extend eax to edx + (define-op int3 byte-op #b11001100) + (define-op rdtsc two-byte-op #b1111 #b00110001) ; read time-stamp counter (define-op rdpmc two-byte-op #b1111 #b00110011) ; read performance monitoring counter (define-op pause two-byte-op #b11110011 #b10010000) ; equivalent to rep nop @@ -1802,6 +1807,13 @@ (emit retl `(imm ,offset) '())) (emit ret '())))) + ;; debugging helper; use as `(%inline check-stack-align)` + (define asm-check-stack-align + (lambda (code*) + (emit testi (list 'imm 15) (cons 'reg %sp) + (emit beq `(label 1 #f) + (emit int3 code*))))) + (define asm-locked-incr (lambda (code* base index offset) (let ([dest (build-mem-opnd base index offset)]) @@ -2211,7 +2223,7 @@ [(i3nt ti3nt) offset] [else (fx- (fxlogand (fx+ offset (fx* 4 arg-count) 15) -16) - (fx* 4 arg-count))]))) + (fx* 4 arg-count))]))) (define (push-registers regs fp-reg-count arg-count) (let ([offset (push-registers-size regs fp-reg-count arg-count)]) (move-registers regs fp-reg-count #f offset @@ -2376,6 +2388,14 @@ ,e ,(save-and-restore result-regs result-fp-count `(set! ,%eax ,(%inline activate-thread))))))] [else e])) + (define (add-cleanup-compensate result-type e) + ;; The convention for the calle to pop the return-pointer argument makes a mess, + ;; especially for alignment, so counteract it right away + (if (callee-pops-result-pointer? result-type) + (%seq + ,e + (set! ,%sp ,(%inline - ,%sp ,(%constant ptr-bytes)))) + e)) (define returnem (lambda (conv* orig-frame-size locs result-type ccall r-loc) (let ([frame-size (constant-case machine-type-name @@ -2394,10 +2414,7 @@ (lambda () (if (or (fx= frame-size 0) (memq 'i3nt-stdcall conv*) (memq 'i3nt-com conv*)) `(nop) - (let ([frame-size (if (callee-pops-result-pointer? result-type) - (fx- frame-size (constant ptr-bytes)) - frame-size)]) - `(set! ,%sp ,(%inline + ,%sp (immediate ,frame-size)))))))))) + `(set! ,%sp ,(%inline + ,%sp (immediate ,frame-size))))))))) (lambda (info) (safe-assert (reg-callee-save? %tc)) ; no need to save-restore (let ([conv* (info-foreign-conv* info)] @@ -2413,18 +2430,20 @@ [live* (add-caller-save-registers (reg-list %eax %edx))] [call (add-deactivate adjust-active? fill-result-here? t0 result-type - (cond - [(memq 'i3nt-com conv*) - (when (null? arg-type*) - ($oops 'foreign-procedure - "__com convention requires instance argument")) - ; jump indirect - (%seq - (set! ,%eax ,(%mref ,%sp 0)) - (set! ,%eax ,(%mref ,%eax 0)) - (set! ,%eax ,(%inline + ,%eax ,t)) - (inline ,(make-info-kill*-live* live* '()) ,%c-call ,(%mref ,%eax 0)))] - [else `(inline ,(make-info-kill*-live* live* '()) ,%c-call ,t)]))]) + (add-cleanup-compensate result-type + (cond + [(memq 'i3nt-com conv*) + (when (null? arg-type*) + ($oops 'foreign-procedure + "__com convention requires instance argument")) + ;; jump indirect + (%seq + (set! ,%eax ,(%mref ,%sp 0)) + (set! ,%eax ,(%mref ,%eax 0)) + (set! ,%eax ,(%inline + ,%eax ,t)) + (inline ,(make-info-kill*-live* live* '()) ,%c-call ,(%mref ,%eax 0)))] + [else + `(inline ,(make-info-kill*-live* live* '()) ,%c-call ,t)])))]) (cond [fill-result-here? (let* ([ftd (nanopass-case (Ltype Type) result-type @@ -2661,12 +2680,13 @@ (list %eax) 0)])])) (define (unactivate result-regs result-num-fp-regs) - (let ([e (%seq - (set! ,%eax ,(%mref ,%sp ,(+ 8 (push-registers-size result-regs result-num-fp-regs 1)))) + (let* ([push-size (push-registers-size result-regs result-num-fp-regs 1)] + [e (%seq + (set! ,%eax ,(%mref ,%sp ,(+ 8 push-size))) ,(%inline push ,%eax) ,(%inline unactivate-thread) (set! ,%eax ,(%inline pop)))]) - (if (and (null? result-regs) (fx= 0 result-num-fp-regs)) + (if (and (null? result-regs) (fx= 0 result-num-fp-regs) (fx= 0 push-size)) e (%seq ,(push-registers result-regs result-num-fp-regs 1)