The dawn of the inception

compile.scm

@@ -5,6 +5,7 @@
 (import
   (scheme base)
   (scheme cxr)
+  (scheme eval)
   (scheme inexact)
   (scheme lazy)
   (scheme process-context)
@@ -256,6 +257,36 @@
     ; Keep an invariant that a `begin` body must not be empty.
     (cons #f (read-all))))
 
+; Inception
+
+(define (incept-expression inceptions expression)
+  (if (pair? expression)
+    (let ((expression
+            (relaxed-map
+              (lambda (expression)
+                (incept-expression inceptions expression))
+              expression)))
+      (cond
+        ((and (null? (cdr expression)) (assq (car expression) inceptions)) =>
+          cdr)
+
+        (else
+          expression)))
+    expression))
+
+(define (incept expression)
+  (incept-expression
+    (list
+      (cons
+        '$$relaxed-map
+        '(define (relaxed-map f xs)
+          (if (pair? xs)
+           (cons
+            (f (car xs))
+            (relaxed-map f (cdr xs)))
+           (f xs)))))
+    expression))
+
 ; Library system
 
 ;; Types
@@ -878,118 +909,126 @@
 
 ; Optimization
 
-(define-record-type optimization-context
-  (make-optimization-context optimizers literals)
-  optimization-context?
-  (optimizers optimization-context-optimizers optimization-context-set-optimizers!)
-  (literals optimization-context-literals optimization-context-set-literals!))
+(define optimization-codes
+  '((define-record-type optimization-context
+     (make-optimization-context optimizers literals)
+     optimization-context?
+     (optimizers optimization-context-optimizers optimization-context-set-optimizers!)
+     (literals optimization-context-literals optimization-context-set-literals!))
 
-(define (optimization-context-append! context name optimizer)
-  (optimization-context-set-optimizers!
-    context
-    (cons
-      (cons name optimizer)
-      (optimization-context-optimizers context))))
+    (define (optimization-context-append! context name optimizer)
+     (optimization-context-set-optimizers!
+      context
+      (cons
+       (cons name optimizer)
+       (optimization-context-optimizers context))))
 
-(define (optimization-context-append-literal! context name literal)
-  (optimization-context-set-literals!
-    context
-    (cons
-      (cons name literal)
-      (optimization-context-literals context))))
+    (define (optimization-context-append-literal! context name literal)
+     (optimization-context-set-literals!
+      context
+      (cons
+       (cons name literal)
+       (optimization-context-literals context))))
 
-(define (make-optimizer name optimizer)
-  (define (match-pattern pattern expression)
-    (cond
-      ((and (pair? pattern) (pair? expression))
+    (define (make-optimizer name optimizer)
+     (define (match-pattern pattern expression)
+      (cond
+       ((and (pair? pattern) (pair? expression))
         (maybe-append
-          (match-pattern (car pattern) (car expression))
-          (match-pattern (cdr pattern) (cdr expression))))
+         (match-pattern (car pattern) (car expression))
+         (match-pattern (cdr pattern) (cdr expression))))
 
-      ((symbol? pattern)
+       ((symbol? pattern)
         (list (cons pattern expression)))
 
-      ((equal? pattern expression)
+       ((equal? pattern expression)
         '())
 
-      (else
+       (else
         #f)))
 
-  (define (fill-template matches template)
-    (cond
-      ((pair? template)
+     (define (fill-template matches template)
+      (cond
+       ((pair? template)
         (cons
-          (fill-template matches (car template))
-          (fill-template matches (cdr template))))
+         (fill-template matches (car template))
+         (fill-template matches (cdr template))))
 
-      ((and (symbol? template) (assq template matches)) =>
+       ((and (symbol? template) (assq template matches)) =>
         cdr)
 
-      (else
+       (else
         template)))
 
-  (case (car optimizer)
-    (($$syntax-rules)
-      (let ((rules (cdddr optimizer)))
+     (case (car optimizer)
+      (($$syntax-rules)
+       (let ((rules (cdddr optimizer)))
         (lambda (expression)
-          (let loop ((rules rules))
-            (if (null? rules)
-              expression
-              (let ((rule (car rules)))
-                (cond
-                  ((match-pattern (car rule) expression) =>
-                    (lambda (matches)
-                      (fill-template matches (cadr rule))))
-
-                  (else
-                    (loop (cdr rules))))))))))
+         (let loop ((rules rules))
+          (if (null? rules)
+           expression
+           (let ((rule (car rules)))
+            (cond
+             ((match-pattern (car rule) expression) =>
+              (lambda (matches)
+               (fill-template matches (cadr rule))))
 
-    (else
-      (error "unsupported optimizer" optimizer))))
+             (else
+              (loop (cdr rules))))))))))
 
-(define (optimize-expression context expression)
-  (define (optimize expression)
-    (optimize-expression context expression))
+      (else
+       (error "unsupported optimizer" optimizer))))
 
-  (if (pair? expression)
-    (let* ((expression (relaxed-map optimize expression))
-           (predicate (car expression)))
-      (cond
+    (define (optimize-expression context expression)
+     (define (optimize expression)
+      (optimize-expression context expression))
+
+     (if (pair? expression)
+      (let* ((expression (relaxed-map optimize expression))
+             (predicate (car expression)))
+       (cond
         ((eq? predicate '$$define-optimizer)
-          (let ((name (cadr expression)))
-            (optimization-context-append! context name (make-optimizer name (caddr expression)))
-            (optimization-context-append-literal! context name (caddr expression)))
-          #f)
+         (let ((name (cadr expression)))
+          (optimization-context-append! context name (make-optimizer name (caddr expression)))
+          (optimization-context-append-literal! context name (caddr expression)))
+         #f)
 
         ((eq? predicate '$$begin)
-          ; Omit top-level constants.
-          ; TODO Define this pass by `define-optimizer`.
-          (cons '$$begin
-            (let loop ((expressions (cdr expression)))
-              (let ((expression (car expressions))
-                    (expressions (cdr expressions)))
-                (cond
-                  ((null? expressions)
-                    (list expression))
-
-                  ((pair? expression)
-                    (cons expression (loop expressions)))
-
-                  (else
-                    (loop expressions)))))))
+         ; Omit top-level constants.
+         ; TODO Define this pass by `define-optimizer`.
+         (cons '$$begin
+          (let loop ((expressions (cdr expression)))
+           (let ((expression (car expressions))
+                 (expressions (cdr expressions)))
+            (cond
+             ((null? expressions)
+              (list expression))
+
+             ((pair? expression)
+              (cons expression (loop expressions)))
+
+             (else
+              (loop expressions)))))))
 
         ((assq predicate (optimization-context-optimizers context)) =>
-          (lambda (pair)
-            ((cdr pair) expression)))
+         (lambda (pair)
+          ((cdr pair) expression)))
 
         (else
-          expression)))
-    expression))
+         expression)))
+      expression))
+
+    (define (optimize optimizers expression)
+     (let* ((context (make-optimization-context optimizers '()))
+            (expression (optimize-expression context expression)))
+      (values expression (optimization-context-literals context))))))
 
-(define (optimize expression)
-  (let* ((context (make-optimization-context '() '()))
-         (expression (optimize-expression context expression)))
-    (values expression (optimization-context-literals context))))
+(define (optimize2 optimizers expression)
+  (eval
+    `(begin
+      ,@optimization-codes
+      (optimize ',optimizers ',expression))
+    '((scheme base))))
 
 ; Compilation
 
@@ -1594,9 +1633,10 @@
 ; Main
 
 (define (main)
-  (define-values (expression1 libraries) (expand-libraries (read-source)))
+  (define expression0 (incept (read-source)))
+  (define-values (expression1 libraries) (expand-libraries expression0))
   (define-values (expression2 macros) (expand-macros expression1))
-  (define-values (expression3 optimizers) (optimize expression2))
+  (define-values (expression3 optimizers) (optimize2 '() expression2))
 
   (encode
     (marshal

prelude.scm

@@ -2578,12 +2578,7 @@
             ((not (pair? xs))
               y)))
 
-        (define (relaxed-map f xs)
-          (if (pair? xs)
-            (cons
-              (f (car xs))
-              (relaxed-map f (cdr xs)))
-            (f xs)))
+        ($$relaxed-map)
 
         (define (relaxed-deep-map f xs)
           (if (pair? xs)