implement closures

Makefile

@@ -94,7 +94,7 @@ sextest:
 	cp ./tools/sextest/sextest .
 
 SEX_TEST_PROGRAMS = hello-world lists comments unicode serialize features \
-                    feature-flags lambdas compound-literals
+                    feature-flags lambdas compound-literals closures fixpoint
 
 # Multi-module linking is checked end to end; see tests/modules/Makefile.
 check-modules: sexc

example/lambdas.sex

@@ -3,6 +3,12 @@
 (fn sum ((a int) (b int)) int
   (return (+ a b)))
 
+;;; A lambda captures nothing and is a bare function pointer; a closure
+;;; captures and is a value carrying its own environment
+(fn make-adder ((a int)) (closure ((int)) int)
+  (return (closure ((b int)) int (a)
+            (return (+ a b)))))
+
 (pub fn main () int
   (var a int 10)
   (var b int 20)
@@ -36,13 +42,7 @@
          (return (+ 600 (l-2 a)))))
   (printf "Calling nested lambdas: %d\n" (l-1 6))
 
-  ;; Not supported yet -- captures belong to `closure' now, see
+  (var add-10 (closure ((int)) int) (make-adder 10))
-  ;; Function-values.org
+  (var add-20 (closure ((int)) int) (make-adder 20))
-  ;;  (fn make-adder ((a int)) (closure ((int)) int)
+  (printf "Calling closures: %d %d\n" (add-10 24) (add-20 24))
-  ;;    (return (closure ((b int)) int (a)
-  ;;              (return (+ a b)))))
-  ;;
-  ;;  (var add-10 (closure ((int)) int) (make-adder 10))
-  ;;  (var add-20 (closure ((int)) int) (make-adder 20))
-  ;;  (printf "Calling closures: %d %d\n" (add-10 24) (add-20 24))
   (return 0))

semen.scm

@@ -17,6 +17,7 @@
   )
 
 (export/rename (process semen-process))
+(export closure-env-declaration)
 
 ;;; for lambda extraction, docstring processing, macro expansion,
 ;;; injection of module headers, i.e. all things that rearrange code
@@ -37,8 +38,18 @@
      (macroexpand (car forms) (cdr forms))
      acc))
    (else
-    (process-rec (cdr forms)
+    ;; A closure type's struct is emitted before the toplevel form that
-                 (match-sex-form (car forms) acc)))))
+    ;; first mentioned it, which is why the new forms are lifted off and
+    ;; the structs slide underneath them
+    (let* ((processed (match-sex-form (car forms) acc))
+           (new (take-until processed acc)))
+      (process-rec (cdr forms)
+                   (append new (flush-closure-structs!) acc))))))
+
+(define (take-until forms tail)
+  (if (eq? forms tail)
+      (list)
+      (cons (car forms) (take-until (cdr forms) tail))))
 
 (define (macroexpand macro-form rest-forms)
   ;; We want to replace macro with its expansion. The problem is,
@@ -225,7 +236,7 @@
                 (extract-fn-docstring (strip-fn-header-comments sex-fn-raw))))
     (let* ((expanded (macro-expand sex-fn))
            (env (make-hash-table))
-           (processed
+           (lifted
             (walk-form
              expanded
              fn-walker
@@ -233,25 +244,133 @@
                (set! (hash-table-ref env :fn-name) (sex-fn-name expanded))
                (set! (hash-table-ref env :lambda-counter) 0)
                (set! (hash-table-ref env :lambda-aux-code) (list))
-               env))))
+               (set! (hash-table-ref env :var-types)
+                 (declared-types (sex-fn-arglist expanded)))
+               env)))
+           (processed (rewrite-closure-calls-in-body lifted env)))
       (with-docstring doc processed
                       (append (hash-table-ref env :lambda-aux-code) acc)))))
 
+(define (declared-types arglist)
+  (let ((types (make-hash-table)))
+    (for-each (lambda (param)
+                (when (and (pair? param) (pair? (cdr param)))
+                  (hash-table-set! types (first param) (second param))))
+              arglist)
+    types))
+
+(define (aux-name! env make)
+  (let ((counter (hash-table-ref env :lambda-counter)))
+    (set! (hash-table-ref env :lambda-counter) (+ counter 1))
+    (make (hash-table-ref env :fn-name) counter)))
+
+(define (add-aux-code! env forms)
+  (set! (hash-table-ref env :lambda-aux-code)
+    (append forms (hash-table-ref env :lambda-aux-code))))
+
 (define (fn-walker form env)
-  (if (eq? 'lambda (car form))
+  (let ((head (car form)))
-      (let ((lambda-name (make-lambda-name (hash-table-ref env :fn-name)
+    (cond
-                                           (hash-table-ref env :lambda-counter))))
+     ((eq? 'lambda head)
-        (set! (hash-table-ref env :lambda-aux-code)
+      (let ((name (aux-name! env make-lambda-name)))
-          (append (lift-lambda lambda-name form)
+        (add-aux-code! env (lift-lambda name form))
-                  (hash-table-ref env :lambda-aux-code)))
+        name))
-        (set! (hash-table-ref env :lambda-counter)
+
-          (+ (hash-table-ref env :lambda-counter) 1))
+     ;; a type, not an expression -- becomes the struct for its signature
-        lambda-name)
+     ((closure-type? form)
-      form))
+      (copy-form-source! form `(struct ,(register-closure-type! form form))))
+
+     ((eq? 'closure head)
+      (let ((base (aux-name! env make-closure-name)))
+        (let-values (((construct forms) (lift-closure base form env)))
+          (add-aux-code! env (fold match-sex-form (list) forms))
+          (copy-form-source! form `(,construct ,@(fourth form))))))
+
+     ;; every binding site is written, so tracking the declarations is
+     ;; enough to know a receiver's type without inference
+     ((and (eq? 'var head) (>= (length form) 3))
+      (hash-table-set! (hash-table-ref env :var-types) (second form) (third form))
+      form)
+
+     (else form))))
+
+(define (rewrite-closure-calls-in-body fn-form env)
+  (let ((header (fn-header-length fn-form)))
+    (append (take fn-form header)
+            (map (lambda (form) (rewrite-closure-calls form env))
+                 (drop fn-form header)))))
+
+(define (rewrite-closure-calls form env)
+  (if (not (list? form))
+      form
+      (let ((type (and (pair? form) (receiver-closure-type (car form) env)))
+            (rewrite (lambda (sub) (rewrite-closure-calls sub env))))
+        (copy-form-source!
+         form
+         (if type
+             `(,(register-closure-call! type form)
+               ,(rewrite (car form))
+               ,@(map rewrite (cdr form)))
+             (map rewrite form))))))
+
+;;; A closure type has two spellings: `(closure ...)' as written, and
+;;; `(struct ƛ...)' once resolved -- which is what a struct
+;;; field holds, since the type database is populated after resolution.
+;;; Both name the same thing, so a receiver is recognised either way.
+(define (as-closure-type type)
+  (cond
+   ((closure-type? type) type)
+   ((and (list? type) (= 2 (length type)) (eq? 'struct (car type)))
+    (hash-table-ref/default +closure-structs+ (second type) #f))
+   (else #f)))
+
+(define (receiver-closure-type expr env)
+  (as-closure-type (expression-type expr env)))
+
+;;; The type of an lvalue path, from known declarations -- a name, and
+;;; what can be reached from one by subscripting, dereferencing and
+;;; member access.
+(define (expression-type expr env)
+  (cond
+   ((symbol? expr)
+    (hash-table-ref/default (hash-table-ref env :var-types) expr #f))
+   ((not (and (list? expr) (>= (length expr) 2))) #f)
+   (else
+    (case (car expr)
+      ((¤) (let ((base (expression-type (second expr) env)))
+             (and (list? base) (>= (length base) 2) (eq? '¤ (car base))
+                  (second base))))
+      ((*) (and (= 2 (length expr))
+                (let ((base (expression-type (second expr) env)))
+                  (and (list? base) (= 2 (length base)) (eq? '* (car base))
+                       (second base)))))
+      ((dot-access) (member-path-type (expression-type (second expr) env)
+                                      (cddr expr)))
+      ((->) (let ((base (expression-type (second expr) env)))
+              (and (list? base) (= 2 (length base)) (eq? '* (car base))
+                   (member-path-type (second base) (cddr expr)))))
+      (else #f)))))
+
+(define (member-path-type type fields)
+  (if (null? fields)
+      type
+      (member-path-type (field-type type (car fields)) (cdr fields))))
+
+(define (field-type type field)
+  (let ((name (cond ((symbol? type) type)
+                    ((and (list? type)
+                          (= 2 (length type))
+                          (memq (car type) '(struct union)))
+                     (second type))
+                    (else #f))))
+    (and name
+         (let* ((fields (get-fields name))
+                (entry (and fields (assq field fields))))
+           (and entry (second entry))))))
 
 (define (make-lambda-name enclosing-fn-name counter)
   (string->symbol
-   (fmt #f "__lambda_" counter "_" enclosing-fn-name)))
+   (fmt #f "λ" counter "_" enclosing-fn-name)))
 
 (define (lift-lambda name form)
   (match form
@@ -260,13 +379,255 @@
                  (list)))
     (else (sex-error form "malformed lambda" form))))
 
+;;; Closures
+;;;
+;;; A closure is a function pointer and an inline environment, so the
+;;; value owns its captures and nothing is allocated. The type
+;;; `(closure ((int)) int)' becomes one struct per signature, shared by
+;;; every closure with that signature. The captures live in `env' as a record
+;;; only the lifted body knows the shape of, which is why `env' is
+;;; max_align_t rather than char -- it has to be aligned for whatever
+;;; ends up in it.
+;;;
+;;; The expression becomes three hoisted definitions -- the capture
+;;; struct, the lifted body, and a constructor -- and is replaced by a
+;;; call to the constructor, so the captures are evaluated as ordinary
+;;; arguments at the point the closure is written.
+
+;;; How much of a closure is environment, in bytes. Counted in bytes
+;;; so a closure that fits where it was written will also fit
+;;; elsewhere. Captures are only by value, and never allocated on
+;;; heap. Anything that is more than 16 bytes should be stored as a
+;;; pointer, and memory management is entirely up to caller
+
+(define +closure-env-bytes+ 16)
+
+;;; +closure-env-bytes+ for maximum capacity, max-align-t for
+;;; effectiveness, hence union
+(define +closure-env-type+ 'ƛenv)
+
+(define (closure-env-declaration)
+  `(union ,+closure-env-type+ ((align max-align-t)
+                               (bytes (¤ char ,+closure-env-bytes+)))))
+
+(define +closure-structs+ (make-hash-table))
+(define +closure-forwards+ (make-hash-table))
+(define *pending-closure-structs* (list))
+
+(define (closure-type? form)
+  (and (pair? form)
+       (eq? 'closure (car form))
+       (= 3 (length form))))
+
+;;; A type spelling becomes an identifier deterministically, so two
+;;; translation units have the same signatures for the same closure
+;;; types: (* const char) -> p_const_char, (closure ((int)) int) ->
+;;; closure_int_int.
+(define (mangle-type type)
+  (cond
+   ((symbol? type) (mangle-word (symbol->string type)))
+   ((number? type) (number->string type))
+   ((null? type) "void")
+   ((pair? type) (string-intersperse (map mangle-type (mangle-head type)) "_"))
+   (else (sex-error type "cannot mangle type" type))))
+
+(define (mangle-head type)
+  (case (car type)
+    ((*) (cons 'p (cdr type)))
+    ((¤) (cons 'a (cdr type)))
+    (else type)))
+
+(define (mangle-word word)
+  (list->string
+   (map (lambda (c)
+          (if (or (char-alphabetic? c) (char-numeric? c)) c #\_))
+        (string->list word))))
+
+(define (aggregates-in type)
+  (cond
+   ((not (list? type)) (list))
+   ((and (= 2 (length type))
+         (memq (car type) '(struct union))
+         (symbol? (second type)))
+    (list type))
+   (else (append-map aggregates-in type))))
+
+;;; Extract aggregate types from the closure's signature to forward
+;;; declare them before the closure, so they can be referenced in the
+;;; closure. Particularly useful for complex cases like fixed point
+;;; combinator, etc.
+(define (forward-declare-aggregates! type src-form)
+  (for-each
+   (lambda (aggregate)
+     (let ((name (second aggregate)))
+       (unless (or (hash-table-exists? +closure-forwards+ name)
+                   (get-tag-info name))
+         (hash-table-set! +closure-forwards+ name #t)
+         (set! *pending-closure-structs*
+           (cons (copy-form-source! src-form aggregate)
+                 *pending-closure-structs*)))))
+   (delete-duplicates (aggregates-in type))))
+
+(define (closure-struct-name type)
+  ;; the glyph says `closure' already, so the tag is just the signature
+  (string->symbol (string-append "ƛ"
+                                 (mangle-type (second type))
+                                 "_"
+                                 (mangle-type (third type)))))
+
+;;; The code pointer takes the environment first; everything else is
+;;; the closure's own signature.
+(define (closure-code-type type)
+  `(fn (((* void)) ,@(second type)) ,(third type)))
+
+;;; Emitted once per signature, before the toplevel form that first
+;;; needed it.
+(define (register-closure-type! type src-form)
+  (let ((name (closure-struct-name type)))
+    (unless (hash-table-exists? +closure-structs+ name)
+      (forward-declare-aggregates! type src-form)
+      (hash-table-set! +closure-structs+ name type)
+      (let ((form (copy-form-source!
+                   src-form
+                   `(struct ,name ((code ,(closure-code-type type))
+                                   (env (union ,+closure-env-type+)))))))
+        (register-aggregate! form)
+        (set! *pending-closure-structs*
+          (cons form *pending-closure-structs*))))
+    name))
+
+;;; Every closure type in FORM becomes the struct for its signature,
+;;; registering it on the way. The walker does this for function bodies
+;;; and headers; globals come through here instead.
+(define (resolve-closure-types form)
+  (cond
+   ((closure-type? form)
+    (copy-form-source! form `(struct ,(register-closure-type! form form))))
+   ((list? form)
+    (copy-form-source! form (map resolve-closure-types form)))
+   (else form)))
+
+(define +closure-calls+ (make-hash-table))
+
+;;; The helper a closure call is routed through: `(f 1)' becomes
+;;; `ƛint_int_call(f, 1)', which unpacks the receiver into
+;;; `ƛc.code(&ƛc.env, ƛa0)' inside. The receiver arrives as an argument,
+;;; so it is evaluated once: unpacked at the call site instead,
+;;; `([table (++ i)] 10)' would read
+;;; `table[++i].code(&table[++i].env, 10)' and bump `i' twice.
+(define (register-closure-call! type src-form)
+  (let* ((closure (closure-struct-name type))
+         (helper  (suffixed closure "_call"))
+         (returns (third type))
+         (params  (map (lambda (arg index)
+                         (list (string->symbol (fmt #f "ƛa" index))
+                               (unwrap-type arg)))
+                       (second type)
+                       (iota (length (second type))))))
+    (unless (hash-table-ref/default +closure-calls+ helper #f)
+      (hash-table-set! +closure-calls+ helper #t)
+      (let ((call `((dot-access ƛc code)
+                    (& (dot-access ƛc env))
+                    ,@(map first params))))
+        (set! *pending-closure-structs*
+          (cons (copy-form-source!
+                 src-form
+                 `(fn ,helper ((ƛc (struct ,closure)) ,@params) ,returns
+                      ,(if (eq? 'void returns) call `(return ,call))))
+                *pending-closure-structs*))))
+    helper))
+
+;;; An argument type is written wrapped: `(int)' in `((int) (float))'
+(define (unwrap-type type)
+  (if (and (list? type) (= 1 (length type)))
+      (car type)
+      type))
+
+(define (flush-closure-structs!)
+  (let ((pending *pending-closure-structs*))
+    (set! *pending-closure-structs* (list))
+    pending))
+
+;;; Lowering
+
+(define (make-closure-name enclosing-fn-name counter)
+  (string->symbol (fmt #f "ƛ" counter "_" enclosing-fn-name)))
+
+(define (suffixed name suffix)
+  (string->symbol (string-append (symbol->string name) suffix)))
+
+;;; A capture is a plain name, whose type comes from the declarations
+;;; the walker has passed. `(name expr)' captures want the type of an
+;;; expression, which is inference, and wait for it.
+(define (capture-binding capture form env)
+  (unless (symbol? capture)
+    (sex-error form "a closure capture must be a plain name for now" capture))
+  (let ((type (hash-table-ref/default (hash-table-ref env :var-types) capture #f)))
+    (unless type
+      (sex-error form "closure captures an undeclared name" capture))
+    (list capture type)))
+
+(define (lift-closure base form env)
+  (match form
+    (('closure arglist ret-type captures . body)
+     (let* ((caps      (map (lambda (c) (capture-binding c form env)) captures))
+            (record    (suffixed base "_captures"))
+            (code      (suffixed base "_code"))
+            (construct (suffixed base "_make"))
+            (type      `(closure ,(map (lambda (p) (list (second p))) arglist)
+                                 ,ret-type))
+            (closure   (register-closure-type! type form)))
+       (values
+        construct
+        (map (lambda (f) (copy-form-source! form f))
+             ;; C has no empty struct, and a closure over nothing needs
+             ;; no record to point at
+             (append
+              (if (null? caps)
+                  (list)
+                  (list `(struct ,record ,caps)))
+
+              (list
+               `(fn ,code ((ƛe (* void)) ,@arglist) ,ret-type
+                    ,@(if (null? caps)
+                          (list)
+                          `((var ƛcaptures (* (struct ,record)) ƛe)
+                            ,@(map (lambda (cap)
+                                     `(var ,(first cap) ,(second cap)
+                                           (-> ƛcaptures ,(first cap))))
+                                   caps)))
+                    ,@body)
+
+               `(fn ,construct ,caps (struct ,closure)
+                    (var ƛc (struct ,closure))
+                    ,@(if (null? caps)
+                          (list)
+                          `((static-assert
+                             (<= (sizeof (struct ,record))
+                                 (sizeof (dot-access ƛc env)))
+                             "closure captures do not fit the inline environment")))
+                    (= (dot-access ƛc code) ,code)
+                    ,@(if (null? caps)
+                          (list)
+                          `((var ƛcaptures (* (struct ,record))
+                                 (cast (& (dot-access ƛc env)) (* (struct ,record))))
+                            ,@(map (lambda (cap)
+                                     `(= (-> ƛcaptures ,(first cap)) ,(first cap)))
+                                   caps)))
+                    (return ƛc))))))))
+    (else (sex-error form "malformed closure" form))))
+
 ;;; Structs
 
 ;;; Record the named structs, unions and enums in the type database
 (define (process-struct sex-struct acc)
   (let-values (((doc form) (extract-aggregate-docstring sex-struct)))
-    (register-aggregate! form)
+    ;; Resolve before registering: a field of closure type has to reach
-    (with-docstring doc form acc)))
+    ;; the type database as the struct it becomes, or member access
+    ;; through it finds nothing
+    (let ((form (resolve-closure-types form)))
+      (register-aggregate! form)
+      (with-docstring doc form acc))))
 
 (define (register-aggregate! form)
   (let* ((f (if (eq? (car form) 'pub) (cdr form) form))
@@ -280,7 +641,9 @@
         ((enum) (add-enum name form))))))
 
 (define (process-global-var sex-var acc)
-  (cons sex-var acc))
+  ;; A global is not walked for lambdas, but its type still has to stop
+  ;; saying `closure' before the writer sees it
+  (cons (resolve-closure-types sex-var) acc))
 
 ;;; Utils
 (define (non-empty-list? form)

sexc.scm

@@ -175,17 +175,22 @@ status, which is ours to pass on."
                       (semen-process raw-forms))))
 
 (define prelude
-  '((include inttypes.h)
+  (append
-    (include stdbool.h)
+   '((include inttypes.h)
+     (include stdbool.h)
+     (include stddef.h)        ; max_align_t, for closure environments
+     (typedef u8 uint8-t)
+     (typedef i8 int8-t)
+     (typedef u16 uint16-t)
+     (typedef i16 int16-t)
+     (typedef u32 uint32-t)
+     (typedef i32 int32-t)
+     (typedef u64 uint64-t)
+     (typedef i64 int64-t))
 
-    (typedef u8 uint8-t)
+   ;; The closure environment is the part of the ABI, so include it in
-    (typedef i8 int8-t)
+   ;; every module
-    (typedef u16 uint16-t)
+   (list (closure-env-declaration))))
-    (typedef i16 int16-t)
-    (typedef u32 uint32-t)
-    (typedef i32 int32-t)
-    (typedef u64 uint64-t)
-    (typedef i64 int64-t)))
 
 (define (main)
   (let* ((argv (command-line-arguments))

tests/codegen.scm

@@ -270,4 +270,59 @@ compiles."
               "_Static_assert(sizeof(int) == 4, \"int is four bytes\")"))
     (test-assert "and not the header macro"
       (not (emits? (in-fn "(static-assert (== (sizeof int) 4) \"x\")")
-                   "static_assert(")))))
+                   "static_assert("))))
+
+  ;; A closure is a code pointer beside its captures. The struct is
+  ;; named from the signature, so separate translation units agree on
+  ;; it, and calling one goes through `code' with `env' passed first.
+  ;;
+  ;; A closure struct, and the helper its calls go through, are each
+  ;; emitted once per signature; the registries deciding that are
+  ;; compile-time state like the type databases, and outlive a single
+  ;; `sex->c' here. So every case below that looks for a *definition*
+  ;; uses a signature of its own -- cases looking at a call site can
+  ;; share one.
+  (test-group "closures"
+    (test-assert "the type becomes a struct named for its signature"
+      (emits? "(fn f ((c (closure ((int)) int))) int (return (c 1)))"
+              "struct ƛint_int"))
+    ;; The environment is one shared union, declared in the prelude --
+    ;; its layout is part of the ABI two units agree on, so it cannot
+    ;; depend on what either file contains. `sex->c' has no prelude, so
+    ;; what is visible here is the member
+    (test-assert "whose environment is the shared union"
+      (emits? "(fn f ((c (closure ((float)) int))) int (return (c 1.0)))"
+              "union ƛenv env;"))
+    ;; The receiver goes through a helper rather than being written
+    ;; out twice, so that `[table (++ i)]' evaluates its index once,
+    ;; exactly as it would for an array of function pointers
+    (test-assert "a call passes the receiver to a helper"
+      (emits? "(fn f ((c (closure ((int)) int))) int (return (c 1)))"
+              "ƛint_int_call(c, 1)"))
+    (test-assert "and the helper is what dereferences it"
+      (emits? "(fn f ((c (closure ((long)) int))) int (return (c 1)))"
+              "ƛc.code(&ƛc.env, ƛa0)"))
+    (test-assert "a subscript receiver is evaluated once"
+      (emits? "(fn f ((t (¤ (closure ((int)) int) 4)) (i int)) int (return ((¤ t (++ i)) 1)))"
+              "ƛint_int_call(t[++i], 1)"))
+    (test-assert "so is a member receiver"
+      (emits? "(struct h ((cb (closure ((int)) int))))
+               (fn f ((s (struct h))) int (return ((. s cb) 1)))"
+              "ƛint_int_call(s.cb, 1)"))
+    (test-assert "a captured name is rebound in the lifted body"
+      (emits? "(fn f ((n int)) (closure ((char)) int) (return (closure ((x char)) int (n) (return n))))"
+              "int n = ƛcaptures->n;"))
+    (test-assert "captures are checked against the environment"
+      (emits? "(fn f ((n int)) (closure ((short)) int) (return (closure ((x short)) int (n) (return n))))"
+              "_Static_assert(sizeof(struct"))
+    ;; A closure over nothing has no record to point at, and C has no
+    ;; empty struct to declare for it
+    (test-assert "no captures means no capture record"
+      (not (emits? "(fn f () (closure () int) (return (closure () int () (return 7))))"
+                   "_captures {")))
+    ;; The receiver is written twice, so a name used as an argument
+    ;; must not be mistaken for a call of its own
+    (test-assert "a closure passed as an argument stays a value"
+      (emits? "(fn g ((c (closure ((int)) int))) int (return 0))
+               (fn f ((c (closure ((int)) int))) int (return (g c)))"
+              "g(c)"))))

tests/modules/Makefile

@@ -10,14 +10,17 @@
 #
 # It also checks what only a second translation unit can check: that an
 # imported type reaches the type database, by expanding a macro that
-# reads the imported struct's fields.
+# reads the imported struct's fields; and that a closure type crossing
+# the boundary works both ways -- one built in the module and called
+# here, one built here and called there, through a code pointer that is
+# static in the other object.
 #
 # The public forms carry comments in their headers, which the reduction
 # to a prototype and to an extern both have to look past.
 
 SEXC ?= ../../sexc
 
-EXPECTED = hello, world\nhello, sex\n2 greetings\ntext times \ntext times \nmood 1
+EXPECTED = hello, world\nhello, sex\n2 greetings\ntext times \ntext times \nmood 1\nclosure 15 21 201
 
 check:
 	@$(SEXC) greet.sex -c -o greet.o

tests/modules/greet-app.sex

@@ -26,4 +26,11 @@
   (printf "\n")
   (var m (enum mood) grumpy)
   (printf "mood %d\n" m)
+
+  (var add-10 (closure ((int)) int) (make-adder 10))
+  (printf "closure %d %d" (add-10 5) (apply-twice add-10 1))
+  (var base int 100)
+  (var here (closure ((int)) int)
+       (closure ((x int)) int (base) (return (+ base x))))
+  (printf " %d\n" (apply-twice here 1))
   (return 0))

tests/modules/greet.sex

@@ -35,6 +35,19 @@
   (++ greet-count)
   (printf "hello, %s\n" name))
 
+;;; A closure type crossing the boundary. Both units generate the
+;;; struct for this signature independently, so they have to agree on
+;;; its tag and its layout, or the value is passed wrong and nothing
+;;; says so.
+(pub fn make-adder ((n int)) (closure ((int)) int)
+  (return (closure ((b int)) int (n)
+            (return (+ n b)))))
+
+;;; The other direction: a closure built by the importer, whose code
+;;; pointer is static in *its* object, called from here
+(pub fn apply-twice ((f (closure ((int)) int)) (x int)) int
+  (return (f (f x))))
+
 ;;; Not `pub': invisible to importers, and static in the generated C.
 (fn unused-helper () void
   (printf "private\n"))

tests/sex-programs/closures.sex

@@ -0,0 +1,80 @@
+(input)
+(output "Adders: 15 25"
+        "Two captures: 47"
+        "No captures: 7"
+        "Through a parameter: 110"
+        "From an array: 1 2 3"
+        "Index evaluated once: 21 i 1"
+        "Through a struct member: 8"
+        "Nested: 33")
+(return 0)
+
+;;; A closure is a code pointer beside its captures, so what this
+;;; checks is that the captures survive the lifting -- that two
+;;; closures of one shape keep their own environments, that a closure
+;;; outlives the call that built it, and that calling one through a
+;;; parameter, an array element or a struct member resolves the same
+;;; way as through a local.
+;;;
+;;; A receiver is also an ordinary expression: `[table (++ i)]' has to
+;;; evaluate its index exactly once, the way it would for an array of
+;;; function pointers.
+
+(include stdio.h)
+
+(fn make-adder ((n int)) (closure ((int)) int)
+  (return (closure ((b int)) int (n)
+            (return (+ n b)))))
+
+(fn make-affine ((k int) (b int)) (closure ((int)) int)
+  (return (closure ((x int)) int (k b)
+            (return (+ (* k x) b)))))
+
+(fn make-const-7 () (closure () int)
+  (return (closure () int ()
+            (return 7))))
+
+;;; A closure arriving as a parameter: its type is written, so the call
+;;; resolves without knowing where it came from
+(fn apply-twice ((f (closure ((int)) int)) (x int)) int
+  (return (f (f x))))
+
+(struct handlers ((on-tick (closure ((int)) int))))
+
+(pub fn main () int
+  (var add-10 (closure ((int)) int) (make-adder 10))
+  (var add-20 (closure ((int)) int) (make-adder 20))
+  (printf "Adders: %d %d\n" (add-10 5) (add-20 5))
+
+  (var affine (closure ((int)) int) (make-affine 5 2))
+  (printf "Two captures: %d\n" (affine 9))
+
+  (var seven (closure () int) (make-const-7))
+  (printf "No captures: %d\n" (seven))
+
+  (printf "Through a parameter: %d\n" (apply-twice (make-adder 50) 10))
+
+  (var table (¤ (closure ((int)) int) 3))
+  (var i int 0)
+  (for (= i 0) (< i 3) (++ i)
+       (= (¤ table i) (make-adder i)))
+  (printf "From an array: %d %d %d\n"
+          ((¤ table 0) 1) ((¤ table 1) 1) ((¤ table 2) 1))
+
+  ;; the index must be evaluated once, so `i' ends at 1 and not 2 --
+  ;; read in a separate statement, since reading and bumping it in one
+  ;; printf would be unsequenced whatever the closure did
+  (= i 0)
+  (var once int ([table (++ i)] 20))
+  (printf "Index evaluated once: %d i %d\n" once i)
+
+  (var h (struct handlers) #((struct handlers) : .on-tick (make-adder 5)))
+  (printf "Through a struct member: %d\n" ((. h on-tick) 3))
+
+  ;; a closure built inside a closure, capturing that one's capture
+  (var outer (closure ((int)) int)
+       (closure ((x int)) int ()
+         (var inner (closure ((int)) int) (make-adder x))
+         (return (inner 3))))
+  (printf "Nested: %d\n" (outer 30))
+  (return 0))

tests/sex-programs/fixpoint.sex

@@ -0,0 +1,55 @@
+(input)
+(output "direct: 120"
+        "fac: 120 3628800"
+        "fib: 55 6765")
+(return 0)
+
+;;; A fixed point built out of closures, which is the hardest thing to
+;;; ask of them: recursion with no recursive function anywhere, only
+;;; self-application.
+;;;
+;;; Self-application needs `x x' and so a recursive type, which is
+;;; spelled here by routing it through a named struct whose field is a
+;;; closure whose own signature mentions that struct. The generated
+;;; closure struct is written before `struct rec' is, so this only
+;;; compiles because a forward declaration is emitted ahead of both.
+;;;
+;;; Note what `fix' captures: a *pointer* to the knot, not the knot. A
+;;; closure is a code pointer beside N bytes of environment, so
+;;; capturing one by value would need N >= 8 + N. No budget makes that
+;;; true, and the static assertion says so rather than letting it
+;;; corrupt anything.
+
+(include stdio.h)
+
+(struct rec ((f (closure (((* (struct rec))) (int)) int))))
+
+;;; Takes a step that expects itself, returns an ordinary closure with
+;;; the self-application hidden inside
+(fn fix ((step (* (struct rec)))) (closure ((int)) int)
+  (return (closure ((n int)) int (step)
+            (return ((-> step f) step n)))))
+
+(pub fn main () int
+  (var fac-knot (struct rec))
+  (= (. fac-knot f)
+     (closure ((self (* (struct rec))) (n int)) int ()
+       (if (<= n 1) (return 1))
+       (return (* n ((-> self f) self (- n 1))))))
+
+  ;; the knot applied to itself directly, without fix
+  (printf "direct: %d\n" ((. fac-knot f) (& fac-knot) 5))
+
+  (var fib-knot (struct rec))
+  (= (. fib-knot f)
+     (closure ((self (* (struct rec))) (n int)) int ()
+       (if (< n 2) (return n))
+       (return (+ ((-> self f) self (- n 1))
+                  ((-> self f) self (- n 2))))))
+
+  ;; one combinator, two different recursions
+  (var fac (closure ((int)) int) (fix (& fac-knot)))
+  (var fib (closure ((int)) int) (fix (& fib-knot)))
+  (printf "fac: %d %d\n" (fac 5) (fac 10))
+  (printf "fib: %d %d\n" (fib 10) (fib 20))
+  (return 0))