4050 lines
215 KiB
Racket
4050 lines
215 KiB
Racket
(module xform mzscheme
|
|
(require mzlib/list
|
|
mzlib/etc
|
|
mzlib/process)
|
|
|
|
(provide xform)
|
|
|
|
(define (xform quiet?
|
|
cpp
|
|
file-in
|
|
file-out
|
|
keep-lines?
|
|
palm? pgc? pgc-really?
|
|
precompiling-header? precompiled-header
|
|
show-info? output-depends-info?
|
|
gc-variable-stack-through-funcs?)
|
|
(parameterize ([current-output-port (current-output-port)] ; because we mutate these...
|
|
[error-escape-handler (error-escape-handler)]
|
|
[current-inspector (current-inspector)])
|
|
(begin-with-definitions
|
|
(define power-inspector (current-inspector))
|
|
(current-inspector (make-inspector))
|
|
|
|
(define check-arith? #t)
|
|
|
|
;; Selects whether to reset GC_variable_stack on return,
|
|
;; or to just reset it on every call.
|
|
(define callee-restore? #t)
|
|
|
|
(define palm-out #f)
|
|
|
|
(define (filter-false s)
|
|
(if (equal? s "-")
|
|
#f
|
|
s))
|
|
|
|
(define source-is-c++? (regexp-match #rx"([.]cc$)|([.]cxx$)" file-in))
|
|
|
|
(define (change-suffix filename new)
|
|
(path-replace-suffix filename new))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; "AST" structures
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define-struct tok (n line file) (make-inspector))
|
|
(define-struct (sysheader-tok tok) ())
|
|
(define-struct (seq tok) (close in) (make-inspector))
|
|
(define-struct (parens seq) () (make-inspector))
|
|
(define-struct (brackets seq) ())
|
|
(define-struct (braces seq) ())
|
|
(define-struct (callstage-parens parens) ())
|
|
(define-struct (creation-parens parens) ())
|
|
(define-struct (nosrc-parens parens) ())
|
|
(define-struct (call tok) (func args live tag nonempty?)) ;; a converted function call
|
|
(define-struct (block-push tok) (vars tag super-tag top?))
|
|
(define-struct (note tok) (s))
|
|
|
|
(define-struct (nested-setup tok) ())
|
|
(define nested-pushable (make-nested-setup 'nested #f #f))
|
|
(define no-nested-pushable (make-nested-setup 'no-nested #f #f))
|
|
(define undefine-nested-pushable (make-nested-setup 'undefine #f #f))
|
|
|
|
(define-struct pragma (s file line))
|
|
|
|
;; For very long lists, it's worth the effort to use a vector instead
|
|
;; of a list to save space:
|
|
(define (seq->list s) (if (vector? s) (vector->list s) s))
|
|
(define (list->seq s) (if (or (null? s) (null? (cdr s)) (null? (cddr s)))
|
|
s
|
|
(list->vector s)))
|
|
(define seqce vector)
|
|
|
|
;; A cheap way of getting rid of unneeded prototypes:
|
|
(define used-symbols (make-hash-table))
|
|
(hash-table-put! used-symbols (string->symbol "GC_variable_stack") 1)
|
|
(hash-table-put! used-symbols (string->symbol "GC_cpp_delete") 1)
|
|
(hash-table-put! used-symbols (string->symbol "GC_get_variable_stack") 1)
|
|
(hash-table-put! used-symbols (string->symbol "GC_set_variable_stack") 1)
|
|
(hash-table-put! used-symbols (string->symbol "memset") 1)
|
|
(hash-table-put! used-symbols (string->symbol "scheme_thread_local_key") 1)
|
|
(hash-table-put! used-symbols (string->symbol "scheme_thread_locals") 1)
|
|
(hash-table-put! used-symbols (string->symbol "pthread_getspecific") 1)
|
|
|
|
;; For dependency tracking:
|
|
(define depends-files (make-hash-table 'equal))
|
|
|
|
(define (make-triple v src line sysheader?)
|
|
(when (symbol? v)
|
|
(hash-table-put! used-symbols v
|
|
(add1 (hash-table-get
|
|
used-symbols
|
|
v
|
|
(lambda () 0)))))
|
|
(when (and src output-depends-info?)
|
|
(hash-table-put! depends-files src #t))
|
|
(if sysheader?
|
|
(make-sysheader-tok v line src)
|
|
(make-tok v line src)))
|
|
|
|
(define (make-a-seq opener src line body)
|
|
((case opener
|
|
[(#\() make-parens]
|
|
[(#\[) make-brackets]
|
|
[(#\{) make-braces])
|
|
(case opener
|
|
[(#\() "("]
|
|
[(#\[) "["]
|
|
[(#\{) "{"])
|
|
line
|
|
src
|
|
(case opener
|
|
[(#\() ")"]
|
|
[(#\[) "]"]
|
|
[(#\{) "}"])
|
|
(list->seq body)))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Tokenizer
|
|
;; Relies on make-triple, make-a-seq, and make-pragma
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (trans pattern)
|
|
(byte-regexp (string->bytes/utf-8 (format "^(~a)" pattern))))
|
|
|
|
(define (translations . t)
|
|
(let loop ([t t])
|
|
(if (null? t)
|
|
null
|
|
(let ([pattern (car t)]
|
|
[result (cadr t)])
|
|
(cons (cons (trans pattern)
|
|
result)
|
|
(loop (cddr t)))))))
|
|
|
|
(define (a-regexp-match-positions re s p)
|
|
(regexp-match-positions re s p))
|
|
|
|
(define seqs string-append)
|
|
(define startseq seqs)
|
|
(define (arbno s) (format "(?:~a)*" s))
|
|
(define (arbno/ s) (format "~a*" s))
|
|
(define (one+ s) (format "(?:~a)+" s))
|
|
(define (one+/ s) (format "~a+" s))
|
|
(define (maybe s) (format "(?:~a)?" s))
|
|
(define (maybe/ s) (format "~a?" s))
|
|
(define (alt a b) (format "~a|~a" a b))
|
|
(define (alt* . l)
|
|
(let loop ([l l])
|
|
(if (null? (cdr l))
|
|
(format "(?:~a)" (car l))
|
|
(format "(?:~a)|~a" (car l) (loop (cdr l))))))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (line-comment s p)
|
|
(let loop ([p (add1 p)])
|
|
(let ([c (bytes-ref s p)])
|
|
(if (or (equal? c 10)
|
|
(equal? c 13))
|
|
(add1 p)
|
|
(loop (add1 p))))))
|
|
|
|
(define re:line #rx#"^#[^\n\r]* ([0-9]+) \"([^\"]*)\"([^\r\n]*)" )
|
|
(define re:pragma #rx#"^#pragma ([^\r\n]*)")
|
|
|
|
(define (do-cpp s p)
|
|
(let ([m (regexp-match re:line s p)])
|
|
(when m
|
|
(set! source-line (string->number (bytes->string/utf-8 (cadr m))))
|
|
(set! source-file (caddr m))
|
|
(set! source-sysheader? (regexp-match? #px#"\\b3\\b" (cadddr m)))))
|
|
(let ([pragma (regexp-match re:pragma s p)])
|
|
(if (and pragma
|
|
(not (regexp-match-positions re:boring (car pragma))))
|
|
(values (make-pragma (cadr pragma) source-file source-line) (line-comment s p))
|
|
(values #f (line-comment s p)))))
|
|
|
|
(define (result s)
|
|
(make-triple
|
|
s
|
|
source-file
|
|
source-line
|
|
source-sysheader?))
|
|
|
|
(define (symbol s)
|
|
(result (string->symbol (bytes->string/utf-8 s))))
|
|
|
|
(define re:octal #rx#"^0[0-9]+$")
|
|
(define re:int #rx#"^[0-9]*$")
|
|
(define (number s)
|
|
(result
|
|
(cond
|
|
[(regexp-match-positions re:octal s)
|
|
(string->number (bytes->string/utf-8 s) 8)]
|
|
[(regexp-match-positions re:int s)
|
|
(string->number (bytes->string/utf-8 s))]
|
|
[else (string->symbol (bytes->string/utf-8 s))])))
|
|
|
|
(define (character s)
|
|
(count-newlines s)
|
|
(symbol s))
|
|
|
|
(define (character? s)
|
|
(and (symbol? s)
|
|
(regexp-match #rx"'[\\]?.'" (symbol->string s))))
|
|
|
|
(define (mk-string s)
|
|
(count-newlines s)
|
|
(result (bytes->string/utf-8 (subbytes s 1 (sub1 (bytes-length s))))))
|
|
|
|
(define (start s)
|
|
'start)
|
|
|
|
(define (stop s)
|
|
#f)
|
|
|
|
(define (count-newlines s)
|
|
(let loop ([p (sub1 (bytes-length s))])
|
|
(unless (= p -1)
|
|
(when (= 10 (bytes-ref s p))
|
|
(set! source-line (add1 source-line)))
|
|
(loop (sub1 p)))))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define D "[0-9]")
|
|
(define L "[a-zA-Z_]")
|
|
(define H "[a-fA-F0-9]")
|
|
(define E (format "[Ee][+-]?~a+" D))
|
|
(define FS "(?:f|F|l|L)")
|
|
(define IS "(?:u|U|l|L)*")
|
|
|
|
(define symbol-complex (trans (seqs L (arbno (alt L D)))))
|
|
|
|
(define number-complex
|
|
(trans (alt*
|
|
(seqs (arbno/ D) "[.]" (one+/ D) (maybe E) (maybe/ FS))
|
|
(seqs (one+/ D) "[.]" (arbno D) (maybe E) (maybe/ FS))
|
|
(seqs (one+/ D) E (maybe/ FS))
|
|
|
|
"0x1[.]0p2047" ;; strange thing in huge_val.h
|
|
|
|
(seqs "0" "[xX]" (one+/ H) IS) ;; hex
|
|
(seqs "0" (one+/ D) IS) ;; octal
|
|
(seqs (one+/ D) IS)))) ;; integer
|
|
|
|
(define char-complex (trans (seqs (maybe L) "'([^\\']|\\\\.)+'")))
|
|
(define string-complex (trans (seqs (maybe L) "\"([^\\\"]|\\\\.)*\"")))
|
|
|
|
(define simple-table (make-vector 256 #f))
|
|
|
|
(define (simple-translations . l)
|
|
(let loop ([l l])
|
|
(unless (null? l)
|
|
(loop (cddr l))
|
|
(let* ([pattern (car l)]
|
|
[result (cadr l)]
|
|
[n (bytes-ref pattern 0)])
|
|
(vector-set! simple-table
|
|
n
|
|
(cons
|
|
(list* pattern (bytes-length pattern)
|
|
result)
|
|
(or
|
|
(vector-ref simple-table n)
|
|
null)))))))
|
|
|
|
(simple-translations
|
|
#"#" symbol
|
|
#"##" symbol
|
|
#"..." symbol
|
|
#">>=" symbol
|
|
#"<<=" symbol
|
|
#"+=" symbol
|
|
#"-=" symbol
|
|
#"*=" symbol
|
|
#"/=" symbol
|
|
#"%=" symbol
|
|
#"&=" symbol
|
|
#"^=" symbol
|
|
#"|=" symbol
|
|
#">>" symbol
|
|
#"<<" symbol
|
|
#"++" symbol
|
|
#"--" symbol
|
|
#"->" symbol
|
|
#"&&" symbol
|
|
#"||" symbol
|
|
#"<=" symbol
|
|
#">=" symbol
|
|
#"==" symbol
|
|
#"!=" symbol
|
|
#";" symbol
|
|
#"{" start
|
|
#"}" stop
|
|
#"," symbol
|
|
#"::" symbol
|
|
#":" symbol
|
|
#"=" symbol
|
|
#"(" start
|
|
#")" stop
|
|
#"[" start
|
|
#"]" stop
|
|
#"." #f ; => symbol/num
|
|
#"&" symbol
|
|
#"!" symbol
|
|
#"~" symbol
|
|
#"-" #f ; => symbol/num
|
|
#"+" #f ; => symbol/num
|
|
#"*" symbol
|
|
#"/" symbol
|
|
#"%" symbol
|
|
#"<" symbol
|
|
#">" symbol
|
|
#"^" symbol
|
|
#"|" symbol
|
|
#"?" symbol)
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define source-file #f)
|
|
(define source-line 0)
|
|
(define source-sysheader? #f)
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (read-all p)
|
|
(let loop ([l null])
|
|
(let ([s (read-bytes 4096 p)])
|
|
(if (eof-object? s)
|
|
(apply bytes-append (reverse l))
|
|
(loop (cons s l))))))
|
|
|
|
(define (tokenize)
|
|
(let* ([s (read-all (current-input-port))]
|
|
[len (bytes-length s)])
|
|
(let loop ([p 0][result null])
|
|
(if (= p len)
|
|
(cons (reverse result) p)
|
|
(let ([char (bytes-ref s p)])
|
|
(when (eq? char 10)
|
|
(set! source-line (add1 source-line)))
|
|
(cond
|
|
[(char-whitespace? (integer->char char))
|
|
(loop (add1 p) result)]
|
|
[(eq? char (char->integer #\#)) ;; We assume only #-based preprocessor left
|
|
(let-values ([(pragma p) (do-cpp s p)])
|
|
(if pragma
|
|
(loop p (cons pragma result))
|
|
(loop p result)))]
|
|
[else
|
|
(let ([simple (let ([sl (vector-ref simple-table char)])
|
|
(and sl
|
|
(ormap
|
|
(lambda (t)
|
|
(and (or (= 1 (cadr t))
|
|
(bytes=? (car t) (subbytes s p (+ p (cadr t)))))
|
|
(let ([f (cddr t)])
|
|
(if f
|
|
(cons (f (car t))
|
|
(+ p (cadr t)))
|
|
(let ([m (regexp-match-positions number-complex s p)])
|
|
(if m
|
|
(cons (number (subbytes s (caar m) (cdar m)))
|
|
(cdar m))
|
|
(cons (symbol (car t))
|
|
(+ p (cadr t)))))))))
|
|
sl)))])
|
|
(cond
|
|
[(not simple)
|
|
(cond
|
|
[(regexp-match-positions symbol-complex s p)
|
|
=> (lambda (m)
|
|
(loop (cdar m)
|
|
(cons (symbol (subbytes s (caar m) (cdar m)))
|
|
result)))]
|
|
[(regexp-match-positions number-complex s p)
|
|
=> (lambda (m)
|
|
(loop (cdar m)
|
|
(cons (number (subbytes s (caar m) (cdar m)))
|
|
result)))]
|
|
[(regexp-match-positions char-complex s p)
|
|
=> (lambda (m)
|
|
(loop (cdar m)
|
|
(cons (character (subbytes s (caar m) (cdar m)))
|
|
result)))]
|
|
[(regexp-match-positions string-complex s p)
|
|
=> (lambda (m)
|
|
(loop (cdar m)
|
|
(cons (mk-string (subbytes s (caar m) (cdar m)))
|
|
result)))]
|
|
[else
|
|
(error 'c-tokenize "strange: ~e ~e" p (subbytes s p (min len (+ p 100))))])]
|
|
[(not (car simple))
|
|
(cons (reverse result) (cdr simple))]
|
|
[(eq? (car simple) 'start)
|
|
(let ([sf source-file]
|
|
[sl source-line]
|
|
[sub (loop (cdr simple) null)])
|
|
(loop (cdr sub) (cons (make-a-seq
|
|
(integer->char (bytes-ref s p))
|
|
sf
|
|
sl
|
|
(car sub))
|
|
result)))]
|
|
[simple
|
|
(loop (cdr simple) (cons (car simple) result))]))]))))))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Pre-process and S-expr-ize
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (verbose f)
|
|
(if quiet?
|
|
f
|
|
(lambda args
|
|
(printf "xform-cpp: ~a\n" args)
|
|
(apply f args))))
|
|
|
|
;; To run cpp:
|
|
(define process2
|
|
(if (eq? (system-type) 'windows)
|
|
(lambda (s)
|
|
(let ([split (let loop ([s s])
|
|
(let ([m (regexp-match #rx"([^ ]*) (.*)" s)])
|
|
(if m
|
|
(cons (cadr m) (loop (caddr m)))
|
|
(list s))))])
|
|
(apply (verbose process*) (find-executable-path (car split) #f)
|
|
(cdr split))))
|
|
(verbose process)))
|
|
|
|
(define cpp-process
|
|
(if (string? cpp)
|
|
(process2 (format "~a~a~a ~a"
|
|
cpp
|
|
(if pgc?
|
|
(if pgc-really?
|
|
" -DMZ_XFORM -DMZ_PRECISE_GC"
|
|
" -DMZ_XFORM")
|
|
"")
|
|
(if callee-restore? " -DGC_STACK_CALLEE_RESTORE" "")
|
|
file-in))
|
|
(apply (verbose process*)
|
|
(append
|
|
cpp
|
|
(if pgc-really?
|
|
'("-DMZ_XFORM" "-DMZ_PRECISE_GC")
|
|
'("-DMZ_XFORM"))
|
|
(if callee-restore?
|
|
'("-DGC_STACK_CALLEE_RESTORE")
|
|
null)
|
|
(list file-in)))))
|
|
(close-output-port (cadr cpp-process))
|
|
|
|
(define (mk-error-thread proc)
|
|
(thread (lambda ()
|
|
(let loop ()
|
|
(let ([l (read-bytes-line (list-ref proc 3) 'any)])
|
|
(unless (eof-object? l)
|
|
(fprintf (current-error-port) "~a\n" l)
|
|
(loop))))
|
|
(close-input-port (list-ref proc 3)))))
|
|
|
|
(define cpp-error-thread (mk-error-thread cpp-process))
|
|
|
|
;; Pipe cpp results through here; we insert a filter
|
|
;; between the pipe ends.
|
|
(define-values (local-ctok-read local-ctok-write)
|
|
(make-pipe 100000))
|
|
|
|
(define recorded-cpp-out
|
|
(and precompiling-header?
|
|
(open-output-file (change-suffix file-out #".e") 'truncate)))
|
|
(define recorded-cpp-in
|
|
(and precompiled-header
|
|
(open-input-file (change-suffix precompiled-header #".e"))))
|
|
(define re:boring #rx#"^(?:(?:[ \t]*)|(?:# .*)|(?:#line .*)|(?:#pragma implementation.*)|(?:#pragma interface.*)|(?:#pragma once)|(?:#pragma warning.*)|(?:#ident.*))$")
|
|
(define re:uninteresting #rx#"^(?:(?:[ \t]*)|(?:# .*)|(?:#line .*)|(?:#pragma implementation.*)|(?:#pragma interface.*)|(?:#pragma once)|(?:#pragma GCC diagnostic.*)|(?:#pragma warning.*)|(?:#ident.*))$")
|
|
(define (skip-to-interesting-line p)
|
|
(let ([l (read-bytes-line p 'any)])
|
|
(cond
|
|
[(eof-object? l) l]
|
|
[(regexp-match-positions re:uninteresting l) (skip-to-interesting-line p)]
|
|
[else l])))
|
|
|
|
(when recorded-cpp-in
|
|
;; Skip over common part:
|
|
(let loop ([lpos 1])
|
|
(let ([pl (read-bytes-line recorded-cpp-in 'any)])
|
|
(unless (eof-object? pl)
|
|
(let ([l (skip-to-interesting-line (car cpp-process))])
|
|
(unless (equal? pl l)
|
|
(error 'precompiled-header "line mismatch with precompiled: ~s (line ~a) versus ~s"
|
|
pl
|
|
lpos
|
|
l))
|
|
(loop (add1 lpos))))))
|
|
(close-input-port recorded-cpp-in))
|
|
|
|
;; cpp output to ctok input, also writes filtered lines to
|
|
;; cpp-out when reading a recompiled header
|
|
(thread (lambda ()
|
|
(if recorded-cpp-out
|
|
;; line-by-line, so we can filter:
|
|
(begin
|
|
(let loop ()
|
|
(let ([l (read-bytes-line (car cpp-process) 'any)])
|
|
(unless (eof-object? l)
|
|
(unless (regexp-match-positions re:boring l)
|
|
(display l recorded-cpp-out)
|
|
(newline recorded-cpp-out))
|
|
(display l local-ctok-write)
|
|
(newline local-ctok-write)
|
|
(loop))))
|
|
(close-output-port recorded-cpp-out)
|
|
(close-input-port (car cpp-process))
|
|
(close-output-port local-ctok-write))
|
|
;; block copy:
|
|
(let ([s (make-bytes 4096)])
|
|
(let loop ()
|
|
(let ([l (read-bytes-avail! s (car cpp-process))])
|
|
(unless (eof-object? l)
|
|
(write-bytes s local-ctok-write 0 l)
|
|
(loop))))
|
|
(close-input-port (car cpp-process))
|
|
(close-output-port local-ctok-write)))))
|
|
|
|
(define e-raw #f)
|
|
|
|
(define read-thread
|
|
(thread
|
|
(lambda ()
|
|
(parameterize ([current-input-port local-ctok-read])
|
|
(set! e-raw (car (tokenize)))))))
|
|
|
|
((list-ref cpp-process 4) 'wait)
|
|
(thread-wait cpp-error-thread)
|
|
(when (eq? ((list-ref cpp-process 4) 'status) 'done-error)
|
|
(error 'xform "cpp failed"))
|
|
|
|
(thread-wait read-thread)
|
|
(set! read-thread #f)
|
|
(when (exn? e-raw)
|
|
(raise e-raw))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Output and error-handling
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(current-output-port (if file-out
|
|
(open-output-file file-out 'truncate)
|
|
(make-output-port 'dev/null
|
|
always-evt
|
|
(lambda (s st ed f?)
|
|
(- ed st))
|
|
void)))
|
|
|
|
(let ([eh (error-escape-handler)])
|
|
(error-escape-handler
|
|
(lambda ()
|
|
(close-output-port (current-output-port))
|
|
(current-output-port (current-error-port))
|
|
(when file-out
|
|
(delete-file file-out))
|
|
(eh))))
|
|
|
|
(define exit-with-error? #f)
|
|
|
|
(define (log-error format . args)
|
|
(fprintf (current-error-port) "Error ")
|
|
(apply fprintf (current-error-port) format args)
|
|
(newline (current-error-port))
|
|
(set! exit-with-error? #t))
|
|
|
|
(define log-warning log-error)
|
|
|
|
(define map-port
|
|
(if palm-out
|
|
(open-output-file palm-out 'truncate)
|
|
#f))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Output common defns
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define per-block-push? #t)
|
|
(define gc-var-stack-mode
|
|
(let loop ([e-raw e-raw])
|
|
(ormap (lambda (e)
|
|
(cond
|
|
[(and (pragma? e)
|
|
(regexp-match #rx"GC_VARIABLE_STACK_THOUGH_TABLE" (pragma-s e)))
|
|
'table]
|
|
[(and (tok? e)
|
|
(eq? (tok-n e) 'XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL))
|
|
'thread-local]
|
|
[(and (tok? e)
|
|
(eq? (tok-n e) 'XFORM_GC_VARIABLE_STACK_THROUGH_GETSPECIFIC))
|
|
'getspecific]
|
|
[(and (tok? e)
|
|
(eq? (tok-n e) 'XFORM_GC_VARIABLE_STACK_THROUGH_FUNCTION))
|
|
'function]
|
|
[(braces? e) (loop (seq->list (seq-in e)))]
|
|
[else #f]))
|
|
e-raw)))
|
|
|
|
;; The code produced by xform uses a number of macros. These macros
|
|
;; make the transformation about a little easier to debug, and they
|
|
;; enable experimentation with different variable-registration
|
|
;; strategies without modifying the xform process.
|
|
|
|
(when (and pgc? (not precompiled-header))
|
|
;; Setup GC_variable_stack macro
|
|
(printf (case gc-var-stack-mode
|
|
[(table)
|
|
"#define GC_VARIABLE_STACK (scheme_extension_table->GC_variable_stack)\n"]
|
|
[(getspecific)
|
|
"#define GC_VARIABLE_STACK (((Thread_Local_Variables *)pthread_getspecific(scheme_thread_local_key))->GC_variable_stack_)\n"]
|
|
[(function)
|
|
"#define GC_VARIABLE_STACK ((scheme_get_thread_local_variables())->GC_variable_stack_)\n"]
|
|
[(thread-local)
|
|
"#define GC_VARIABLE_STACK ((&scheme_thread_locals)->GC_variable_stack_)\n"]
|
|
[else "#define GC_VARIABLE_STACK GC_variable_stack\n"]))
|
|
|
|
(if gc-variable-stack-through-funcs?
|
|
(begin
|
|
(printf "#define GET_GC_VARIABLE_STACK() GC_get_variable_stack()\n")
|
|
(printf "#define SET_GC_VARIABLE_STACK(v) GC_set_variable_stack(v)\n"))
|
|
(begin
|
|
(printf "#define GET_GC_VARIABLE_STACK() GC_VARIABLE_STACK\n")
|
|
(printf "#define SET_GC_VARIABLE_STACK(v) (GC_VARIABLE_STACK = (v))\n")))
|
|
|
|
;; Declare stack-registration record of a particular size:
|
|
(printf (string-append
|
|
"#define PREPARE_VAR_STACK(size) void *__gc_var_stack__[size+2]; __gc_var_stack__[0] = GET_GC_VARIABLE_STACK();"
|
|
(if callee-restore?
|
|
" SET_GC_VARIABLE_STACK(__gc_var_stack__);"
|
|
"")
|
|
"\n"))
|
|
|
|
;; Same, but in a function where the number of registered variables
|
|
;; never changes within the procedure (i.e., in nested blocks):
|
|
(printf "#define PREPARE_VAR_STACK_ONCE(size) PREPARE_VAR_STACK(size); __gc_var_stack__[1] = (void *)size;\n")
|
|
|
|
;; Full setup to use before a function call, normally used with FUNCCALL:
|
|
(printf (string-append
|
|
"#define SETUP(x) ("
|
|
(if callee-restore?
|
|
""
|
|
"SET_GC_VARIABLE_STACK(__gc_var_stack__), ")
|
|
"__gc_var_stack__[1] = (void *)x)\n"))
|
|
|
|
;; Debugging support:
|
|
(printf "#ifdef MZ_3M_CHECK_VAR_STACK\n")
|
|
(printf "static int _bad_var_stack_() { *(long *)0x0 = 1; return 0; }\n")
|
|
(printf "# define CHECK_GC_V_S ((GC_VARIABLE_STACK == __gc_var_stack__) ? 0 : _bad_var_stack_()),\n")
|
|
(printf "#else\n")
|
|
(printf "# define CHECK_GC_V_S /*empty*/\n")
|
|
(printf "#endif\n")
|
|
|
|
;; Call a function where the number of registered variables can change in
|
|
;; nested blocks:
|
|
(printf "#define FUNCCALL_each(setup, x) (CHECK_GC_V_S setup, x)\n")
|
|
;; The same, but a "tail" call:
|
|
(printf "#define FUNCCALL_EMPTY_each(x) (SET_GC_VARIABLE_STACK((void **)__gc_var_stack__[0]), x)\n")
|
|
;; The same, but the number of registered variables for this call is definitely
|
|
;; the same as for the previous call:
|
|
(printf (if callee-restore?
|
|
"#define FUNCCALL_AGAIN_each(x) (CHECK_GC_V_S x)\n"
|
|
"#define FUNCCALL_AGAIN_each(x) FUNCCALL_each(SET_GC_VARIABLE_STACK(__gc_var_stack__), x)\n"))
|
|
|
|
;; As above, but when the number of registered variables never changes
|
|
;; within a procedure:
|
|
(printf "#define FUNCCALL_once(setup, x) FUNCCALL_AGAIN_each(x)\n")
|
|
(printf "#define FUNCCALL_EMPTY_once(x) FUNCCALL_EMPTY_each(x)\n")
|
|
(printf "#define FUNCCALL_AGAIN_once(x) FUNCCALL_AGAIN_each(x)\n")
|
|
|
|
;; Register a particular variable locally:
|
|
(printf "#define PUSH(v, x) (__gc_var_stack__[x+2] = (void *)&(v))\n")
|
|
;; Register a particular array variable locally:
|
|
(printf (string-append
|
|
"#define PUSHARRAY(v, l, x) (__gc_var_stack__[x+2] = (void *)0, __gc_var_stack__[x+3] = (void *)&(v), "
|
|
"__gc_var_stack__[x+4] = (void *)l)\n"))
|
|
|
|
;; Wraps code to setup a block's variables:
|
|
(printf "#define BLOCK_SETUP_TOP(x) ~a\n" (if per-block-push? "x" "/* skipped */"))
|
|
;; Same, but specifically in a function where nested blocks register
|
|
;; extra variables:
|
|
(printf "#define BLOCK_SETUP_each(x) BLOCK_SETUP_TOP(x)\n")
|
|
;; Same, but specifically in a function where nested blocks DO NOT
|
|
;; register extra variables:
|
|
(printf "#define BLOCK_SETUP_once(x) /* no effect */\n")
|
|
|
|
;; Wrap a normal return:
|
|
(printf (if callee-restore?
|
|
"#define RET_VALUE_START return (__ret__val__ = \n"
|
|
"#define RET_VALUE_START return\n"))
|
|
(printf (if callee-restore?
|
|
"#define RET_VALUE_END , SET_GC_VARIABLE_STACK((void **)__gc_var_stack__[0]), __ret__val__)\n"
|
|
"#define RET_VALUE_END \n"))
|
|
;; Wrap a return where the value is produced by a FUNCCALL_EMPTY expression:
|
|
(printf "#define RET_VALUE_EMPTY_START return\n")
|
|
(printf "#define RET_VALUE_EMPTY_END \n")
|
|
;; Replacement for non-value return:
|
|
(printf "#define RET_NOTHING { SET_GC_VARIABLE_STACK((void **)__gc_var_stack__[0]); return; }\n")
|
|
;; A non-value return inserted at the end of a void-returning function:
|
|
(printf "#define RET_NOTHING_AT_END RET_NOTHING\n")
|
|
|
|
;; Declare a temp variable to hold the return value of the indicated type:
|
|
(printf (if callee-restore?
|
|
"#define DECL_RET_SAVE(type) type __ret__val__;\n"
|
|
"#define DECL_RET_SAVE(type) /**/\n"))
|
|
|
|
;; Value used to initialize pointer variables:
|
|
(printf "#define NULLED_OUT 0\n")
|
|
;; Macro to initialize a pointer array:
|
|
(printf "#define NULL_OUT_ARRAY(a) memset(a, 0, sizeof(a))\n")
|
|
;; Annotation that normally disappears:
|
|
(printf "#define GC_CAN_IGNORE /**/\n")
|
|
(printf "#define __xform_nongcing__ /**/\n")
|
|
;; Another annotation to protect against GC conversion:
|
|
(printf "#define HIDE_FROM_XFORM(x) x\n")
|
|
(printf "#define XFORM_HIDE_EXPR(x) x\n")
|
|
(printf "#define HIDE_NOTHING_FROM_XFORM() /**/\n")
|
|
;; In case a conversion is unnecessary where we have this annotation:
|
|
(printf "#define START_XFORM_SKIP /**/\n")
|
|
(printf "#define END_XFORM_SKIP /**/\n")
|
|
(printf "#define START_XFORM_SUSPEND /**/\n")
|
|
(printf "#define END_XFORM_SUSPEND /**/\n")
|
|
(printf "#define XFORM_START_SKIP /**/\n")
|
|
(printf "#define XFORM_END_SKIP /**/\n")
|
|
(printf "#define XFORM_START_SUSPEND /**/\n")
|
|
(printf "#define XFORM_END_SUSPEND /**/\n")
|
|
(printf "#define XFORM_SKIP_PROC /**/\n")
|
|
;; For avoiding warnings:
|
|
(printf "#define XFORM_OK_PLUS +\n")
|
|
(printf "#define XFORM_OK_MINUS -\n")
|
|
(printf "#define XFORM_TRUST_PLUS +\n")
|
|
(printf "#define XFORM_TRUST_MINUS -\n")
|
|
(printf "#define XFORM_OK_ASSIGN /**/\n")
|
|
(printf "\n")
|
|
|
|
;; C++ cupport:
|
|
(printf "#define NEW_OBJ(t) new (UseGC) t\n")
|
|
(printf "#define NEW_ARRAY(t, array) (new (UseGC) t array)\n")
|
|
(printf "#define NEW_ATOM(t) (new (AtomicGC) t)\n")
|
|
(printf "#define NEW_PTR(t) (new (UseGC) t)\n")
|
|
(printf "#define NEW_ATOM_ARRAY(t, array) (new (AtomicGC) t array)\n")
|
|
(printf "#define NEW_PTR_ARRAY(t, array) (new (UseGC) t* array)\n")
|
|
(printf "#define DELETE(x) (delete x)\n")
|
|
(printf "#define DELETE_ARRAY(x) (delete[] x)\n")
|
|
(printf (if callee-restore?
|
|
"#define XFORM_RESET_VAR_STACK /* empty */\n"
|
|
"#define XFORM_RESET_VAR_STACK SET_GC_VARIABLE_STACK((void **)__gc_var_stack__[0]);\n"))
|
|
|
|
(unless pgc-really?
|
|
(printf "#include \"cgc2.h\"\n"))
|
|
|
|
(printf "\n"))
|
|
|
|
(when (and pgc? precompiled-header)
|
|
(printf "#include \"~a\"\n" (let-values ([(base name dir?) (split-path precompiled-header)])
|
|
(path->string name))))
|
|
|
|
(when palm?
|
|
(printf "#include \"segmap.h\"\n"))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Structures and constants
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; vtype and its substructs describe the shape of a local variable:
|
|
(define-struct vtype ())
|
|
(define-struct (pointer-type vtype) (base stars))
|
|
(define-struct (array-type vtype) (count))
|
|
(define-struct (struc-type vtype) (struct))
|
|
(define-struct (struct-array-type struc-type) (count))
|
|
(define-struct (union-type vtype) ())
|
|
(define-struct (non-pointer-type vtype) (base))
|
|
|
|
;; A live-var-info struct is threaded through the conversion process
|
|
;; on a function body. It keeps information about which variables
|
|
;; are live, which variables were invented along the way, how long
|
|
;; the __gc_var_stack__ array needs to be, and so on.
|
|
(define-struct live-var-info (tag
|
|
maxlive
|
|
maxpush
|
|
vars
|
|
new-vars
|
|
pushed-vars
|
|
num-calls
|
|
num-noreturn-calls
|
|
num-empty-calls
|
|
nonempty-calls?))
|
|
|
|
;; A function prototype record:
|
|
(define-struct prototype (type args static? pointer? pointer?-determined?))
|
|
|
|
;; A C++ class record:
|
|
(define-struct c++-class (parent parent-name prototyped top-vars))
|
|
|
|
;; Symbol constants:
|
|
(define semi (string->symbol ";"))
|
|
(define START_XFORM_SKIP (string->symbol "START_XFORM_SKIP"))
|
|
(define END_XFORM_SKIP (string->symbol "END_XFORM_SKIP"))
|
|
(define START_XFORM_SUSPEND (string->symbol "START_XFORM_SUSPEND"))
|
|
(define END_XFORM_SUSPEND (string->symbol "END_XFORM_SUSPEND"))
|
|
(define Scheme_Object (string->symbol "Scheme_Object"))
|
|
(define sElF (string->symbol "sElF"))
|
|
(define NULLED_OUT (string->symbol "NULLED_OUT"))
|
|
(define NULL_OUT_ARRAY (string->symbol "NULL_OUT_ARRAY"))
|
|
(define gcMark (string->symbol "gcMark"))
|
|
(define gcFixup (string->symbol "gcFixup"))
|
|
(define gcMARK_TYPED (string->symbol "gcMARK_TYPED"))
|
|
(define gcFIXUP_TYPED (string->symbol "gcFIXUP_TYPED"))
|
|
(define Mark_Proc (string->symbol "Mark_Proc"))
|
|
(define gcBYTES_TO_WORDS (string->symbol "gcBYTES_TO_WORDS"))
|
|
(define GC_cpp_delete (string->symbol "GC_cpp_delete"))
|
|
(define PRE_ALLOCATE (string->symbol "PRE_ALLOCATE"))
|
|
(define NEW_OBJ (string->symbol "NEW_OBJ"))
|
|
(define NEW_ARRAY (string->symbol "NEW_ARRAY"))
|
|
(define NEW_ATOM (string->symbol "NEW_ATOM"))
|
|
(define NEW_PTR (string->symbol "NEW_PTR"))
|
|
(define NEW_ATOM_ARRAY (string->symbol "NEW_ATOM_ARRAY"))
|
|
(define NEW_PTR_ARRAY (string->symbol "NEW_PTR_ARRAY"))
|
|
(define DELETE (string->symbol "DELETE"))
|
|
(define DELETE_ARRAY (string->symbol "DELETE_ARRAY"))
|
|
(define CURRENT_NEW_THIS (string->symbol "CURRENT_NEW_THIS"))
|
|
(define RESTORE_CURRENT_NEW_VAR_STACK (string->symbol "RESTORE_CURRENT_NEW_VAR_STACK"))
|
|
(define XFORM_RESET_VAR_STACK (string->symbol "XFORM_RESET_VAR_STACK"))
|
|
(define END_XFORM_ARITH (string->symbol "END_XFORM_ARITH"))
|
|
(define START_XFORM_ARITH (string->symbol "START_XFORM_ARITH"))
|
|
(define GC_CAN_IGNORE (string->symbol "GC_CAN_IGNORE"))
|
|
(define RET_VALUE_START (string->symbol "RET_VALUE_START"))
|
|
(define RET_VALUE_END (string->symbol "RET_VALUE_END"))
|
|
(define RET_VALUE_EMPTY_START (string->symbol "RET_VALUE_EMPTY_START"))
|
|
(define RET_VALUE_EMPTY_END (string->symbol "RET_VALUE_EMPTY_END"))
|
|
(define RET_NOTHING (string->symbol "RET_NOTHING"))
|
|
(define RET_NOTHING_AT_END (string->symbol "RET_NOTHING_AT_END"))
|
|
(define DECL_RET_SAVE (string->symbol "DECL_RET_SAVE"))
|
|
|
|
(define __attribute__ (string->symbol "__attribute__"))
|
|
|
|
(define re:_stk_ (regexp "^_stk_"))
|
|
|
|
;; These don't act like functions, but we need to treat them
|
|
;; specially:
|
|
(define setjmp-functions
|
|
'(setjmp _setjmp scheme_setjmp scheme_mz_setjmp))
|
|
|
|
;; The non-functions table identifies symbols to ignore when
|
|
;; finding function calls
|
|
(define non-functions
|
|
'(<= < > >= == != !
|
|
\| \|\| & && |:| ? % + - * / ^ >> << ~
|
|
#csXFORM_OK_PLUS #csXFORM_OK_MINUS #csXFORM_TRUST_PLUS #csXFORM_TRUST_MINUS
|
|
= >>= <<= ^= += *= /= -= %= \|= &= ++ --
|
|
return if for while else switch case XFORM_OK_ASSIGN
|
|
asm __asm __asm__ __volatile __volatile__ volatile __extension__
|
|
__typeof sizeof __builtin_object_size
|
|
|
|
;; These don't act like functions:
|
|
setjmp longjmp _longjmp scheme_longjmp_setjmp scheme_mz_longjmp scheme_jit_longjmp
|
|
scheme_jit_setjmp_prepare
|
|
scheme_get_thread_local_variables pthread_getspecific
|
|
|
|
;; The following are functions, but they don't trigger GC, and
|
|
;; they either take one argument or no pointer arguments.
|
|
;; So we can ignore them:
|
|
|
|
strlen cos sin exp pow log sqrt atan2
|
|
isnan isinf fpclass _fpclass _isnan __isfinited __isnanl __isnan
|
|
__isinff __isinfl isnanf isinff __isinfd __isnanf __isnand __isinf
|
|
floor ceil round fmod modf fabs __maskrune _errno __errno
|
|
isalpha isdigit isspace tolower toupper
|
|
fread fwrite socket fcntl setsockopt connect send recv close
|
|
__builtin_next_arg __builtin_saveregs
|
|
__builtin_constant_p
|
|
__builtin___CFStringMakeConstantString
|
|
__error __errno_location __toupper __tolower
|
|
__attribute__ __mode__ ; not really functions in gcc
|
|
__iob_func ; VC 8
|
|
scheme_get_milliseconds scheme_get_process_milliseconds
|
|
scheme_rational_to_double scheme_bignum_to_double
|
|
scheme_rational_to_float scheme_bignum_to_float
|
|
|GetStdHandle| |__CFStringMakeConstantString|
|
|
_vswprintf_c
|
|
|
|
scheme_make_small_bignum scheme_make_small_rational scheme_make_small_complex))
|
|
(define non-functions-table
|
|
(let ([ht (make-hash-table)])
|
|
(for-each (lambda (s)
|
|
(hash-table-put! ht s #f))
|
|
non-functions)
|
|
ht))
|
|
|
|
(define args-unevaled '(sizeof __typeof __builtin_object_size))
|
|
(define args-unevaled-table
|
|
(let ([ht (make-hash-table)])
|
|
(for-each (lambda (s)
|
|
(hash-table-put! ht s #t))
|
|
args-unevaled)
|
|
ht))
|
|
|
|
(define non-gcing-builtin-functions
|
|
;; The following don't need wrappers, but we need to check for
|
|
;; nested function calls because it takes more than one argument:
|
|
(append
|
|
'(memcpy memmove memcmp memset
|
|
__builtin___memmove_chk __inline_memmove_chk
|
|
__builtin___memcpy_chk __inline_memcpy_chk
|
|
__builtin___memset_chk __inline_memset_chk
|
|
__builtin___memcmp_chk __inline_memcmp_chk
|
|
strcmp strcoll strcpy _mzstrcpy strcat
|
|
__builtin_memset
|
|
printf sprintf vsprintf vprintf
|
|
strncmp
|
|
read write)
|
|
(map
|
|
string->symbol
|
|
'("XTextExtents" "XTextExtents16"
|
|
"XDrawImageString16" "XDrawImageString"
|
|
"XDrawString16" "XDrawString"))))
|
|
(define non-gcing-functions (make-hash-table))
|
|
(for-each (lambda (name)
|
|
(hash-table-put! non-gcing-functions name #t))
|
|
non-gcing-builtin-functions)
|
|
|
|
(define non-returning-functions
|
|
;; The following functions never return, so the wrappers
|
|
;; don't need to push any variables:
|
|
'(exit
|
|
scheme_wrong_type scheme_wrong_number scheme_wrong_syntax
|
|
scheme_wrong_count scheme_wrong_count_m scheme_wrong_rator scheme_read_err
|
|
scheme_raise_exn scheme_signal_error
|
|
scheme_raise_out_of_memory
|
|
))
|
|
|
|
|
|
(define non-pointer-typedef-names
|
|
;; Under Windows, things like HANDLE and HWND, are not
|
|
;; malloced and could overlap with GCed areas.
|
|
;; Mac OS X has similar things.
|
|
#cs
|
|
'(HANDLE
|
|
HWND HDC HMENU
|
|
HBITMAP HBRUSH HPEN HFONT HPALETTE HRGN
|
|
HICON HINSTANCE
|
|
GLOBALHANDLE LOCALHANDLE HGLOBAL HLOCAL
|
|
GrafPtr RgnHandle PixMapHandle Handle MenuHandle GDHandle
|
|
WindowPtr DialogPtr ControlRef EventRef EventHandlerCallRef
|
|
CGContextRef))
|
|
|
|
(define asm-commands
|
|
;; When outputting, add newline before these syms
|
|
;; (for __asm blocks in Windows)
|
|
'(mov shl shld shr shrd sar lock setc add))
|
|
|
|
(define (get-constructor v)
|
|
(cond
|
|
[(creation-parens? v) make-creation-parens]
|
|
[(parens? v) make-parens]
|
|
[(brackets? v) make-brackets]
|
|
[(braces? v) make-braces]))
|
|
|
|
;; gets the size of a variable in terms of the number of
|
|
;; __gc_var_stack__ slots it needs
|
|
(define (get-variable-size vtype)
|
|
(cond
|
|
[(array-type? vtype)
|
|
;; 1 for "is an array", 1 for array size, 1 for array pointer
|
|
3]
|
|
[(struc-type? vtype)
|
|
(let ([size (let ([m (lookup-struct-def (struc-type-struct vtype))])
|
|
(apply + (map get-variable-size
|
|
(map cdr (cdr m)))))])
|
|
(if (struct-array-type? vtype)
|
|
(* size (struct-array-type-count vtype))
|
|
size))]
|
|
[(vtype? vtype) 1]
|
|
[else (error 'get-variable-size "not a vtype: ~e"
|
|
vtype)]))
|
|
|
|
(define (replace-live-vars live-vars new-live-vars)
|
|
(make-live-var-info (live-var-info-tag live-vars)
|
|
(live-var-info-maxlive live-vars)
|
|
(live-var-info-maxpush live-vars)
|
|
new-live-vars
|
|
(live-var-info-new-vars live-vars)
|
|
(live-var-info-pushed-vars live-vars)
|
|
(live-var-info-num-calls live-vars)
|
|
(live-var-info-num-noreturn-calls live-vars)
|
|
(live-var-info-num-empty-calls live-vars)
|
|
(live-var-info-nonempty-calls? live-vars)))
|
|
|
|
(define gentag-count 0)
|
|
|
|
(define gentag
|
|
(lambda ()
|
|
(set! gentag-count (add1 gentag-count))
|
|
(format "XfOrM~a" gentag-count)))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; State
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; See `used-symbols' above
|
|
|
|
(define c++-classes null)
|
|
|
|
;; list of (cons symbol prototype)
|
|
(define prototyped (make-parameter null))
|
|
;; list of (cons symbol vtype)
|
|
(define top-vars (make-parameter null))
|
|
|
|
;; Accum top-level typedefs for pointers and non-pointers as a list-of-sym:
|
|
(define pointer-types '())
|
|
(define non-pointer-types '(int char long unsigned intptr_t ulong uint uintptr_t void float double uchar wchar_t))
|
|
;; Accum top-level struct decls as list of (cons sym (list (cons symbol vtype) ...))
|
|
(define struct-defs '())
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Marhsaling and unmarshaling
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define makers (make-hash-table))
|
|
(hash-table-put! makers 'struct:tok (cons 'make-tok make-tok))
|
|
(hash-table-put! makers 'struct:sysheader-tok (cons 'make-sysheader-tok make-sysheader-tok))
|
|
(hash-table-put! makers 'struct:seq (cons 'make-a-seq make-a-seq))
|
|
(hash-table-put! makers 'struct:parens (cons 'make-parens make-parens))
|
|
(hash-table-put! makers 'struct:brackets (cons 'make-brackets make-brackets))
|
|
(hash-table-put! makers 'struct:braces (cons 'make-braces make-braces))
|
|
(hash-table-put! makers 'struct:callstage-parens (cons 'make-callstage-parens make-callstage-parens))
|
|
(hash-table-put! makers 'struct:creation-parens (cons 'make-creation-parens make-creation-parens))
|
|
(hash-table-put! makers 'struct:nosrc-parens (cons 'make-nosrc-parens make-nosrc-parens))
|
|
(hash-table-put! makers 'struct:call (cons 'make-call make-call))
|
|
(hash-table-put! makers 'struct:block-push (cons 'make-block-push make-block-push))
|
|
(hash-table-put! makers 'struct:note (cons 'make-note make-note))
|
|
(hash-table-put! makers 'struct:vtype (cons 'make-vtype make-vtype))
|
|
(hash-table-put! makers 'struct:pointer-type (cons 'make-pointer-type make-pointer-type))
|
|
(hash-table-put! makers 'struct:array-type (cons 'make-array-type make-array-type))
|
|
(hash-table-put! makers 'struct:struc-type (cons 'make-struc-type make-struc-type))
|
|
(hash-table-put! makers 'struct:struct-array-type (cons 'make-struct-array-type make-struct-array-type))
|
|
(hash-table-put! makers 'struct:union-type (cons 'make-union-type make-union-type))
|
|
(hash-table-put! makers 'struct:non-pointer-type (cons 'make-non-pointer-type make-non-pointer-type))
|
|
(hash-table-put! makers 'struct:live-var-info (cons 'make-live-var-info make-live-var-info))
|
|
(hash-table-put! makers 'struct:prototype (cons 'make-prototype make-prototype))
|
|
(hash-table-put! makers 'struct:c++-class (cons 'make-c++-class make-c++-class))
|
|
|
|
(define (make-short-tok l) (make-tok l #f #f))
|
|
|
|
;; A precompiled header saves the above state variables.
|
|
(when precompiled-header
|
|
(let ([orig (current-namespace)])
|
|
(parameterize ([current-namespace (make-namespace)])
|
|
(namespace-attach-module orig 'mzscheme)
|
|
(namespace-require 'mzscheme)
|
|
;; Put constructors into the namespace:
|
|
(hash-table-for-each makers
|
|
(lambda (k v)
|
|
(namespace-set-variable-value! (car v) (cdr v))))
|
|
(namespace-set-variable-value! 'make-short-tok make-short-tok)
|
|
;; Load the pre-compiled-header-as-.zo:
|
|
(let ([l (load (change-suffix precompiled-header #".zo"))])
|
|
(for-each (lambda (x)
|
|
(hash-table-put! used-symbols (car x)
|
|
(+
|
|
(hash-table-get
|
|
used-symbols (car x)
|
|
(lambda () 0))
|
|
(cdr x))))
|
|
(list-ref l 0))
|
|
|
|
(set! c++-classes (list-ref l 1))
|
|
(prototyped (list-ref l 2))
|
|
(top-vars (list-ref l 3))
|
|
|
|
(set! pointer-types (list-ref l 4))
|
|
(set! non-pointer-types (list-ref l 5))
|
|
(set! struct-defs (list-ref l 6))
|
|
|
|
(set! non-gcing-functions (hash-table-copy (list-ref l 7)))
|
|
|
|
(set! gc-var-stack-mode (list-ref l 8))))))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Pretty-printing output
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define next-indent #f)
|
|
|
|
(define (newline/indent i)
|
|
(newline)
|
|
(set! next-indent i))
|
|
|
|
(define (display/indent v s)
|
|
(when next-indent
|
|
(display (make-string next-indent #\space))
|
|
(set! next-indent #f))
|
|
(display s))
|
|
|
|
(define re:quote-or-backslash (regexp "[\\\"]"))
|
|
|
|
(define (push-vars l plus comma)
|
|
(let loop ([l l][n 0][comma comma])
|
|
(unless (null? l)
|
|
(loop (cdr l)
|
|
(let push-var ([full-name (caar l)][vtype (cdar l)][n n][comma comma])
|
|
(cond
|
|
[(union-type? vtype)
|
|
(log-error "[UNION]: Can't push union onto mark stack: ~a." full-name)
|
|
(printf "~aPUSHUNION(~a, ~a~a)" comma full-name n plus)
|
|
(add1 n)]
|
|
[(array-type? vtype)
|
|
(printf "~aPUSHARRAY(~a, ~a, ~a~a)" comma full-name (array-type-count vtype) n plus)
|
|
(+ 3 n)]
|
|
[(struc-type? vtype)
|
|
(let aloop ([array-index 0][n n][comma comma])
|
|
;; Push each struct in array (or only struct if not an array)
|
|
(let loop ([n n][l (cdr (lookup-struct-def (struc-type-struct vtype)))][comma comma])
|
|
(if (null? l)
|
|
(if (and (struct-array-type? vtype)
|
|
(< (add1 array-index) (struct-array-type-count vtype)))
|
|
;; Next in array
|
|
(aloop (add1 array-index) n comma)
|
|
;; All done
|
|
n)
|
|
(loop (push-var (format "~a~a.~a"
|
|
full-name
|
|
(if (struct-array-type? vtype)
|
|
(format "[~a]" array-index)
|
|
"")
|
|
(caar l))
|
|
(cdar l)
|
|
n
|
|
comma)
|
|
(cdr l)
|
|
", "))))]
|
|
[else
|
|
(printf "~aPUSH(~a, ~a~a)" comma full-name n plus)
|
|
(+ n 1)]))
|
|
", "))))
|
|
|
|
(define (total-push-size vars)
|
|
(apply + (map (lambda (x)
|
|
(get-variable-size (cdr x)))
|
|
vars)))
|
|
|
|
(define (extract-src-tok v)
|
|
(cond
|
|
[(tok? v) v]
|
|
[(call? v) (extract-src-tok (call-func v))]
|
|
[else #f]))
|
|
|
|
(define (print-it e indent semi-newlines? ordered? line file sysheader? keep-lines?)
|
|
(let loop ([e e][prev #f][prevs null][old-line line][old-file file][old-sysheader? sysheader?])
|
|
(if (null? e)
|
|
(values old-line old-file old-sysheader?)
|
|
(let* ([v (car e)]
|
|
[sv (extract-src-tok v)]
|
|
[line (if keep-lines?
|
|
(or (and sv (tok-line sv))
|
|
old-line)
|
|
old-line)]
|
|
[file (if keep-lines?
|
|
(or (and sv (tok-file sv))
|
|
old-file)
|
|
old-file)]
|
|
[sysheader? (if keep-lines?
|
|
(if (and sv (tok-file sv))
|
|
(sysheader-tok? sv)
|
|
old-sysheader?)
|
|
old-sysheader?)]
|
|
[inc-line! (lambda () (set! line (add1 line)))])
|
|
(when keep-lines?
|
|
(unless (and (equal? line old-line)
|
|
(equal? file old-file))
|
|
(if (and (equal? file old-file)
|
|
(line . > . old-line)
|
|
((- line old-line) . < . 10))
|
|
(display (make-string (- line old-line) #\newline))
|
|
(printf "\n# ~a \"~a\"~a\n" line file
|
|
(if sysheader? " 3" "")))
|
|
(set! next-indent indent)))
|
|
(cond
|
|
[(pragma? v)
|
|
(let ([s (format "#pragma ~a" (pragma-s v))])
|
|
(unless (regexp-match re:boring s)
|
|
(printf "\n~a\n\n" s)
|
|
(set! line (+ line 3))))]
|
|
[(threadlocal-decl? v) (void)]
|
|
[(seq? v)
|
|
(display/indent v (tok-n v))
|
|
(let ([subindent (if (braces? v)
|
|
(begin
|
|
(newline/indent (+ indent 2))
|
|
(inc-line!)
|
|
(+ indent 2))
|
|
indent)])
|
|
(let-values ([(l f s?)
|
|
(print-it (seq->list (seq-in v)) subindent
|
|
(not (and (parens? v)
|
|
prev
|
|
(tok? prev)
|
|
(memq (tok-n prev) '(for))))
|
|
(or (braces? v) (callstage-parens? v))
|
|
line file sysheader?
|
|
(and keep-lines?
|
|
(not (nosrc-parens? v))))])
|
|
(set! line l)
|
|
(set! file f)
|
|
(set! sysheader? s?))
|
|
(when (and next-indent (= next-indent subindent))
|
|
(set! next-indent indent)))
|
|
(display/indent #f (seq-close v))
|
|
(cond
|
|
[(braces? v)
|
|
(newline/indent indent)
|
|
(inc-line!)]
|
|
[(brackets? v)
|
|
(display/indent v " ")]
|
|
[(parens? v)
|
|
(if (and prev
|
|
(tok? prev)
|
|
(memq (tok-n prev) '(if))
|
|
(or (null? (cdr e))
|
|
(not (braces? (cadr e)))))
|
|
(begin
|
|
(newline/indent (+ indent 2))
|
|
(inc-line!))
|
|
(display/indent v " "))]
|
|
[else (error 'xform "unknown brace: ~a" (caar v))])]
|
|
[(note? v)
|
|
(display/indent v (note-s v))
|
|
(newline/indent indent)
|
|
(inc-line!)]
|
|
[(call? v)
|
|
(if (not (call-nonempty? v))
|
|
(display/indent v "FUNCCALL_EMPTY(")
|
|
(if (and ordered? (prev-was-funcall? prevs))
|
|
;; Do fast version
|
|
(begin
|
|
(display/indent v "FUNCCALL_AGAIN("))
|
|
;; Do general version
|
|
(begin
|
|
(display/indent v (format "FUNCCALL(SETUP_~a("
|
|
(call-tag v)))
|
|
(if show-info?
|
|
(begin
|
|
(display/indent v (format "(SETUP(~a)"
|
|
(total-push-size (call-live v))))
|
|
(push-vars (call-live v) "" ", ")
|
|
(display/indent v ")"))
|
|
(display/indent v "_"))
|
|
(display/indent v "), "))))
|
|
(let-values ([(l f s?)
|
|
(print-it (append (call-func v) (list (call-args v)))
|
|
indent #f #f line file sysheader?
|
|
;; Can't put srcloc within macro call:
|
|
#f)])
|
|
(set! line l)
|
|
(set! file f)
|
|
(set! sysheader? s?))
|
|
(display/indent v ")")]
|
|
[(block-push? v)
|
|
(let ([size (total-push-size (block-push-vars v))]
|
|
[prev-add (if (block-push-super-tag v)
|
|
(format "+~a_COUNT" (block-push-super-tag v))
|
|
"")]
|
|
[tag (block-push-tag v)]
|
|
[tabbing (if (zero? indent)
|
|
""
|
|
(make-string (sub1 indent) #\space))])
|
|
(unless (zero? size)
|
|
(display/indent v (format "BLOCK_SETUP~a((" (if (block-push-top? v) "_TOP" "")))
|
|
(push-vars (block-push-vars v) prev-add "")
|
|
(display/indent v "));")
|
|
(newline)
|
|
(inc-line!))
|
|
(printf "#~adefine ~a_COUNT (~a~a)\n" tabbing tag size prev-add)
|
|
(inc-line!)
|
|
(printf "#~adefine SETUP_~a(x) " tabbing tag)
|
|
(cond
|
|
[(and (zero? size) (block-push-super-tag v))
|
|
(printf "SETUP_~a(x)" (block-push-super-tag v))]
|
|
[per-block-push? (printf "SETUP(~a_COUNT)" tag)]
|
|
[else (printf "x")])
|
|
(newline/indent indent)
|
|
(inc-line!))]
|
|
[(nested-setup? v)
|
|
(let ([tabbing (if (zero? indent)
|
|
""
|
|
(make-string (sub1 indent) #\space))])
|
|
(case (tok-n v)
|
|
[(nested)
|
|
(printf "#~adefine BLOCK_SETUP(x) BLOCK_SETUP_each(x)\n" tabbing)
|
|
(printf "#~adefine FUNCCALL(s, x) FUNCCALL_each(s, x)\n" tabbing)
|
|
(printf "#~adefine FUNCCALL_EMPTY(x) FUNCCALL_EMPTY_each(x)\n" tabbing)
|
|
(printf "#~adefine FUNCCALL_AGAIN(x) FUNCCALL_AGAIN_each(x)\n" tabbing)]
|
|
[(no-nested)
|
|
(printf "#~adefine BLOCK_SETUP(x) BLOCK_SETUP_once(x)\n" tabbing)
|
|
(printf "#~adefine FUNCCALL(s, x) FUNCCALL_once(s, x)\n" tabbing)
|
|
(printf "#~adefine FUNCCALL_EMPTY(x) FUNCCALL_EMPTY_once(x)\n" tabbing)
|
|
(printf "#~adefine FUNCCALL_AGAIN(x) FUNCCALL_AGAIN_once(x)\n" tabbing)]
|
|
[(undefine)
|
|
(printf "#~aundef BLOCK_SETUP\n" tabbing)
|
|
(printf "#~aundef FUNCCALL\n" tabbing)
|
|
(printf "#~aundef FUNCCALL_EMPTY\n" tabbing)
|
|
(printf "#~aundef FUNCCALL_AGAIN\n" tabbing)])
|
|
(set! line (+ 4 line)))]
|
|
[(memq (tok-n v) asm-commands)
|
|
(newline/indent indent)
|
|
(inc-line!)
|
|
(display/indent v (tok-n v))
|
|
(display/indent v " ")]
|
|
[(and (or (eq? '|HIDE_FROM_XFORM| (tok-n v))
|
|
(eq? '|XFORM_HIDE_EXPR| (tok-n v)))
|
|
(pair? (cdr e))
|
|
(seq? (cadr e))
|
|
(null? (seq->list (seq-in (cadr e)))))
|
|
;; This handles the case where we were trying to hide
|
|
;; something from xform, but the something macro-expanded
|
|
;; to nothing. It happens, for example, in FreeBSD gcc
|
|
;; 2.95.x when hiding a va_end() use
|
|
(display/indent v '|HIDE_NOTHING_FROM_XFORM|)]
|
|
[else
|
|
(if (string? (tok-n v))
|
|
(begin
|
|
(display/indent v "\"")
|
|
(display (tok-n v))
|
|
(display/indent v "\""))
|
|
(display/indent v (tok-n v)))
|
|
;; Don't put a space between L and a string, because without
|
|
;; the space it means a long string.
|
|
(unless (and (eq? '|L| (tok-n v))
|
|
(pair? (cdr e))
|
|
(or (string? (tok-n (cadr e)))
|
|
(character? (tok-n (cadr e))))
|
|
(not (seq? (tok-n (cadr e)))))
|
|
(display/indent v " "))
|
|
(when (and (eq? semi (tok-n v))
|
|
semi-newlines?)
|
|
(newline/indent indent)
|
|
(inc-line!))])
|
|
(loop (cdr e) v (cons v prevs) line file sysheader?)))))
|
|
|
|
|
|
;; prev-was-funcall? implements a last-ditch optimization: if
|
|
;; we just did a FUNCALL setup, we can do a FUNCALL_AGAIN setup
|
|
;; this time (which is possibly quicker)
|
|
(define (prev-was-funcall? prevs)
|
|
(letrec ([acall? (lambda (v)
|
|
(or (call? v)
|
|
;; Maybe nested seq
|
|
(and (parens? v)
|
|
(let ([p (reverse (seq->list (seq-in v)))])
|
|
(and (pair? p)
|
|
(call? (car p))
|
|
(callseq-prev? (cdr p)))))))]
|
|
[callseq-prev? (lambda (prevs)
|
|
(and (pair? prevs) (pair? (cdr prevs))
|
|
(tok? (car prevs))
|
|
(eq? '|,| (tok-n (car prevs)))
|
|
(acall? (cadr prevs))))])
|
|
(or
|
|
;; Stmt (call or assign=call) sequence
|
|
(let loop ([prevs prevs][semis 0])
|
|
(cond
|
|
[(and (pair? prevs)
|
|
(tok? (car prevs))
|
|
(eq? semi (tok-n (car prevs))))
|
|
(or (positive? semis) ;; means that we already found a proc-ending semi
|
|
(if (and (pair? (cdr prevs))
|
|
(eq? semi (tok-n (cadr prevs))))
|
|
;; Odd extra semi-colon. Skip it and try again.
|
|
(loop (cdr prevs) semis)
|
|
;; Look further...
|
|
(and (pair? (cdr prevs))
|
|
(acall? (cadr prevs))
|
|
(loop (cddr prevs) (add1 semis)))))]
|
|
[(and (pair? prevs) (pair? (cdr prevs)) (pair? (cddr prevs))
|
|
(tok? (car prevs))
|
|
(tok? (cadr prevs))
|
|
(eq? '= (tok-n (car prevs)))
|
|
(symbol? (tok-n (cadr prevs)))
|
|
(eq? semi (tok-n (caddr prevs))))
|
|
(loop (cddr prevs) semis)]
|
|
[else #f]))
|
|
;; Eval sequence
|
|
(callseq-prev? prevs))))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; "Parsing"
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define skipping? #f)
|
|
(define suspend-xform 0)
|
|
|
|
(define re:h (regexp "[.]h$"))
|
|
|
|
;; top-level converts the top-level tok list e into
|
|
;; a new top-level tok list, often collecting info
|
|
;; (such as function prototypes and typedefs).
|
|
;; It expects that the tok list e reprsents one "thing",
|
|
;; which often means that it's terminated with a semicolon.
|
|
(define (top-level e where can-drop-vars?)
|
|
(cond
|
|
[(pragma? (car e))
|
|
(list (car e))]
|
|
|
|
;; START_XFORM_SKIP and END_XFORM_SKIP:
|
|
[(end-skip? e)
|
|
(set! skipping? #f)
|
|
null]
|
|
[(start-skip? e)
|
|
(set! skipping? #t)
|
|
null]
|
|
[skipping?
|
|
e]
|
|
|
|
;; START_XFORM_SUSPEND and END_XFORM_SUSPEND:
|
|
[(end-suspend? e)
|
|
(set! suspend-xform (sub1 suspend-xform))
|
|
null]
|
|
[(start-suspend? e)
|
|
(set! suspend-xform (add1 suspend-xform))
|
|
null]
|
|
|
|
;; END_XFORM_ARITH and START_XFORM_ARITH enable and
|
|
;; re-enable warnings about arithmetic operations
|
|
;; on pointers
|
|
[(end-arith? e)
|
|
(set! check-arith? #f)
|
|
null]
|
|
[(start-arith? e)
|
|
(set! check-arith? #t)
|
|
null]
|
|
|
|
[(threadlocal-decl? e)
|
|
null]
|
|
|
|
[(access-modifier? e)
|
|
;; public, private, etc.
|
|
(list* (car e) (cadr e) (top-level (cddr e) where can-drop-vars?))]
|
|
[(friend? e)
|
|
;; C++ friend annotation
|
|
e]
|
|
|
|
;; process 'extern "C"' blocks
|
|
[(and (>= (length e) 3)
|
|
(eq? (tok-n (car e)) 'extern)
|
|
(member (tok-n (cadr e)) '("C" "C++"))
|
|
(braces? (caddr e)))
|
|
(list* (car e)
|
|
(cadr e)
|
|
(let ([body-v (caddr e)])
|
|
(make-braces
|
|
(tok-n body-v)
|
|
(tok-line body-v)
|
|
(tok-file body-v)
|
|
(seq-close body-v)
|
|
(list->seq (process-top-level (seq->list (seq-in body-v)) where can-drop-vars?))))
|
|
(cdddr e))]
|
|
|
|
;; process 'namespace X' blocks; currently, we assume that namespace
|
|
;; content is distinct
|
|
[(and (>= (length e) 3)
|
|
(eq? (tok-n (car e)) 'namespace)
|
|
(symbol? (tok-n (cadr e)))
|
|
(braces? (caddr e)))
|
|
(list* (car e)
|
|
(cadr e)
|
|
(let ([body-v (caddr e)])
|
|
(make-braces
|
|
(tok-n body-v)
|
|
(tok-line body-v)
|
|
(tok-file body-v)
|
|
(seq-close body-v)
|
|
(list->seq (process-top-level (seq->list (seq-in body-v)) where can-drop-vars?))))
|
|
(cdddr e))]
|
|
|
|
[(typedef? e)
|
|
(when show-info?
|
|
(printf "/* TYPEDEF */\n"))
|
|
(if (or (simple-unused-def? e)
|
|
(unused-struc-typedef? e))
|
|
null
|
|
(begin
|
|
(when pgc?
|
|
(check-pointer-type e))
|
|
e))]
|
|
[(proc-prototype? e)
|
|
(let ([name (register-proto-information e)])
|
|
(when (eq? (tok-n (car e)) '__xform_nongcing__)
|
|
(hash-table-put! non-gcing-functions name #t))
|
|
(when show-info?
|
|
(printf "/* PROTO ~a */\n" name))
|
|
(if (or precompiling-header?
|
|
(> (hash-table-get used-symbols name) 1)
|
|
(ormap (lambda (v) (eq? (tok-n v) 'virtual)) e)) ; can't drop virtual methods!
|
|
(if palm?
|
|
(add-segment-label name e)
|
|
(clean-proto e))
|
|
null))]
|
|
[(struct-decl? e)
|
|
(if (braces? (caddr e))
|
|
(begin
|
|
(when pgc?
|
|
(register-struct e))
|
|
(when show-info? (printf "/* STRUCT ~a */\n" (tok-n (cadr e)))))
|
|
(when show-info? (printf "/* STRUCT DECL */\n")))
|
|
e]
|
|
[(class-decl? e)
|
|
(if (or (braces? (caddr e))
|
|
(eq? '|:| (tok-n (caddr e))))
|
|
(begin
|
|
(when show-info? (printf "/* CLASS ~a */\n" (tok-n (cadr e))))
|
|
(register-class e))
|
|
(begin
|
|
(when show-info? (printf "/* CLASS DECL */\n"))
|
|
(let ([name (tok-n (cadr e))])
|
|
(if (assoc name c++-classes)
|
|
;; we already know this class
|
|
null
|
|
e))))]
|
|
[(function? e)
|
|
(let ([name (register-proto-information e)])
|
|
(when (eq? (tok-n (car e)) '__xform_nongcing__)
|
|
(hash-table-put! non-gcing-functions name #t))
|
|
(if (skip-function? e)
|
|
e
|
|
(begin
|
|
(when show-info? (printf "/* FUNCTION ~a */\n" name))
|
|
(if (or (positive? suspend-xform)
|
|
(not pgc?)
|
|
(and where
|
|
(regexp-match re:h where)
|
|
(let loop ([e e][prev #f])
|
|
(cond
|
|
[(null? e) #t]
|
|
[(and (eq? '|::| (tok-n (car e)))
|
|
prev
|
|
(eq? (tok-n prev) (tok-n (cadr e))))
|
|
;; inline constructor: need to convert
|
|
#f]
|
|
[else (loop (cdr e) (car e))]))))
|
|
;; Not pgc, xform suspended,
|
|
;; or still in headers and probably a simple inlined function
|
|
(let ([palm-static? (and palm? (eq? 'static (tok-n (car e))))])
|
|
(when palm?
|
|
(fprintf map-port "(~aimpl ~s)\n"
|
|
(if palm-static? "s" "")
|
|
name)
|
|
(call-graph name e))
|
|
(append
|
|
(if palm-static?
|
|
;; Need to make sure prototype is there for section
|
|
(add-segment-label
|
|
name
|
|
(let loop ([e e])
|
|
(if (braces? (car e))
|
|
(list (make-tok semi #f #f))
|
|
(cons (car e) (loop (cdr e))))))
|
|
null)
|
|
e))
|
|
(convert-function e name)))))]
|
|
[(var-decl? e)
|
|
(when show-info? (printf "/* VAR */\n"))
|
|
(if (and can-drop-vars?
|
|
(simple-unused-def? e))
|
|
null
|
|
(begin
|
|
(when pgc?
|
|
(unless (eq? (tok-n (car e)) 'static)
|
|
(let-values ([(pointers non-pointers) (get-vars e "TOPVAR" #f)])
|
|
(top-vars (append pointers non-pointers (top-vars))))))
|
|
e))]
|
|
|
|
[(empty-decl? e)
|
|
e]
|
|
|
|
[else (print-struct #t)
|
|
(error 'xform "unknown form: ~s" e)]))
|
|
|
|
(define (empty-decl? e)
|
|
(and (= 1 (length e))
|
|
(eq? '|;| (tok-n (car e)))))
|
|
|
|
(define (start-skip? e)
|
|
(and (pair? e)
|
|
(or (eq? START_XFORM_SKIP (tok-n (car e)))
|
|
(eq? 'XFORM_START_SKIP (tok-n (car e))))))
|
|
|
|
(define (end-skip? e)
|
|
(and (pair? e)
|
|
(or (eq? END_XFORM_SKIP (tok-n (car e)))
|
|
(eq? 'XFORM_END_SKIP (tok-n (car e))))))
|
|
|
|
(define (start-suspend? e)
|
|
(and (pair? e)
|
|
(or (eq? START_XFORM_SUSPEND (tok-n (car e)))
|
|
(eq? 'XFORM_START_SUSPEND (tok-n (car e))))))
|
|
|
|
(define (end-suspend? e)
|
|
(and (pair? e)
|
|
(or (eq? END_XFORM_SUSPEND (tok-n (car e)))
|
|
(eq? 'XFORM_END_SUSPEND (tok-n (car e))))))
|
|
|
|
(define (start-arith? e)
|
|
(and (pair? e)
|
|
(or (eq? START_XFORM_ARITH (tok-n (car e)))
|
|
(eq? 'XFORM_END_TRUST_ARITH (tok-n (car e))))))
|
|
|
|
(define (end-arith? e)
|
|
(and (pair? e)
|
|
(or (eq? END_XFORM_ARITH (tok-n (car e)))
|
|
(eq? 'XFORM_START_TRUST_ARITH (tok-n (car e))))))
|
|
|
|
(define (threadlocal-decl? e)
|
|
(and (pair? e)
|
|
(or (eq? 'XFORM_GC_VARIABLE_STACK_THROUGH_GETSPECIFIC (tok-n (car e)))
|
|
(eq? 'XFORM_GC_VARIABLE_STACK_THROUGH_FUNCTION (tok-n (car e)))
|
|
(eq? 'XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL (tok-n (car e))))))
|
|
|
|
(define (access-modifier? e)
|
|
(and (memq (tok-n (car e)) '(public private protected))
|
|
(eq? (tok-n (cadr e)) '|:|)))
|
|
|
|
(define (friend? e)
|
|
(memq (tok-n (car e)) '(friend)))
|
|
|
|
;; recognize a function prototype:
|
|
(define (proc-prototype? e)
|
|
(let ([l (length e)])
|
|
(and (> l 2)
|
|
;; Ends in semicolon
|
|
(eq? semi (tok-n (list-ref e (sub1 l))))
|
|
(or (and
|
|
;; next-to-last is parens
|
|
(parens? (list-ref e (- l 2)))
|
|
;; Symbol before parens, not '=
|
|
(let ([s (tok-n (list-ref e (- l 3)))])
|
|
(and (symbol? s)
|
|
(not (eq? '= s)))))
|
|
(and
|
|
;; next-to-last is 0, then =, then parens
|
|
(eq? 0 (tok-n (list-ref e (- l 2))))
|
|
(eq? '= (tok-n (list-ref e (- l 3))))
|
|
(parens? (list-ref e (- l 4)))
|
|
;; Symbol before parens
|
|
(symbol? (tok-n (list-ref e (- l 5)))))))))
|
|
|
|
;; recognize a typedef:
|
|
(define (typedef? e)
|
|
(or (eq? 'typedef (tok-n (car e)))
|
|
(and (eq? '__extension__ (tok-n (car e)))
|
|
(pair? (cdr e))
|
|
(eq? 'typedef (tok-n (cadr e))))))
|
|
|
|
;; Sometimes, we know that a declaration is unused because
|
|
;; the tokenizer saw the defined symbol only once. (This
|
|
;; doesn't work if we're pre-compiling a header for later.)
|
|
(define (simple-unused-def? e)
|
|
(and (not precompiling-header?)
|
|
(andmap (lambda (x) (and (symbol? (tok-n x))
|
|
(not (eq? '|,| (tok-n x)))))
|
|
e)
|
|
(= 1 (hash-table-get used-symbols
|
|
(let loop ([e e])
|
|
(if (null? (cddr e))
|
|
(tok-n (car e))
|
|
(loop (cdr e))))))))
|
|
|
|
;; See `simple-unused-def?'. The `struct' case is more
|
|
;; complex, because multiple names might be assigned
|
|
;; in the same declaration.
|
|
(define (unused-struc-typedef? e)
|
|
(let ([once (lambda (s)
|
|
(and (not precompiling-header?)
|
|
(= 1 (hash-table-get used-symbols
|
|
(tok-n s)))))]
|
|
[seps (list '|,| '* semi)])
|
|
(let ([e (if (eq? '__extension__ (car e))
|
|
(cdr e)
|
|
e)])
|
|
(and (eq? (tok-n (cadr e)) 'struct)
|
|
(brackets? (cadddr e))
|
|
(once (caddr e))
|
|
(let loop ([e (cddddr e)])
|
|
(cond
|
|
[(null? e) #t]
|
|
[(or (memq (tok-n (car e)) seps)
|
|
(braces? (car e))
|
|
(once (car e)))
|
|
(loop (cdr e))]
|
|
[else #f]))))))
|
|
|
|
(define (struct-decl? e)
|
|
(and (memq (tok-n (car e)) '(struct enum))
|
|
(ormap braces? (cdr e))))
|
|
|
|
(define (class-decl? e)
|
|
(memq (tok-n (car e)) '(class)))
|
|
|
|
; ;Recognize a function (as opposed to a prototype):
|
|
(define (function? e)
|
|
(let ([l (length e)])
|
|
(and (> l 2)
|
|
(let* ([_n (tok-n (list-ref e (sub1 l)))]
|
|
[ll (if (eq? _n semi)
|
|
(- l 2)
|
|
(sub1 l))])
|
|
(let ([v (list-ref e ll)])
|
|
(and (braces? v)
|
|
(let ([v (list-ref e (sub1 ll))])
|
|
(or (parens? v)
|
|
(eq? (tok-n v) 'XFORM_SKIP_PROC)
|
|
;; `const' can appear between the arg parens
|
|
;; and the function body; this happens in the
|
|
;; OS X headers
|
|
(and (eq? 'const (tok-n v))
|
|
(positive? (sub1 ll))
|
|
(parens? (list-ref e (- ll 2))))))))))))
|
|
|
|
(define (skip-function? e)
|
|
(ormap (lambda (v) (eq? (tok-n v) 'XFORM_SKIP_PROC)) e))
|
|
|
|
;; Recognize a top-level variable declaration:
|
|
(define (var-decl? e)
|
|
(let ([l (length e)])
|
|
(and (> l 2)
|
|
(eq? semi (tok-n (list-ref e (sub1 l)))))))
|
|
|
|
(define (skip-static-line? e)
|
|
;; We want to skip the really-big static declaration for
|
|
;; the inlined bytecodes in GRacket
|
|
(let loop ([e e][l '(static unsigned char expr)])
|
|
(cond
|
|
[(null? l) #t]
|
|
[(null? e) #f]
|
|
[(eq? (tok-n (car e)) (car l))
|
|
(loop (cdr e) (cdr l))]
|
|
[else #f])))
|
|
|
|
(define (clean-proto e)
|
|
;; Strip __declspec(deprecated(...))
|
|
(if (and (eq? '__declspec (tok-n (car e)))
|
|
(parens? (cadr e))
|
|
(let ([l (seq->list (seq-in (cadr e)))])
|
|
(and (= 2 (length l))
|
|
(eq? 'deprecated (tok-n (car l)))
|
|
(parens? (cadr l)))))
|
|
;; Drop __declspec
|
|
(cddr e)
|
|
;; Nothing to drop
|
|
e))
|
|
|
|
;; e has been determined to be a function prototype.
|
|
;; Remember the information needed to convert calls
|
|
;; to e (especially the return type).
|
|
(define (register-proto-information e)
|
|
(parse-proto-information
|
|
e
|
|
(lambda (name class-name type args static?)
|
|
(unless class-name
|
|
(prototyped (cons (cons name (make-prototype
|
|
type
|
|
(seq->list (seq-in args))
|
|
static? #f #f))
|
|
(prototyped))))
|
|
name)))
|
|
|
|
(define (parse-proto-information e k)
|
|
(let loop ([e e][type null])
|
|
(cond
|
|
[(eq? '__declspec (tok-n (car e)))
|
|
(loop (cddr e) type)]
|
|
[(parens? (cadr e))
|
|
(let ([name (tok-n (car e))]
|
|
[type (let loop ([t (reverse type)])
|
|
(if (pair? t)
|
|
(if (or (memq (tok-n (car t)) '(extern static virtual __stdcall __cdecl
|
|
inline _inline __inline __inline__
|
|
__xform_nongcing__))
|
|
(equal? "C" (tok-n (car t))))
|
|
(loop (cdr t))
|
|
(cons (car t) (loop (cdr t))))
|
|
t))]
|
|
[static? (ormap (lambda (t) (eq? (tok-n t) 'static)) type)])
|
|
;; Clean type if we find a method/constructor/destructor
|
|
(let-values ([(type class-name)
|
|
(if (and (list? type)
|
|
((length type) . >= . 2))
|
|
(let ([rev-type (reverse type)])
|
|
(cond
|
|
[(eq? '|::| (tok-n (car rev-type)))
|
|
(values (reverse (cddr rev-type)) (cadr rev-type))]
|
|
[(and ((length type) . >= . 3)
|
|
(eq? '~ (tok-n (car rev-type)))
|
|
(eq? '|::| (tok-n (cadr rev-type))))
|
|
(values (reverse (cdddr rev-type)) (caddr rev-type))]
|
|
[else (values type #f)]))
|
|
(values type #f))])
|
|
(k name
|
|
class-name
|
|
type
|
|
(cadr e)
|
|
static?)))]
|
|
[else
|
|
(loop (cdr e) (cons (car e) type))])))
|
|
|
|
;; prototype-for-pointer? : (cons sym prototype) -> bool
|
|
;; Returns #t if the prototype declares a function that returns
|
|
;; a pointer. This information is computed (based on the declaration)
|
|
;; the first time it is needed, and then cached.
|
|
(define (prototype-for-pointer? m)
|
|
(let ([name (car m)]
|
|
[proto (cdr m)])
|
|
(unless (prototype-pointer?-determined? proto)
|
|
;; We want to use `get-pointer-vars' to figure out the
|
|
;; answer, so invent a fake declaration and check it:
|
|
(let ([e (append (prototype-type proto)
|
|
(list (make-tok name #f #f)
|
|
(make-tok semi #f #f)))])
|
|
(let ([vars (get-pointer-vars e "PROTODEF" #f)])
|
|
(set-prototype-pointer?! proto (not (null? vars)))
|
|
(set-prototype-pointer?-determined?! proto #t))))
|
|
(prototype-pointer? proto)))
|
|
|
|
(define (lookup-non-pointer-type t)
|
|
(memq t non-pointer-types))
|
|
(define (lookup-pointer-type t)
|
|
(assq t pointer-types))
|
|
(define (lookup-struct-def t)
|
|
(assq t struct-defs))
|
|
|
|
;; e is a typedef; drop the "typedef" keyword and
|
|
;; parse it as a variable declaration using `get-vars', then extend
|
|
;; `pointer-types' and `non-pointer-types' based on the result.
|
|
(define (check-pointer-type e)
|
|
(let*-values ([(pointers non-pointers)
|
|
(get-vars ((if (eq? '__extension__ (car e))
|
|
cddr
|
|
cdr)
|
|
e)
|
|
"PTRDEF" #t)]
|
|
;; Remove things like HANDLE and HWND, which are not
|
|
;; malloced and could overlap with GCed areas:
|
|
[(pointers non-pointers)
|
|
(let ([l (filter (lambda (p)
|
|
(memq (car p) non-pointer-typedef-names))
|
|
pointers)])
|
|
(if (null? l)
|
|
(values pointers non-pointers)
|
|
(values (filter (lambda (p)
|
|
(not (memq (car p) non-pointer-typedef-names)))
|
|
pointers)
|
|
(append l non-pointers))))])
|
|
(set! pointer-types (append pointers pointer-types))
|
|
(set! non-pointer-types (append (map car non-pointers) non-pointer-types))))
|
|
|
|
;; get-vars : tok-list str bool -> (values list-of-(cons sym vtype) list-of-(cons sym vtype))
|
|
;; Parses a declaration of one line (which may have multiple, comma-separated variables).
|
|
;; Returns a list of pointer declarations and a list of non-pointer declarations.
|
|
(define (get-vars e comment union-ok?)
|
|
(let* ([e (if (or (eq? GC_CAN_IGNORE (tok-n (car e)))
|
|
(eq? 'XFORM_CAN_IGNORE (tok-n (car e))))
|
|
(list (make-tok semi #f #f)) ; drop everything
|
|
(filter (lambda (x) (not (memq (tok-n x) '(volatile __volatile__ __volatile const)))) e))]
|
|
[base (tok-n (car e))]
|
|
[base-is-ptr?
|
|
(lookup-pointer-type base)]
|
|
[base-struct
|
|
(and (eq? base 'struct)
|
|
(if (or (braces? (cadr e)) (braces? (caddr e)))
|
|
(register-struct e)
|
|
(let ([m (lookup-struct-def (tok-n (cadr e)))])
|
|
(and m (car m)))))]
|
|
[minpos (if (or (eq? base 'struct)
|
|
(eq? base 'union))
|
|
1
|
|
0)]
|
|
[non-ptr-base (cond
|
|
[(eq? 'unsigned (tok-n (car e)))
|
|
(if (memq (tok-n (cadr e)) '(int long char intptr_t))
|
|
(list 'unsigned (tok-n (cadr e))))]
|
|
[(lookup-non-pointer-type (tok-n (car e)))
|
|
(list (tok-n (car e)))]
|
|
[else #f])])
|
|
(let loop ([l (- (length e) 2)][array-size #f][pointers null][non-pointers null])
|
|
(if (<= l minpos)
|
|
(values pointers non-pointers)
|
|
;; Look back for "=" before comma:
|
|
(let ([skip (let loop ([l (sub1 l)])
|
|
(cond
|
|
[(or (<= l minpos)
|
|
(eq? '|,| (tok-n (list-ref e l))))
|
|
#f]
|
|
[(eq? '= (tok-n (list-ref e l)))
|
|
(sub1 l)]
|
|
[else (loop (sub1 l))]))])
|
|
(if skip
|
|
;; Skip assignment RHS:
|
|
(loop skip #f pointers non-pointers)
|
|
;; Not assignment RHS:
|
|
(let ([v (list-ref e l)])
|
|
(cond
|
|
[(seq? v)
|
|
;; Array? Struct?
|
|
(cond
|
|
[(brackets? v)
|
|
;; Array decl:
|
|
(loop (sub1 l)
|
|
(let ([inner (seq->list (seq-in (list-ref e l)))])
|
|
(if (null? inner)
|
|
'pointer
|
|
(tok-n (car inner))))
|
|
pointers non-pointers)]
|
|
[(braces? v)
|
|
;; No more variable declarations
|
|
(values pointers non-pointers)]
|
|
[else
|
|
;; End of function ptr
|
|
;; (and we don't care about func ptrs)
|
|
(values pointers non-pointers)])]
|
|
[(memq (tok-n v) '(int long char unsigned intptr_t void ulong uint uintptr_t))
|
|
;; No more variable declarations
|
|
(values pointers non-pointers)]
|
|
[(memq (tok-n v) '(|,| * |:| 1))
|
|
(loop (sub1 l) #f pointers non-pointers)]
|
|
[else (let* ([name (tok-n v)]
|
|
[pointer? (or (eq? 'pointer array-size)
|
|
(eq? '* (tok-n (list-ref e (sub1 l)))))]
|
|
[star-count (+ (if (eq? 'pointer array-size)
|
|
1
|
|
0)
|
|
(let loop ([l (sub1 l)])
|
|
(if (eq? '* (tok-n (list-ref e l)))
|
|
(add1 (loop (sub1 l)))
|
|
0)))]
|
|
[base-struct (or base-struct
|
|
(and base-is-ptr?
|
|
(struc-type? (cdr base-is-ptr?))
|
|
(struc-type-struct (cdr base-is-ptr?))))]
|
|
[union? (or (eq? base 'union)
|
|
(and base-is-ptr?
|
|
(union-type? (cdr base-is-ptr?))))]
|
|
[struct-array? (or (and base-struct (not pointer?) (number? array-size))
|
|
(and base-is-ptr? (struct-array-type? (cdr base-is-ptr?))))]
|
|
[array-size (if (number? array-size)
|
|
array-size
|
|
(and struct-array?
|
|
(struct-array-type-count (cdr base-is-ptr?))))])
|
|
(when (and struct-array?
|
|
(not union-ok?)
|
|
(> array-size 16))
|
|
(log-error "[SIZE] ~a in ~a: Large array of structures at ~a."
|
|
(tok-line v) (tok-file v) name))
|
|
(when (and (not union-ok?)
|
|
(not pointer?)
|
|
(or union?
|
|
(and base-struct
|
|
(let has-union? ([base base-struct])
|
|
(let ([v (cdr (lookup-struct-def base))])
|
|
(ormap
|
|
(lambda (v)
|
|
(or (union-type? v)
|
|
(and (struc-type? v)
|
|
(has-union? (struc-type-struct v)))))
|
|
v))))))
|
|
(log-warning "[UNION] ~a in ~a: Can't handle union or record with union, ~a."
|
|
(tok-line v) (tok-file v) name))
|
|
(if (and (or pointer?
|
|
base-is-ptr?
|
|
base-struct
|
|
union?)
|
|
; Ignore these variables, for one reason or another:
|
|
(not (memq name '(tcp_connect_dest_addr
|
|
tcp_listen_addr
|
|
tcp_here_addr
|
|
tcp_there_addr
|
|
tcp_accept_addr))))
|
|
(begin
|
|
(when show-info?
|
|
(printf "/* ~a: ~a ~a*/\n"
|
|
comment name
|
|
(cond
|
|
[struct-array?
|
|
(format "struct ~a[~a] " base-struct array-size)]
|
|
[(number? array-size)
|
|
(format "[~a] " array-size)]
|
|
[(and base-struct (not pointer?))
|
|
(format "struct ~a " base-struct)]
|
|
[(and union? (not pointer?)) "union "]
|
|
[else (format "~a ~a* " (or (and base (list base))
|
|
non-ptr-base)
|
|
star-count)])))
|
|
(loop (sub1 l) #f
|
|
(cons (cons name
|
|
(cond
|
|
[struct-array?
|
|
(make-struct-array-type base-struct array-size)]
|
|
[(number? array-size)
|
|
(make-array-type array-size)]
|
|
[pointer? (make-pointer-type (or (and base (list base))
|
|
non-ptr-base)
|
|
star-count)]
|
|
[base-struct
|
|
(make-struc-type base-struct)]
|
|
[union?
|
|
(make-union-type)]
|
|
[else
|
|
(make-pointer-type (or (and base (list base))
|
|
non-ptr-base)
|
|
star-count)]))
|
|
pointers)
|
|
non-pointers))
|
|
(begin
|
|
(when (and base (find-c++-class base #f))
|
|
(log-error "[INST] ~a in ~a: Static instance of class ~a."
|
|
(tok-line (car e)) (tok-file (car e)) base))
|
|
(when show-info?
|
|
(printf "/* NP ~a: ~a */\n"
|
|
comment name))
|
|
(loop (sub1 l) #f pointers (cons (cons name
|
|
(make-non-pointer-type non-ptr-base))
|
|
non-pointers)))))]))))))))
|
|
|
|
(define (get-pointer-vars e comment union-ok?)
|
|
(let-values ([(pointers non-pointers)
|
|
(get-vars e comment union-ok?)])
|
|
pointers))
|
|
|
|
(define (get-pointer-vars-from-seq body comment comma-sep?)
|
|
(let-values ([(pragmas el) (body->lines body comma-sep?)])
|
|
(apply
|
|
append
|
|
(map (lambda (e)
|
|
(get-pointer-vars e comment #t))
|
|
el))))
|
|
|
|
;; e is a struct decl; parse it an remember the results
|
|
(define (register-struct e)
|
|
(let ([body (seq->list (seq-in (if (braces? (cadr e))
|
|
(cadr e)
|
|
(caddr e))))]
|
|
[name (if (braces? (cadr e))
|
|
(gensym 'Anonymous)
|
|
(tok-n (cadr e)))])
|
|
(let ([l (get-pointer-vars-from-seq body "PTRFIELD" #f)])
|
|
(and (not (null? l))
|
|
(begin
|
|
(set! struct-defs (cons (cons name l) struct-defs))
|
|
name)))))
|
|
|
|
;; This is for PalmOS conversion with SEGOF decls.
|
|
(define (add-segment-label name e)
|
|
(let loop ([e e])
|
|
(cond
|
|
[(null? (cdr e))
|
|
(fprintf map-port "(decl ~s)\n" name)
|
|
(list (make-tok (string->symbol (format "SEGOF_~a" name))
|
|
#f #f)
|
|
(car e))]
|
|
[(memq (tok-n (car e)) (list __attribute__))
|
|
;; No segment wanted
|
|
e]
|
|
[else
|
|
(cons (car e) (loop (cdr e)))])))
|
|
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Transformations
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; type->decl : vtype tok[for errs] -> seq list
|
|
;; Creates a type declaration based on a type struct (without the name of
|
|
;; a declared variable).
|
|
(define (type->decl x where-v)
|
|
(cond
|
|
[(and (non-pointer-type? x)
|
|
(non-pointer-type-base x))
|
|
(map (lambda (x) (make-tok x #f #f)) (non-pointer-type-base x))]
|
|
[(and (pointer-type? x) (pointer-type-base x))
|
|
(append (map (lambda (x) (make-tok x #f #f)) (pointer-type-base x))
|
|
(let loop ([n (pointer-type-stars x)])
|
|
(if (zero? n)
|
|
null
|
|
(cons (make-tok '* #f #f) (loop (sub1 n))))))]
|
|
[else (log-error "[TYPE] ~a in ~a: Can't render type declaration for ~a"
|
|
(tok-line where-v) (tok-file where-v)
|
|
x)
|
|
(list (make-tok '??? #f #f))]))
|
|
|
|
;; Takes a class-decl, parses it, and records the information.
|
|
;; The basic strategy is to parse the class body as a top-level
|
|
;; sequence, and then move the collected info into the class
|
|
;; record. As the same time, we re-arrange the constructor
|
|
;; and put the work into a gcInit_ method to be called explicitly.
|
|
;; We also manufactor the gcMark and gcFixup methods.
|
|
(define (register-class e)
|
|
(let ([name (tok-n (cadr e))]
|
|
[body-pos (if (eq? '|:| (tok-n (caddr e)))
|
|
(if (memq (tok-n (cadddr e)) '(public private))
|
|
5
|
|
4)
|
|
2)])
|
|
(unless (braces? (list-ref e body-pos))
|
|
(error 'xform "Confused by form of class declaration at line ~a in ~a"
|
|
(tok-line (car e))
|
|
(tok-file (car e))))
|
|
(let* ([super (if (> body-pos 2)
|
|
(tok-n (list-ref e (sub1 body-pos)))
|
|
#f)]
|
|
[cl (make-c++-class super
|
|
(if (or super (eq? name 'gc))
|
|
super
|
|
'gc)
|
|
null
|
|
null)]
|
|
[pt (prototyped)]
|
|
[vs (top-vars)])
|
|
(set! c++-classes (cons (cons name cl) c++-classes))
|
|
(prototyped null)
|
|
(top-vars null)
|
|
(let* ([body-v (list-ref e body-pos)]
|
|
[body-e (process-top-level (seq->list (seq-in body-v)) ".h" #f)]
|
|
[methods (prototyped)])
|
|
;; Save prototype list, but remove constructor and statics:
|
|
(set-c++-class-prototyped! cl (filter (lambda (x)
|
|
(not (or (eq? (car x) name)
|
|
(prototype-static? (cdr x)))))
|
|
methods))
|
|
(set-c++-class-top-vars! cl (top-vars))
|
|
(prototyped pt)
|
|
(top-vars vs)
|
|
(if (not (or (eq? 'gc (tok-n (caddr e)))
|
|
(assoc 'gc c++-classes)))
|
|
;; primitive class, before `gc' defn
|
|
e
|
|
;; normal class:
|
|
(let loop ([e e][p body-pos])
|
|
(if (zero? p)
|
|
(append
|
|
(if (or super (eq? name 'gc))
|
|
null
|
|
(list
|
|
(make-tok '|:| #f #f)
|
|
(make-tok 'public #f #f)
|
|
(make-tok 'gc #f #f)))
|
|
(cons (make-braces
|
|
(tok-n body-v)
|
|
(tok-line body-v)
|
|
(tok-file body-v)
|
|
(seq-close body-v)
|
|
(list->seq
|
|
(append
|
|
|
|
;; Replace constructors names with gcInit_ names
|
|
(let loop ([e body-e][did-one? #f])
|
|
(cond
|
|
[(null? e) (if did-one?
|
|
null
|
|
;; Need an explicit gcInit_ method:
|
|
(list
|
|
(make-tok 'inline #f #f)
|
|
(make-tok 'void #f #f)
|
|
(make-gc-init-tok name)
|
|
(make-parens "(" #f #f ")" (seqce))
|
|
(make-braces "{" #f #f "}"
|
|
(if super
|
|
(seqce
|
|
(make-tok 'this #f #f)
|
|
(make-tok '-> #f #f)
|
|
(make-gc-init-tok super)
|
|
(make-parens "(" #f #f ")" (seqce))
|
|
(make-tok semi #f #f))
|
|
(seqce)))))]
|
|
[(eq? (tok-n (car e)) '~)
|
|
;; destructor
|
|
(cons (car e) (cons (cadr e) (loop (cddr e) did-one?)))]
|
|
[(and (eq? (tok-n (car e)) name)
|
|
(parens? (cadr e)))
|
|
;; constructor
|
|
(cons (make-tok 'void #f #f)
|
|
(cons (make-gc-init-tok (tok-n (car e)))
|
|
(loop (cdr e) #t)))]
|
|
[else (cons (car e) (loop (cdr e) did-one?))]))
|
|
|
|
(if (or (eq? name 'gc)
|
|
(assq gcMark (c++-class-prototyped cl)))
|
|
;; Don't add to gc or to a class that has it
|
|
null
|
|
|
|
;; Add gcMark and gcFixup methods:
|
|
(let ([mk-proc
|
|
(lambda (name marker)
|
|
(list
|
|
(make-tok 'inline #f #f)
|
|
(make-tok 'void #f #f)
|
|
(make-tok name #f #f)
|
|
(make-parens
|
|
"(" #f #f ")"
|
|
(seqce))
|
|
(make-braces
|
|
"{" #f #f "}"
|
|
(list->seq
|
|
(make-mark-body name marker
|
|
(or super 'gc)
|
|
(c++-class-top-vars cl)
|
|
(car e))))))])
|
|
(append
|
|
(list
|
|
(make-tok 'public #f #f)
|
|
(make-tok '|:| #f #f))
|
|
;; gcMark method:
|
|
(mk-proc gcMark gcMARK_TYPED)
|
|
;; gcFixup method:
|
|
(mk-proc gcFixup gcFIXUP_TYPED)))))))
|
|
(cdr e)))
|
|
|
|
(cons (car e) (loop (cdr e) (sub1 p))))))))))
|
|
|
|
;; Builds the body of a gcMark or gcFixup method
|
|
(define (make-mark-body name marker super vars where-v)
|
|
(let ([pointers (append
|
|
(filter (lambda (x)
|
|
(not (non-pointer-type? (cdr x))))
|
|
vars))])
|
|
(append
|
|
(list
|
|
(make-tok super #f #f)
|
|
(make-tok '|::| #f #f)
|
|
(make-tok name #f #f)
|
|
(make-parens
|
|
"(" #f #f ")"
|
|
(seqce))
|
|
(make-tok semi #f #f))
|
|
(if (null? pointers)
|
|
null
|
|
(apply
|
|
append
|
|
(map (lambda (x)
|
|
(list
|
|
(make-tok marker #f #f)
|
|
(make-parens
|
|
"(" #f #f ")"
|
|
(list->seq
|
|
(append
|
|
(type->decl (cdr x) where-v)
|
|
(list (make-tok '|,| #f #f)
|
|
(make-tok (car x) #f #f)))))
|
|
(make-tok semi #f #f)))
|
|
pointers))))))
|
|
|
|
(define (find-c++-class class-name report-err?)
|
|
(and class-name
|
|
(let ([m (assoc class-name c++-classes)])
|
|
(if m
|
|
(cdr m)
|
|
(begin
|
|
(when report-err?
|
|
(log-error "[CLASS]: Unknown class ~a."
|
|
class-name))
|
|
#f)))))
|
|
|
|
(define (get-c++-class-member var c++-class c++-class-members)
|
|
(and c++-class
|
|
(let ([m (assoc var (c++-class-members c++-class))])
|
|
(or m
|
|
(let ([parent (c++-class-parent c++-class)])
|
|
(and parent
|
|
(if (c++-class? parent)
|
|
(get-c++-class-member var parent c++-class-members)
|
|
(let ([parent (find-c++-class parent #t)])
|
|
(set-c++-class-parent! c++-class parent)
|
|
(get-c++-class-member var parent c++-class-members)))))))))
|
|
|
|
(define (get-c++-class-var var c++-class)
|
|
(get-c++-class-member var c++-class c++-class-top-vars))
|
|
|
|
(define (get-c++-class-method var c++-class)
|
|
(get-c++-class-member var c++-class c++-class-prototyped))
|
|
|
|
;; Temporary state used during a conversion:
|
|
(define used-self? #f)
|
|
(define important-conversion? #f)
|
|
(define saw-gcing-call #f)
|
|
|
|
(define (new-vars->decls vars)
|
|
(apply
|
|
append
|
|
(map
|
|
(lambda (tv)
|
|
(list (make-tok (car tv) #f #f)
|
|
(make-tok '* #f #f)
|
|
(make-tok (cdr tv) #f #f)
|
|
(make-tok semi #f #f)))
|
|
vars)))
|
|
|
|
(define (make-gc-init-tok s)
|
|
(make-tok (string->symbol (format "gcInit_~a" s)) #f #f))
|
|
|
|
;; e is a function definition. Convert its body (if necessary)
|
|
;; to register locals with the GC. Do a little special work
|
|
;; for constructors, detected by a '|:| outside the body.
|
|
(define (convert-function e name)
|
|
(let*-values ([(body-v len) (let* ([len (sub1 (length e))]
|
|
[v (list-ref e len)])
|
|
;; Function may have trailing semicolon:
|
|
(if (eq? semi (tok-n v))
|
|
(values (list-ref e (sub1 len)) (sub1 len))
|
|
(values v len)))]
|
|
[(body-e) (seq->list (seq-in body-v))]
|
|
[(class-name function-name func-pos)
|
|
(let loop ([e e][p 0])
|
|
(cond
|
|
[(null? e) (values #f #f #f)]
|
|
[(null? (cdr e)) (values #f #f #f)]
|
|
[(eq? '|::| (tok-n (cadr e)))
|
|
(values (tok-n (car e))
|
|
(tok-n (caddr e))
|
|
(+ p 2))]
|
|
[else (loop (cdr e) (add1 p))]))]
|
|
[(args-e) (seq->list (seq-in (list-ref e (if (and func-pos
|
|
(eq? class-name function-name))
|
|
(add1 func-pos)
|
|
(sub1 len)))))]
|
|
[(arg-vars all-arg-vars)
|
|
(let-values ([(arg-pragmas arg-decls) (body->lines (append
|
|
args-e
|
|
(list (make-tok '|,| #f #f)))
|
|
#t)])
|
|
(unless (null? arg-pragmas)
|
|
(error 'arg-decls "unexpected pragmas"))
|
|
(let loop ([l arg-decls][arg-vars null][all-arg-vars null])
|
|
(if (null? l)
|
|
(values arg-vars all-arg-vars)
|
|
(let-values ([(ptrs non-ptrs) (get-vars (car l) "PTRARG" #f)])
|
|
(loop (cdr l) (append arg-vars ptrs) (append all-arg-vars ptrs non-ptrs))))))]
|
|
[(c++-class) (let ([c++-class (find-c++-class class-name #t)])
|
|
(and c++-class
|
|
(or (get-c++-class-method function-name c++-class)
|
|
(eq? function-name class-name)
|
|
(eq? function-name '~))
|
|
c++-class))]
|
|
[(initializers) (let loop ([e e][len len])
|
|
(cond
|
|
[(zero? len) #f]
|
|
[(eq? (tok-n (car e)) '|:|)
|
|
(cons (cadr e) (caddr e))]
|
|
[else (loop (cdr e) (sub1 len))]))])
|
|
(append
|
|
|
|
;; Build all of the function declaration up to the body:
|
|
(let loop ([e e][len len][need-void? #t])
|
|
(cond
|
|
[(zero? len)
|
|
null]
|
|
[(eq? (tok-n (car e)) '|:|)
|
|
;; skip initializers
|
|
null]
|
|
[(and function-name
|
|
(eq? function-name class-name)
|
|
(eq? (tok-n (car e)) class-name)
|
|
(parens? (cadr e)))
|
|
;; Replace constructor name with gcInit_ name:
|
|
(cons (make-gc-init-tok (tok-n (car e)))
|
|
(loop (cdr e) (sub1 len) #f))]
|
|
[(eq? (tok-n (car e)) 'inline)
|
|
;; Don't want 'void before 'inline
|
|
(cons (car e) (loop (cdr e) (sub1 len) need-void?))]
|
|
[else
|
|
(if (and need-void?
|
|
function-name
|
|
(eq? function-name class-name))
|
|
(cons (make-tok 'void #f #f)
|
|
(loop e len #f))
|
|
(cons (car e)
|
|
(loop (cdr e) (sub1 len) #f)))]))
|
|
(list
|
|
(make-braces
|
|
(tok-n body-v)
|
|
(tok-line body-v)
|
|
(tok-file body-v)
|
|
(seq-close body-v)
|
|
(let-values ([(orig-body-e) (begin
|
|
(set! important-conversion? #f)
|
|
(set! saw-gcing-call #f)
|
|
body-e)]
|
|
[(body-e live-vars)
|
|
;; convert-body does most of the conversion work, and also
|
|
;; introduces the PREPARE_VAR_STACK decl, since the last arg
|
|
;; provided here is not #f.
|
|
(convert-body (if c++-class
|
|
(let* ([new-vars-box (box null)]
|
|
[e (begin
|
|
(set! used-self? #f)
|
|
(convert-class-vars body-e all-arg-vars c++-class new-vars-box))])
|
|
(append
|
|
;; If sElF is used, add its declaration.
|
|
(if (or used-self?
|
|
(and function-name
|
|
(eq? class-name function-name)))
|
|
(list
|
|
(make-tok class-name #f #f)
|
|
(make-tok '* #f #f)
|
|
(make-tok sElF #f #f)
|
|
(make-tok '= #f #f)
|
|
(make-tok 'this #f #f)
|
|
(make-tok semi #f #f))
|
|
null)
|
|
;; New vars for obj creation:
|
|
(new-vars->decls (unbox new-vars-box))
|
|
;; The main body:
|
|
e))
|
|
|
|
;; Do any conversion?
|
|
(if source-is-c++?
|
|
(let* ([new-vars-box (box null)]
|
|
[e (convert-class-vars body-e all-arg-vars #f new-vars-box)])
|
|
(append
|
|
(new-vars->decls (unbox new-vars-box))
|
|
e))
|
|
body-e))
|
|
arg-vars arg-vars #f
|
|
c++-class
|
|
;; Moved initializers, if constructor
|
|
(if (and function-name
|
|
(eq? class-name function-name))
|
|
(let ([super-type (if initializers
|
|
(tok-n (car initializers))
|
|
(c++-class-parent-name c++-class))]
|
|
[super-args (if initializers
|
|
(cdr initializers)
|
|
(make-parens "(" #f #f ")" (seqce)))])
|
|
(list (list (make-tok sElF #f #f)
|
|
(make-tok '-> #f #f)
|
|
(make-gc-init-tok super-type)
|
|
super-args
|
|
(make-tok semi #f #f))))
|
|
null)
|
|
(lambda () null)
|
|
;; Initially, no live vars, no introduiced vars, etc.:
|
|
(make-live-var-info #f -1 0 null null null 0 0 0 #f)
|
|
;; Add PREPARE_VAR_STACK and ensure result return:
|
|
(parse-proto-information
|
|
e
|
|
(lambda (name class-name type args static?)
|
|
type)))])
|
|
(if (hash-table-get non-gcing-functions name (lambda () #f))
|
|
(when saw-gcing-call
|
|
(log-error "[GCING] ~a in ~a: Function ~a declared __xform_nongcing__, but includes a function call."
|
|
(tok-line saw-gcing-call) (tok-file saw-gcing-call)
|
|
name))
|
|
(unless saw-gcing-call
|
|
'
|
|
(fprintf (current-error-port)
|
|
"[SUGGEST] Consider declaring ~a as __xform_nongcing__.\n"
|
|
name)))
|
|
(if (and (not important-conversion?)
|
|
(not (and function-name
|
|
(eq? class-name function-name)))
|
|
(or (not saw-gcing-call)
|
|
(and
|
|
(null? (live-var-info-new-vars live-vars))
|
|
(zero? (live-var-info-maxpush live-vars))
|
|
(or (<= (live-var-info-num-calls live-vars) 1)
|
|
(= (live-var-info-num-calls live-vars)
|
|
(+ (live-var-info-num-empty-calls live-vars)
|
|
(live-var-info-num-noreturn-calls live-vars)))))))
|
|
;; No conversion necessary. (Lack of `call' records means no GC-setup
|
|
;; work when printing out the function.)
|
|
(list->seq
|
|
(cons
|
|
(make-note 'note #f #f "/* No conversion */")
|
|
orig-body-e))
|
|
(list->seq body-e))))))))
|
|
|
|
(define (convert-class-vars body-e arg-vars c++-class new-vars-box)
|
|
(when c++-class
|
|
(let-values ([(pragmas el) (body->lines body-e #f)])
|
|
(let-values ([(decls body) (split-decls el)])
|
|
(for-each (lambda (e)
|
|
(let-values ([(pointers non-pointers) (get-vars e "CVTLOCAL" #f)])
|
|
(for-each
|
|
(lambda (var)
|
|
(when (get-c++-class-var (car var) c++-class)
|
|
(log-error "[SHADOW++] ~a in ~a: Class variable ~a shadowed in decls."
|
|
(tok-line (caar decls)) (tok-file (caar decls))
|
|
(car var))))
|
|
(append pointers non-pointers))))
|
|
decls))))
|
|
(let loop ([e body-e][can-convert? #t][paren-arrows? #t])
|
|
(cond
|
|
[(null? e) null]
|
|
[(skip-static-line? e)
|
|
;; Jump to semicolon:
|
|
(let jloop ([e e])
|
|
(if (eq? semi (tok-n (car e)))
|
|
(loop e can-convert? paren-arrows?)
|
|
(cons (car e) (jloop (cdr e)))))]
|
|
[(and can-convert?
|
|
c++-class
|
|
(pair? (cdr e))
|
|
(eq? (tok-n (cadr e)) '|::|)
|
|
(find-c++-class (tok-n (car e)) #f))
|
|
;; Maybe class-qualified method invocation. See
|
|
;; what happens if we remove the qualification
|
|
(let ([rest (loop (cddr e) #t paren-arrows?)])
|
|
(if (eq? sElF (tok-n (car rest)))
|
|
(list* (car rest)
|
|
(cadr rest)
|
|
(car e)
|
|
(cadr e)
|
|
(cddr rest))
|
|
(list* (car e)
|
|
(cadr e)
|
|
rest)))]
|
|
[else
|
|
(let ([v (car e)])
|
|
(cond
|
|
[(pragma? v)
|
|
(cons v (loop (cdr e) can-convert? paren-arrows?))]
|
|
[(memq (tok-n v) '(|.| -> |::|))
|
|
;; Don't check next as class member
|
|
(cons v (loop (cdr e) #f paren-arrows?))]
|
|
[(eq? (tok-n v) 'delete)
|
|
;; Make `delete' expression look like a function call
|
|
(let ([arr? (brackets? (cadr e))])
|
|
(loop (list*
|
|
(make-tok (if arr? DELETE_ARRAY DELETE)
|
|
(tok-line v) (tok-file v))
|
|
(make-parens
|
|
"(" (tok-line v) (tok-file v) ")"
|
|
(seqce ((if arr? caddr cadr) e)))
|
|
((if arr? cdddr cddr) e))
|
|
#t
|
|
paren-arrows?))]
|
|
[(eq? (tok-n v) 'delete_wxobject)
|
|
;; replace with call to GC_cpp_delete()
|
|
(set! important-conversion? #t)
|
|
(when (brackets? (cadr e))
|
|
(log-error "[DELOBJ] ~a in ~a: bad use of delete_wxobject"
|
|
(tok-line v) (tok-file v)))
|
|
(loop (list*
|
|
(make-tok GC_cpp_delete (tok-line v) (tok-file v))
|
|
(make-parens
|
|
"(" (tok-line v) (tok-file v) ")"
|
|
(seqce (cadr e)))
|
|
(cddr e))
|
|
#t
|
|
paren-arrows?)]
|
|
[(eq? (tok-n v) 'new)
|
|
;; Make `new' expression look like a function call
|
|
(set! important-conversion? #t)
|
|
(let* ([t (cadr e)]
|
|
[obj? (find-c++-class (tok-n t) #f)]
|
|
[atom? (lookup-non-pointer-type (tok-n t))])
|
|
(unless (or obj? atom?)
|
|
(log-error "[NEW] ~a in ~a: New used on non-class"
|
|
(tok-line (car e)) (tok-file (car e))))
|
|
|
|
(cond
|
|
[(and (pair? (cddr e))
|
|
(eq? '* (tok-n (caddr e)))
|
|
(pair? (cdddr e))
|
|
(brackets? (cadddr e)))
|
|
;; Array of pointers
|
|
(loop (list*
|
|
(make-tok NEW_PTR_ARRAY
|
|
(tok-line v) (tok-file v))
|
|
(make-parens
|
|
"(" (tok-line v) (tok-file v) ")"
|
|
(seqce (cadr e)
|
|
(make-tok '|,| #f #f)
|
|
(cadddr e)))
|
|
(cddddr e))
|
|
#t
|
|
paren-arrows?)]
|
|
[(and (pair? (cddr e))
|
|
(eq? '* (tok-n (caddr e))))
|
|
;; A pointer
|
|
(loop (list*
|
|
(make-tok NEW_PTR
|
|
(tok-line v) (tok-file v))
|
|
(make-parens
|
|
"(" (tok-line v) (tok-file v) ")"
|
|
(seqce (cadr e) (caddr e)))
|
|
(cdddr e))
|
|
#t
|
|
paren-arrows?)]
|
|
[(and (pair? (cddr e))
|
|
(brackets? (caddr e)))
|
|
;; An array of objects
|
|
(unless (or atom? (eq? #cs'wxPoint (tok-n t)))
|
|
(log-warning "[ARRAY] ~a in ~a: array of ~a objects, allocating as array of atomic."
|
|
(tok-line t) (tok-file t)
|
|
(tok-n t)))
|
|
(loop (list*
|
|
(make-tok (if atom?
|
|
NEW_ATOM_ARRAY
|
|
NEW_ARRAY)
|
|
#f #f)
|
|
(make-parens
|
|
"(" (tok-line v) (tok-file v) ")"
|
|
(seqce (cadr e)
|
|
(make-tok '|,| #f #f)
|
|
(caddr e)))
|
|
(cdddr e))
|
|
#t
|
|
paren-arrows?)]
|
|
[(or (and (pair? (cddr e))
|
|
(parens? (caddr e)))
|
|
(not atom?))
|
|
;; An object with init argument
|
|
(when atom?
|
|
(log-error "[CONFUSED] ~a in ~a: atomic type with initializers?"
|
|
(tok-line v) (tok-file v)))
|
|
(let ([args? (and (pair? (cddr e))
|
|
(parens? (caddr e)))]
|
|
[line (tok-line v)]
|
|
[file (tok-file v)]
|
|
[new-var (string->symbol (format "~a_created" (tok-n (cadr e))))])
|
|
(unless (assq (tok-n (cadr e)) (unbox new-vars-box))
|
|
(set-box! new-vars-box (cons (cons (tok-n (cadr e)) new-var)
|
|
(unbox new-vars-box))))
|
|
(loop (list*
|
|
(make-creation-parens
|
|
"(" line file ")"
|
|
(seqce
|
|
(make-tok new-var line file)
|
|
(make-tok '= line file)
|
|
(make-tok NEW_OBJ line file)
|
|
(make-parens
|
|
"(" line file ")"
|
|
(seqce (cadr e)))
|
|
(make-tok '|,| line file)
|
|
(make-tok new-var line file)
|
|
(make-tok '-> line file)
|
|
(make-gc-init-tok (tok-n (cadr e)))
|
|
(if args?
|
|
(caddr e)
|
|
(make-parens
|
|
"(" line file ")"
|
|
(seqce)))
|
|
(make-tok '|,| line file)
|
|
(make-tok new-var line file)))
|
|
((if args? cdddr cddr) e))
|
|
#t
|
|
paren-arrows?))]
|
|
[else
|
|
;; An atom
|
|
(loop (list*
|
|
(make-tok NEW_ATOM (tok-line v) (tok-file v))
|
|
(make-parens
|
|
"(" (tok-line v) (tok-file v) ")"
|
|
(seqce (cadr e)))
|
|
(cddr e))
|
|
#t
|
|
paren-arrows?)]))]
|
|
[(and can-convert?
|
|
c++-class
|
|
(pair? (cdr e))
|
|
(parens? (cadr e))
|
|
(get-c++-class-method (tok-n v) c++-class))
|
|
;; method call:
|
|
(set! used-self? #t)
|
|
(list*
|
|
(make-tok sElF (tok-line v) (tok-file v))
|
|
(make-tok '-> (tok-line v) (tok-file v))
|
|
v
|
|
(loop (cdr e) #t paren-arrows?))]
|
|
[(and paren-arrows?
|
|
(>= (length e) 3)
|
|
(eq? '-> (tok-n (cadr e)))
|
|
(or (null? (cdddr e))
|
|
(not (or (parens? (cadddr e))
|
|
(eq? '|::| (tok-n (cadddr e)))))))
|
|
(loop (cons (make-parens
|
|
"(" #f #f ")"
|
|
(seqce (car e) (cadr e) (caddr e)))
|
|
(cdddr e))
|
|
can-convert?
|
|
#t)]
|
|
[else
|
|
;; look for conversion
|
|
(cons
|
|
(cond
|
|
[(braces? v)
|
|
(make-braces
|
|
"{" (tok-line v) (tok-file v) "}"
|
|
(list->seq (convert-class-vars (seq->list (seq-in v)) arg-vars c++-class new-vars-box)))]
|
|
[(seq? v)
|
|
((get-constructor v)
|
|
(tok-n v) (tok-line v) (tok-file v) (seq-close v)
|
|
(list->seq (loop (seq->list (seq-in v)) #t #f)))]
|
|
[(and can-convert? (eq? (tok-n v) 'this))
|
|
(set! used-self? #t)
|
|
(make-tok sElF (tok-line v) (tok-file v))]
|
|
[(and can-convert?
|
|
c++-class
|
|
(not (assq (tok-n v) arg-vars))
|
|
(get-c++-class-var (tok-n v) c++-class))
|
|
(set! used-self? #t)
|
|
(make-parens
|
|
"(" (tok-line v) (tok-file v) ")"
|
|
(seqce (make-tok sElF (tok-line v) (tok-file v))
|
|
(make-tok '-> (tok-line v) (tok-file v))
|
|
v))]
|
|
[else v])
|
|
(loop (cdr e) #t paren-arrows?))]))])))
|
|
|
|
(define re:funcarg (regexp "^__funcarg"))
|
|
(define (is-generated? x)
|
|
(regexp-match re:funcarg (symbol->string (car x))))
|
|
|
|
;; body-e is something in {} or (). Convert the body with
|
|
;; `convert-function-calls' (which does the actual statement-level
|
|
;; inspection), and add appropriate body headers. Some of the
|
|
;; work here is distinguishing decls from body code.
|
|
;; The result is two values: converted body, and a new live-vars
|
|
;; record.
|
|
(define (convert-body body-e extra-vars pushable-vars &-vars c++-class initializers after-vars-thunk live-vars setup-stack-return-type)
|
|
(let-values ([(&-vars) (or &-vars (find-&-vars body-e))]
|
|
[(pragmas el) (body->lines body-e #f)])
|
|
(let-values ([(decls body) (split-decls el)])
|
|
(let* ([local-vars
|
|
(apply
|
|
append
|
|
(map (lambda (e)
|
|
(if (eq? (tok-n (car e)) 'static)
|
|
null
|
|
(get-pointer-vars e "PTRLOCAL" #f)))
|
|
decls))]
|
|
[vars (begin
|
|
(ormap (lambda (var)
|
|
(when (assq (car var) extra-vars)
|
|
(log-error "[SHADOW] ~a in ~a: Pointerful variable ~a shadowed in decls."
|
|
(tok-line (caar decls)) (tok-file (caar decls))
|
|
(car var))))
|
|
|
|
local-vars)
|
|
(append extra-vars local-vars))])
|
|
;; Convert calls and body (recusively)
|
|
(let-values ([(orig-maxlive) (live-var-info-maxlive live-vars)]
|
|
[(orig-maxpush) (live-var-info-maxpush live-vars)]
|
|
[(orig-tag) (live-var-info-tag live-vars)]
|
|
[(body-x live-vars)
|
|
(let loop ([body (append initializers body)])
|
|
(cond
|
|
[(null? body)
|
|
;; Starting live-vars record for this block:
|
|
;; Create new tag
|
|
;; Locally-defined arrays, records, and & variables, are always live.
|
|
;; Start with -1 maxlive in case we want to check whether anything
|
|
;; was pushed in the block.
|
|
(values null (make-live-var-info (gentag)
|
|
-1
|
|
0
|
|
(append
|
|
(let loop ([vars extra-vars])
|
|
(cond
|
|
[(null? vars) null]
|
|
[(memq (caar vars) &-vars)
|
|
(cons (car vars) (loop (cdr vars)))]
|
|
[else (loop (cdr vars))]))
|
|
(let loop ([vars local-vars])
|
|
(cond
|
|
[(null? vars) null]
|
|
[(or (array-type? (cdar vars))
|
|
(struc-type? (cdar vars))
|
|
(memq (caar vars) &-vars))
|
|
(cons (car vars) (loop (cdr vars)))]
|
|
[else (loop (cdr vars))]))
|
|
(live-var-info-vars live-vars))
|
|
(live-var-info-new-vars live-vars)
|
|
(live-var-info-pushed-vars live-vars)
|
|
(live-var-info-num-calls live-vars)
|
|
(live-var-info-num-noreturn-calls live-vars)
|
|
(live-var-info-num-empty-calls live-vars)
|
|
(live-var-info-nonempty-calls? live-vars)))]
|
|
[(memq (tok-n (caar body)) '(START_XFORM_SKIP XFORM_START_SKIP))
|
|
(let skip-loop ([body (cdr body)])
|
|
(let*-values ([(end?) (memq (tok-n (caar body)) '(END_XFORM_SKIP XFORM_START_SKIP))]
|
|
[(rest live-vars) ((if end?
|
|
loop
|
|
skip-loop)
|
|
(cdr body))])
|
|
(values (if end? rest (cons (car body) rest)) live-vars)))]
|
|
[(eq? (tok-n (caar body)) XFORM_RESET_VAR_STACK)
|
|
(let-values ([(rest live-vars) (loop (cdr body))])
|
|
(values (cons (car body) rest) live-vars))]
|
|
[else
|
|
(when (body-var-decl? (car body))
|
|
(let ([type (tok-n (caar body))]
|
|
[var (let loop ([e (car body)])
|
|
(if (or (null? (cdr e))
|
|
(eq? semi (tok-n (cadr e))))
|
|
(tok-n (car e))
|
|
(loop (cdr e))))])
|
|
(unless (or (eq? '|::| type) (eq? '|::| (tok-n (cadar body)))) ;; $patch vs2008 - goetter
|
|
(log-error "[DECL] ~a in ~a: Variable declaration (~a ~a) not at the beginning of a block."
|
|
(tok-line (caar body)) (tok-file (caar body))
|
|
type var))))
|
|
(let*-values ([(rest live-vars) (loop (cdr body))]
|
|
[(e live-vars)
|
|
(if (skip-static-line? (car body))
|
|
(values (car body) live-vars)
|
|
;; Here's the main body work:
|
|
(convert-function-calls (car body)
|
|
vars
|
|
&-vars
|
|
c++-class
|
|
live-vars
|
|
#f #f #f))])
|
|
(values (cons e rest) live-vars))]))])
|
|
;; Collect live vars and look for function calls in decl section.
|
|
(let ([live-vars
|
|
(let loop ([decls decls][live-vars live-vars])
|
|
(if (null? decls)
|
|
live-vars
|
|
(let dloop ([el (let-values ([(pragmas el) (body->lines (car decls) #t)])
|
|
el)]
|
|
[live-vars live-vars])
|
|
(if (null? el)
|
|
(loop (cdr decls) live-vars)
|
|
(let-values ([(_ live-vars)
|
|
;; We're not really interested in the conversion.
|
|
;; We just want to get live vars and
|
|
;; complain about function calls in the decl area:
|
|
(convert-function-calls (car el) extra-vars &-vars c++-class live-vars "decls" #f #t)])
|
|
(dloop (cdr el) live-vars))))))])
|
|
;; Calculate vars to push in this block. Make sure there are no duplicates.
|
|
(let ([newly-pushed (let ([ht (make-hash-table)])
|
|
(for-each (lambda (x)
|
|
(when (or (assq (car x) local-vars)
|
|
(assq (car x) pushable-vars)
|
|
(and setup-stack-return-type
|
|
(is-generated? x)))
|
|
(hash-table-put! ht (car x) x)))
|
|
(live-var-info-pushed-vars live-vars))
|
|
(hash-table-map ht (lambda (k v) v)))])
|
|
(values (apply
|
|
append
|
|
pragmas
|
|
(append
|
|
decls
|
|
(list (after-vars-thunk))
|
|
(list (let* ([vs-size (if per-block-push?
|
|
(+ (total-push-size newly-pushed)
|
|
(live-var-info-maxpush live-vars))
|
|
(live-var-info-maxlive live-vars))]
|
|
[once? (and setup-stack-return-type
|
|
(= (total-push-size newly-pushed) vs-size))])
|
|
(append (if show-info?
|
|
(list (make-note 'note #f #f (format "/* PTRVARS: ~a */" (map car vars))))
|
|
null)
|
|
(if setup-stack-return-type
|
|
(apply append (live-var-info-new-vars live-vars))
|
|
null)
|
|
(if (and setup-stack-return-type
|
|
;; Look for RET_VALUE_START anywhere:
|
|
(let loop ([e body-x])
|
|
(cond
|
|
[(list? e) (ormap loop e)]
|
|
[(pair? e) (or (loop (cdr e))
|
|
(loop (car e)))]
|
|
[(seq? e) (ormap loop (seq->list (seq-in e)))]
|
|
[(and (tok? e) (eq? RET_VALUE_START (tok-n e)))
|
|
#t]
|
|
[else #f])))
|
|
(list (make-tok DECL_RET_SAVE #f #f)
|
|
(make-nosrc-parens
|
|
"(" #f #f ")"
|
|
(list->seq setup-stack-return-type)))
|
|
null)
|
|
(if (and setup-stack-return-type (not (negative? (live-var-info-maxlive live-vars))))
|
|
(list (make-note 'note #f #f
|
|
(format "PREPARE_VAR_STACK~a(~a);"
|
|
(if once?
|
|
"_ONCE"
|
|
"")
|
|
vs-size)))
|
|
|
|
null)
|
|
(if (negative? (live-var-info-maxlive live-vars))
|
|
null
|
|
(list (make-block-push
|
|
"block push"
|
|
#f #f
|
|
newly-pushed (live-var-info-tag live-vars) orig-tag
|
|
setup-stack-return-type)))
|
|
(if setup-stack-return-type
|
|
(if once?
|
|
(list no-nested-pushable)
|
|
(list nested-pushable))
|
|
null))))
|
|
;; Null out local vars:
|
|
(map (lambda (var)
|
|
;; Check that the variable isn't specifically initialized:
|
|
(if (let loop ([decls decls])
|
|
(and (pair? decls)
|
|
(or (let loop ([e (car decls)])
|
|
(and (pair? e)
|
|
(pair? (cdr e))
|
|
(or (and (eq? (car var) (tok-n (car e)))
|
|
(eq? '= (tok-n (cadr e))))
|
|
(loop (cdr e)))))
|
|
(loop (cdr decls)))))
|
|
null
|
|
(let null-var ([full-name (car var)][vtype (cdr var)])
|
|
(cond
|
|
[(or (union-type? vtype)
|
|
(non-pointer-type? vtype))
|
|
null]
|
|
[(array-type? vtype)
|
|
(let ([c (array-type-count vtype)])
|
|
(if (<= c 3)
|
|
(let loop ([n 0])
|
|
(if (= n c)
|
|
null
|
|
(append
|
|
(null-var (string->symbol
|
|
(format "~a[~a]" full-name n))
|
|
#f)
|
|
(loop (add1 n)))))
|
|
(list (make-tok NULL_OUT_ARRAY #f #f)
|
|
(make-parens "(" #f #f ")"
|
|
(seqce (make-tok full-name #f #f)))
|
|
(make-tok semi #f #f))))]
|
|
[(struc-type? vtype)
|
|
(let aloop ([array-index 0])
|
|
;; Push each struct in array (or only struct if not an array)
|
|
(let loop ([l (cdr (lookup-struct-def (struc-type-struct vtype)))])
|
|
(if (null? l)
|
|
(if (and (struct-array-type? vtype)
|
|
(< (add1 array-index) (struct-array-type-count vtype)))
|
|
;; Next in array
|
|
(aloop (add1 array-index))
|
|
;; All done
|
|
null)
|
|
(append
|
|
(null-var (string->symbol
|
|
(format "~a~a.~a"
|
|
full-name
|
|
(if (struct-array-type? vtype)
|
|
(format "[~a]" array-index)
|
|
"")
|
|
(caar l)))
|
|
(cdar l))
|
|
(loop (cdr l))))))]
|
|
[else
|
|
(list (make-tok full-name #f #f)
|
|
(make-tok '= #f #f)
|
|
(make-tok NULLED_OUT #f #f)
|
|
(make-tok semi #f #f))]))))
|
|
local-vars)
|
|
body-x
|
|
(if setup-stack-return-type
|
|
(list (append
|
|
(if (or (null? setup-stack-return-type)
|
|
(and (= 1 (length setup-stack-return-type))
|
|
(eq? 'void (tok-n (car setup-stack-return-type)))))
|
|
(list (make-tok RET_NOTHING_AT_END #f #f)
|
|
(make-tok semi #f #f))
|
|
null)
|
|
(list undefine-nested-pushable)))
|
|
null)))
|
|
;; Restore original tag and union max live vars:
|
|
(let ([total-pushed (total-push-size newly-pushed)])
|
|
(make-live-var-info orig-tag
|
|
(max orig-maxlive
|
|
(live-var-info-maxlive live-vars))
|
|
(max orig-maxpush
|
|
(+ total-pushed
|
|
(live-var-info-maxpush live-vars)))
|
|
(live-var-info-vars live-vars)
|
|
(live-var-info-new-vars live-vars)
|
|
(live-var-info-pushed-vars live-vars)
|
|
(live-var-info-num-calls live-vars)
|
|
(live-var-info-num-noreturn-calls live-vars)
|
|
(live-var-info-num-empty-calls live-vars)
|
|
(live-var-info-nonempty-calls? live-vars)))))))))))
|
|
|
|
(define (body-var-decl? e)
|
|
(and (pair? e)
|
|
(or (lookup-non-pointer-type (tok-n (car e)))
|
|
(lookup-pointer-type (tok-n (car e)))
|
|
(assq (tok-n (car e)) c++-classes))))
|
|
|
|
(define (looks-like-call? e- nf?)
|
|
;; e- is a reversed expression
|
|
(and (pair? e-)
|
|
(parens? (car e-))
|
|
;; Something precedes
|
|
(not (null? (cdr e-)))
|
|
;; Not an assignment, sizeof, if, string
|
|
(or nf? (hash-table-get non-functions-table (tok-n (cadr e-)) #t))
|
|
(not (string? (tok-n (cadr e-))))
|
|
;; Look back one more for if, etc. if preceding is paren
|
|
(not (and (parens? (cadr e-))
|
|
(not (null? (cddr e-)))
|
|
(memq (tok-n (caddr e-)) '(if while for))))))
|
|
|
|
(define (ignored-stuff? e-)
|
|
;; e- is a reversed expression
|
|
(and (pair? e-)
|
|
(parens? (car e-))
|
|
;; Something precedes
|
|
(not (null? (cdr e-)))
|
|
(memq (tok-n (cadr e-)) '(|HIDE_FROM_XFORM| |XFORM_HIDE_EXPR|))))
|
|
|
|
(define (cast-or-call e- cast-k call-k)
|
|
;; Looks like a function call, although we don't know the
|
|
;; function yet. (The parens may be preceded by an
|
|
;; unparenthesized expression.) And it could be a cast (which
|
|
;; requires parens).
|
|
(let ([pre (cadr e-)])
|
|
;; Look for cast:
|
|
(if (and (parens? pre)
|
|
(let ([prel (seq->list (seq-in pre))])
|
|
(or
|
|
;; Assume we never have (func)(args, ...)
|
|
(= 1 (length prel))
|
|
;; trailing * is a give-away
|
|
(eq? '* (tok-n (list-ref prel (sub1 (length prel)))))
|
|
;; leading `struct' is a giveaway:
|
|
(eq? 'struct (tok-n (car prel))))))
|
|
;; Cast
|
|
(cast-k)
|
|
;; Call
|
|
(call-k))))
|
|
|
|
(define (resolve-indirection v get-c++-class-member c++-class locals)
|
|
(and (parens? v)
|
|
(let ([seql (seq->list (seq-in v))])
|
|
(and (= 3 (length seql))
|
|
(eq? '-> (tok-n (cadr seql)))
|
|
(let ([lhs (car seql)])
|
|
(cond
|
|
[(eq? sElF (tok-n lhs))
|
|
(get-c++-class-member (tok-n (caddr seql)) c++-class)]
|
|
[(or (resolve-indirection lhs get-c++-class-var c++-class locals)
|
|
(assq (tok-n lhs) locals)
|
|
(assq (tok-n lhs) (top-vars)))
|
|
=> (lambda (m)
|
|
(let ([type (cdr m)])
|
|
(and (pointer-type? type)
|
|
(= 1 (pointer-type-stars type))
|
|
(= 1 (length (pointer-type-base type))))
|
|
(let ([c++-class (find-c++-class (car (pointer-type-base type)) #f)])
|
|
(and c++-class
|
|
(get-c++-class-member (tok-n (caddr seql)) c++-class)))))]
|
|
[else #f]))))))
|
|
|
|
(define (extract-resolvable-record-var v)
|
|
(and (parens? v)
|
|
(let ([seql (seq->list (seq-in v))])
|
|
(= 3 (length seql))
|
|
(eq? '-> (tok-n (cadr seql)))
|
|
(if (parens? (car seql))
|
|
(extract-resolvable-record-var (car seql))
|
|
(car seql)))))
|
|
|
|
;; Found a sequance of argument expressions where function calls
|
|
;; are not allowed. Lift out the calls, inventing temporary variables
|
|
;; as necessary.
|
|
(define (lift-out-calls args live-vars c++-class locals)
|
|
(let ([e (seq->list (seq-in args))])
|
|
(if (null? e)
|
|
(values null args null null live-vars)
|
|
(let-values ([(pragmas el) (body->lines e #t)])
|
|
(unless (null? pragmas)
|
|
(error 'lift-out-calls "unexpected pragma"))
|
|
(let loop ([el el]
|
|
[new-args null][setups null][new-vars null]
|
|
[ok-calls null][must-convert? #t][live-vars live-vars])
|
|
(letrec ([lift-one?
|
|
(lambda (e)
|
|
(let ([e- (let ([e- (reverse e)])
|
|
(if (null? (cdr el))
|
|
e-
|
|
(cdr e-)))]) ; skip comma
|
|
(and (looks-like-call? e- #f)
|
|
(cast-or-call e-
|
|
(lambda () #f)
|
|
(lambda ()
|
|
(lambda (wrap)
|
|
(lift-one (cons e
|
|
(cons (or (and (null? (cddr e-))
|
|
(cadr e-))
|
|
(and (= 3 (length (cdr e-)))
|
|
(eq? '-> (tok-n (caddr e-)))
|
|
(make-parens
|
|
"(" #f #f ")"
|
|
(list->seq (reverse (cdr e-))))))
|
|
(car e-)))
|
|
wrap)))))))]
|
|
[lift-one
|
|
(lambda (call-form wrap)
|
|
(let* ([call (car call-form)]
|
|
[call-func (cadr call-form)]
|
|
[call-args (cddr call-form)]
|
|
[p-m (and must-convert?
|
|
call-func
|
|
(if (parens? call-func)
|
|
(resolve-indirection call-func get-c++-class-method c++-class locals)
|
|
(assq (tok-n call-func) (prototyped))))])
|
|
(if p-m
|
|
(let ([new-var (gensym '__funcarg)])
|
|
(loop (cdr el)
|
|
(cons (append
|
|
(wrap (list (make-tok new-var #f #f)))
|
|
(if (null? (cdr el))
|
|
null
|
|
(list (make-tok '|,| #f #f))))
|
|
new-args)
|
|
(cons (if (null? (cdr el))
|
|
;; Add comma
|
|
(append call (list (make-tok '|,| #f #f)))
|
|
call)
|
|
setups)
|
|
(cons (cons new-var (prototype-for-pointer? p-m))
|
|
new-vars)
|
|
ok-calls
|
|
#t
|
|
(make-live-var-info
|
|
(live-var-info-tag live-vars)
|
|
(live-var-info-maxlive live-vars)
|
|
(live-var-info-maxpush live-vars)
|
|
(live-var-info-vars live-vars)
|
|
;; Add newly-created vars for lifting to declaration set
|
|
(cons (append (prototype-type (cdr p-m))
|
|
(list
|
|
(make-tok new-var #f #f))
|
|
(if (prototype-for-pointer? p-m)
|
|
(list (make-tok '= #f #f)
|
|
(make-tok NULLED_OUT #f #f))
|
|
null)
|
|
(list
|
|
(make-tok semi #f #f)))
|
|
(live-var-info-new-vars live-vars))
|
|
(live-var-info-pushed-vars live-vars)
|
|
(live-var-info-num-calls live-vars)
|
|
(live-var-info-num-noreturn-calls live-vars)
|
|
(live-var-info-num-empty-calls live-vars)
|
|
(live-var-info-nonempty-calls? live-vars))))
|
|
(loop (cdr el) (cons (wrap e) new-args) setups new-vars
|
|
(if must-convert?
|
|
ok-calls
|
|
(cons call-args ok-calls))
|
|
#t
|
|
live-vars))))]
|
|
[lift-in-arithmetic?
|
|
(lambda (e)
|
|
(and (pair? e)
|
|
(cond
|
|
;; look for: ! <liftable>
|
|
[(eq? '! (tok-n (car e)))
|
|
(let ([k (lift-in-arithmetic? (cdr e))])
|
|
(and k
|
|
(lambda (wrap)
|
|
(k (lambda (x)
|
|
(wrap
|
|
(cons (car e) x)))))))]
|
|
;; look for: (<liftable>)
|
|
[(and (parens? (car e))
|
|
(null? (cdr e)))
|
|
(let ([k (lift-in-arithmetic? (seq->list (seq-in (car e))))])
|
|
(and k
|
|
(lambda (wrap)
|
|
(k (lambda (x)
|
|
(wrap (list
|
|
(make-parens
|
|
"(" #f #f ")"
|
|
(list->seq x)))))))))]
|
|
;; look for: n op <liftable>
|
|
[(and (>= (length e) 3)
|
|
(let ([n (tok-n (car e))])
|
|
(or (number? n) (symbol? n)))
|
|
(memq (tok-n (cadr e)) '(+ - * /
|
|
#csXFORM_OK_PLUS #csXFORM_OK_MINUS
|
|
#csXFORM_TRUST_PLUS #csXFORM_TRUST_MINUS)))
|
|
(let ([k (lift-in-arithmetic? (cddr e))])
|
|
(and k
|
|
(lambda (wrap)
|
|
(k (lambda (x)
|
|
(wrap
|
|
(list* (car e) (cadr e) x)))))))]
|
|
;; look for: <liftable> op n
|
|
[(let ([len (if (null? el)
|
|
(length e)
|
|
(sub1 (length e)))]) ; skip comma
|
|
(and (>= len 3)
|
|
(let ([n (tok-n (list-ref e (sub1 len)))])
|
|
(or (number? n) (symbol? n)))
|
|
(memq (tok-n (list-ref e (- len 2))) '(+ - * /
|
|
#csXFORM_OK_PLUS #csXFORM_OK_MINUS
|
|
#csXFORM_TRUST_PLUS #csXFORM_TRUST_MINUS))))
|
|
(let* ([last? (null? el)]
|
|
[len (if last?
|
|
(length e)
|
|
(sub1 (length e)))])
|
|
(let ([k (lift-in-arithmetic? (let loop ([e e])
|
|
(if (null? ((if last?
|
|
cddr
|
|
cdddr)
|
|
e))
|
|
(if last?
|
|
null
|
|
(cddr e))
|
|
(cons (car e) (loop (cdr e))))))])
|
|
(and k
|
|
(lambda (wrap)
|
|
(k (lambda (x)
|
|
(wrap
|
|
(append x
|
|
(list
|
|
(list-ref e (- len 2))
|
|
(list-ref e (- len 1)))
|
|
(if last?
|
|
(list (list-ref e len))
|
|
null)))))))))]
|
|
[(lift-one? e) => values]
|
|
[else #f])))])
|
|
(cond
|
|
[(null? el)
|
|
(if (null? new-vars)
|
|
(values null args null ok-calls live-vars)
|
|
(values
|
|
setups
|
|
(make-parens
|
|
"(" (tok-line args) (tok-file args) ")"
|
|
(list->seq (apply append (reverse new-args))))
|
|
new-vars
|
|
ok-calls
|
|
live-vars))]
|
|
[(lift-in-arithmetic? (car el)) => (lambda (k) (k values))]
|
|
[(and (= (length (car el)) 2)
|
|
(or (string? (tok-n (caar el)))
|
|
(number? (tok-n (caar el)))))
|
|
;; Constant => still no need to lift other args..
|
|
(loop (cdr el) (cons (car el) new-args) setups new-vars ok-calls must-convert? live-vars)]
|
|
[else
|
|
(loop (cdr el) (cons (car el) new-args) setups new-vars ok-calls #t live-vars)])))))))
|
|
|
|
(define (check-special-live-vars rest- vars live-vars)
|
|
(cond
|
|
[(and (pair? rest-)
|
|
(eq? '= (tok-n (car rest-)))
|
|
(pair? (cdr rest-))
|
|
(extract-resolvable-record-var (cadr rest-)))
|
|
=> (lambda (v)
|
|
(if (and (assq (tok-n v) vars)
|
|
(not (assq (tok-n v) (live-var-info-vars live-vars))))
|
|
;; Add a live variable:
|
|
(replace-live-vars live-vars
|
|
(cons (assq (tok-n v) vars)
|
|
(live-var-info-vars live-vars)))
|
|
;; Already there, or not pushable:
|
|
live-vars))]
|
|
[else live-vars]))
|
|
|
|
;; Inspect an expression sequence statement-by-statement to convert
|
|
;; function calls with the GC-registration wrappers, expose temps,
|
|
;; etc. Some conversions require generating local variables, as
|
|
;; accumulated in a `live-vars' record. The result is two values:
|
|
;; converted body, and a new live-vars record. (This function is
|
|
;; Mutually recursive with convert-body.)
|
|
(define (convert-function-calls e vars &-vars c++-class live-vars complain-not-in memcpy? braces-are-aggregates?)
|
|
;; e is a single statement
|
|
;; Reverse to calculate live vars as we go.
|
|
;; Also, it's easier to look for parens and then inspect preceding
|
|
;; to find function calls.
|
|
;; complain-not-in is ither #f [function calls are ok], a string [not ok, string describes way],
|
|
;; or (list ok-exprs ...)) [in a rator position, only ok-expr calls are allowed,
|
|
;; because they're blessed by the lifter]
|
|
(let ([e- (reverse e)]
|
|
[orig-num-calls (live-var-info-num-calls live-vars)])
|
|
(let loop ([e- e-][result null][live-vars live-vars][converted-sub? #f])
|
|
(cond
|
|
[(null? e-) (values result live-vars)]
|
|
[(ignored-stuff? e-)
|
|
(loop (cdr e-) (cons (car e-) result) live-vars converted-sub?)]
|
|
[(eq? 'return (tok-n (car e-)))
|
|
;; Look forward in result to semicolon, and wrap that:
|
|
(let rloop ([result result][l null])
|
|
(cond
|
|
[(null? result)
|
|
(error 'xform "odd return at ~a:~a" (tok-file (car e-)) (tok-line (car e-)))]
|
|
[(eq? (tok-n (car result)) semi)
|
|
(loop (cdr e-)
|
|
(if (null? l)
|
|
(cons (make-tok RET_NOTHING (tok-line (car e-)) (tok-file (car e-)))
|
|
result)
|
|
(let ([has-empty-funccall?
|
|
;; All calls must be empty calls, otherwise
|
|
;; the result might not depend on the empty call
|
|
;; (e.g., f() && empty(f()) )
|
|
(let loop ([l l][one? #f])
|
|
(cond
|
|
[(null? l) one?]
|
|
[(call? (car l))
|
|
(if (null? (call-live (car l)))
|
|
(loop (cdr l) #t)
|
|
#f)]
|
|
[(seq? (car l))
|
|
(and (loop (seq->list (seq-in (car l))) one?)
|
|
(loop (cdr l) one?))]
|
|
[else #f]))])
|
|
(list* (make-tok (if has-empty-funccall?
|
|
RET_VALUE_EMPTY_START
|
|
RET_VALUE_START)
|
|
(tok-line (car e-)) (tok-file (car e-)))
|
|
(make-parens
|
|
"(" (tok-line (car e-)) (tok-file (car e-)) ")"
|
|
(list->seq (reverse l)))
|
|
(make-tok (if has-empty-funccall?
|
|
RET_VALUE_EMPTY_END
|
|
RET_VALUE_END)
|
|
(tok-line (car e-)) (tok-file (car e-)))
|
|
result)))
|
|
live-vars
|
|
converted-sub?)]
|
|
[else (rloop (cdr result) (cons (car result) l))]))]
|
|
[(looks-like-call? e- #f)
|
|
;; Looks like a function call, maybe a cast:
|
|
(cast-or-call
|
|
e-
|
|
(lambda ()
|
|
;; It's a cast:
|
|
(let-values ([(v live-vars)
|
|
(convert-paren-interior (car e-) vars &-vars c++-class live-vars complain-not-in memcpy?)])
|
|
(loop (cddr e-)
|
|
(list* (cadr e-) v result)
|
|
live-vars
|
|
#t)))
|
|
(lambda ()
|
|
;; It's a function call; find the start
|
|
(let-values ([(args) (car e-)]
|
|
[(func rest-)
|
|
(let loop ([e- (cdr e-)])
|
|
(cond
|
|
[(null? e-)
|
|
(values null null)]
|
|
[(null? (cdr e-))
|
|
(values e- null)]
|
|
[(parens? (car e-))
|
|
(values (list (car e-)) (cdr e-))]
|
|
[(brackets? (car e-))
|
|
;; Array access
|
|
(let-values ([(func rest-) (loop (cdr e-))])
|
|
(values (cons (car e-) func) rest-))]
|
|
;; Assignment to result of top-level call
|
|
[(and (pair? (cddr e-))
|
|
(eq? (tok-n (cadr e-)) '|::|)
|
|
(eq? (tok-n (caddr e-)) '=))
|
|
(values (list (car e-) (cadr e-)) (cddr e-))]
|
|
;; Struct reference, class-specified:
|
|
[(memq (tok-n (cadr e-)) '(-> |.| |::|))
|
|
;; In '|::| case, check for 'return or parens that might mean "if"
|
|
(if (and (eq? '|::| (tok-n (cadr e-)))
|
|
(pair? (cddr e-))
|
|
(or (eq? 'return (tok-n (caddr e-)))
|
|
(seq? (caddr e-))))
|
|
(values (list (car e-) (cadr e-)) (cddr e-))
|
|
(let-values ([(func rest-) (loop (cddr e-))])
|
|
(values (list* (car e-) (cadr e-) func) rest-)))]
|
|
[else (values (list (car e-)) (cdr e-))]))])
|
|
(when (and complain-not-in
|
|
(or (not (pair? complain-not-in))
|
|
(not (memq args complain-not-in))))
|
|
(log-error "[CALL] ~a in ~a: Bad place for function call~a, starting tok is ~s."
|
|
(tok-line (car func)) (tok-file (car func))
|
|
(if (list? complain-not-in)
|
|
""
|
|
(format " (in ~a)" complain-not-in))
|
|
(tok-n (car func))))
|
|
;; Lift out function calls as arguments. (Can re-order code.
|
|
;; Racket source code must live with this change to C's semantics.)
|
|
;; Calls are replaced by varaibles, and setup code generated that
|
|
;; assigns to the variables.
|
|
(let*-values ([(live-vars)
|
|
;; Check for special form (XXX -> ivar) = call, which will
|
|
;; get re-arranged to (newvar = call, (XXX -> ivar) = newvar)
|
|
(check-special-live-vars rest- vars live-vars)]
|
|
[(orig-live-vars) live-vars]
|
|
[(setups args new-vars ok-calls live-vars)
|
|
;; Split args into setup (calls) and args.
|
|
;; List newly-created vars (in order) in new-vars.
|
|
;; Make sure each setup ends with a comma.
|
|
(lift-out-calls args live-vars c++-class vars)]
|
|
[(sub-memcpy?)
|
|
;; memcpy, etc. call?
|
|
(and (pair? (cdr e-))
|
|
(hash-table-get non-gcing-functions (tok-n (cadr e-)) #f))]
|
|
[(args live-vars)
|
|
(convert-paren-interior args vars &-vars
|
|
c++-class
|
|
(replace-live-vars
|
|
live-vars
|
|
(append (map (lambda (x)
|
|
(cons (car x) (make-vtype)))
|
|
(filter (lambda (x)
|
|
(cdr x))
|
|
new-vars))
|
|
(live-var-info-vars live-vars)))
|
|
ok-calls
|
|
sub-memcpy?)]
|
|
[(func live-vars)
|
|
(convert-function-calls (reverse func) vars &-vars c++-class live-vars "rator" #f #f)]
|
|
;; Process lifted-out function calls:
|
|
[(setups live-vars)
|
|
(let loop ([setups setups][new-vars new-vars][result null][live-vars live-vars])
|
|
(if (null? setups)
|
|
(values result live-vars)
|
|
(let-values ([(setup live-vars)
|
|
(convert-function-calls (car setups) vars &-vars
|
|
c++-class
|
|
;; Remove var for this one:
|
|
(replace-live-vars
|
|
live-vars
|
|
(remove (caar new-vars)
|
|
(live-var-info-vars live-vars)
|
|
(lambda (a b)
|
|
(eq? a (car b)))))
|
|
#f #f #f)])
|
|
(loop (cdr setups)
|
|
(cdr new-vars)
|
|
(cons (list* (make-tok (caar new-vars) #f #f)
|
|
(make-tok '= #f #f)
|
|
setup)
|
|
result)
|
|
live-vars))))])
|
|
;; Put everything back together. Lifted out calls go into a sequence
|
|
;; before the main function call.
|
|
(let* ([non-returning? (and
|
|
;; call declared to not return, or after a `return'
|
|
(or (and (null? (cdr func))
|
|
(memq (tok-n (car func)) non-returning-functions))
|
|
(and (pair? rest-)
|
|
(eq? 'return (tok-n (car rest-)))
|
|
(not converted-sub?)))
|
|
;; no arrays of pointers in this scope, or addresses of
|
|
;; local vars taken in the function.
|
|
(not (or (ormap (lambda (var)
|
|
(and (array-type? (cdr var))
|
|
'(fprintf (current-error-port)
|
|
"Optwarn [return] ~a in ~a: tail-push blocked by ~s[].\n"
|
|
(tok-line (car func)) (tok-file (car func))
|
|
(car var))))
|
|
(live-var-info-vars live-vars))
|
|
(ormap (lambda (&-var)
|
|
(and (assq &-var vars)
|
|
'(fprintf (current-error-port)
|
|
"Optwarn [return] ~a in ~a: tail-push blocked by &~s.\n"
|
|
(tok-line (car func)) (tok-file (car func))
|
|
&-var)))
|
|
&-vars))))]
|
|
[pushed-vars (cond
|
|
[non-returning?
|
|
;; non-returning -> don't need to push vars
|
|
null]
|
|
[else
|
|
(live-var-info-vars orig-live-vars)])]
|
|
[this-nonempty?
|
|
(and (not non-returning?)
|
|
(or (pair? pushed-vars)
|
|
(live-var-info-nonempty-calls? live-vars)))])
|
|
(let ([non-gcing-call?
|
|
(and (null? (cdr func))
|
|
(hash-table-get non-gcing-functions (tok-n (car func)) (lambda () #f)))]
|
|
[setjmp-call?
|
|
(memq (tok-n (car func)) setjmp-functions)])
|
|
(loop rest-
|
|
(let ([call (if (or non-gcing-call?
|
|
setjmp-call?)
|
|
;; Call without pointer pushes
|
|
(make-parens
|
|
"(" #f #f ")"
|
|
(list->seq (append func (list args))))
|
|
;; Call with pointer pushes
|
|
(begin
|
|
(set! saw-gcing-call (car e-))
|
|
(make-call
|
|
"func call"
|
|
#f #f
|
|
func
|
|
args
|
|
pushed-vars
|
|
(live-var-info-tag orig-live-vars)
|
|
this-nonempty?)))])
|
|
(cons (if (null? setups)
|
|
call
|
|
(make-callstage-parens
|
|
"(" #f #f ")"
|
|
(list->seq
|
|
(append
|
|
(apply append setups)
|
|
(list call)))))
|
|
result))
|
|
(make-live-var-info (live-var-info-tag live-vars)
|
|
;; maxlive is either size for this push or old maxlive:
|
|
(max (if non-gcing-call?
|
|
0
|
|
(total-push-size (live-var-info-vars orig-live-vars)))
|
|
(live-var-info-maxlive live-vars))
|
|
;; note: maxpush calculated at block level
|
|
(live-var-info-maxpush live-vars)
|
|
(live-var-info-vars live-vars)
|
|
(live-var-info-new-vars live-vars)
|
|
;; Add newly-pushed variable to pushed set:
|
|
(let* ([old-pushed (live-var-info-pushed-vars live-vars)]
|
|
[new-pushed (if non-gcing-call?
|
|
null
|
|
(filter (lambda (x) (not (assq (car x) old-pushed)))
|
|
pushed-vars))])
|
|
(append new-pushed old-pushed))
|
|
(+ (if (or non-gcing-call? setjmp-call?) 0 1)
|
|
(live-var-info-num-calls live-vars))
|
|
(+ (if (or non-gcing-call? setjmp-call?) 0 (if non-returning? 1 0))
|
|
(live-var-info-num-noreturn-calls live-vars))
|
|
(+ (if (or non-gcing-call? non-returning? setjmp-call?) 0 (if this-nonempty? 0 1))
|
|
(live-var-info-num-empty-calls live-vars))
|
|
(or (and this-nonempty? (not (or non-gcing-call? setjmp-call?)))
|
|
(live-var-info-nonempty-calls? live-vars)))
|
|
(or converted-sub?
|
|
(null? rest-)
|
|
(not (memq (tok-n (car rest-)) '(return else)))))))))))]
|
|
[(and (looks-like-call? e- #t)
|
|
(hash-table-get args-unevaled-table (tok-n (cadr e-)) #f))
|
|
(loop (cddr e-) (cons (cadr e-) (cons (car e-) result)) live-vars converted-sub?)]
|
|
[(eq? 'goto (tok-n (car e-)))
|
|
;; Goto - assume all vars are live
|
|
(loop (cdr e-) (cons (car e-) result)
|
|
(replace-live-vars live-vars vars)
|
|
#t)]
|
|
[(eq? '= (tok-n (car e-)))
|
|
;; Check for assignments where the LHS can move due to
|
|
;; a function call on the RHS. [Note that special support
|
|
;; in the function call case is necessary.]
|
|
(if (> (live-var-info-num-calls live-vars) orig-num-calls)
|
|
(let ([assignee (cdr e-)])
|
|
;; Special case: (YYY -> ivar) = XXX;
|
|
(let ([special-case-type (and (not (null? assignee))
|
|
(null? (cdr assignee))
|
|
(= 2 (length result))
|
|
(or (call? (car result))
|
|
(creation-parens? (car result)))
|
|
(eq? semi (tok-n (cadr result)))
|
|
(let ([m (resolve-indirection (car assignee) get-c++-class-var c++-class vars)])
|
|
(and m (cdr m))))])
|
|
(if (and special-case-type
|
|
(or (non-pointer-type? special-case-type)
|
|
(pointer-type? special-case-type)))
|
|
;; Change to (newvar = XXX, (YYY -> ivar) = newvar)
|
|
(let ([new-var (gensym '__assign)]
|
|
[v (car e-)])
|
|
(loop null
|
|
(list
|
|
(make-parens
|
|
"(" (tok-line v) (tok-file v) ")"
|
|
(seqce (make-tok new-var #f #f)
|
|
(make-tok '= #f #f)
|
|
(car result)
|
|
(make-tok '|,| #f #f)
|
|
(car assignee)
|
|
v
|
|
(make-tok new-var (tok-line v) (tok-file v))))
|
|
(cadr result)) ; semicolon
|
|
;; Add new variable to the list:
|
|
(make-live-var-info
|
|
(live-var-info-tag live-vars)
|
|
(live-var-info-maxlive live-vars)
|
|
(live-var-info-maxpush live-vars)
|
|
(live-var-info-vars live-vars)
|
|
;; Add newly-created vars for lifting to declaration set
|
|
(cons (append (type->decl special-case-type v)
|
|
(list
|
|
(make-tok new-var #f #f)
|
|
(make-tok semi #f #f)))
|
|
(live-var-info-new-vars live-vars))
|
|
(live-var-info-pushed-vars live-vars)
|
|
(live-var-info-num-calls live-vars)
|
|
(live-var-info-num-noreturn-calls live-vars)
|
|
(live-var-info-num-empty-calls live-vars)
|
|
(live-var-info-nonempty-calls? live-vars))
|
|
#t))
|
|
(begin
|
|
(when (and (not (null? assignee))
|
|
(or (if (brackets? (car assignee))
|
|
(or (not (or (null? (cddr assignee))
|
|
(eq? '|:| (tok-n (caddr assignee)))))
|
|
(let ([v (cadr assignee)])
|
|
(or (not (symbol? (tok-n v)))
|
|
;; Assignment to locally-declared array is fine:
|
|
(let ([m (assq (tok-n v) vars)])
|
|
(and m
|
|
(not (or (array-type? (cdr m))
|
|
(struct-array-type? (cdr m)))))))))
|
|
(and (not (symbol? (tok-n (car assignee))))
|
|
;; as below, ok if preceded by XFORM_OK_ASSIGN
|
|
(or (not (pair? (cdr assignee)))
|
|
(not (eq? (tok-n (cadr assignee)) 'XFORM_OK_ASSIGN)))))
|
|
(and (symbol? (tok-n (car assignee)))
|
|
(not (null? (cdr assignee)))
|
|
;; ok if name starts with "_stk_"
|
|
(not (regexp-match re:_stk_ (symbol->string (tok-n (car assignee)))))
|
|
;; ok if preceding is else or label terminator
|
|
(not (memq (tok-n (cadr assignee)) '(else |:|)))
|
|
;; assignment to field in record is ok
|
|
(not (and (eq? (tok-n (cadr assignee)) '|.|)
|
|
(pair? (cddr assignee))
|
|
(symbol? (tok-n (caddr assignee)))
|
|
(null? (cdddr assignee))))
|
|
;; ok if preceded by XFORM_OK_ASSIGN
|
|
(not (eq? (tok-n (cadr assignee)) 'XFORM_OK_ASSIGN))
|
|
;; ok if preceding is `if', `until', etc.
|
|
(not (and (parens? (cadr assignee))
|
|
(pair? (cddr assignee))
|
|
(memq (tok-n (caddr assignee)) '(if while for until))))))
|
|
(not (eq? 'exn_table (tok-n (car (last-pair e-))))))
|
|
(log-warning "[ASSIGN] ~a in ~a: suspicious assignment with a function call, LHS ends ~s."
|
|
(tok-line (car e-)) (tok-file (car e-))
|
|
(tok-n (cadr e-))))
|
|
(loop (cdr e-) (cons (car e-) result) live-vars #t)))))
|
|
(loop (cdr e-) (cons (car e-) result) live-vars #t))]
|
|
[(and (braces? (car e-)) (not braces-are-aggregates?))
|
|
(let*-values ([(v) (car e-)]
|
|
;; do/while/for: we'll need a fixpoint for live-vars
|
|
;; (We'll get the fixpoint by poing things twice)
|
|
[(do?) (and (not (null? (cdr e-)))
|
|
(memq (tok-n (cadr e-)) '(do)))]
|
|
[(while?) (and (not (null? (cdr e-)))
|
|
(parens? (cadr e-))
|
|
(not (null? (cddr e-)))
|
|
(memq (tok-n (caddr e-)) '(for while)))]
|
|
[(orig-new-vars) (live-var-info-new-vars live-vars)]
|
|
[(orig-pushed-vars) (live-var-info-pushed-vars live-vars)]
|
|
;; Proc to convert body once
|
|
[(convert-brace-body)
|
|
(lambda (live-vars)
|
|
(convert-body (seq->list (seq-in v)) vars null &-vars c++-class null (lambda () null) live-vars #f))]
|
|
;; First conversion
|
|
[(e live-vars) (convert-brace-body live-vars)]
|
|
;; Proc to filter live and pushed vars, dropping vars no longer in scope:
|
|
[(filter-live-vars)
|
|
(lambda (live-vars)
|
|
(let* ([not-declared (lambda (x) (assq (car x) vars))]
|
|
[new-live-vars (filter
|
|
not-declared
|
|
(live-var-info-vars live-vars))]
|
|
[new-pushed-vars (filter
|
|
(lambda (x) (or (not-declared x)
|
|
(is-generated? x)))
|
|
(live-var-info-pushed-vars live-vars))])
|
|
(make-live-var-info (live-var-info-tag live-vars)
|
|
(live-var-info-maxlive live-vars)
|
|
(live-var-info-maxpush live-vars)
|
|
new-live-vars
|
|
(live-var-info-new-vars live-vars)
|
|
new-pushed-vars
|
|
(live-var-info-num-calls live-vars)
|
|
(live-var-info-num-noreturn-calls live-vars)
|
|
(live-var-info-num-empty-calls live-vars)
|
|
(live-var-info-nonempty-calls? live-vars))))]
|
|
[(restore-new-vars)
|
|
(lambda (live-vars)
|
|
(make-live-var-info (live-var-info-tag live-vars)
|
|
(live-var-info-maxlive live-vars)
|
|
(live-var-info-maxpush live-vars)
|
|
(live-var-info-vars live-vars)
|
|
orig-new-vars
|
|
orig-pushed-vars
|
|
(live-var-info-num-calls live-vars)
|
|
(live-var-info-num-noreturn-calls live-vars)
|
|
(live-var-info-num-empty-calls live-vars)
|
|
(live-var-info-nonempty-calls? live-vars)))]
|
|
[(e live-vars rest extra)
|
|
(cond
|
|
[(and do? (not exit-with-error?))
|
|
(let-values ([(e live-vars)
|
|
(convert-brace-body (restore-new-vars live-vars))])
|
|
(values e live-vars (cdr e-) #f))]
|
|
[(and while? (not exit-with-error?))
|
|
;; Run test part. We don't filter live-vars, but maybe we should:
|
|
(let-values ([(v live-vars)
|
|
(convert-seq-interior (cadr e-) #t vars &-vars
|
|
c++-class
|
|
(restore-new-vars live-vars)
|
|
#f #f)])
|
|
;; Now run body again:
|
|
(let-values ([(e live-vars)
|
|
(convert-brace-body (restore-new-vars live-vars))])
|
|
;; Finally, run test again:
|
|
(let-values ([(v live-vars)
|
|
(convert-seq-interior (cadr e-) #t vars &-vars
|
|
c++-class
|
|
live-vars
|
|
#f #f)])
|
|
(values e live-vars (cddr e-) v))))]
|
|
[else
|
|
(values e live-vars (cdr e-) #f)])])
|
|
(loop rest
|
|
(append
|
|
(if extra
|
|
(list extra)
|
|
null)
|
|
(list (make-braces
|
|
(tok-n v)
|
|
(tok-line v)
|
|
(tok-file v)
|
|
(seq-close v)
|
|
(list->seq e)))
|
|
result)
|
|
(filter-live-vars live-vars)
|
|
#t))]
|
|
[(seq? (car e-))
|
|
;; Do nested body.
|
|
;; For (v = new x, ...) parens, check for special conversion
|
|
;; on (XXX -> ivar) = (v = new x, ...)
|
|
(let ([live-vars (if (creation-parens? (car e-))
|
|
(check-special-live-vars (cdr e-) vars live-vars)
|
|
live-vars)])
|
|
(let-values ([(v live-vars)
|
|
(convert-seq-interior (car e-) (parens? (car e-))
|
|
vars &-vars c++-class live-vars
|
|
(or complain-not-in
|
|
(and (brackets? (car e-))
|
|
"array access"))
|
|
memcpy?)])
|
|
(loop (cdr e-) (cons v result) live-vars #t)))]
|
|
[(and (assq (tok-n (car e-)) vars)
|
|
(not (assq (tok-n (car e-)) (live-var-info-vars live-vars))))
|
|
;; Add a live variable:
|
|
(loop (cdr e-)
|
|
(cons (car e-) result)
|
|
(replace-live-vars live-vars
|
|
(cons (assq (tok-n (car e-)) vars)
|
|
(live-var-info-vars live-vars)))
|
|
#t)]
|
|
[(and (memq (tok-n (car e-)) '(while do for))
|
|
(case (tok-n (car e-))
|
|
[(do)
|
|
(not (braces? (car result)))]
|
|
[(for)
|
|
(not (braces? (cadr result)))]
|
|
[(while)
|
|
(not (or (eq? semi (tok-n (cadr result)))
|
|
(braces? (cadr result))))]))
|
|
(log-error "[LOOP] ~a in ~a: while/do/for with body not in braces."
|
|
(tok-line (car e-)) (tok-file (car e-)))
|
|
(loop (cdr e-) (cons (car e-) result) live-vars #t)]
|
|
[else
|
|
(when (and check-arith? (not memcpy?)
|
|
(positive? (live-var-info-num-calls live-vars)))
|
|
(when (and (memq (tok-n (car e-)) '(+ - ++ -- += -=))
|
|
(let ([assignee (cdr e-)])
|
|
(or (and (not (null? assignee))
|
|
(assq (tok-n (car assignee)) vars))
|
|
;; Special case: (YYY -> ivar) + ...;
|
|
(let ([special-case-type (and (not (null? assignee))
|
|
(let ([m (resolve-indirection (car assignee) get-c++-class-var c++-class vars)])
|
|
(and m (cdr m))))])
|
|
(and special-case-type
|
|
(pointer-type? special-case-type))))))
|
|
;; __u comes from memset in some variants of gcc
|
|
(unless (eq? '__u (tok-n (cadr e-)))
|
|
(log-warning "[ARITH] ~a in ~a: suspicious arithmetic, LHS ends ~s."
|
|
(tok-line (car e-)) (tok-file (car e-))
|
|
(tok-n (cadr e-))))))
|
|
(loop (cdr e-) (cons (car e-) result) live-vars converted-sub?)]))))
|
|
|
|
(define (convert-seq-interior v comma-sep? vars &-vars c++-class live-vars complain-not-in memcpy?)
|
|
(let ([e (seq->list (seq-in v))])
|
|
(let-values ([(pragmas el) (body->lines e comma-sep?)])
|
|
(unless (null? pragmas)
|
|
(error 'convert-seq-interior "unexpected pragmas"))
|
|
(let-values ([(el live-vars)
|
|
(let loop ([el el])
|
|
(if (null? el)
|
|
(values null live-vars)
|
|
(let-values ([(rest live-vars) (loop (cdr el))])
|
|
(let-values ([(e live-vars)
|
|
(convert-function-calls (car el) vars &-vars c++-class live-vars complain-not-in memcpy? #f)])
|
|
(values (cons e rest) live-vars)))))])
|
|
(values ((get-constructor v)
|
|
(tok-n v)
|
|
(tok-line v)
|
|
(tok-file v)
|
|
(seq-close v)
|
|
(list->seq (apply append el)))
|
|
live-vars)))))
|
|
|
|
(define (convert-paren-interior v vars &-vars c++-class live-vars complain-not-in memcpy?)
|
|
(convert-seq-interior v #t vars &-vars c++-class live-vars complain-not-in memcpy?))
|
|
|
|
(define (find-&-vars e)
|
|
(let loop ([e e])
|
|
(cond
|
|
[(null? e)
|
|
null]
|
|
[(pragma? (car e))
|
|
(loop (cdr e))]
|
|
[(eq? '& (tok-n (car e)))
|
|
(if (null? (cdr e))
|
|
null
|
|
(let ([next (let loop ([next (cadr e)])
|
|
(cond
|
|
[(symbol? (tok-n next)) next]
|
|
[(seq? (tok-n next))
|
|
(let ([l (seq->list (seq-in next))])
|
|
(if (null? l)
|
|
#f
|
|
(loop (car l))))]
|
|
[else #f]))])
|
|
(if next
|
|
(cons (tok-n next) (loop (cdr e)))
|
|
(loop (cdr e)))))]
|
|
[(seq? (car e))
|
|
(append (find-&-vars (seq->list (seq-in (car e))))
|
|
(loop (cdr e)))]
|
|
[else (loop (cdr e))])))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Palm call-graph
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (call-graph name e)
|
|
(let ([body-v (let* ([len (sub1 (length e))]
|
|
[v (list-ref e len)])
|
|
;; Function may have trailing semicolon:
|
|
(if (eq? semi (tok-n v))
|
|
(list-ref e (sub1 len))
|
|
v))])
|
|
(call-graph/body name (seq->list (seq-in body-v)))))
|
|
|
|
(define (call-graph/body name body-e)
|
|
(let-values ([(pragmas el) (body->lines body-e #f)])
|
|
(for-each
|
|
(lambda (v)
|
|
(call-graph/stmt name v))
|
|
el)))
|
|
|
|
(define (call-graph/stmt name e)
|
|
;; e is a single statement
|
|
(for-each
|
|
(lambda (v)
|
|
(cond
|
|
[(seq? v)
|
|
(call-graph/body name (seq->list (seq-in v)))]
|
|
[(assq (tok-n v) (prototyped))
|
|
(fprintf map-port
|
|
"(call ~s ~s)\n"
|
|
name (tok-n v))]
|
|
[else (void)]))
|
|
e))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; More "parsing", main loop
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (body->lines e comma-sep?)
|
|
(let loop ([e e][pragmas null])
|
|
(if (or (null? e)
|
|
(not (pragma? (car e))))
|
|
(values
|
|
(reverse pragmas)
|
|
(reverse
|
|
(foldl-statement
|
|
e
|
|
comma-sep?
|
|
(lambda (sube l)
|
|
(cons sube l))
|
|
null)))
|
|
(loop (cdr e)
|
|
(cons (car e) pragmas)))))
|
|
|
|
(define (split-decls el)
|
|
(let loop ([el el][decls null])
|
|
(if (null? el)
|
|
(values (reverse decls) null)
|
|
(let ([e (car el)])
|
|
(if (or
|
|
;; These keywords appear only in decls:
|
|
(memq (tok-n (car e)) '(union struct static))
|
|
;; Otherwise try harder:
|
|
(and
|
|
;; Decl needs at least three parts:
|
|
(< 2 (length e))
|
|
;; Decl ends in seimicolon
|
|
(eq? semi (tok-n (list-ref e (sub1 (length e)))))
|
|
;; Doesn't start with a star, decrement, increment, or global call
|
|
(not (memq (tok-n (car e)) '(* -- ++ |::|)))
|
|
;; Not an assignemnt
|
|
(not (memq (tok-n (cadr e)) '(= += -=)))
|
|
;; Not a return, case, new, or delete
|
|
(not (memq (tok-n (car e)) '(return case new delete delete_wxobject)))
|
|
;; Not a label, field lookup, pointer deref, class-specific
|
|
(not (memq (tok-n (cadr e)) '(|:| |.| -> |::|)))
|
|
;; No parens/braces in first two parts, except __typeof
|
|
(not (seq? (car e)))
|
|
(or (not (seq? (cadr e)))
|
|
(eq? '__typeof (tok-n (car e))))))
|
|
;; Looks like a decl
|
|
(loop (cdr el) (cons e decls))
|
|
;; Not a decl
|
|
(values (reverse decls) el))))))
|
|
|
|
(define braces-then-semi '(typedef struct union enum __extension__))
|
|
|
|
(define (get-one e comma-sep?)
|
|
(let loop ([e e][result null][first #f][second #f])
|
|
(cond
|
|
[(null? e) (values (reverse result) null)]
|
|
[(pragma? (car e))
|
|
(unless (null? result)
|
|
(error 'pragma "unexpected pragma: ~a at: ~a:~a"
|
|
(pragma-s (car e))
|
|
(pragma-file (car e)) (pragma-line (car e))))
|
|
(values (list (car e)) (cdr e))]
|
|
[(eq? semi (tok-n (car e)))
|
|
(values (reverse (cons (car e) result)) (cdr e))]
|
|
[(and (eq? '|,| (tok-n (car e))) comma-sep?)
|
|
(values (reverse (cons (car e) result)) (cdr e))]
|
|
[(and (braces? (car e))
|
|
(not (memq first '(typedef enum __extension__)))
|
|
(or (not (memq first '(static extern const struct union)))
|
|
(equal? second "C") ; => extern "C" ...
|
|
(equal? second "C++") ; => extern "C++" ...
|
|
(ormap parens? result))) ; => function prototype
|
|
(let ([rest (cdr e)])
|
|
(if (or (null? rest)
|
|
(pragma? (car rest))
|
|
(not (eq? semi (tok-n (car rest)))))
|
|
(values (reverse (cons (car e) result)) rest)
|
|
(values (reverse (list* (car rest) (car e) result)) (cdr rest))))]
|
|
[else (loop (cdr e) (cons (car e) result)
|
|
(or first (tok-n (car e)))
|
|
(or second (and first (tok-n (car e)))))])))
|
|
|
|
(define (foldl-statement e comma-sep? f a-init)
|
|
(let loop ([e e][a a-init])
|
|
(cond
|
|
[(null? e) a]
|
|
[else
|
|
(let-values ([(sube e) (get-one e comma-sep?)])
|
|
(loop e (f sube a)))])))
|
|
|
|
; (print-it e 0 #t) (exit)
|
|
|
|
(define (process-top-level e init-file can-drop-vars?)
|
|
(foldl-statement
|
|
e
|
|
#f
|
|
(lambda (sube l)
|
|
(let* ([sube (top-level sube init-file can-drop-vars?)])
|
|
(append l sube)))
|
|
null))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(let* ([e e-raw]
|
|
[line -inf.0]
|
|
[file #f]
|
|
[sysheader? #f])
|
|
(set! e-raw #f) ;; to allow GC
|
|
(foldl-statement
|
|
e
|
|
#f
|
|
(lambda (sube where)
|
|
(let* ([where (if (pragma? (car sube))
|
|
where
|
|
(or (tok-file (car sube))
|
|
where))]
|
|
[sube (top-level sube where #t)])
|
|
(let-values ([(l f s?) (print-it sube 0 #t #f line file sysheader? keep-lines?)])
|
|
(set! line l)
|
|
(set! file f)
|
|
(set! sysheader? s?))
|
|
where))
|
|
#f))
|
|
|
|
|
|
(define (marshall v)
|
|
(let loop ([v v])
|
|
(cond
|
|
[(struct? v) (let ([vec (struct->vector v)])
|
|
(if (eq? 'struct:tok (vector-ref vec 0))
|
|
(list 'make-short-tok (loop (vector-ref vec 1)))
|
|
(cons
|
|
(car (hash-table-get makers (vector-ref vec 0)))
|
|
(map loop (cdr (vector->list vec))))))]
|
|
[(list? v) (cons 'list (map loop v))]
|
|
[(pair? v) (list 'cons (loop (car v)) (loop (cdr v)))]
|
|
[(vector? v)
|
|
(cons 'vector (map loop (vector->list v)))]
|
|
[(symbol? v) (list 'quote v)]
|
|
[else v])))
|
|
|
|
(when precompiling-header?
|
|
(parameterize ([current-inspector power-inspector]
|
|
[print-struct #t])
|
|
(let ([e
|
|
(list
|
|
'list
|
|
|
|
(list 'quote (hash-table-map used-symbols cons))
|
|
|
|
(marshall c++-classes)
|
|
(marshall (prototyped))
|
|
(marshall (top-vars))
|
|
|
|
(marshall pointer-types)
|
|
(marshall non-pointer-types)
|
|
(marshall struct-defs)
|
|
non-gcing-functions
|
|
(list 'quote gc-var-stack-mode))])
|
|
(with-output-to-file (change-suffix file-out #".zo")
|
|
(lambda ()
|
|
(let ([orig (current-namespace)])
|
|
(parameterize ([current-namespace (make-namespace)])
|
|
(namespace-attach-module orig 'mzscheme)
|
|
(namespace-require 'mzscheme)
|
|
(eval #'(define-syntaxes (#%top-interaction) (lambda (stx) (cdr (syntax-e stx)))))
|
|
(write (compile e)))))
|
|
'truncate))))
|
|
|
|
(when precompiling-header?
|
|
(let loop ([i 1])
|
|
(unless (i . > . gentag-count)
|
|
(printf "#undef XfOrM~a_COUNT\n" i)
|
|
(printf "#undef SETUP_XfOrM~a\n" i)
|
|
(loop (add1 i)))))
|
|
|
|
(close-output-port (current-output-port))
|
|
|
|
(when exit-with-error?
|
|
(error 'xform "Errors converting"))
|
|
|
|
(when output-depends-info?
|
|
(with-output-to-file (change-suffix file-out #".sdep")
|
|
(lambda ()
|
|
(write (hash-table-map depends-files (lambda (k v) k)))
|
|
(newline))
|
|
'truncate/replace))))))
|