c-platform.scm

Scheme跨平台编译器

;;;; c-platform.scm - Platform specific parameters and definitions
;
; Copyright (c) 2000-2007, Felix L. Winkelmann
; Copyright (c) 2008, The Chicken Team
; All rights reserved.
;
; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
; conditions are met:
;
;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
;     disclaimer. 
;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
;     disclaimer in the documentation and/or other materials provided with the distribution. 
;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
;     products derived from this software without specific prior written permission. 
;
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
; POSSIBILITY OF SUCH DAMAGE.


(declare (unit platform))


(private compiler
  compiler-arguments process-command-line
  default-standard-bindings default-extended-bindings side-effecting-standard-bindings
  non-foldable-standard-bindings foldable-standard-bindings non-foldable-extended-bindings foldable-extended-bindings
  standard-bindings-that-never-return-false side-effect-free-standard-bindings-that-never-return-false
  installation-home debugging
  dump-nodes
  unit-name insert-timer-checks used-units inlining
  foreign-declarations block-compilation line-number-database-size
  target-heap-size target-stack-size 
  default-default-target-heap-size default-default-target-stack-size verbose-mode original-program-size
  current-program-size line-number-database-2 foreign-lambda-stubs immutable-constants foreign-variables
  rest-parameters-promoted-to-vector inline-table inline-table-used constant-table constants-used mutable-constants
  broken-constant-nodes inline-substitutions-enabled
  direct-call-ids foreign-type-table first-analysis
  initialize-compiler canonicalize-expression expand-foreign-lambda update-line-number-database scan-toplevel-assignments
  perform-cps-conversion analyze-expression simplifications perform-high-level-optimizations perform-pre-optimization!
  reorganize-recursive-bindings substitution-table simplify-named-call find-inlining-candidates perform-inlining!
  perform-closure-conversion prepare-for-code-generation compiler-source-file create-foreign-stub expand-foreign-lambda*
  transform-direct-lambdas! decompose-lambda-list rewrite
  debugging-chicken bomb check-signature posq stringify symbolify build-lambda-list
  string->c-identifier c-ify-string words check-and-open-input-file close-checked-input-file fold-inner constant?
  collapsable-literal? immediate? canonicalize-begin-body extract-mutable-constants string->expr get get-all
  put! collect! count! get-line get-line-2 find-lambda-container display-analysis-database varnode qnode 
  build-node-graph build-expression-tree fold-boolean inline-lambda-bindings match-node expression-has-side-effects?
  simple-lambda-node? compute-database-statistics print-program-statistics output gen gen-list 
  pprint-expressions-to-file foreign-type-check estimate-foreign-result-size scan-used-variables scan-free-variables
  topological-sort print-version print-usage initialize-analysis-database
  default-declarations default-debugging-declarations units-used-by-default words-per-flonum
  parameter-limit eq-inline-operator optimizable-rest-argument-operators
  membership-test-operators membership-unfold-limit valid-compiler-options valid-compiler-options-with-argument
  target-include-file default-profiling-declarations
  default-optimization-passes internal-bindings big-fixnum?
  generate-code make-variable-list make-argument-list generate-foreign-stubs foreign-type-declaration
  foreign-argument-conversion foreign-result-conversion)


(include "tweaks")


;;; Parameters:

(define default-optimization-passes 3)

