diff --git a/LOG b/LOG
index e5aae978a0..f9c2fd1698 100644
--- a/LOG
+++ b/LOG
@@ -1027,3 +1027,5 @@
     cpnanopass.ss, x86_64.ss, x86.ss, foreign2.c, foreign.ms
 - added initialization of seginfo sorted and trigger_ephemerons fields.
     segment.c
+- avoid fasl overflow of C stack
+    fasl.ss, compile.ss, cmacros.ss, fasl.c, 6.ms
diff --git a/c/fasl.c b/c/fasl.c
index c659c69ec2..72a3dd3ffd 100644
--- a/c/fasl.c
+++ b/c/fasl.c
@@ -961,6 +961,13 @@ static void faslin(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f) {
             faslin(tc, &INITCDR(p), t, pstrbuf, f);
             return;
         }
+        case fasl_type_begin: {
+            uptr n = uptrin(f) - 1; ptr v;
+            while (n--)
+              faslin(tc, &v, t, pstrbuf, f);
+            faslin(tc, x, t, pstrbuf, f);
+            return;
+        }
         default:
             S_error2("", "invalid object type ~d in fasl file ~a", FIX(ty), f->uf->path);
     }
diff --git a/mats/6.ms b/mats/6.ms
index 667ecb6b4d..4b330499fd 100644
--- a/mats/6.ms
+++ b/mats/6.ms
@@ -970,6 +970,46 @@
     '(#t #f #t #t #f #t))
 )
 
