From 7d7126bf0d58b683d739cf8a2a00c02f200e00b1 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Tue, 13 Jun 2017 20:20:38 +0200 Subject: [PATCH] mescc: Remove jump calculation, use labels: switch. * module/language/c99/compiler.mes (expr->accu): Refactor (switch ...). (clause->info): Refactor. --- module/language/c99/compiler.mes | 154 ++++++++++++++++--------------- 1 file changed, 82 insertions(+), 72 deletions(-) diff --git a/module/language/c99/compiler.mes b/module/language/c99/compiler.mes index 3458b22d..7b6f6e10 100644 --- a/module/language/c99/compiler.mes +++ b/module/language/c99/compiler.mes @@ -1006,18 +1006,17 @@ (let ((s (string-drop o (string-length prefix)))) (map byte->hex (string-split s #\space)))))) -(define (clause->jump-info info) - (define (jump n) - (wrap-as (i386:Xjump n))) - (define (jump-nz n) - (wrap-as (i386:Xjump-nz n))) - (define (jump-z n) - (wrap-as (i386:Xjump-z n))) - (define (statement->info info body-length) - (lambda (o) - (pmatch o - ((break) (append-text info (jump body-length))) - (_ ((ast->info info) o))))) +(define (clause->info info i label last?) + (define clause-label + (string-append label "clause" (number->string i))) + (define body-label + (string-append label "body" (number->string i))) + (define (jump label) + (wrap-as (i386:jump-label `(#:local ,label)))) + (define (jump-nz label) + (wrap-as (i386:jump-label-nz `(#:local ,label)))) + (define (jump-z label) + (wrap-as (i386:jump-label-z `(#:local ,label)))) (define (test->text test) (let ((value (pmatch test (0 0) @@ -1026,42 +1025,41 @@ ((p-expr (fixed ,value)) (cstring->number value)) ((neg (p-expr (fixed ,value))) (- (cstring->number value))) (_ (error "case test: unsupported: " test))))) - (lambda (n) - (append (wrap-as (i386:accu-cmp-value value)) - (jump-z (+ (length (object->list (jump 0))) - (if (= n 0) 0 - (* n (length (object->list ((test->text 0) 0))))))))))) - (define (cases+jump cases clause-length) - (append-text info - (append - (append-map (lambda (t i) (t i)) cases (reverse (iota (length cases)))) - (if (null? cases) '() - (jump clause-length))))) + (append (wrap-as (i386:accu-cmp-value value)) + (jump-z body-label)))) + (define (cases+jump info cases) + (let* ((info (append-text info (wrap-as `(#:label ,clause-label)))) + (next-clause-label (string-append label "clause" + (number->string (1+ i)))) + (info (append-text info (apply append cases))) + (info (if (null? cases) info + (append-text info (jump next-clause-label)))) + (info (append-text info (wrap-as `(#:label ,body-label))))) + info)) + (lambda (o) - (lambda (body-length) - (let loop ((o o) (cases '()) (clause #f)) - (pmatch o - ((case ,test ,statement) - (loop statement (append cases (list (test->text test))) clause)) - ((default ,statement) - (loop statement cases clause)) - ((compd-stmt (block-item-list)) - (loop '() cases clause)) - ((compd-stmt (block-item-list . ,elements)) - (let ((clause (or clause (cases+jump cases 0)))) - (loop `(compd-stmt (block-item-list ,@(cdr elements))) cases - ((statement->info clause body-length) (car elements))))) - (() - (let* ((cases-length (length (.text (cases+jump cases 0)))) - (clause-text (list-tail (.text clause) cases-length)) - (clause-length (length (object->list clause-text)))) - (clone clause #:text - (append (.text (cases+jump cases clause-length)) - clause-text)))) - (_ - (let ((clause (or clause (cases+jump cases 0)))) - (loop '() cases - ((statement->info clause body-length) o))))))))) + (let loop ((o o) (cases '()) (clause #f)) + (pmatch o + ((case ,test ,statement) + (loop statement (append cases (list (test->text test))) clause)) + ((default ,statement) + (loop statement cases clause)) + ((compd-stmt (block-item-list)) + (loop '() cases clause)) + ((compd-stmt (block-item-list . ,elements)) + (let ((clause (or clause (cases+jump info cases)))) + (loop `(compd-stmt (block-item-list ,@(cdr elements))) cases + ((ast->info clause) (car elements))))) + (() + (let ((clause (or clause (cases+jump info cases)))) + (if last? clause + (let ((next-body-label (string-append label "body" + (number->string (1+ i))))) + (append-text clause (wrap-as (i386:jump-label `(#:local ,next-body-label)))))))) + (_ + (let ((clause (or clause (cases+jump info cases)))) + (loop '() cases + ((ast->info clause) o)))))))) (define (test->jump->info info) (define (jump type . test) @@ -1403,7 +1401,9 @@ (let* ((source (with-output-to-string (lambda () (pretty-print-c99 `(if ,test (ellipsis)))))) (info (append-text info (wrap-as `(#:comment ,source)))) (here (number->string (length text))) - (break-label (string-append (.function info) "_break_" here)) + (label (string-append (.function info) "_" here "_")) + (break-label (string-append label "break")) + (else-label (string-append label "else")) (info ((test-jump-label->info info break-label) test)) (info ((ast->info info) then)) (info (append-text info (wrap-as (i386:jump-label `(#:local ,break-label))))) @@ -1415,8 +1415,9 @@ (let* ((source (with-output-to-string (lambda () (pretty-print-c99 `(if ,test (ellipsis) (ellipsis)))))) (info (append-text info (wrap-as `(#:comment ,source)))) (here (number->string (length text))) - (else-label (string-append (.function info) "_else_" here)) - (break-label (string-append (.function info) "_break_" here)) + (label (string-append (.function info) "_" here "_")) + (break-label (string-append label "break")) + (else-label (string-append label "else")) (info ((test-jump-label->info info else-label) test)) (info ((ast->info info) then)) (info (append-text info (wrap-as (i386:jump-label `(#:local ,break-label))))) @@ -1431,8 +1432,9 @@ (let* ((source (with-output-to-string (lambda () (pretty-print-c99 `(cond-expr ,test (ellipsis) (ellipsis)))))) (info (append-text info (wrap-as `(#:comment ,source)))) (here (number->string (length text))) - (else-label (string-append (.function info) "_else_" here)) - (break-label (string-append (.function info) "_break_" here)) + (label (string-append (.function info) "_" here "_")) + (else-label (string-append label "else")) + (break-label (string-append label "break")) (info ((test-jump-label->info info else-label) test)) (info ((ast->info info) then)) (info (append-text info (wrap-as (i386:jump-label `(#:local ,break-label))))) @@ -1442,25 +1444,31 @@ info)) ((switch ,expr (compd-stmt (block-item-list . ,statements))) - (let* ((clauses (statements->clauses statements)) - (expr ((expr->accu info) expr)) - (empty (clone info #:text '())) - (clause-infos (map (clause->jump-info empty) clauses)) - (clause-lengths (map (lambda (c-j) (length (object->list (.text (c-j 0))))) clause-infos)) - (clauses-info (let loop ((clauses clauses) (info expr) (lengths clause-lengths)) - (if (null? clauses) info - (let ((c-j ((clause->jump-info info) (car clauses)))) - (loop (cdr clauses) (c-j (apply + (cdr lengths))) (cdr lengths))))))) - clauses-info)) + (let* ((source (with-output-to-string (lambda () (pretty-print-c99 `(switch ,expr (compd-stmt (block-item-list (ellipsis)))))))) + (info (append-text info (wrap-as `(#:comment ,source)))) + (here (number->string (length text))) + (label (string-append (.function info) "_" here "_")) + (break-label (string-append label "break")) + (clauses (statements->clauses statements)) + (info ((expr->accu info) expr)) + (info (clone info #:break (cons break-label (.break info)))) + (info (let loop ((clauses clauses) (i 0) (info info)) + (if (null? clauses) info + (loop (cdr clauses) (1+ i) ((clause->info info i label (null? (cdr clauses))) (car clauses)))))) + (info (append-text info (wrap-as `(#:label ,break-label))))) + (clone info + #:locals locals + #:break (cdr (.break info))))) ((for ,init ,test ,step ,body) (let* ((source (with-output-to-string (lambda () (pretty-print-c99 `(for ,init ,test ,step (ellipsis)))))) (info (append-text info (wrap-as `(#:comment ,source)))) (here (number->string (length text))) - (loop-label (string-append (.function info) "_loop_" here)) - (continue-label (string-append (.function info) "_continue_" here)) - (initial-skip-label (string-append (.function info) "_initial_skip_" here)) - (break-label (string-append (.function info) "_break_" here)) + (label (string-append (.function info) "_" here "_")) + (break-label (string-append label "break")) + (loop-label (string-append label "loop")) + (continue-label (string-append label "continue")) + (initial-skip-label (string-append label "initial_skip")) (info ((ast->info info) init)) (info (clone info #:break (cons break-label (.break info)))) (info (clone info #:continue (cons continue-label (.continue info)))) @@ -1482,9 +1490,10 @@ (let* ((source (with-output-to-string (lambda () (pretty-print-c99 `(while ,test (ellipsis)))))) (info (append-text info (wrap-as `(#:comment ,source)))) (here (number->string (length text))) - (loop-label (string-append (.function info) "_loop_" here)) - (continue-label (string-append (.function info) "_continue_" here)) - (break-label (string-append (.function info) "_break_" here)) + (label (string-append (.function info) "_" here "_")) + (break-label (string-append label "break")) + (loop-label (string-append label "loop")) + (continue-label (string-append label "continue")) (info (append-text info (wrap-as (i386:jump-label `(#:local ,continue-label))))) (info (clone info #:break (cons break-label (.break info)))) (info (clone info #:continue (cons continue-label (.continue info)))) @@ -1503,9 +1512,10 @@ (let* ((source (with-output-to-string (lambda () (pretty-print-c99 `(do-while ,test (ellipsis)))))) (info (append-text info (wrap-as `(#:comment ,source)))) (here (number->string (length text))) - (loop-label (string-append (.function info) "_loop_" here)) - (continue-label (string-append (.function info) "_continue_" here)) - (break-label (string-append (.function info) "_break_" here)) + (label (string-append (.function info) "_" here "_")) + (break-label (string-append label "break")) + (loop-label (string-append label "loop")) + (continue-label (string-append label "continue")) (info (clone info #:break (cons break-label (.break info)))) (info (clone info #:continue (cons continue-label (.continue info)))) (info (append-text info (wrap-as `(#:label ,loop-label))))