(define default-declarations
  '((always-bound
     ##sys#standard-input ##sys#standard-output ##sys#standard-error)
    (bound-to-procedure
     ##sys#for-each ##sys#map ##sys#print ##sys#setter
     ##sys#setslot ##sys#dynamic-wind ##sys#call-with-values ##sys#match-error
     ##sys#start-timer ##sys#stop-timer ##sys#gcd ##sys#lcm ##sys#make-promise ##sys#structure? ##sys#slot 
     ##sys#allocate-vector ##sys#list->vector ##sys#block-ref ##sys#block-set!
     ##sys#list ##sys#cons ##sys#append ##sys#vector ##sys#foreign-char-argument ##sys#foreign-fixnum-argument
     ##sys#foreign-flonum-argument ##sys#error ##sys#peek-c-string ##sys#peek-nonnull-c-string 
     ##sys#peek-and-free-c-string ##sys#peek-and-free-nonnull-c-string
     ##sys#foreign-block-argument ##sys#foreign-string-argument ##sys#foreign-pointer-argument ##sys#foreign-integer-argument
     ##sys#call-with-current-continuation) ) )

(define default-debugging-declarations
  '((##core#declare
      '(uses debugger)
      '(bound-to-procedure
	##sys#push-debug-frame ##sys#pop-debug-frame ##sys#check-debug-entry ##sys#check-debug-assignment
	##sys#register-debug-lambdas ##sys#register-debug-variables ##sys#debug-call) ) ) )

(define default-profiling-declarations
  '((##core#declare
     '(uses profiler)
     '(bound-to-procedure
       ##sys#profile-entry ##sys#profile-exit) ) ) )

(define units-used-by-default '(library eval data-structures ports extras srfi-69)) 
(define words-per-flonum 4)
(define parameter-limit 1024)
(define small-parameter-limit 128)

(define eq-inline-operator "C_eqp")
(define optimizable-rest-argument-operators '(car cadr caddr cadddr length pair? null? list-ref))
(define membership-test-operators
  '(("C_i_memq" . "C_eqp") ("C_u_i_memq" . "C_eqp") ("C_i_member" . "C_i_equalp")
    ("C_i_memv" . "C_i_eqvp") ) )
(define membership-unfold-limit 20)
(define target-include-file "chicken.h")

(define valid-compiler-options
  '(-help h help version verbose explicit-use quiet no-trace no-warnings unsafe block
    check-syntax to-stdout no-usual-integrations case-insensitive no-lambda-info 
    profile inline keep-shadowed-macros
    fixnum-arithmetic disable-interrupts optimize-leaf-routines check-imports
    lambda-lift run-time-macros tag-pointers accumulate-profile
    disable-stack-overflow-checks disable-c-syntax-checks unsafe-libraries raw 
    emit-external-prototypes-first release disable-compiler-macros
    analyze-only dynamic extension) )

(define valid-compiler-options-with-argument
  '(debug output-file include-path heap-size stack-size unit uses keyword-style require-extension 
	  inline-limit profile-name disable-warning emit-exports import
    prelude postlude prologue epilogue nursery extend feature 
    compress-literals			; DEPRECATED
    heap-growth heap-shrinkage heap-initial-size ffi-define ffi-include-path) )


;;; Standard and extended bindings:

(define default-standard-bindings
  '(not boolean? apply call-with-current-continuation eq? eqv? equal? pair? cons car cdr caar cadr
    cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar
    cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr set-car! set-cdr!
    null? list list? length zero? * - + / - > < >= <= = current-output-port current-input-port
    write-char newline write display append symbol->string for-each map char? char->integer
    integer->char eof-object? vector-length string-length string-ref string-set! vector-ref 
    vector-set! char=? char<? char>? char>=? char<=? gcd lcm reverse symbol? string->symbol
    number? complex? real? integer? rational? odd? even? positive? negative? exact? inexact?
    max min quotient remainder modulo floor ceiling truncate round exact->inexact inexact->exact
    exp log sin expt sqrt cos tan asin acos atan number->string string->number char-ci=?
    char-ci<? char-ci>? char-ci>=? char-ci<=? char-alphabetic? char-whitespace? char-numeric?
    char-lower-case? char-upper-case? char-upcase char-downcase string? string=? string>? string<?
    string>=? string<=? string-ci=? string-ci<? string-ci>? string-ci<=? string-ci>=?
    string-append string->list list->string vector? vector->list list->vector string read
    read-char substring string-fill! vector-fill! make-string make-vector open-input-file
    open-output-file call-with-input-file call-with-output-file close-input-port close-output-port
    values call-with-values vector procedure? memq memv member assq assv assoc list-tail
    list-ref abs char-ready? peek-char list->string string->list) )

(define default-extended-bindings
  '(bitwise-and bitwise-ior bitwise-xor bitwise-not add1 sub1 fx+ fx- fx* fx/ fxmod
    fx= fx> fx< fx>= fx<= fixnum? fxneg fxmax fxmin identity fp+ fp- fp* fp/ fpmin fpmax fpneg
    fp> fp< fp= fp>= fp<= fxand fxnot fxior fxxor fxshr fxshl bit-set?
    arithmetic-shift void flush-output thread-specific thread-specific-set!
    not-pair? atom? null-list? print print* error cpu-time proper-list? call/cc
    u8vector->byte-vector s8vector->byte-vector u16vector->byte-vector s16vector->byte-vector ; DEPRECATED
    u32vector->byte-vector s32vector->byte-vector byte-vector-length ; DEPRECATED
    f32vector->byte-vector f64vector->byte-vector byte-vector-ref byte-vector-set! ; DEPRECATED
    blob-size u8vector->blob/shared s8vector->blob/shared u16vector->blob/shared
    s16vector->blob/shared u32vector->blob/shared s32vector->blob/shared
    f32vector->blob/shared f64vector->blob/shared
    blob->u8vector/shared blob->s8vector/shared blob->u16vector/shared
    blob->s16vector/shared blob->u32vector/shared blob->s32vector/shared
    blob->f32vector/shared blob->f64vector/shared
    block-ref block-set! number-of-slots substring-index substring-index-ci
    hash-table-ref any? read-string substring=? substring-ci=?
    first second third fourth make-record-instance
    u8vector-length s8vector-length u16vector-length s16vector-length u32vector-length s32vector-length
    f32vector-length f64vector-length setter
    u8vector-ref s8vector-ref u16vector-ref s16vector-ref u32vector-ref s32vector-ref
    f32vector-ref f64vector-ref
    u8vector-set! s8vector-set! u16vector-set! s16vector-set! u32vector-set! s32vector-set!
    locative-ref locative-set! locative->object locative? global-ref
    null-pointer? pointer->object flonum? finite?) )

(define internal-bindings
  '(##sys#slot ##sys#setslot ##sys#block-ref ##sys#block-set!
    ##sys#call-with-current-continuation ##sys#size ##sys#byte ##sys#setbyte
    ##sys#pointer? ##sys#generic-structure? ##sys#structure? ##sys#check-structure
    ##sys#check-exact ##sys#check-number ##sys#check-list ##sys#check-pair ##sys#check-string ##sys#check-symbol 
    ##sys#check-char ##sys#check-vector ##sys#check-byte-vector ##sys#list ##sys#cons
    ##sys#call-with-values ##sys#fits-in-int? ##sys#fits-in-unsigned-int? ##sys#flonum-in-fixnum-range? 
    ##sys#fudge ##sys#immediate? ##sys#direct-return ##sys#context-switch
    ##sys#make-structure ##sys#apply ##sys#apply-values ##sys#continuation-graft
    ##sys#bytevector? ##sys#make-vector ##sys#setter
    ##sys#foreign-char-argument ##sys#foreign-fixnum-argument ##sys#foreign-flonum-argument
    ##sys#foreign-block-argument ##sys#foreign-number-vector-argument
    ##sys#foreign-string-argument ##sys#foreign-pointer-argument ##sys#void
    ##sys#foreign-integer-argument ##sys#foreign-unsigned-integer-argument ##sys#double->number
    ##sys#peek-fixnum ##sys#setislot ##sys#poke-integer ##sys#permanent? ##sys#values ##sys#poke-double
    ##sys#intern-symbol ##sys#make-symbol ##sys#null-pointer? ##sys#peek-byte) )

(define side-effecting-standard-bindings
  '(apply call-with-current-continuation set-car! set-cdr! write-char newline write display
    peek-char char-ready?
    read read-char for-each map string-set! vector-set! string-fill! vector-fill! open-input-file
    open-output-file close-input-port close-output-port call-with-input-port call-with-output-port
    call-with-values eval) )

(define non-foldable-standard-bindings
  '(vector cons list string make-vector make-string string->symbol values current-input-port current-output-port
	   read-char write-char) )

