diff options
Diffstat (limited to 'csc')
| -rw-r--r-- | csc/linker-test.csc | 59 | ||||
| -rw-r--r-- | csc/linker.csc | 109 |
2 files changed, 111 insertions, 57 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))) + (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 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 (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 (remove-labels program) - (filter - (lambda (opcode) - (match opcode - (('label _) #f) - (_ #t))) - program)) + (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) - (let* ((program (apply append programs)) - (label-map (make-label-map program))) - (encode (translate-labels (remove-labels program) label-map)))))) + (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)))) |