six-comp.scm

   1 #!/usr/bin/env gsi
   2
   3 (declare (standard-bindings))
   4
   5 (define allocate-registers? #t) ; can be turned off to reduce compilation time
   6 (define fold-constants?     #t)
   7 (define coalesce?           #t)
   8
   9 ;; to use when interpreting
  10 '(begin (include "asm.scm")
  11        (include "pic18.scm")
  12        (include "pic18-sim.scm")
  13        (include "utilities.scm")
  14        (include "ast.scm")
  15        (include "operators.scm")
  16        (include "cte.scm")
  17        (include "parser.scm")
  18        (include "cfg.scm")
  19        (include "optimizations.scm")
  20        (include "code-generation.scm")
  21        (include "register-allocation.scm")
  22        (include "profiler.scm"))
  23 ;; to use with compiled code
  24 (begin (load "asm")
  25        (load "pic18")
  26        (load "pic18-sim")
  27        (load "utilities")
  28        (load "ast")
  29        (load "operators")
  30        (load "cte")
  31        (load "parser")
  32        (load "cfg")
  33        (load "optimizations")
  34        (load "code-generation")
  35        (load "register-allocation")
  36        (load "profiler"))
  37
  38 ;------------------------------------------------------------------------------
  39
  40 ;; temporary solution, to support more than int
  41 (set! ##six-types ;; TODO signed types ?
  42   '((int    . #f)
  43     (byte   . #f)
  44     (int8   . #f)
  45     (int16  . #f)
  46     (int32  . #f)
  47     (char   . #f)
  48     (bool   . #f)
  49     (void   . #f)
  50     (float  . #f)
  51     (double . #f)
  52     (obj    . #f)))
  53 ;; TODO typedef should add to this list
  54
  55 '(current-exception-handler (lambda (exc) (##repl))) ; when not running in the repl
  56
  57 (define (read-source filename)
  58   (shell-command (string-append "cpp -P " filename " > " filename ".tmp"))
  59 ;;   (##read-all-as-a-begin-expr-from-path ;; TODO use vectorized notation to have info on errors (where in the source)
  60 ;;    (string-append filename ".tmp")
  61 ;;    (readtable-start-syntax-set (current-readtable) 'six)
  62 ;;    ##wrap-datum
  63 ;;    ##unwrap-datum)
  64   (with-input-from-file
  65       (string-append filename ".tmp")
  66     (lambda ()
  67       (input-port-readtable-set!
  68        (current-input-port)
  69        (readtable-start-syntax-set
  70         (input-port-readtable (current-input-port))
  71         'six))
  72       (read-all)))
  73   )
  74
  75
  76 (define asm-filename #f)
  77
  78 (define (main filename . data)
  79
  80   (output-port-readtable-set!
  81    (current-output-port)
  82    (readtable-sharing-allowed?-set
  83     (output-port-readtable (current-output-port))
  84     #t))
  85
  86   (let ((source (read-source filename)))
  87     '(pretty-print source)
  88     (let* ((ast (parse source)))
  89       '(pretty-print ast)
  90       (let ((cfg (generate-cfg ast)))
  91         '(print-cfg-bbs cfg)
  92         '(pretty-print cfg)
  93         (remove-branch-cascades-and-dead-code cfg)
  94         (remove-converging-branches cfg) ;; TODO maybe make it possible to disable it, the one before, and the next one ?
  95         (remove-dead-instructions cfg)
  96         '(print-cfg-bbs cfg)
  97         (if allocate-registers? (allocate-registers cfg))
  98         (assembler-gen filename cfg)
  99         (asm-assemble)
 100         '(asm-display-listing (current-output-port))
 101         (set! asm-filename (string-append filename ".s"))
 102         (with-output-to-file asm-filename
 103           (lambda () (asm-display-listing (current-output-port))))
 104         (with-output-to-file (string-append filename ".map")
 105           (lambda () (write (table->list symbol-table))))
 106         (with-output-to-file (string-append filename ".reg")
 107           (lambda () (write (map (lambda (x)
 108                                    ;; write it in hex, for easier
 109                                    ;; cross-reference with the simulation
 110                                    (cons (number->string (car x) 16) (cdr x)))
 111                                  (table->list register-table)))))
 112         (asm-write-hex-file (string-append filename ".hex"))
 113         (asm-end!)
 114         ;; data contains a list of additional hex files
 115         (apply execute-hex-files (cons (string-append filename ".hex") data))
 116         #t))))
 117
 118 (define (picobit prog #!optional (recompile? #f))
 119   (set! trace-instr #f)
 120   (if recompile?
 121       (main "tests/picobit/picobit-vm-sixpic.c" prog)
 122       (simulate (list "tests/picobit/picobit-vm-sixpic.c.hex" prog)
 123                 "tests/picobit/picobit-vm-sixpic.c.map"
 124                 "tests/picobit/picobit-vm-sixpic.c.reg"
 125                 "tests/picobit/picobit-vm-sixpic.c.s")))
 126
 127 (define (simulate hexs map-file reg-file asm-file)
 128   (set! symbol-table   (with-input-from-file map-file
 129                          (lambda () (list->table (read)))))
 130   (let ((regs (with-input-from-file reg-file read)))
 131     (set! register-table
 132           (list->table
 133            (map (lambda (x) (cons (string->number (car x) 16) (cdr x)))
 134                 regs)))
 135     (set! reverse-register-table (make-table))
 136     (for-each (lambda (x)
 137                 (for-each (lambda (y)
 138                             (table-set! reverse-register-table
 139                                         (cdr y)
 140                                         (string->number (car x) 16)))
 141                           (cdr x)))
 142               regs))
 143   (set! asm-filename asm-file)
 144   (apply execute-hex-files hexs))
 145
 146 (include "../statprof/statprof.scm")
 147 (define (profile) ; profile using picobit
 148   (time (begin (with-exception-catcher
 149                 ;; to have the profiling results even it the compilation fails
 150                 (lambda (x)
 151                   (profile-stop!)
 152                   (write-profile-report "profiling-picobit"))
 153                 (lambda ()
 154                   (profile-start!)
 155                   (main "tests/picobit/picobit-vm-sixpic.c")
 156                   (profile-stop!)
 157                   (write-profile-report "profiling-picobit")))
 158                (pp TOTAL:))))