pkulev/sex
1
0
Fork 0
forked from alex-eg/sex
Code Pull Requests Activity

implement type inference

Browse Source 
Two things out of one mechanism. `_' as a type means "work it out from
the initializer", so (var n _ (strlen s)) stops needing size-t spelled
out; `type-of' hands a macro the type of an expression, so a macro can
dispatch on what it was handed rather than on what was declared. Both
read the same answers from two sides.

Algorithm W's core, intra-procedural, with the extensions C forces:

  - an unknown type, since (include stdio.h) brings in names we never
    parsed. Unification is consistency rather than equality, so
    anything touching an unparsed declaration stops constraining
    instead of rejecting a program that compiled yesterday;
  - the usual arithmetic conversions, since `+' is not a function of
    one type;
  - checking mode for initializers, since #(0 0) has no type of its own
    and takes one from its context. #(T : ...) is the way out of that.

What it wanted on the way:

  - what type a *name* has, which neither the typedef nor the tag
    database recorded. One table serves functions and variables, since
    a function type already has a surface spelling;
  - a scope chain, so a (var c int 9) inside a do ends with the block;
  - form-type, keyed by cons cell, so one form has one type;
  - macros expanded during the walk rather than before it, so type-of
    is answered in the scope the macro was written in.

Closures take the same machinery: a receiver whose type comes from a
call, captures written (name expr) and typed from the expression, and
conversion from a bare function wherever a closure is expected.

type-match grew `_' on the pattern side, since (closure ((int)) int)
and (closure ((float)) int) were separate clauses for one case.
This commit is contained in:
alex-eg
2026-09-29 23:52:08 +03:00
parent 53f92727a5
commit 1f445f0f9b
15 changed files with 1126 additions and 100 deletions
Download Patch File Download Diff File Expand all files Collapse all files

534
semen.scm
View File

