From e1da69922aa0869e136c91def848b8fc028f3a39 Mon Sep 17 00:00:00 2001
From: Rose Hogenson <rhogenson@posteo.net>
Date: Mon, 25 Jul 2022 20:54:17 -0700
Subject: Re-write the linker.

---
 csc/linker-test.csc |  59 ++++++++++++++++++++-----
 csc/linker.csc      | 121 +++++++++++++++++++++++++++++-----------------------
 2 files changed, 117 insertions(+), 63 deletions(-)

diff --git a/csc/linker-test.csc b/csc/linker-test.csc
index 084e9ae..cc07a74 100644
--- a/csc/linker-test.csc
+++ b/csc/linker-test.csc
@@ -1,24 +1,63 @@
 (import (scheme base)
-        (only (csc encoding) encode)
+        (only (csc format)
+          sprintf)
+        (only (csc hash-map)
+          alist->map
+          hash-bytevector
+          make-comparer
+          make-map)
+        (only (csc list)
+          all)
         (only (csc testing)
           assert-equal
           test)
         (csc linker))
 
 
-(test link-if
+(define compare-globals
+  (make-comparer
+    (lambda (x)
+      (hash-bytevector (string->utf8 (sprintf "{}" x))))
+    (lambda (x y)
+      (cond
+        ((equal? x y) 0)
+        ((string<? (sprintf "{}" x) (sprintf "{}" y)) -1)
+        (else 1)))))
+
+
+(test link-labels
   (assert-equal
-    (encode '((const 5) (const 1) (if 2) (const 5) add exit))
-    (link '((const 5) (const 1) (if "label1") (const 5) add (label "label1") exit))))
+    '((jmp (const 1))
+      (jmp (const 0)))
+    (link
+      '(((label 0)
+         (jmp (label 1))
+         (label 1)
+         (jmp (label 0))))
+      (make-map compare-globals))))
 
 
-(test link-backwards-if
+(test link-labels-are-unique-per-program
   (assert-equal
-    (encode '((const 10) (const 5) add (if -3)))
-    (link '((const 10) (label "label1") (const 5) add (if "label1")))))
+    '((jmp (const 1))
+      (jmp (const 0))
+      (jmp (const 3))
+      (jmp (const 2)))
+    (link
+      '(((label 0)
+          (jmp (label 1))
+          (label 1)
+          (jmp (label 0)))
+         ((label 0)
+          (jmp (label 1))
+          (label 1)
+          (jmp (label 0))))
+      (make-map compare-globals))))
 
 
-(test link-call
+(test link-globals
   (assert-equal
-    (encode '((call 3) (const 10) exit (const 5) exit))
-    (link '((call "label1") (const 10) (label "label0") exit (label "label1") (const 5) exit))))
+    '((peek (local 0) (const 10)))
+    (link
+      '(((peek (local 0) (global cons (csc based)))))
+      (alist->map compare-globals '(((global cons (csc based)) . 10))))))
diff --git a/csc/linker.csc b/csc/linker.csc
index feec289..238fbc5 100644
--- a/csc/linker.csc
+++ b/csc/linker.csc
@@ -1,63 +1,78 @@
 (define-library (csc linker)
-  (export link remove-labels make-label-map translate-labels)
+  (export link)
   (import (scheme base)
-          (only (csc encoding) encode)
-          (only (csc format) sprintf)
           (only (csc hash-map)
+            compare-numbers
             insert
-            compare-strings
             lookup
-            make-map)
-          (only (csc list)
-            enumerate
-            filter)
+            make-map
+            map-for-each)
+          (only (csc loop)
+            loop
+            return)
           (only (csc match) match))
   (begin
-    ; A CSC bytecode program is a list of opcodes. An opcode is a symbol, or a 2
-    ; item list of a symbol and an argument. The full list of opcodes can be
-    ; found in encoding.csc.
+    ; A CSC bytecode program is a list of opcodes and labels. An opcode is a
+    ; list of an opcode and arguments. Arguments can be any of:
+    ;   - (local x),
+    ;   - (global x lib),
+    ;   - (const x),
+    ;   - or (label x).
+    ; The full list of opcodes can be found in encoding.csc.
 
 
+    ; Rewrites each (label x) form into a integer constant.
     (define (translate-labels program label-map)
-      (map
-        (lambda (x)
-          (match x
-            ((i . ('if label))
-             ; Compute offset from the current position. Subtract 1
-             ; because the instruction pointer is incremented each
-             ; time already.
-             (list 'if (- (lookup label-map label) i 1)))
-            ((_ . ('call label))
-             (list 'call (lookup label-map label)))
-            ((_ . opcode) opcode)))
-        (enumerate program)))
-    (lambda (i . opcode)
-          (match opcode
-            (((! 'if) label) #t)
-            (_ #f)))
-
-
-    (define (make-label-map program)
-      (let loop ((m (make-map compare-strings))
-                 (program program)
-                 (i 0))
-        (match program
-          ('() m)
-          ((('label name) . tail)
-           (loop (insert m name i) tail i))  ; N.b.: i instead of (+ 1 i) because we're going to remove the labels later.
-          ((_ . tail) (loop m tail (+ 1 i))))))
-
-
-    (define (remove-labels program)
-      (filter
-        (lambda (opcode)
-          (match opcode
-            (('label _) #f)
-            (_ #t)))
-        program))
-
-
-    (define (link . programs)
-      (let* ((program (apply append programs))
-             (label-map (make-label-map program)))
-        (encode (translate-labels (remove-labels program) label-map))))))
+      (loop for opcode in program
+            for op = (car opcode)
+            for args = (cdr opcode)
+            unless (symbol=? op 'label)
+              collect (cons op (loop for arg in args
+                                     collect (match arg
+                                               (('label x)
+                                                 (list 'const (lookup label-map x)))
+                                               (_ arg))))))
+
+
+    (define (make-label-map offset program)
+      (loop for op in program
+            for i from offset
+            with m = (make-map compare-numbers)
+            do (match op
+                 (('label id)
+                   (set! m (insert m id i))
+                   (set! i (- i 1))))  ; Labels will be removed later.
+            finally (return m)))
+
+
+    (define (translate-globals program environment)
+      (define next-global-id 0)
+      (map-for-each (lambda (k v)
+                      (when (>= v next-global-id)
+                        (set! next-global-id (+ 1 v))))
+        environment)
+      (define (translate-global x)
+        (or (lookup environment x #f)
+            (let ((id next-global-id))
+              (set! next-global-id (+ 1 next-global-id))
+              (set! environment (insert environment x id))
+              id)))
+      (loop for opcode in program
+            for op = (car opcode)
+            for args = (cdr opcode)
+            collect (cons op (loop for arg in args
+                                   collect (match arg
+                                             (('global x lib)
+                                               (list 'const (translate-global arg)))
+                                             (_ arg))))))
+
+
+    (define (link programs environment)
+      (translate-globals
+        (loop for prog in programs
+              for off = 0 then (+ off (length converted-prog))
+              for converted-prog = (translate-labels
+                                     prog
+                                     (make-label-map off prog))
+              append converted-prog)
+        environment))))
-- 
cgit v1.3.1