;;;;
;;;;
;;;; compflags.stk         -- Compiler Flags
;;;;
;;;; Copyright © 2023-2024 Erick Gallesio <eg@stklos.net>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;;           Author: Erick Gallesio [eg@stklos.net]
;;;;    Creation date:  4-Mar-2023 11:48
;;;;



;; ----------------------------------------------------------------------
;;      Compiler parameters ...
;; ----------------------------------------------------------------------

(export define-parameter
        compiler:time-display
        compiler:gen-line-number
        compiler:warn-use-undefined
        compiler:warn-use-undefined-postpone
        compiler:show-assembly-code
        compiler:keep-formals
        compiler:keep-source
        compiler:inline-common-functions
        compiler:unroll-iterations
        compiler:peephole-optimizer
        compiler:source-rewrite)

#|
<doc EXT compiler:time-display
 * (compiler:time-display)
 * (compiler:time-display bool)
 *
 * This parameter controls if the time used for compiling a file must be
 * displayed or not. It defaults to `#t`.
 *
doc>
<doc
<doc EXT compiler:gen-line-number
 * (compiler:gen-line-number)
 * (compiler:gen-line-number bool)
 *
 * This parameter controls if the compiled code must embed indications of
 * the file location of the  of the source expressions. When set, this
 * parameter makes programs slower and bigger. However, it can be useful
 * when debugging a program. This parameter defaults to `#f` (but is set to
 * ``#t` when {{stklos}} is launched in debug mode).
doc>
<doc EXT compiler:show-assembly-code
 * (compiler:show-assembly-code)
 * (compiler:show-assembly-code bool)
 *
 * This parameter controls if the object files produced by the {{stklos}}
 * compiler code must embed a readable version of the code. The code is placed
 * at the beginning of the produced file. This parameter defaults to `#f`.
doc>
<doc EXT compiler:inline-common-functions
 * (compiler:inline-common-functions)
 * (compiler:inline-common-functions bool)
 *
 * This parameter controls if the compiler must try to inline the most common
 * Scheme primitives (simple arithmetic, main list or vector functions, ...).
 * Code produced  when this parameter is set is more efficient. Note that the
 * compiler can sometimes be misleaded if those functions are redefined, hence
 * the existence of this parameter. |compiler:inline-common-functions| is set
 * by default to `#t`.
 * @lisp
 * > (compiler:inline-common-functions #t)
 * > (disassemble-expr '(begin (car '(1 2 3)) (+ a 1)) #t)
 *
 * 000:  CONSTANT             0
 * 002:  IN-CAR
 * 003:  GLOBAL-REF           1
 * 005:  IN-INCR
 * 006:
 *
 * Constants:
 * 0: (1 2 3)
 * 1: a
 * @end lisp
 *
 * @lisp
 * > (compiler:inline-common-functions #f)
 * > (disassemble-expr '(begin (car '(1 2 3)) (+ a 1)) #t)
 *
 * 000:  PREPARE-CALL
 * 001:  CONSTANT-PUSH        0
 * 003:  GREF-INVOKE          1 1
 * 006:  PREPARE-CALL
 * 007:  GLOBAL-REF-PUSH      2
 * 009:  ONE-PUSH
 * 010:  GREF-INVOKE          3 2
 * 013:
 *
 * Constants:
 * 0: (1 2 3)
 * 1: car
 * 2: a
 * 3: +
 * @end lisp
doc>
<doc EXT compiler:keep-formals
 * (compiler:keep-formals)
 * (compiler:keep-formals bool)
 *
 * This parameter controls if the formal parameters of a user procedure is kept
 * at runtime. The formal parameters can be accessed with the primitive
 * <<"procedure-formals">>.
 * Default value for |compiler:keep-formals| is `#f`.
 * @lisp
 * > (compiler:keep-formals #f)
 * > (define (foo a b) ( + a b 1))
 * > foo
 * #[closure foo]
 * > (procedure-formals foo)
 * #f
 * @end lisp
 * @lisp
 * > (compiler:keep-formals #t)
 * > (define (foo a b) ( + a b 1))
 * > foo
 * #[closure foo (a b)]
 * > (procedure-formals foo)
 * (a b)
 * @end lisp
doc>
<doc EXT compiler:keep-source
 * (compiler:keep-source)
 * (compiler:keep-source bool)
 *
 * This parameter controls if the source of a user procedure is kept
 * at runtime. The source of a procedure can be accessed with the primitive
 * <<"procedure-source">>.
 * Default value for |compiler:keep-source| is `#f`.
 *
 * @lisp
 * > (compiler:keep-source #t)
 * > (define fib
 *      (lambda (n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))))
 * > (pretty-print (procedure-source fib))
 * (lambda (n)
 *   (if (< n 2)
 *     n
 *     (+ (fib (- n 1))
 *        (fib (- n 2)))))
 * @end lisp
doc>
<doc EXT compiler:unroll-iterations
 * (compiler:unroll-iterations)
 * (compiler:unroll-iterations n)
 *
 * This parameter controls the number of iterations to be unrolled in
 * loops. Currently, only |repeat| loops are unrolled. The argument
 * |n| must be a positive integer.
doc>
<doc EXT compiler:peephole-optimizer
 * (compiler:peephole-optimizer)
 * (compiler:peephole-optimizer bool)
 *
 * This parameter determines if the peephole optimizer is used when compiling.
 * The default value for this parameter is `#t`. The next example illustrates
 * how it works.
 *
 * @lisp
 * (compiler:peephole-optimizer #f)
 * (disassemble-expr '(+ a #f) #t)
 * @end lisp
 * will print
 * @lisp
 * 000:  GLOBAL-REF           0
 * 002:  PUSH
 * 003:  IM-FALSE
 * 004:  IN-ADD2
 * 005:
 * @end lisp
 * Now, if we change the parameter,
 * @lisp
 * (compiler:peephole-optimizer #t)
 * (disassemble-expr '(+ a #f) #t)
 * then the result is
 * @lisp
 * 000:  GLOBAL-REF-PUSH      0
 * 002:  IM-FALSE
 * 003:  IN-ADD2
 * 004:
 * @end lisp
 * See that the `GLOBAL-REF` and `PUSH` were turned by the peephole optimizer
 * into `GLOBAL-REF-PUSH`.
doc>
<doc EXT compiler:source-rewrite
 * (compiler:source-rewrite)
 * (compiler:source-rewrite bool)
 *
 * This parameter determines if compiler tries to rewrite some expressions in
 * simpler ones. For instance, it permit to eliminate the unneeded expression
 * in a |begin| form, or to evaluate some simple expression. For instance,
 * @lisp
 * (begin 100 foo (display "Hello") "Hi" (not #f))
 * @end lisp
 * is rewritten in
 * @lisp
 * (begin (display "Hello") #t)
 * @end lisp
 * This parameter defaults to `#t`. 
doc>
|#
(define-parameter compiler:time-display                   #t)
(define-parameter compiler:gen-line-number                #f)
(define-parameter compiler:warn-use-undefined             #f)
(define-parameter compiler:warn-use-undefined-postpone    #t)
(define-parameter compiler:show-assembly-code             #f)
(define-parameter compiler:keep-formals                   #f)
(define-parameter compiler:keep-source                    #f)
(define-parameter compiler:peephole-optimizer             #t)
(define-parameter compiler:source-rewrite                 #t)
(define-parameter compiler:unroll-iterations 4
  (lambda (v)
    (unless (and (fixnum? v) (positive? v))
      (error 'compiler:unroll-iterations
             "must be a positive fixnum. It was ~s" v))
    v))

(define compiler:inline-common-functions
  (let* ((inlined-math-commutative *inline-math-commutative*)
         (inlined-math-general     *inline-math-general*)
         (inlined-math             *inline-math*)
         (inlined-general          *inline-general*)
         (res (make-parameter
               #t
               (lambda (v)
                 (set! *inline-math-commutative* (if v inlined-math-commutative '()))
                 (set! *inline-math-general*     (if v inlined-math-general     '()))
                 (set! *inline-math*             (if v inlined-math             '()))
                 (set! *inline-general*          (if v inlined-general          '()))
                 (set! *inline-table*            (append *inline-math*
                                                         *inline-general*))
                 (not (null? *inline-table*))))))
    (%set-parameter-name! res 'compiler:inline-common-functions)
    res))


;; ----------------------------------------------------------------------
;;      %compiler-set-flags ...
;; ----------------------------------------------------------------------
(define (%compiler-set-flags str-flags)
  ;; str-flags is something like "+xxx,-yyy,+zzz,www=42"
  (with-handler (lambda (c)
                  ;; when flags are analysed we don't hav set a handler
                  (eprintf "Fatal error: ~a\nABORT\n" (condition-message c))
                  (emergency-exit 1))
    (for-each (lambda (flag)
                (let ((sign (string-ref flag 0)))
                  (if (memv sign '(#\+ #\-))
                      ;; boolean flag
                      (let ((opt (substring flag 1 (string-length flag)))
                            (val  (char=? sign #\+)))
                        (case (string->symbol opt)
                          ((line-info)         (compiler:gen-line-number val))
                          ((time-display)      (compiler:time-display val))
                          ((keep-formals)      (compiler:generate-signature val))
                          ((keep-source)       (compiler:keep-source val))
                          ((inline-usuals)     (compiler:inline-common-functions val))
                          ((source-rewrite)    (compiler:source-rewrite val))
                          ((show-instructions) (compiler:show-assembly-code val))
                          ((peephole-optimizer)(compiler:peephole-optimizer val))
                          (else (error "bad boolean flag ~s" flag))))
                      ;; valued flag
                      (let* ((lst  (string-split flag "=")))
                        (if (= (length lst) 2)
                            (let ((f (string->symbol (car lst)))
                                  (v (string->number (cadr lst))))
                              (case f
                                ((unroll-iterations)
                                 (if v
                                     (compiler:unroll-iterations v)
                                     (error "bad value for unroll-iteration ~s"
                                            (cadr lst))))
                                (else
                                 (error "bad flag name ~s" f))))
                            (error "bad valued flag ~s" flag))))))
              (string-split str-flags ","))))
