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

@@ -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;

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.

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

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)
+                      `(set! ,%sp ,(%inline + ,%sp (immediate ,frame-size)))))))))
-                                            (fx- frame-size (constant ptr-bytes))
-                                            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
+                              (add-cleanup-compensate result-type
-                                [(memq 'i3nt-com conv*)
+                                (cond
-                                 (when (null? arg-type*)
+                                  [(memq 'i3nt-com conv*)
-                                   ($oops 'foreign-procedure
+                                   (when (null? arg-type*)
-                                          "__com convention requires instance argument"))
+                                     ($oops 'foreign-procedure
-                                 ; jump indirect
+                                            "__com convention requires instance argument"))
-                                 (%seq
+                                   ;; jump indirect
-                                  (set! ,%eax ,(%mref ,%sp 0))
+                                   (%seq
-                                  (set! ,%eax ,(%mref ,%eax 0))
+                                    (set! ,%eax ,(%mref ,%sp 0))
-                                  (set! ,%eax ,(%inline + ,%eax ,t))
+                                    (set! ,%eax ,(%mref ,%eax 0))
-                                  (inline ,(make-info-kill*-live* live* '()) ,%c-call ,(%mref ,%eax 0)))]
+                                    (set! ,%eax ,(%inline + ,%eax ,t))
-                                [else `(inline ,(make-info-kill*-live* live* '()) ,%c-call ,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
+            (let* ([push-size (push-registers-size result-regs result-num-fp-regs 1)]
-                       (set! ,%eax ,(%mref ,%sp ,(+ 8 (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)