substrate-lang 0.9.2 → 0.9.4

package/substrate/compiler/link.sub

@@ -251,8 +251,8 @@
         [nkept u32 0] [base u32 0])
     (set! (-> k nf) (+ (-> s nfimports) ndefined))
     (set! (-> k ng) (+ (-> s ngimports) (length (-> s globals))))
-    (set! (-> k fmap) (cast (ptr u32) (malloc (* 4 (+ (-> k nf) 1)))))
-    (set! (-> k gmap) (cast (ptr u32) (malloc (* 4 (+ (-> k ng) 1)))))
+    (set! (-> k fmap) (-> (new 0 u32 (+ (-> k nf) 1)) items))
+    (set! (-> k gmap) (-> (new 0 u32 (+ (-> k ng) 1)) items))
     (set! (-> k kept) nil)
     (set! (-> k hooks) nil)
     (set! (-> k sp) 0)

package/substrate/compiler/main.sub

@@ -100,15 +100,28 @@
               [else ""]))
       ""))
 
+;; write-program! writes the built program to dir: its wasm modules and the program file that lists them, plus the
+;; compiled modules its sessions can load. Each compiled module is saved as <hash>.subc, where hash is the SHA-256 of
+;; its contents, and listed in the compiled file. compiled.map holds the module map they were built with.
 (define (write-program! [root datum] [file datum] [dir datum] [strip bool])
   (let* ([m (compile-module-file root file)] [pruned-modules (pruned (program-wasm-modules m))]
-         [ls (if strip (stripped pruned-modules) pruned-modules)] [names nil])
+         [ls (if strip (stripped pruned-modules) pruned-modules)] [names nil] [compiled (program-compiled-modules m)]
+         [listed nil])
     (make-dir dir)
     (while (pair? ls)
       (write-file (joined `(,dir "/" ,(car (car ls)) ".wasm")) (datum->bytes (cdr (car ls))))
       (set! names (cons '"\n" (cons (car (car ls)) names)))
       (set! ls (cdr ls)))
-    (write-file (joined `(,dir "/program")) (cast (slice u8) (datum->string (joined (reverse names)))))))
+    (write-file (joined `(,dir "/program")) (cast (slice u8) (datum->string (joined (reverse names)))))
+    (for-each (lambda ([c datum])
+                (write-file (joined `(,dir "/" ,(cadr c) ".subc")) (datum->bytes (caddr c)))
+                (set! listed (cons '"\n" (cons (car c) (cons '" " (cons (cadr c) listed))))))
+              compiled)
+    (unless (null? compiled)
+      (write-file (joined `(,dir "/compiled.map"))
+                  (cast (slice u8) (datum->string (joined (map (lambda ([f datum]) -> datum (format "~s\n" (cons f nil)))
+                                                               (compiled-module-map)))))))
+    (write-file (joined `(,dir "/compiled")) (cast (slice u8) (datum->string (joined (reverse listed)))))))
 
 (define (print-expanded [form datum])
   (let ([b (make-buffer)])

package/substrate/compiler/ops.sub

@@ -15,7 +15,7 @@
     memory.copy memory.fill))
 
 (define (def! [name datum] [code datum] [params datum] [results datum] [align i32])
-  (let ([op (cast (ptr prim-op) (arena-alloc (& run-arena) (sizeof prim-op)))])
+  (let ([op (new (& run-arena) prim-op)])
     (set! (-> op name) name)
     (set! (-> op code) code)
     (set! (-> op params) params)

package/substrate/compiler/prune.sub

@@ -18,7 +18,7 @@
 (define (unreadable) (raise-compile-error 0 "internal: a program's wasm module cannot be read"))
 
 (define (new-wasm [name datum] [bytes datum]) -> (ptr wasm)
-  (let ([w (cast (ptr wasm) (arena-alloc (current-arena) (sizeof wasm)))] [id u32 0] [head u32 0] [next u32 0])
+  (let ([w (new (current-arena) wasm)] [id u32 0] [head u32 0] [next u32 0])
     (set! (-> w name) name)
     (set! (-> w bytes) (datum->bytes bytes))
     (set! (-> w sections) nil)
@@ -66,20 +66,15 @@
             [(== id 9) (read-elems!)]
             [(== id 10) (read-bodies! w)])
       (set! ss (cdr ss)))
-    (set! (-> w live) (cast (ptr bool) (arena-alloc (current-arena) (+ (-> w nimports) (-> w count) 1))))
-    (memset (-> w live) 0 (+ (-> w nimports) (-> w count) 1))
-    (set! (-> w table-functions) (cast (ptr bool) (arena-alloc (current-arena) (+ (-> w nimports) (-> w count) 1))))
-    (memset (-> w table-functions) 0 (+ (-> w nimports) (-> w count) 1))
+    (set! (-> w live) (-> (new (current-arena) bool (+ (-> w nimports) (-> w count) 1)) items))
+    (set! (-> w table-functions) (-> (new (current-arena) bool (+ (-> w nimports) (-> w count) 1)) items))
     (for-each (lambda ([t datum]) (set! (@ (-> w table-functions) (cast u32 (integer-value (car t)))) #t)) (-> w tables))
-    (set! (-> w valued) (cast (ptr bool) (arena-alloc (current-arena) (+ (-> w nimports) (-> w count) 1))))
-    (memset (-> w valued) 0 (+ (-> w nimports) (-> w count) 1))
-    (set! (-> w read-globals) (cast (ptr bool) (arena-alloc (current-arena) (+ (-> w nglobals) 1))))
-    (memset (-> w read-globals) 0 (+ (-> w nglobals) 1))
-    (set! (-> w read-datas) (cast (ptr bool) (arena-alloc (current-arena) (+ (-> w ndatas) 1))))
-    (memset (-> w read-datas) 0 (+ (-> w ndatas) 1))
+    (set! (-> w valued) (-> (new (current-arena) bool (+ (-> w nimports) (-> w count) 1)) items))
+    (set! (-> w read-globals) (-> (new (current-arena) bool (+ (-> w nglobals) 1)) items))
+    (set! (-> w read-datas) (-> (new (current-arena) bool (+ (-> w ndatas) 1)) items))
     (set! (-> w sites) (make-buffer))
-    (set! (-> w site-starts) (cast (ptr u32) (arena-alloc (current-arena) (* 4 (+ (-> w count) 1)))))
-    (set! (-> w site-ends) (cast (ptr u32) (arena-alloc (current-arena) (* 4 (+ (-> w count) 1)))))))
+    (set! (-> w site-starts) (-> (new (current-arena) u32 (+ (-> w count) 1)) items))
+    (set! (-> w site-ends) (-> (new (current-arena) u32 (+ (-> w count) 1)) items))))
 
 ;; Each import's span is its kind and its bytes' start and end.
 (define (read-imports! [w (ptr wasm)])
@@ -125,8 +120,8 @@
 (define (read-bodies! [w (ptr wasm)])
   (let ([n (uleb)] [size u32 0])
     (set! (-> w count) n)
-    (set! (-> w starts) (cast (ptr u32) (arena-alloc (current-arena) (* 4 (+ n 1)))))
-    (set! (-> w ends) (cast (ptr u32) (arena-alloc (current-arena) (* 4 (+ n 1)))))
+    (set! (-> w starts) (-> (new (current-arena) u32 (+ n 1)) items))
+    (set! (-> w ends) (-> (new (current-arena) u32 (+ n 1)) items))
     (for ([k u32 0]) (< k n) (+= k 1)
       (set! size (uleb))
       (set! (@ (-> w starts) k) (position))
@@ -335,7 +330,7 @@
 
 (define (renumber! [w (ptr wasm)])
   (let ([total (+ (-> w nimports) (-> w count))] [next u32 0])
-    (set! (-> w indexes) (cast (ptr u32) (arena-alloc (current-arena) (* 4 (+ total 1)))))
+    (set! (-> w indexes) (-> (new (current-arena) u32 (+ total 1)) items))
     (for ([i u32 0]) (< i total) (+= i 1)
       (set! (@ (-> w indexes) i) next)
       (when (@ (-> w live) i) (+= next 1)))))
@@ -371,7 +366,7 @@
 (define (rewritten [w (ptr wasm)]) -> datum
   (let ([out (make-buffer)] [ss (-> w sections)] [news (ptr u32) 0] [s datum 0])
     (renumber! w)
-    (set! news (cast (ptr u32) (arena-alloc (current-arena) (* 4 (+ (-> w count) 1)))))
+    (set! news (-> (new (current-arena) u32 (+ (-> w count) 1)) items))
     (buffer-add! (& out) (slice (-> w bytes) 0 8))
     (while (pair? ss)
       (let* ([sec (car ss)] [id (integer-value (car sec))] [head (cast u32 (integer-value (cadr sec)))]

package/substrate/compiler/roots.sub

@@ -8,7 +8,7 @@
 
 (provide set-toolchain-directory! set-module-map! set-module-map-text! set-display-directory! toolchain-root? toolchain-roots
          toolchain-holding root-directories root-under-test? identity identity-label host-file entry-identity program-identity
-         module-source-file module-path-from
+         set-compiled-module-map! compiled-module-map compiled-module compiled-root? module-source-file module-path-from
          module-identity named-file program-forms language-path compiler-file module-source? string-literal? displayed
          write-error fail-at read-text file-text host-error module-refusal)
 
@@ -76,35 +76,46 @@
   (set! toolchain-directory (keep (absolute dir)))
   (set! roots (keep (toolchain-roots)))
   (set! shared-uses nil)
-  (set! test-labels nil))
+  (set! test-labels nil)
+  (set! compiled nil))
 
 ;; A root is (label directory uses rules): uses is ((name label) ...), and rules is () or (exports file packages), with
 ;; paths relative to the directory. A module's identity is label/path in its root, or ./path or ../path from the first
-;; file's directory when no root holds it.
+;; file's directory when no root holds it. A root of compiled modules has #f instead of a directory.
 (define roots datum nil)
 (define shared-uses datum nil)
 (define test-labels datum nil)
 (define loose-directory datum 0)
 (define display-directory datum 0)
 
+;; compiled holds the compiled modules from the program's build, as (identity hash) pairs, where hash is the SHA-256 of
+;; the module's file.
+(define compiled datum nil)
+
 (define toolchain-labels datum '("host" "compiler"))
 
 (define (toolchain-root? [label datum]) -> bool (!= (member label toolchain-labels) 0))
 
-(define (toolchain-roots) -> datum (map (lambda ([l datum]) -> datum `(,l ,(file-in toolchain-directory l) () ())) toolchain-labels))
+(define (toolchain-roots) -> datum
+  (map (lambda ([l datum]) -> datum `(,l ,(if (== toolchain-directory 0) '#f (file-in toolchain-directory l)) () ()))
+       toolchain-labels))
 
-(define (root-directories) -> datum (map (lambda ([r datum]) -> datum (cadr r)) roots))
+(define (root-directories) -> datum
+  (filter (lambda ([d datum]) -> bool (not (equal? d '#f))) (map (lambda ([r datum]) -> datum (cadr r)) roots)))
 
 (define (root-under-test? [label datum]) -> bool (!= (member label test-labels) 0))
 
-;; set-module-map! replaces the roots with a module map's, given as (root label "directory" clause ...) and
-;; (uses (name label) ...) forms.
+;; set-module-map! replaces the roots with those of a module map, which is made of (root label "directory" clause ...),
+;; (uses (name label) ...) and (program label) forms. A root of compiled modules has no directory.
 (define (set-module-map! [forms datum])
   (set! roots (keep (toolchain-roots)))
   (set! shared-uses nil)
   (set! test-labels nil)
   (for-each (lambda ([f datum])
-              (if (and (pair? f) (equal? (car f) 'uses)) (set! shared-uses (keep (uses-in f shared-uses))) (add-root! f)))
+              (cond [(and (pair? f) (equal? (car f) 'uses)) (set! shared-uses (keep (uses-in f shared-uses)))]
+                    [(and (pair? f) (equal? (car f) 'program) (pair? (cdr f)) (symbol? (cadr f)) (null? (cddr f)))
+                     (set! program-label (keep (string->datum (symbol->string (cadr f)))))]
+                    [else (add-root! f)]))
             forms)
   (for-each (lambda ([r datum])
               (for-each (lambda ([u datum])
@@ -117,13 +128,16 @@
             shared-uses))
 
 (define (add-root! [f datum])
-  (let ([label datum 0] [uses nil] [exports nil] [one '""] [nested nil] [restricted #f] [cs datum 0])
-    (unless (and (pair? f) (equal? (car f) 'root) (pair? (cdr f)) (symbol? (cadr f)) (pair? (cddr f)) (string? (caddr f)))
+  (let ([label datum 0] [dir datum '#f] [uses nil] [exports nil] [one '""] [nested nil] [restricted #f] [cs datum 0])
+    (unless (and (pair? f) (equal? (car f) 'root) (pair? (cdr f)) (symbol? (cadr f)))
       (fail-at 0 "expected (root label \"directory\" clause ...) or (uses (name label) ...), not ~s" (list1 f)))
     (set! label (string->datum (symbol->string (cadr f))))
     (when (or (toolchain-root? label) (!= (assoc label roots) 0))
       (fail-at 0 "the module map gives a root named ~a twice, or names a root host or compiler" (list1 label)))
-    (set! cs (cdddr f))
+    (set! cs (cddr f))
+    (when (and (pair? cs) (string? (car cs)))
+      (set! dir (absolute (car cs)))
+      (set! cs (cdr cs)))
     (while (pair? cs)
       (let ([c (car cs)])
         (cond [(and (pair? c) (equal? (car c) 'uses)) (set! uses (uses-in c uses))]
@@ -141,7 +155,7 @@
                (fail-at 0 "a root's clauses are (uses (name label) ...), (exports \"path\" ...), (file \"path\"), (packages (name \"path\") ...) and (test), not ~s"
                         (list1 c))]))
       (set! cs (cdr cs)))
-    (set! roots (keep (cons `(,label ,(absolute (caddr f)) ,uses ,(if restricted `(,exports ,one ,nested) nil)) roots)))))
+    (set! roots (keep (cons `(,label ,dir ,uses ,(if restricted `(,exports ,one ,nested) nil)) roots)))))
 
 (define (nested? [l datum]) -> bool
   (while (pair? l)
@@ -169,6 +183,44 @@
 (define (set-module-map-text! [text datum] [source datum])
   (set-module-map! (map (lambda ([f datum]) -> datum (syntax->datum f)) (read-text text (symbol-of source)))))
 
+;; set-compiled-module-map! replaces the roots with those of the program's compiled modules, which have no directories.
+(define (set-compiled-module-map! [forms datum] [modules datum])
+  (set! toolchain-directory 0)
+  (set-module-map! forms)
+  (set! compiled (keep modules)))
+
+;; compiled-module-map returns the module map without directories, which a build writes next to the program's compiled
+;; modules.
+(define (compiled-module-map) -> datum
+  (let ([out (if (== program-label 0) nil `((program ,(symbol-of program-label))))])
+    (unless (null? shared-uses) (set! out (cons (cons 'uses (uses-forms shared-uses)) out)))
+    (for-each (lambda ([r datum])
+                (unless (toolchain-root? (car r))
+                  (set! out (cons (append `(root ,(symbol-of (car r)) ,(cons 'uses (uses-forms (caddr r))))
+                                          (append (rules-forms (cadddr r)) (if (root-under-test? (car r)) '((test)) nil)))
+                                  out))))
+              roots)
+    out))
+
+(define (uses-forms [uses datum]) -> datum
+  (map (lambda ([u datum]) -> datum `(,(symbol-of (car u)) ,(symbol-of (cadr u)))) uses))
+
+(define (rules-forms [rules datum]) -> datum
+  (if (null? rules)
+      nil
+      (append (list1 (cons 'exports (car rules)))
+              (append (if (equal? (cadr rules) '"") nil `((file ,(cadr rules))))
+                      (if (null? (caddr rules))
+                          nil
+                          (list1 (cons 'packages (map (lambda ([p datum]) -> datum `(,(symbol-of (car p)) ,(cadr p)))
+                                                      (caddr rules)))))))))
+
+(define (compiled-module [id datum]) -> datum (assoc id compiled))
+
+(define (compiled-root? [id datum]) -> bool
+  (let* ([label (identity-label id)] [r (if (== label 0) 0 (assoc label roots))])
+    (and (!= r 0) (equal? (cadr r) '#f))))
+
 (define (set-display-directory! [dir datum]) (set! display-directory (keep (absolute dir))))
 
 (define (root-of [label datum]) -> datum (root-in label roots))
@@ -205,12 +257,13 @@
           [else id])))
 
 (define (host-file [id datum]) -> datum
-  (let ([label (identity-label id)])
-    (if (== label 0)
-        (resolve-segments (concat (loose-root) (concat '"/" (identity-path id))))
-        (file-in (cadr (root-of label)) (identity-path id)))))
+  (let ([label (identity-label id)] [dir datum 0])
+    (when (== label 0) (return (resolve-segments (concat (loose-root) (concat '"/" (identity-path id))))))
+    (set! dir (cadr (root-of label)))
+    (if (equal? dir '#f) '#f (file-in dir (identity-path id)))))
 
-(define (inside? [file datum] [dir datum]) -> bool (path-within? (path-windows?) (datum->string file) (datum->string dir)))
+(define (inside? [file datum] [dir datum]) -> bool
+  (and (not (equal? dir '#f)) (path-within? (path-windows?) (datum->string file) (datum->string dir))))
 
 (define (toolchain-holding [file datum]) -> datum
   (let ([l roots] [found datum 0])
@@ -228,7 +281,9 @@
     found))
 
 (define (holds? [r datum] [file datum]) -> bool
-  (if (equal? (one-file r) '"") (inside? file (cadr r)) (same? file (file-in (cadr r) (one-file r)))))
+  (cond [(equal? (cadr r) '#f) #f]
+        [(equal? (one-file r) '"") (inside? file (cadr r))]
+        [else (same? file (file-in (cadr r) (one-file r)))]))
 
 (define (same? [a datum] [b datum]) -> bool (path-same? (path-windows?) (datum->string a) (datum->string b)))
 
@@ -286,7 +341,7 @@
 
 (define (displayed [source datum]) -> datum
   (let ([label (identity-label source)])
-    (cond [(and (!= label 0) (== (assoc label roots) 0)) source]
+    (cond [(and (!= label 0) (or (== (assoc label roots) 0) (compiled-root? source))) source]
           [(!= display-directory 0) (relative-path display-directory (host-file source))]
           [(== label 0) (identity-path source)]
           [else source])))
@@ -296,9 +351,10 @@
       name
       (string->datum (path-joined (path-windows?) (datum->string dir) (datum->string name)))))
 
-(define (kind-of [path datum]) -> i32
+(define (kind-of [path datum]) -> fs-kind
   (let ([info fs-info])
-    (if (< (fs-stat (datum->string path) (& info) 0) 0) 0 (-> info kind))))
+    (fs-stat (datum->string path) (& info) 0)
+    (-> info kind)))
 
 (define (clean-name? [s string]) -> bool
   (let ([start u32 0])
@@ -318,9 +374,10 @@
   (let* ([s (symbol->string (syntax-e id))] [n (-> s length)] [slash u32 0] [label datum 0])
     (unless (clean-name? s) (fail-at id "~a is not a module name: its parts may not be empty, . or .." (list1 (syntax-e id))))
     (while (and (< slash n) (!= (@ s slash) #\/)) (+= slash 1))
-    (set! label (named-root id (string->datum (slice s 0 slash)) (if (== from 0) 0 (identity-label from)) rs))
+    (set! label (named-root id (string->datum (slice s 0 slash)) (naming-label from) rs))
     (when (== slash n) (return (identity label (concat (label-name label) '".sub"))))
-    (identity label (named-file (cadr (root-in label rs)) (string->datum (slice s (+ slash 1) n))))))
+    (let ([dir (cadr (root-in label rs))] [rest (string->datum (slice s (+ slash 1) n))])
+      (identity label (if (equal? dir '#f) (compiled-file label rest) (named-file dir rest))))))
 
 (define (named-file [dir datum] [rest datum]) -> datum
   (let ([file (concat rest '".sub")])
@@ -328,6 +385,16 @@
         (file-in rest (concat (last-part rest) '".sub"))
         file)))
 
+;; compiled-file does what named-file does, for a root of compiled modules.
+(define (compiled-file [label datum] [rest datum]) -> datum
+  (let ([file (concat rest '".sub")] [inner (file-in rest (concat (last-part rest) '".sub"))])
+    (if (and (== (compiled-module (identity label file)) 0) (!= (compiled-module (identity label inner)) 0)) inner file)))
+
+;; naming-label returns the root used to resolve module names in code from a given module: that module's root, or the
+;; program's root for code outside any root, such as session input.
+(define (naming-label [from datum]) -> datum
+  (let ([label (if (== from 0) 0 (identity-label from))]) (if (== label 0) program-label label)))
+
 (define (named-root [id datum] [head datum] [from datum] [rs datum]) -> datum
   (let ([r (if (or (== from 0) (toolchain-root? from)) 0 (root-in from rs))] [u datum 0])
     (cond [(toolchain-root? head) head]
@@ -395,13 +462,13 @@
           [else (package-refusal subject id r (if (== from 0) program-label (identity-label from)))])))
 
 (define (package-refusal [subject datum] [id datum] [r datum] [from-label datum]) -> datum
-  (let* ([rules (cadddr r)] [exports (car rules)] [one (cadr rules)] [path (identity-path id)]
-         [holder (root-holding (host-file id))] [inner (nested-holding (caddr rules) path)])
+  (let* ([rules (cadddr r)] [exports (car rules)] [one (cadr rules)] [path (identity-path id)] [files (not (equal? (cadr r) '#f))]
+         [holder (if files (root-holding (host-file id)) 0)] [inner (nested-holding (caddr rules) path)])
     (cond [(not (equal? one '""))
            (if (equal? path one) 0 (format "~a is not part of ~a, a package of one file" `(,subject ,(car r))))]
           [(!= inner 0) (format "~a is in the package ~a, which is required by name" `(,subject ,(car inner)))]
           [(and (!= holder 0) (not (equal? (cadr holder) (cadr r)))) (by-name subject holder)]
-          [(linked-under? (cadr r) path)
+          [(and files (linked-under? (cadr r) path))
            (format "~a goes through a link in the package ~a, which packages do not allow" `(,subject ,(car r)))]
           [(or (and (!= from-label 0) (equal? from-label (car r))) (!= (member path exports) 0)) 0]
           [else (format "~a is not one of the modules ~a exports" `(,subject ,(car r)))])))

package/substrate/compiler/serialize.sub

@@ -8,7 +8,7 @@
         [atoms (ptr hash-table)] [pairs (ptr hash-table)] [scopes (ptr hash-table)] [table datum])
 
 (define (make-serializer) -> (ptr serializer)
-  (let ([s (cast (ptr serializer) (arena-alloc (current-arena) (sizeof serializer)))])
+  (let ([s (new (current-arena) serializer)])
     (set! (-> s out) (make-buffer))
     (set! (-> s count) 0)
     (set! (-> s shared) (make-table))

package/substrate/compiler/sha256.sub

@@ -0,0 +1,110 @@
+;; SHA-256 (FIPS 180-4), over bytes added in pieces or given at once.
+(provide sha256 sha256-init! sha256-add! sha256-end! sha256-of)
+
+(struct sha256 [state (array u32 8)] [block (array u8 64)] [filled u32] [length u64])
+
+(define k (array u32 64)
+  (array-of u32 #x428a2f98 #x71374491 #xb5c0fbcf #xe9b5dba5 #x3956c25b #x59f111f1 #x923f82a4 #xab1c5ed5
+               #xd807aa98 #x12835b01 #x243185be #x550c7dc3 #x72be5d74 #x80deb1fe #x9bdc06a7 #xc19bf174
+               #xe49b69c1 #xefbe4786 #x0fc19dc6 #x240ca1cc #x2de92c6f #x4a7484aa #x5cb0a9dc #x76f988da
+               #x983e5152 #xa831c66d #xb00327c8 #xbf597fc7 #xc6e00bf3 #xd5a79147 #x06ca6351 #x14292967
+               #x27b70a85 #x2e1b2138 #x4d2c6dfc #x53380d13 #x650a7354 #x766a0abb #x81c2c92e #x92722c85
+               #xa2bfe8a1 #xa81a664b #xc24b8b70 #xc76c51a3 #xd192e819 #xd6990624 #xf40e3585 #x106aa070
+               #x19a4c116 #x1e376c08 #x2748774c #x34b0bcb5 #x391c0cb3 #x4ed8aa4a #x5b9cca4f #x682e6ff3
+               #x748f82ee #x78a5636f #x84c87814 #x8cc70208 #x90befffa #xa4506ceb #xbef9a3f7 #xc67178f2))
+
+(define (rotr [x u32] [n u32]) #:inline -> u32 (bit-or (>> x n) (<< x (- 32 n))))
+
+(define (word [p (ptr u8)]) #:inline -> u32
+  (bit-or (<< (cast u32 (@ p 0)) 24) (<< (cast u32 (@ p 1)) 16) (<< (cast u32 (@ p 2)) 8) (cast u32 (@ p 3))))
+
+(define (compress! [s (ptr sha256)] [p (ptr u8)])
+  (let ([w (array u32 64)]
+        [a (@ (-> s state) 0)] [b (@ (-> s state) 1)] [c (@ (-> s state) 2)] [d (@ (-> s state) 3)]
+        [e (@ (-> s state) 4)] [f (@ (-> s state) 5)] [g (@ (-> s state) 6)] [hh (@ (-> s state) 7)])
+    (for ([i u32 0]) (< i 16) (+= i 1) (set! (@ w i) (word (+ p (* i 4)))))
+    (for ([i u32 16]) (< i 64) (+= i 1)
+      (let ([x (@ w (- i 15))] [y (@ w (- i 2))])
+        (set! (@ w i) (+ (@ w (- i 16)) (bit-xor (rotr x 7) (rotr x 18) (>> x 3)) (@ w (- i 7))
+                         (bit-xor (rotr y 17) (rotr y 19) (>> y 10))))))
+    (for ([i u32 0]) (< i 64) (+= i 1)
+      (let* ([t1 (+ hh (bit-xor (rotr e 6) (rotr e 11) (rotr e 25)) (bit-xor (bit-and e f) (bit-and (bit-not e) g))
+                    (@ k i) (@ w i))]
+             [t2 (+ (bit-xor (rotr a 2) (rotr a 13) (rotr a 22)) (bit-xor (bit-and a b) (bit-and a c) (bit-and b c)))])
+        (set! hh g)
+        (set! g f)
+        (set! f e)
+        (set! e (+ d t1))
+        (set! d c)
+        (set! c b)
+        (set! b a)
+        (set! a (+ t1 t2))))
+    (+= (@ (-> s state) 0) a)
+    (+= (@ (-> s state) 1) b)
+    (+= (@ (-> s state) 2) c)
+    (+= (@ (-> s state) 3) d)
+    (+= (@ (-> s state) 4) e)
+    (+= (@ (-> s state) 5) f)
+    (+= (@ (-> s state) 6) g)
+    (+= (@ (-> s state) 7) hh)))
+
+(define (sha256-init! [s (ptr sha256)])
+  (set! (@ (-> s state) 0) #x6a09e667)
+  (set! (@ (-> s state) 1) #xbb67ae85)
+  (set! (@ (-> s state) 2) #x3c6ef372)
+  (set! (@ (-> s state) 3) #xa54ff53a)
+  (set! (@ (-> s state) 4) #x510e527f)
+  (set! (@ (-> s state) 5) #x9b05688c)
+  (set! (@ (-> s state) 6) #x1f83d9ab)
+  (set! (@ (-> s state) 7) #x5be0cd19)
+  (set! (-> s filled) 0)
+  (set! (-> s length) 0))
+
+(define (sha256-add! [s (ptr sha256)] [b (slice u8)])
+  (let ([p (-> b items)] [n (-> b length)] [i u32 0])
+    (+= (-> s length) (cast u64 n))
+    (when (> (-> s filled) 0)
+      (while (and (< i n) (< (-> s filled) 64))
+        (set! (@ (-> s block) (-> s filled)) (@ p i))
+        (+= (-> s filled) 1)
+        (+= i 1))
+      (when (== (-> s filled) 64)
+        (compress! s (-> s block))
+        (set! (-> s filled) 0)))
+    (while (<= (+ i 64) n)
+      (compress! s (+ p i))
+      (+= i 64))
+    (while (< i n)
+      (set! (@ (-> s block) (-> s filled)) (@ p i))
+      (+= (-> s filled) 1)
+      (+= i 1))))
+
+;; into takes the 32 bytes of the digest.
+(define (sha256-end! [s (ptr sha256)] [into (slice u8)])
+  (let ([bits (* (-> s length) 8)])
+    (set! (@ (-> s block) (-> s filled)) 128)
+    (+= (-> s filled) 1)
+    (when (> (-> s filled) 56)
+      (while (< (-> s filled) 64)
+        (set! (@ (-> s block) (-> s filled)) 0)
+        (+= (-> s filled) 1))
+      (compress! s (-> s block))
+      (set! (-> s filled) 0))
+    (while (< (-> s filled) 56)
+      (set! (@ (-> s block) (-> s filled)) 0)
+      (+= (-> s filled) 1))
+    (for ([i u32 0]) (< i 8) (+= i 1)
+      (set! (@ (-> s block) (+ 56 i)) (cast u8 (>> bits (* 8 (- 7 i))))))
+    (compress! s (-> s block))
+    (for ([i u32 0]) (< i 8) (+= i 1)
+      (let ([h (@ (-> s state) i)])
+        (set! (@ into (* i 4)) (cast u8 (>> h 24)))
+        (set! (@ into (+ (* i 4) 1)) (cast u8 (>> h 16)))
+        (set! (@ into (+ (* i 4) 2)) (cast u8 (>> h 8)))
+        (set! (@ into (+ (* i 4) 3)) (cast u8 h))))))
+
+(define (sha256-of [b (slice u8)] [into (slice u8)])
+  (let ([s sha256])
+    (sha256-init! (& s))
+    (sha256-add! (& s) b)
+    (sha256-end! (& s) into)))

package/substrate/compiler/substrate.sub

@@ -1,6 +1,6 @@
 ;; Substrate in one module: the language, its runtime and its library.
 
-(provide define struct union variant match exception throw try lambda inst typedef const let let* set!
+(provide define struct union variant enum match exception throw try lambda inst typedef const let let* set!
          if return values import supply
          #%datum #%top-interaction #%module-begin
          when unless cond case while for break continue rethrow and or not cast sizeof offsetof array-of slice @ & ->
@@ -8,12 +8,13 @@
          += -= *= /= %= <<= >>= bit-and= bit-or= bit-xor=
          heap-start sbrk reset-stack!
          host-write host-trap host-args host-os host-exit host-instantiate host-export-index
-         host-program-modules host-module-bytes handler event-head untagged-handler! trap-handler! printf print-bytes
+         host-program-modules host-module-bytes host-compiled-file handler event-head untagged-handler! trap-handler!
+         printf print-bytes
          output-to! test expect expect-equal test-failed test-skipped
          buffer-add-entries! entry-strings
          sqrt fabs floor ceil trunc nearbyint copysign sqrtf fabsf floorf ceilf truncf nearbyintf copysignf
          malloc calloc realloc free try-malloc try-calloc try-realloc memcpy memset memcmp
-         arena make-arena arena-alloc arena-start! arena-free new
+         arena make-arena arena-alloc arena-start! arena-free new copy
          buffer make-buffer buffer-add! buffer-add-byte! buffer-add-string! buffer-add-utf-8! buffer-add-u32! buffer-add-f32!
          buffer-bytes buffer-string
          buffer-reserve buffer-free! buffer-trim! hash-bytes hash-table hash-ref hash-set! hash-clear! hash-free!
@@ -24,9 +25,9 @@
 ;; ---- the forms ----
 
 (define-syntax forms (quote-syntax (#%form forms)))
-(forms #%module-begin #%top-interaction define struct union variant match exception
+(forms #%module-begin #%top-interaction define struct union variant enum match exception
        throw try lambda inst substrate-struct-check typedef const let let* #%datum when unless cond case array-of slice
-       while for cast sizeof offsetof -> & set! @ break continue rethrow new printf test expect expect-equal
+       while for cast sizeof offsetof -> & set! @ break continue rethrow new copy printf test expect expect-equal
        + - * / % == != < <= > >= and or not bit-and bit-or bit-xor bit-not << >>
        += -= *= /= %= <<= >>= bit-and= bit-or= bit-xor=)
 
@@ -43,6 +44,7 @@
     (constant (const NAME TYPE VALUE))
     (type (struct NAME FIELD ...))
     (type (variant NAME CASE ...))
+    (type (enum NAME CASE ...))
     (type (typedef NAME TYPE))
     (exception (exception NAME TYPE ...))
     (macro (define-syntax NAME _))
@@ -98,6 +100,7 @@
 (import export_index "host" "export_index" (i32 i32 i32 i32 -> i32))
 (import program_modules "host" "program_modules" (i32 -> i32))
 (import module_bytes "host" "module_bytes" (i32 i32 i32 -> i32))
+(import compiled_file "host" "compiled_file" (i32 i32 i32 -> i32))
 
 (define (host-write [fd i32] [b (slice u8)]) #:inline -> i32 (write fd (cast i32 (-> b items)) (cast i32 (-> b length))))
 (define (host-trap [s string]) #:inline (trap (cast i32 (-> s bytes)) (cast i32 (-> s length))))
@@ -142,6 +145,9 @@
 (define (host-module-bytes [name string]) -> (slice u8)
   (let* ([n u32 0] [p (module_bytes (cast i32 (-> name bytes)) (cast i32 (-> name length)) (cast i32 (& n)))])
     (slice (cast (ptr u8) p) n)))
+(define (host-compiled-file [name string]) -> (slice u8)
+  (let* ([n u32 0] [p (compiled_file (cast i32 (-> name bytes)) (cast i32 (-> name length)) (cast i32 (& n)))])
+    (slice (cast (ptr u8) p) n)))
 
 ;; ---- output ----
 
@@ -178,10 +184,7 @@
 
 ;; ---- strings and slices ----
 
-(define (string-copy [s string]) -> string
-  (let ([p (cast (ptr u8) (malloc (-> s length)))])
-    (memcpy p (-> s bytes) (-> s length))
-    (cast string (slice p (-> s length)))))
+(define (string-copy [s string]) -> string (copy 0 s))
 
 ;; The checker's code calls these to compare strings by their bytes, and to trap on an index or a part out of range.
 
@@ -972,7 +975,7 @@
   (+ ten-powers (* 2 (+ q 348))))
 
 (define (make-ten-powers) -> (ptr u64)
-  (let* ([t (cast (ptr u64) (malloc 11136))] [limbs (array u64 44)] [x (slice limbs)])
+  (let* ([t (-> (new 0 u64 1392) items)] [limbs (array u64 44)] [x (slice limbs)])
     (memset limbs 0 352)
     (set! (@ x 0) 1)
     (for ([q 0]) (<= q 347) (+= q 1)
@@ -1015,10 +1018,7 @@
           [else (bit-or (<< (cast u64 (+ e2 1075)) 52) (- mant 4503599627370496))])))
 
 ;; A number is 32-bit limbs, least significant first, each in a u64.
-(define (big-new [a (ptr arena)] [len u32]) -> (slice u64)
-  (let ([x (cast (ptr u64) (arena-alloc a (* 8 len)))])
-    (memset x 0 (* 8 len))
-    (slice x len)))
+(define (big-new [a (ptr arena)] [len u32]) -> (slice u64) (new a u64 len))
 
 (define (big-mul-add! [x (slice u64)] [k u64] [c u64])
   (for ([i u32 0]) (< i (-> x length)) (+= i 1)

package/substrate/compiler/syntax.sub

@@ -90,7 +90,7 @@
 (define (in-run-arena?) -> bool (== current (& run-arena)))
 
 (define (begin-module-arena)
-  (let ([m (cast (ptr module-arena) (malloc (sizeof module-arena)))])
+  (let ([m (new 0 module-arena)])
     (set! (-> m arena) (make-arena))
     (set! (-> m outer) innermost)
     (set! innermost m)
@@ -302,7 +302,7 @@
 
 ;; ---- tables in an arena ----
 (define (make-table) -> (ptr hash-table)
-  (let ([t (cast (ptr hash-table) (memset (arena-alloc current (sizeof hash-table)) 0 (sizeof hash-table)))])
+  (let ([t (new current hash-table)])
     (set! (-> t arena) current)
     t))
 
@@ -322,7 +322,7 @@
         (set! (-> e value) value)
         (return))
       (set! e (-> e next)))
-    (set! e (cast (ptr entry) (arena-alloc (-> t arena) (sizeof entry))))
+    (set! e (new (-> t arena) entry))
     (set! (-> e key) key)
     (set! (-> e value) value)
     (set! (-> e next) first)
@@ -341,10 +341,7 @@
 (define symbols hash-table)
 (define keywords hash-table)
 
-(define (kept-text [s string]) -> string
-  (let ([p (cast (ptr u8) (arena-alloc (& run-arena) (-> s length)))])
-    (memcpy p (-> s bytes) (-> s length))
-    (cast string (slice p (-> s length)))))
+(define (kept-text [s string]) -> string (copy (& run-arena) s))
 
 (define (held-text [s string]) -> string
   (let ([p (held-bytes (-> s length))])
@@ -519,11 +516,7 @@
 ;; ---- changes to scopes ----
 
 (define (new-change [sc u32] [kind u32] [next (ptr change)]) -> (ptr change)
-  (let ([c (cast (ptr change) (arena-alloc current (sizeof change)))])
-    (set! (-> c scope) sc)
-    (set! (-> c kind) kind)
-    (set! (-> c next) next)
-    c))
+  (new current (change #:scope sc #:kind kind #:next next)))
 
 (define (changes-add [cs (ptr change)] [sc u32] [kind u32]) -> (ptr change)
   (cond [(== cs 0) (new-change sc kind 0)]
@@ -600,13 +593,7 @@
   (make-cell (syntax e scopes loc props 0)))
 
 (define (make-srcloc [source datum] [line u32] [col u32] [pos u32] [span u32]) -> (ptr srcloc)
-  (let ([l (cast (ptr srcloc) (arena-alloc current (sizeof srcloc)))])
-    (set! (-> l source) source)
-    (set! (-> l line) line)
-    (set! (-> l col) col)
-    (set! (-> l pos) pos)
-    (set! (-> l span) span)
-    l))
+  (new current (srcloc #:source source #:line line #:col col #:pos pos #:span span)))
 
 (define (syntax-e [s datum]) #:copied -> datum
   (match (cell-of s)
@@ -730,7 +717,7 @@
 (define (keep-srcloc [l (ptr srcloc)]) -> (ptr srcloc)
   (if (== l 0)
       0
-      (let ([kept (cast (ptr srcloc) (arena-alloc (& run-arena) (sizeof srcloc)))])
+      (let ([kept (new (& run-arena) srcloc)])
         (set! (@ kept) (@ l))
         kept)))
 
@@ -1098,7 +1085,7 @@
 (define (deserialize [bytes (ptr u8)] [n u32]) -> (ptr datum)
   (set! in-bytes bytes)
   (set! in-at 0)
-  (let* ([count (cast u32 (in-uleb))] [objs (cast (ptr u32) (arena-alloc current (* 4 (+ count 1))))])
+  (let* ([count (cast u32 (in-uleb))] [objs (-> (new current u32 (+ count 1)) items)])
     (for ([i u32 0]) (< i count) (+= i 1) (set! (@ objs i) (in-entry objs)))
     (cast (ptr datum) objs)))