+(mat fasl-depth
+  (begin
+    (define fasl-deep-N 100000)
+    (define (check v)
+      (let-values ([(o get) (open-bytevector-output-port)])
+        (fasl-write v o)
+        (equal? v (fasl-read (open-bytevector-input-port (get))))))
+    (define (check-mk mk)
+      (check (let loop ([n fasl-deep-N])
+               (if (zero? n)
+                   'done
+                   (mk (loop (sub1 n)))))))
+    (define-record-type other
+      (fields val))
+    (record-type-equal-procedure (record-type-descriptor other)
+                                 (lambda (a b eql?)
+                                   (eql? (other-val a) (other-val b))))
+    #t)
+
+  (check-mk vector)
+  (check-mk box)
+  (check-mk list)
+  (check-mk (lambda (v) (cons 'x v)))
+  (check-mk make-other)
+
+  ;; Generate a chain of code records:
+  (let-values ([(o get) (open-bytevector-output-port)])
+    (compile-to-port
+     (list
+      `(lambda ()
+         ,(let loop ([n fasl-deep-N])
+            (if (zero? n)
+                ''end
+                `(if (stop?)
+                     'stop
+                     ,(loop (sub1 n)))))))
+     o)
+    (fasl-read (open-bytevector-input-port (get)))
+    #t))
+
 (mat clear-output-port ; test interactively
    (procedure? clear-output-port)
  )
diff --git a/s/cmacros.ss b/s/cmacros.ss
index bd188e982a..78c3b5047e 100644
--- a/s/cmacros.ss
+++ b/s/cmacros.ss
@@ -455,6 +455,8 @@
 (define-constant fasl-type-immutable-bytevector 39)
 (define-constant fasl-type-immutable-box 40)
 
+(define-constant fasl-type-begin 41)
+
 (define-constant fasl-fld-ptr 0)
 (define-constant fasl-fld-u8 1)
 (define-constant fasl-fld-i16 2)
diff --git a/s/compile.ss b/s/compile.ss
index 10a961e66b..cc3ae985fc 100644
--- a/s/compile.ss
+++ b/s/compile.ss
@@ -229,48 +229,48 @@
 
 (define c-build-fasl
   (lambda (x t a?)
-    (let build ([x x])
+    (let build ([x x] [d 0])
       (record-case x
-         [(object) (x) ($fasl-enter x t a?)]
+         [(object) (x) ($fasl-enter x t a? d)]
          [(closure) func
-          ($fasl-bld-graph x t a?
-            (lambda (x t a?)
-              (build ($c-func-code-record func))))]
+          ($fasl-bld-graph x t a? d #f
+            (lambda (x t a? d)
+              (build ($c-func-code-record func) d)))]
          [(code) stuff
-          ($fasl-bld-graph x t a?
-            (lambda (x t a?)
+          ($fasl-bld-graph x t a? d #f
+            (lambda (x t a? d)
               (record-case x
                 [(code) (func subtype free name arity-mask size code-list info pinfo*)
-                 ($fasl-enter name t a?)
-                 ($fasl-enter arity-mask t a?)
-                 ($fasl-enter info t a?)
-                 ($fasl-enter pinfo* t a?)
+                 ($fasl-enter name t a? d)
+                 ($fasl-enter arity-mask t a? d)
+                 ($fasl-enter info t a? d)
+                 ($fasl-enter pinfo* t a? d)
                  (for-each
                    (lambda (x)
                      (record-case x
-                       [(abs) (n x) (build x)]
+                       [(abs) (n x) (build x d)]
                        [else
                         (constant-case architecture
                           [(x86)
                            (record-case x
-                             [(rel) (n x) (build x)]
+                             [(rel) (n x) (build x d)]
                              [else (void)])]
                           [(x86_64)
                            (record-case x
-                             [(x86_64-jump x86_64-call) (n x) (build x)]
+                             [(x86_64-jump x86_64-call) (n x) (build x d)]
                              [else (void)])]
                           [(arm32)
                            (record-case x
-                             [(arm32-abs arm32-call arm32-jump) (n x) (build x)]
+                             [(arm32-abs arm32-call arm32-jump) (n x) (build x d)]
                              [else (void)])]
                           [(ppc32)
                            (record-case x
-                             [(ppc32-abs ppc32-call ppc32-jump) (n x) (build x)]
+                             [(ppc32-abs ppc32-call ppc32-jump) (n x) (build x d)]
                              [else (void)])])]))
                    code-list)])))]
-         [(group) elt* (for-each build elt*)]
-         [(revisit-stuff) elt (build elt)]
-         [(visit-stuff) elt (build elt)]))))
+         [(group) elt* (for-each (lambda (elt) (build elt d)) elt*)]
+         [(revisit-stuff) elt (build elt d)]
+         [(visit-stuff) elt (build elt d)]))))
 
 (include "fasl-helpers.ss")
 
@@ -442,8 +442,8 @@
 (define (c-print-fasl x p)
   (let ([t ($fasl-table)] [a? (or (generate-inspector-information) (eq? ($compile-profile) 'source))])
      (c-build-fasl x t a?)
-     ($fasl-start p t
-       (lambda (p) (c-faslobj x t p a?)))))
+     ($fasl-start x p t
+       (lambda (x p) (c-faslobj x t p a?)))))
 
 (define-record-type visit-chunk
   (nongenerative)
@@ -611,8 +611,8 @@
                         (lambda ()
                           (parameterize ([$target-machine (machine-type)])
                             (let ([t ($fasl-table)])
-                              ($fasl-enter x1 t #t)
-                              ($fasl-start wpoop t (lambda (p) ($fasl-out x1 p t #t))))))))))
+                              ($fasl-enter x1 t #t 0)
+                              ($fasl-start x1 wpoop t (lambda (x p) ($fasl-out x p t #t))))))))))
                 (compile-file-help1 x1 op source-info-string)
                 (when hostop
                   ; the host library file contains expander output possibly augmented with
@@ -622,8 +622,8 @@
                     (lambda ()
                       (parameterize ([$target-machine (machine-type)])
                         (let ([t ($fasl-table)])
-                          ($fasl-enter x1 t #t)
-                          ($fasl-start hostop t (lambda (p) ($fasl-out x1 p t #t)))))))))
+                          ($fasl-enter x1 t #t 0)
+                          ($fasl-start x1 hostop t (lambda (x p) ($fasl-out x p t #t)))))))))
               (cfh0 (+ n 1)))))))))
 
 (define library/program-info?
@@ -1378,8 +1378,8 @@
                     (let ([t ($fasl-table)])
                       (let ([x (fold-left (lambda (outer ir) (with-output-language (Lexpand Outer) `(group ,outer ,ir)))
                                  (car ir*) (cdr ir*))])
-                        ($fasl-enter x t #t)
-                        ($fasl-start wpoop t (lambda (p) ($fasl-out x p t #t)))))))))
+                        ($fasl-enter x t #t 0)
+                        ($fasl-start x wpoop t (lambda (x p) ($fasl-out x p t #t)))))))))
             (close-port wpoop))))))
 
   (define build-required-library-list
diff --git a/s/fasl.ss b/s/fasl.ss
index be4eaefd86..678ba950ca 100644
--- a/s/fasl.ss
+++ b/s/fasl.ss
@@ -53,47 +53,47 @@
 (include "fasl-helpers.ss")
 
 (define bld-pair
-   (lambda (x t a?)
-      (bld (car x) t a?)
-      (bld (cdr x) t a?)))
+   (lambda (x t a? d)
+      (bld (car x) t a? d)
+      (bld (cdr x) t a? d)))
 
 (define bld-vector
-   (lambda (x t a?)
+   (lambda (x t a? d)
       (let ([len (vector-length x)])
          (let bldvec ([i 0])
             (unless (fx= i len)
-               (bld (vector-ref x i) t a?)
+               (bld (vector-ref x i) t a? d)
                (bldvec (fx+ i 1)))))))
 
 (define bld-record
-  (lambda (x t a?)
+  (lambda (x t a? d)
     (unless (eq? x #!base-rtd)
-      (really-bld-record x t a?))))
+      (really-bld-record x t a? d))))
 
 (define really-bld-record
-  (lambda (x t a?)
+  (lambda (x t a? d)
     (let ([rtd ($record-type-descriptor x)])
-      (bld rtd t a?)
+      (bld rtd t a? d)
       (do ([flds (rtd-flds rtd) (cdr flds)] [i 0 (+ i 1)])
         ((null? flds))
         (when (memq (fld-type (car flds)) '(scheme-object ptr))
-          (bld ((csv7:record-field-accessor rtd i) x) t a?))))))
+          (bld ((csv7:record-field-accessor rtd i) x) t a? d))))))
 
 (define bld-ht
-  (lambda (x t a?)
+  (lambda (x t a? d)
     (let-values ([(keyvec valvec) (hashtable-entries x)])
       (vector-for-each
         (lambda (key val)
-          (bld key t a?)
-          (bld val t a?))
+          (bld key t a? d)
+          (bld val t a? d))
         keyvec valvec))))
 
 (define bld-box
-   (lambda (x t a?)
-      (bld (unbox x) t a?)))
+   (lambda (x t a? d)
+      (bld (unbox x) t a? d)))
 
 (define bld-simple
-   (lambda (x t a?)
+   (lambda (x t a? d)
       (void)))
 
 (module (bld-graph dump-graph reset-dump-graph)
@@ -129,7 +129,7 @@
             (printf "~10s ~10s ~s\n" entry dup (car cat)))
           vcat ventry vdup))))
   (define bld-graph
-    (lambda (x t a? handler)
+    (lambda (x t a? d inner? handler)
       (let ([a (eq-hashtable-cell (table-hash t) x 'first)])
         (let ([p (cdr a)])
           (cond
@@ -138,8 +138,16 @@
                  (when (fx= (modulo n 10000) 0)
                    (printf "entries = ~s, ba = ~s, count = ~s\n" n (bytes-allocated) (table-count t))))
              (record! ventry x)
-             (set-cdr! a #f)
-             (handler x t a?)]
+             (cond
+              [(fx>= d 500)
+               ;; Limit depth of recursion by lifting to a `fasl-begin` graph:
+               (let ([n (table-count t)])
+                 (set-cdr! a (cons n (if inner? 'inner-begin 'begin)))
+                 (table-count-set! t (fx+ n 1)))
+               (handler x t a? 0)]
+              [else
+               (set-cdr! a #f)
+               (handler x t a? (fx+ d 1))])]
             [(not p)
              (record! vdup x)
              (let ([n (table-count t)])
@@ -148,20 +156,20 @@
   (reset-dump-graph))
 
 (define bld
-   (lambda (x t a?)
+   (lambda (x t a? d)
       (cond
-        [(pair? x) (bld-graph x t a? bld-pair)]
-        [(vector? x) (bld-graph x t a? bld-vector)]
-        [(or (symbol? x) (string? x)) (bld-graph x t a? bld-simple)]
+        [(pair? x) (bld-graph x t a? d #t bld-pair)]
+        [(vector? x) (bld-graph x t a? d #t bld-vector)]
+        [(or (symbol? x) (string? x)) (bld-graph x t a? d #t bld-simple)]
         [(and (annotation? x) (not a?))
-         (bld (annotation-stripped x) t a?)]
-        [(eq-hashtable? x) (bld-graph x t a? bld-ht)]
-        [(symbol-hashtable? x) (bld-graph x t a? bld-ht)]
-        [($record? x) (bld-graph x t a? bld-record)]
-        [(box? x) (bld-graph x t a? bld-box)]
+         (bld (annotation-stripped x) t a? d)]
+        [(eq-hashtable? x) (bld-graph x t a? d #t bld-ht)]
+        [(symbol-hashtable? x) (bld-graph x t a? d #t bld-ht)]
+        [($record? x) (bld-graph x t a? d #t bld-record)]
+        [(box? x) (bld-graph x t a? d #t bld-box)]
         [(or (large-integer? x) (ratnum? x) ($inexactnum? x) ($exactnum? x)
              (fxvector? x) (bytevector? x))
-         (bld-graph x t a? bld-simple)])))
+         (bld-graph x t a? d #t bld-simple)])))
 
 (module (small-integer? large-integer?)
   (define least-small-integer (- (expt 2 31)))
@@ -566,20 +574,53 @@
          [($rtd-counts? x) (wrf-immediate (constant sfalse) p)]
          [else ($oops 'fasl-write "invalid fasl object ~s" x)])))
 
-(define start
-  (lambda (p t proc)
-    (dump-graph)
-    (let-values ([(bv* size)
-                  (let-values ([(p extractor) ($open-bytevector-list-output-port)])
-                    (let ([n (table-count t)])
-                      (unless (fx= n 0)
-                        (put-u8 p (constant fasl-type-graph))
-                        (put-uptr p n)))
-                    (proc p)
-                    (extractor))])
-      (put-u8 p (constant fasl-type-fasl-size))
-      (put-uptr p size)
-      (for-each (lambda (bv) (put-bytevector p bv)) bv*))))
+(module (start)
+  (define start
+    (lambda (x p t proc)
+      (dump-graph)
+      (let-values ([(bv* size)
+                    (let-values ([(p extractor) ($open-bytevector-list-output-port)])
+                      (let ([n (table-count t)])
+                        (unless (fx= n 0)
+                          (put-u8 p (constant fasl-type-graph))
+                          (put-uptr p n)))
+                      (let ([begins (extract-begins t)])
+                        (unless (null? begins)
+                          (put-u8 p (constant fasl-type-begin))
+                          (put-uptr p (fx+ (length begins) 1))
+                          (for-each (lambda (x)
+                                      (if (eq? 'begin (cdr (eq-hashtable-ref (table-hash t) x #f)))
+                                          (proc x p)
+                                          (wrf x p t #t)))
+                                    begins)))
+                      (proc x p)
+                      (extractor))])
+        (put-u8 p (constant fasl-type-fasl-size))
+        (put-uptr p size)
+        (for-each (lambda (bv) (put-bytevector p bv)) bv*))))
+
+  (define (extract-begins t)
+    (let ([ht (table-hash t)])
+      (let-values ([(keys vals) (hashtable-entries ht)])
+        (let ([len (vector-length keys)])
+          (let loop ([i 0] [begins '()])
+            (cond
+             [(fx= i len)
+              ;; Sort so that higher graph numbers are earlier, which
+              ;; achieves the intended effect of limiting recursion.
+              (list-sort (lambda (a b)
+                           (> (car (eq-hashtable-ref ht a #f))
+                              (car (eq-hashtable-ref ht b #f))))
+                         begins)]
+             [else
+              (let ([v (vector-ref vals i)])
+                (cond
+                 [(not v) (loop (fx+ i 1) begins)]
+                 [(or (eq? 'begin (cdr v))
+                      (eq? 'inner-begin (cdr v)))
+                  (loop (fx+ i 1)
+                        (cons (vector-ref keys i) begins))]
+                 [else (loop (fx+ i 1) begins)]))])))))))
 
 (module (fasl-write fasl-file)
   ; when called from fasl-write or fasl-file, pass #t for a? to preserve annotations;
@@ -587,8 +628,8 @@
   (define fasl-one
     (lambda (x p)
       (let ([t (make-table)])
-         (bld x t #t)
-         (start p t (lambda (p) (wrf x p t #t))))))
+         (bld x t #t 0)
+         (start x p t (lambda (x p) (wrf x p t #t))))))
 
   (define-who fasl-write
     (lambda (x p)
@@ -623,8 +664,8 @@
   (lambda (x p)
     (emit-header p (constant machine-type-any))
     (let ([t (make-table)])
-      (bld-graph x t #f really-bld-record)
-      (start p t (lambda (p) (wrf-graph x p t #f really-wrf-record))))))
+      (bld-graph x t #f 0 #t really-bld-record)
+      (start x p t (lambda (x p) (wrf-graph x p t #f really-wrf-record))))))
 
 ($fasl-target (make-target bld-graph bld wrf start make-table wrf-graph fasl-base-rtd fasl-write fasl-file))
 )
@@ -635,10 +676,10 @@
       (let ([target ($fasl-target)])
         (assert target)
         target)))
-  (set! $fasl-bld-graph (lambda (x t a? handler) ((target-fasl-bld-graph (fasl-target)) x t a? handler)))
-  (set! $fasl-enter (lambda (x t a?) ((target-fasl-enter (fasl-target)) x t a?)))
+  (set! $fasl-bld-graph (lambda (x t a? d inner? handler) ((target-fasl-bld-graph (fasl-target)) x t a? d inner? handler)))
+  (set! $fasl-enter (lambda (x t a? d) ((target-fasl-enter (fasl-target)) x t a? d)))
   (set! $fasl-out (lambda (x p t a?) ((target-fasl-out (fasl-target)) x p t a?)))
-  (set! $fasl-start (lambda (p t proc) ((target-fasl-start (fasl-target)) p t proc)))
+  (set! $fasl-start (lambda (x p t proc) ((target-fasl-start (fasl-target)) x p t proc)))
   (set! $fasl-table (lambda () ((target-fasl-table (fasl-target)))))
   (set! $fasl-wrf-graph (lambda (x p t a? handler) ((target-fasl-wrf-graph (fasl-target)) x p t a? handler)))
   (set! $fasl-base-rtd (lambda (x p) ((target-fasl-base-rtd (fasl-target)) x p)))