mescc: Remove jump calculation, use labels: switch.
authorJan Nieuwenhuizen <janneke@gnu.org>
Tue, 13 Jun 2017 18:20:38 +0000 (20:20 +0200)
committerJan Nieuwenhuizen <janneke@gnu.org>
Tue, 13 Jun 2017 18:20:38 +0000 (20:20 +0200)
* module/language/c99/compiler.mes (expr->accu): Refactor (switch ...).
  (clause->info): Refactor.

module/language/c99/compiler.mes

index 3458b22dadb8212083efc4b70aebeba3ac398ec0..7b6f6e1085947a32fdfe110d4e9a80c16f7fdfc4 100644 (file)
         (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)
                    ((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)
          (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)))))
          (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)))))
          (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)))))
            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))))
          (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))))
          (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))))