(define foldable-standard-bindings
  (lset-difference 
   eq? default-standard-bindings 
   side-effecting-standard-bindings non-foldable-standard-bindings) )

(define non-foldable-extended-bindings
  '(##sys#slot ##sys#setslot ##sys#call-with-current-continuation ##sys#fudge flush-output print void
    u8vector->byte-vector s8vector->byte-vector u16vector->byte-vector s16vector->byte-vector u32vector->byte-vector ; DEPRECATED
    f32vector->byte-vector f64vector->byte-vector s32vector->byte-vector ;DEPRECATED
    u8vector->blob/shared s8vector->blob/shared u16vector->blob/shared s16vector->blob/shared u32vector->blob/shared
    f32vector->blob/shared f64vector->blob/shared
    s32vector->blob/shared read-string read-string!
    ##sys#make-structure print* ##sys#make-vector ##sys#apply ##sys#setislot ##sys#block-ref
    ##sys#byte ##sys#setbyte 
    byte-vector-ref byte-vector-set!	; DEPRECATED
    u8vector-length s8vector-length u16vector-length s16vector-length u32vector-length s32vector-length
    f32vector-length f64vector-length ##sys#apply-values ##sys#setter setter
    u8vector-ref s8vector-ref u16vector-ref s16vector-ref u32vector-ref s32vector-ref
    u8vector-set! s8vector-set! u16vector-set! s16vector-set! u32vector-set! s32vector-set!
    ##sys#intern-symbol ##sys#make-symbol make-record-instance error cpu-time ##sys#block-set!) )

(define foldable-extended-bindings
  (lset-difference
   eq? default-extended-bindings non-foldable-extended-bindings) )

(define standard-bindings-that-never-return-false
  '(cons list length * - + / current-output-port current-input-port append symbol->string char->integer
    integer->char vector-length string-length string-ref gcd lcm reverse string->symbol max min
    quotient remainder modulo floor ceiling truncate round exact->inexact inexact->exact exp log sin
    cons tan atan expt sqrt asin acos number->string char-upcase char-downcase string-append string
    string->list list->string vector->list list->vector read-char substring make-string make-vector
    open-input-file open-output-file vector write-char) )