@@ -7,6 +7,7 @@
(chicken string)
(chicken module)
fmt
infer
sex-macros
sex-modules
types
@@ -38,9 +39,9 @@
(macroexpand (car forms) (cdr forms))
acc))
(else
;; A closure type's struct is emitted before the toplevel form that
;; first mentioned it, which is why the new forms are lifted off and
;; the structs slide underneath them
;; `struct ƛint_int' has to be declared before the function whose
;; signature first mentioned it, so the forms that function produced
;; are lifted off and the structs slid underneath them
(let* ((processed (match-sex-form (car forms) acc))
(new (take-until processed acc)))
(process-rec (cdr forms)
@@ -241,30 +242,45 @@
(define (process-fn sex-fn-raw acc)
(let-values (((doc sex-fn)
(extract-fn-docstring (strip-fn-header-comments sex-fn-raw))))
(let* ((expanded (macro-expand sex-fn))
(env (make-hash-table))
(lifted
(walk-form
expanded
fn-walker
(begin
(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))
(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)))))
(let* ((boundary (fn-header-length sex-fn))
;; only the header is expanded up front. A macro in the body
;; is expanded during the walk, where `(type-of x)' can still
;; be answered from the scope it was written in
(expanded (append (macro-expand (take sex-fn boundary))
(drop sex-fn boundary))))
(add-name-type! (sex-fn-name expanded) (fn-type-of expanded))
(let* ((env (make-fn-env expanded))
;; the parameters are the body's outermost scope
(header (map resolve-closure-types (take expanded boundary)))
(body (walk-body (drop expanded boundary) env))
(processed (append header body)))
(with-docstring doc processed
(append (hash-table-ref env :lambda-aux-code) acc))))))
(define (declared-types arglist)
(let ((types (make-hash-table)))
(define (make-fn-env fn-form)
(let ((env (make-hash-table))
(parameters (make-hash-table)))
(for-each (lambda (param)
(when (and (pair? param) (pair? (cdr param)))
(hash-table-set! types (first param) (second param))))
arglist)
types))
(hash-table-set! parameters (first param) (second param))))
(sex-fn-arglist fn-form))
(set! (hash-table-ref env :fn-name) (sex-fn-name fn-form))
(set! (hash-table-ref env :lambda-counter) 0)
(set! (hash-table-ref env :lambda-aux-code) (list))
(set! (hash-table-ref env :returns) (sex-fn-return-type fn-form))
(set! (hash-table-ref env :scopes) (list parameters))
env))
;;; (fn sum ((a int) (b int)) int ...) -> (fn ((int) (int)) int).
;;; Anything that is not a plain (name type) -- a variadic tail -- goes
;;; through untouched.
(define (fn-type-of fn-form)
`(fn ,(map (lambda (param)
(if (and (pair? param) (= 2 (length param)))
(list (second param))
param))
(sex-fn-arglist fn-form))
,(sex-fn-return-type fn-form)))
(define (aux-name! env make)
(let ((counter (hash-table-ref env :lambda-counter)))
@@ -275,55 +291,220 @@
(set! (hash-table-ref env :lambda-aux-code)
(append forms (hash-table-ref env :lambda-aux-code))))
(define (fn-walker form env)
(let ((head (car form)))
(cond
((eq? 'lambda head)
(let ((name (aux-name! env make-lambda-name)))
(add-aux-code! env (lift-lambda name form))
name))
;; a type, not an expression -- becomes the struct for its signature
((closure-type? form)
(copy-form-source! form `(struct ,(register-closure-type! form form))))
;;; The scope chain
;;;
;;; `(do (var c int 9) ...)' declares a `c' that ends with the block, so
;;; a closure-typed `c' outside it is still a closure after it. `do' and
;;; `for' each open a frame; innermost first.
((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))))))
(define (declare-name! env name type)
(hash-table-set! (car (hash-table-ref env :scopes)) name type))
;; 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)
(define (lookup-name env name)
(let search ((scopes (hash-table-ref env :scopes)))
(and (pair? scopes)
(or (hash-table-ref/default (car scopes) name #f)
(search (cdr scopes))))))
(else form))))
(define (with-scope env body)
(let ((enclosing (hash-table-ref env :scopes)))
(set! (hash-table-ref env :scopes) (cons (make-hash-table) enclosing))
(let ((walked (body)))
(set! (hash-table-ref env :scopes) enclosing)
walked)))
(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)))))
;;; The body walk
;;;
;;; One pass in statement order: lifts lambdas and closures out,
;;; resolves closure types to the struct that stands for them, records
;;; what each declaration binds, and rewrites a call whose head is a
;;; closure.
;;;
;;; Not `walk-form': it has no event for leaving a scope, and it hands
;;; the walk function every cdr-tail as well, so the `f' in `(g f)'
;;; arrives as `(f)' and reads as a call of its own.
(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))))
(define (walk-body forms env)
(append-map (lambda (form)
(let ((walked (walk-statement form env)))
(if (and (pair? walked) (eq? (car walked) walk-embed-result))
(cdr walked)
(list walked))))
forms))
(define (walk-statement form env)
(cond
((not (list? form)) form)
((null? form) form)
;; expanded here rather than before the walk, so the macro body can
;; ask `(type-of x)' about a local the walk has already passed
((macro? form)
(let ((expansion (parameterize
((current-type-of
(lambda (queried)
(unresolve-closure-types
(expression-type queried env)))))
(macroexpand form (list)))))
(if (and (pair? expansion) (null? (cdr expansion)))
(walk-statement (car expansion) env)
(cons walk-embed-result (walk-body expansion env)))))
(else
(case (car form)
((do for) (with-scope env (lambda () (walk-parts form env))))
((lambda)
(let ((name (aux-name! env make-lambda-name)))
(add-aux-code! env (lift-lambda name form))
name))
((closure)
(if (closure-type? form)
;; a type, not an expression: the struct for its signature
(copy-form-source! form `(struct ,(register-closure-type! form form)))
(let ((base (aux-name! env make-closure-name)))
(let-values (((construct lifted) (lift-closure base form env)))
(add-aux-code! env (fold match-sex-form (list) lifted))
(copy-form-source!
form
`(,construct ,@(map (lambda (capture)
(walk-statement (capture-argument capture)
env))
(fourth form))))))))
((var)
;; the initializer is walked before the name it binds is in scope
(let* ((walked (resolve-wildcard (walk-parts form env) env))
(bound (if (>= (length walked) 4)
(copy-form-source!
walked
(append (take walked 3)
(cons (convert-to-closure (third walked)
(fourth walked)
env walked)
(drop walked 4))))
walked)))
(when (>= (length bound) 3)
(declare-name! env (second bound) (third bound)))
bound))
((return)
(let ((walked (walk-parts form env)))
(if (>= (length walked) 2)
(copy-form-source!
walked
(cons 'return
(cons (convert-to-closure (hash-table-ref env :returns)
(second walked) env walked)
(cddr walked))))
walked)))
(else
(let ((closure (receiver-closure-type (car form) env)))
(if closure
(copy-form-source!
form
`(,(register-closure-call! closure form)
,(walk-statement (car form) env)
,@(map (lambda (argument) (walk-statement argument env))
(cdr form))))
(convert-arguments (walk-parts form env) env))))))))
;;; `(var n _ (strlen s))' becomes `(var n size-t (strlen s))'.
(define (resolve-wildcard form env)
(if (and (>= (length form) 3) (wildcard-type? (third form)))
(let ((declared (parse-type (third form))))
(solve-wildcards! declared
(and (>= (length form) 4) (fourth form))
form env)
(let ((written (unparse-type declared)))
(cond
;; `?' is what a name from an unparsed header types as, and
;; the writer has no spelling for it
((mentions? written '?)
(sex-error form "type of this is unknown; write it out"
(second form)))
((mentions? written '_)
(sex-error form "cannot infer the type of" (second form)))
(else
(copy-form-source! form
(cons (first form)
(cons (second form)
(cons written (cdddr form)))))))))
form))
;;; `(* _)' against `(* (struct point))' solves only the wildcard inside
;;; the pointer; a bare `_' is the same with nothing around it.
;;;
;;; `#(0 1 4 9)' has no type of its own, so it cannot answer a bare `_',
;;; but its elements still solve the hole in `(¤ _ 4)' -- each one is
;;; unified with the element type, which is what makes `(¤ _ 4)' worth
;;; writing at all.
(define (solve-wildcards! declared initializer form env)
(cond
((not initializer)
(sex-error form "cannot infer the type of" (second form)))
((brace-initializer? initializer)
(let ((element (and (array-type? declared) (array-elt declared))))
(unless element
(sex-error form "cannot infer the type of" (second form)))
(for-each (lambda (written)
(let ((type (expression-type written env)))
(when type
(unify element
(parse-type (resolve-closure-types type))
form))))
(vector->list initializer))))
(else
(let ((type (expression-type initializer env)))
(unless type
(sex-error form "cannot infer the type of" (second form)))
;; `(closure ((int)) int)' is spelled `(struct ƛint_int)'
;; everywhere past this point, and is what `parse-type' knows
(unify declared (parse-type (resolve-closure-types type)) form)))))
;;; `#(0 1 4 9)', as against the compound literal `#(T : ...)'
(define (brace-initializer? form)
(and (vector? form)
(null? (cdr (list-split (vector->list form) ':)))))
(define (wildcard-type? type) (mentions? type '_))
(define (mentions? type word)
(cond ((eq? type word) #t)
((list? type) (any (lambda (part) (mentions? part word)) type))
(else #f)))
;;; `(each xs compare)' where `each' takes a closure: the argument is
;;; checked against the parameter that signature wrote.
(define (convert-arguments form env)
(let ((signature (and (symbol? (car form)) (get-name-type (car form)))))
(if (and (list? signature) (= 3 (length signature)) (eq? 'fn (car signature)))
(copy-form-source!
form
(if type
`(,(register-closure-call! type form)
,(rewrite (car form))
,@(map rewrite (cdr form)))
(map rewrite form))))))
(cons (car form)
(map (lambda (argument expected)
(if expected
(convert-to-closure expected argument env form)
argument))
(cdr form)
(parameter-types signature (length (cdr form))))))
form)))
;;; One per argument, #f past the end of the parameter list -- a
;;; variadic tail has nothing written to check against
(define (parameter-types signature count)
(let pair ((params (second signature)) (remaining count) (acc (list)))
(cond
((zero? remaining) (reverse acc))
((null? params) (pair params (- remaining 1) (cons #f acc)))
(else (pair (cdr params) (- remaining 1)
(cons (unwrap-type (car params)) acc))))))
(define (walk-parts form env)
(copy-form-source! form (walk-body form env)))
;;; 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)
@@ -337,26 +518,111 @@
;;; The type of an lvalue path, from known declarations -- a name, and
;;; what can be reached from one by subscripting, dereferencing and
;;; member access.
;;; The type of an expression as a surface type, or #f when nothing
;;; here can say. Every form it visits is recorded in `form-type', so
;;; asking once types the whole subtree.
;;;
;;; 42 -> int (. p x) -> that field's type
;;; "hi" -> (* const char) (& p) -> (* (struct point))
;;; (area 3 4) -> what `area' returns
(define (expression-type expr env)
(set-form-type! expr (compute-expression-type expr env)))
(define (compute-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)
((and (number? expr) (exact? expr)) 'int)
((number? expr) 'double)
((string? expr) '(* const char))
((char? expr) 'char)
((memq expr '(true false)) 'bool)
;; `#(T : ...)' carries its own type; a bare `#(...)' has none and
;; takes one from whatever it is being written into
((vector? expr)
(let ((parts (list-split (vector->list expr) ':)))
(and (pair? (cdr parts))
(let ((written (car parts)))
(if (= 1 (length written)) (car written) written)))))
((symbol? expr) (or (lookup-name env expr) (get-name-type expr)))
((not (and (list? expr) (pair? expr))) #f)
;; a call of no arguments is still a call
((< (length expr) 2)
(and (symbol? (car expr)) (get-return-type (car expr))))
(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)))))
((&) (and (= 2 (length expr))
(let ((target (expression-type (second expr) env)))
(and target `(* ,target)))))
;; unary `*' is a dereference; with two operands it is a product
((*) (if (= 2 (length expr))
(pointer-target (expression-type (second expr) env))
(arithmetic-type expr env)))
((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)))))
((->) (member-path-type (pointer-target (expression-type (second expr) env))
(cddr expr)))
((cast) (and (= 3 (length expr)) (third expr)))
((sizeof) 'size-t)
((== != < > <= >= c-and c-or !) 'bool)
((+ - / %) (arithmetic-type expr env))
;; otherwise a call: a closure answers with its own return type,
;; anything else with what its signature says
(else
(let ((closure (receiver-closure-type (car expr) env)))
(if closure
(third closure)
(and (symbol? (car expr)) (get-return-type (car expr))))))))))
;;; C's usual arithmetic conversions, far enough to answer `_':
;;;
;;; (+ i d) i int, d double -> double
;;; (+ i l) l long -> long
;;; (+ g d) g float -> double
;;; (+ (& p) 1) -> (* (struct point))
;;;
;;; `unsigned int' against `int' answers `int', where C says otherwise.
(define (arithmetic-type expr env)
(fold (lambda (operand joined)
(arith-join joined (expression-type operand env)))
#f
(cdr expr)))
(define (arith-join left right)
(cond
((not left) right)
((not right) left)
((equal? left right) left)
(else
(let ((l (underlying (parse-type left)))
(r (underlying (parse-type right))))
(cond
((or (ptr-type? l) (array-type? l)) left)
((or (ptr-type? r) (array-type? r)) right)
((< (conversion-rank l) (conversion-rank r)) right)
(else left))))))
;;; `char' and `short' promote to `int', so the ranks start there
(define (conversion-rank type)
(let ((words (and (prim-type? type) (prim-name type))))
(cond
((not words) 1)
((memq 'double words) (if (memq 'long words) 7 6))
((memq 'float words) 5)
((memq 'long words) (if (= 2 (count (lambda (w) (eq? w 'long)) words)) 4 3))
(else 1))))
;;; `(* const char)' is flat: everything after the `*' is the target.
;;; `(& x)' builds the nested `(* (struct point))' and `unparse-type'
;;; writes the flat `(* struct point)', so both spellings turn up.
(define (pointer-target type)
(and (list? type)
(>= (length type) 2)
(eq? '* (car type))
(unwrap-type (cdr type))))
(define (member-path-type type fields)
(if (null? fields)
@@ -421,6 +687,12 @@
(define +closure-forwards+ (make-hash-table))
(define *pending-closure-structs* (list))
(define (closure-expression? form)
(and (list? form)
(pair? form)
(eq? 'closure (car form))
(>= (length form) 4)))
(define (closure-type? form)
(and (pair? form)
(eq? 'closure (car form))
@@ -506,14 +778,90 @@
;;; 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.
;;; The inverse of `resolve-closure-types', for what a macro is shown:
;;; `(struct ƛint_int)' is a generated name, and `(closure ((int)) int)'
;;; is what was written and what a `type-match' pattern says.
(define (unresolve-closure-types type)
(or (as-closure-type type)
(if (list? type)
(map unresolve-closure-types type)
type)))
(define (resolve-closure-types form)
(cond
;; `(closure args ret captures . body)' is an expression, and one is
;; lifted into the function it was written in. At toplevel, or in a
;; struct field, there is none
((closure-expression? form)
(sex-error form "a closure can only be written inside a function" form))
((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-conversions+ (make-hash-table))
;;; `(var c (closure ((int)) int) sum)' becomes `ƛint_int_fromfn(sum)'.
;;; The function pointer goes in the environment and a thunk reads it
;;; back out, so one thunk serves every function of that signature:
;;;
;;; struct ƛint_int_fnptr { int (*f)(int); };
;;; static int ƛint_int_fnthunk (void *ƛe, int ƛa0) {
;;; struct ƛint_int_fnptr *ƛcaptures = ƛe;
;;; return ƛcaptures->f(ƛa0);
;;; }
(define (register-fn-conversion! type src-form)
(let* ((closure (closure-struct-name type))
(convert (suffixed closure "_fromfn"))
(record (suffixed closure "_fnptr"))
(thunk (suffixed closure "_fnthunk"))
(returns (third type))
(pointer `(fn ,(second type) ,returns))
(params (map (lambda (argument index)
(list (string->symbol (fmt #f "ƛa" index))
(unwrap-type argument)))
(second type)
(iota (length (second type))))))
(unless (hash-table-exists? +closure-conversions+ convert)
(hash-table-set! +closure-conversions+ convert #t)
(let ((call `((-> ƛcaptures f) ,@(map first params))))
(for-each
(lambda (emitted)
(set! *pending-closure-structs*
(cons (copy-form-source! src-form emitted)
*pending-closure-structs*)))
(list
`(struct ,record ((f ,pointer)))
`(fn ,thunk ((ƛe (* void)) ,@params) ,returns
(var ƛcaptures (* (struct ,record)) ƛe)
,(if (eq? 'void returns) call `(return ,call)))
`(fn ,convert ((f ,pointer)) (struct ,closure)
(var ƛc (struct ,closure))
(= (dot-access ƛc code) ,thunk)
(var ƛcaptures (* (struct ,record))
(cast (& (dot-access ƛc env)) (* (struct ,record))))
(= (-> ƛcaptures f) f)
(return ƛc))))))
convert))
;;; A bare function is a closure that captures nothing, so it converts
;;; wherever one is expected. The reverse cannot: a closure has an
;;; environment and a function pointer has nowhere to put it.
(define (convert-to-closure expected value env form)
(let ((closure (as-closure-type expected))
(actual (expression-type value env)))
(if (and closure
(list? actual)
(= 3 (length actual))
(eq? 'fn (car actual))
(equal? (cdr actual) (cdr closure)))
(copy-form-source! form
(list (register-fn-conversion! closure form) value))
value)))
(define +closure-calls+ (make-hash-table))
;;; The helper a closure call is routed through: `(f 1)' becomes
@@ -563,16 +911,28 @@
(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.
;;; `(closure ((b int)) int (n) ...)' captures `n' under its own name
;;; and takes its type from wherever it was declared. `((pa (& a)))'
;;; names the capture and gives the expression it holds, so `pa' is a
;;; `(* int)' inside the body and `a' is never mentioned there.
(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)))
(let ((name (capture-name capture)))
(unless (symbol? name)
(sex-error form "a closure capture needs a name" capture))
(let ((type (if (pair? capture)
(expression-type (capture-argument capture) env)
(lookup-name env name))))
(unless type
(sex-error form "cannot infer what is captured as" name))
(list name type))))
(define (capture-name capture)
(if (pair? capture) (first capture) capture))
;;; What the constructor is handed: the name itself, or the expression
;;; written beside it
(define (capture-argument capture)
(if (pair? capture) (second capture) capture))
(define (lift-closure base form env)
(match form
@@ -650,7 +1010,11 @@
(define (process-global-var 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))
(let* ((form (resolve-closure-types sex-var))
(core (if (memq (car form) '(pub extern)) (cdr form) form)))
(when (and (pair? (cdr core)) (pair? (cddr core)) (symbol? (second core)))
(add-name-type! (second core) (third core)))
(cons form acc)))
;;; Utils
(define (non-empty-list? form)