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
   8 ;; to use when interpreting
   9 (include "asm.scm")
  10 (include "pic18.scm")
  11 (include "pic18-sim.scm")
  12 (include "utilities.scm")
  13 (include "ast.scm")
  14 (include "operators.scm")
  15 (include "cte.scm")
  16 (include "parser.scm")
  17 (include "cfg.scm")
  18 (include "optimizations.scm")
  19 (include "code-generation.scm")
  20 (include "register-allocation.scm")
  21 (include "profiler.scm")
  22
  23 ;; ;; to use with compiled code
  24 ;; (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, and the next one ?
  95         (remove-dead-instructions cfg)
  96         (if allocate-registers? (allocate-registers cfg))
  97         (assembler-gen filename cfg)
  98         (asm-assemble)
  99         '(asm-display-listing (current-output-port))
 100         (set! asm-filename (string-append filename ".s"))
 101         (with-output-to-file asm-filename
 102           (lambda () (asm-display-listing (current-output-port))))
 103         (with-output-to-file (string-append filename ".map")
 104           (lambda () (write (table->list symbol-table))))
 105         (with-output-to-file (string-append filename ".reg")
 106           (lambda () (write (map (lambda (x)
 107                                    ;; write it in hex, for easier
 108                                    ;; cross-reference with the simulation
 109                                    (cons (number->string (car x) 16) (cdr x)))
 110                                  (table->list register-table)))))
 111         (asm-write-hex-file (string-append filename ".hex"))
 112         (asm-end!)
 113         ;; data contains a list of additional hex files
 114         (apply execute-hex-files (cons (string-append filename ".hex") data))
 115         #t))))
 116
 117 (define (picobit prog #!optional (recompile? #f))
 118   (set! trace-instr #f)
 119   (if recompile?
 120       (main "tests/picobit/picobit-vm-sixpic.c" prog)
 121       (simulate (list "tests/picobit/picobit-vm-sixpic.c.hex" prog)
 122                 "tests/picobit/picobit-vm-sixpic.c.map"
 123                 "tests/picobit/picobit-vm-sixpic.c.reg"
 124                 "tests/picobit/picobit-vm-sixpic.c.s")))
 125
 126 (define (simulate hexs map-file reg-file asm-file)
 127   (set! symbol-table   (with-input-from-file map-file
 128                          (lambda () (list->table (read)))))
 129   (set! register-table
 130         (with-input-from-file reg-file
 131           (lambda () (list->table
 132                       (map (lambda (x)
 133                              ;; read from hex
 134                              (cons (string->number (car x) 16) (cdr x)))
 135                            (read))))))
 136   (set! asm-filename asm-file)
 137   (apply execute-hex-files hexs))
 138
 139 (include "../statprof/statprof.scm")
 140 (define (profile) ; profile using picobit
 141   (time (begin (with-exception-catcher
 142                 ;; to have the profiling results even it the compilation fails
 143                 (lambda (x)
 144                   (profile-stop!)
 145                   (write-profile-report "profiling-picobit"))
 146                 (lambda ()
 147                   (profile-start!)
 148                   (main "tests/picobit/picobit-vm-sixpic.c")
 149                   (profile-stop!)
 150                   (write-profile-report "profiling-picobit")))
 151                (pp TOTAL:))))