(define side-effect-free-standard-bindings-that-never-return-false
  (lset-difference
   eq? standard-bindings-that-never-return-false
   side-effecting-standard-bindings) )


;;; Rewriting-definitions for this platform:

(rewrite '+ 19 0 "C_fixnum_plus" "C_u_fixnum_plus" #f)

(rewrite
 '* 8 
 (lambda (db classargs cont callargs)
   ;; (*) -> 1
   ;; (* <x>) -> <x>
   ;; (* <x1> ...) -> (##core#inline "C_fixnum_times" <x1> (##core#inline "C_fixnum_times" ...)) [fixnum-mode]
   ;; - Remove "1" from arguments.
   ;; - Replace multiplications with 2 by shift left. [fixnum-mode]
   (let ([callargs 
	  (remove
	   (lambda (x)
	     (and (eq? 'quote (node-class x))
		  (= 1 (first (node-parameters x))) ) ) 
	   callargs) ] )
     (cond [(null? callargs) (make-node '##core#call '(#t) (list cont (qnode 0)))]
	   [(null? (cdr callargs))
	    (make-node '##core#call '(#t) (list cont (first callargs))) ]
	   [(eq? number-type 'fixnum)
	    (make-node 
	     '##core#call '(#t)
	     (list
	      cont
	      (fold-inner