From bda88101f891ba001456bbf044d7141d2f9ced90 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 4 Oct 2005 18:41:49 +0000 Subject: [PATCH] xform support in setup-extension svn: r967 --- collects/compiler/private/xform.ss | 7468 ++++++++++++++-------------- collects/compiler/xform.ss | 21 + collects/make/doc.txt | 7 +- collects/make/setup-extension.ss | 102 +- collects/openssl/pre-installer.ss | 139 +- 5 files changed, 3863 insertions(+), 3874 deletions(-) create mode 100644 collects/compiler/xform.ss diff --git a/collects/compiler/private/xform.ss b/collects/compiler/private/xform.ss index 17c51b9a40..d541c961ab 100644 --- a/collects/compiler/private/xform.ss +++ b/collects/compiler/private/xform.ss @@ -1,3748 +1,3728 @@ (module xform mzscheme (require (lib "list.ss") - (lib "process.ss") - (lib "cmdline.ss")) - - (define power-inspector (current-inspector)) - (current-inspector (make-inspector)) - - (define precompiling-header? (getenv "XFORM_PRECOMP")) - (define precompiled-header (getenv "XFORM_USE_PRECOMP")) - - (define show-info? #f) - (define output-depends-info? #f) - (define check-arith? #t) - - (define palm? #f) - (define pgc? #t) - (define pgc-really? #t) - - ;; Selects whether to reset GC_variable_stack on return, - ;; or to just reset it on every call. - (define callee-restore? #t) - - (define cpp #f) - (define file-in #f) - (define file-out #f) - (define palm-out #f) - - (define (filter-false s) - (if (equal? s "-") - #f - s)) + (lib "etc.ss") + (lib "process.ss")) - (define cmd-line - (command-line - "xform" - (current-command-line-arguments) - [once-each - [("--setup") "ignored; for compatbility with makefile" - (void)] - [("--precompile") "generate precompiled header; or set XFORM_PRECOMP" - (set! precompiling-header? #t)] - [("--precompiled") file "select precompiled header; or set XFORM_USE_PRECOMP" - (set! precompiled-header file)] - [("--notes") "enable notes in generated code" - (set! show-info? #t)] - [("--depends") "generate dependency information" - (set! output-depends-info? #t)] - #; - [("--palm") "PalmOS splitting" - (set! palm? #t) - (set! pgc? #f) - (set! pgc-really? #f)] - [("--cgc") "conservative collection mode" - (set! pgc-really? #f)] - [("--cpp") cmdline "set CPP command line" - (set! cpp cmdline)] - [("-o") dest-file "name destination file" - (set! file-out dest-file)]] - [args (file) - (set! file-in file)])) - - (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 (seq tok) (close in)) - (define-struct (parens seq) ()) - (define-struct (brackets seq) ()) - (define-struct (braces seq) ()) - (define-struct (callstage-parens parens) ()) - (define-struct (creation-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 "memset") 1) - - ;; For dependency tracking: - (define depends-files (make-hash-table 'equal)) - - (define (make-triple v src line) - (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)) - (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]+) \"([^\"]*)\"" ) - (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)))) - (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 ; file - source-line)) ; line - - (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 (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 (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 - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - ;; To run cpp: - (define process2 - (if (eq? (system-type) 'windows) - (lambda (s) - (let ([split (let loop ([s s]) - (let ([m (regexp-match "([^ ]*) (.*)" s)]) - (if m - (cons (cadr m) (loop (caddr m))) - (list s))))]) - (apply process* (find-executable-path (car split) #f) - (cdr split)))) - process)) - - (define cpp-process - (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))) - (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#"^(?:(?:)|(?:# .*)|(?:#line .*)|(?:#pragma implementation.*)|(?:#pragma interface.*)|(?:#pragma once)|(?:#pragma warning.*))$") - (define (skip-to-interesting-line p) - (let ([l (read-bytes-line p 'any)]) - (cond - [(eof-object? l) l] - [(regexp-match-positions re:boring 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-through-table? - (ormap (lambda (e) - (and (pragma? e) - (regexp-match #rx"GC_VARIABLE_SATCK_THOUGH_TABLE" (pragma-s e)))) - 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 (if gc-var-stack-through-table? - "#define GC_VARIABLE_STACK (scheme_extension_table->GC_variable_stack)~n" - "#define GC_VARIABLE_STACK GC_variable_stack~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] = GC_VARIABLE_STACK;" - (if callee-restore? - " 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? - "" - "GC_VARIABLE_STACK = __gc_var_stack__, ") - "__gc_var_stack__[1] = (void *)x)~n")) - - ;; Call a function where the number of registered variables can change in - ;; nested blocks: - (printf "#define FUNCCALL_each(setup, x) (setup, x)~n") - ;; The same, but a "tail" call: - (printf "#define FUNCCALL_EMPTY_each(x) FUNCCALL_each(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) x~n" - "#define FUNCCALL_AGAIN_each(x) FUNCCALL_each(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 , 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 { 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") - ;; Another annotation to protect against GC conversion: - (printf "#define HIDE_FROM_XFORM(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") - ;; For avoiding warnings: - (printf "#define XFORM_OK_PLUS +~n") - (printf "#define XFORM_OK_MINUS -~n") - (printf "~n") - - ;; C++ cupport: - (printf "#define NEW_OBJ(t) new t~n") - (printf "#define NEW_ARRAY(t, array) (new t array)~n") - (printf "#define NEW_ATOM(t) (new (AtomicGC) t)~n") - (printf "#define NEW_PTR(t) (new t)~n") - (printf "#define NEW_ATOM_ARRAY(t, array) (new (AtomicGC) t array)~n") - (printf "#define NEW_PTR_ARRAY(t, array) (new 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 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 - 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_")) - - ;; The non-functions table identifies symbols to ignore when - ;; finding function calls - (define non-functions - '(<= < > >= == != ! - \| \|\| & && |:| ? % + - * / ^ >> << ~ #csXFORM_OK_PLUS #csXFORM_OK_MINUS - = >>= <<= ^= += *= /= -= %= \|= &= ++ -- - return sizeof if for while else switch case - asm __asm __asm__ __volatile __volatile__ volatile __extension__ - __typeof - - ;; These don't act like functions: - setjmp longjmp _setjmp _longjmp scheme_setjmp scheme_longjmp scheme_mz_setjmp scheme_mz_longjmp - - ;; 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 - floor ceil round fmod fabs __maskrune _errno - isalpha isdigit isspace tolower toupper - fread fwrite socket fcntl setsockopt connect send recv close - __builtin_next_arg __builtin_saveregs - __builtin_constant_p __builtin_memset - __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 non-gcing-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 - strcmp strcoll strcpy _mzstrcpy strcat memset - printf sprintf vsprintf vprintf - strncmp scheme_strncmp - read write - bigdig_length) - (map - string->symbol - '("XTextExtents" "XTextExtents16" - "XDrawImageString16" "XDrawImageString" - "XDrawString16" "XDrawString")))) - - (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 - )) - + (provide xform) - (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)) - - (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-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 ulong uint void float double uchar)) - ;; 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: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: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 - ;; 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)))) - - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; Pretty-printing output - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (define next-indent #f) - - (define (newline/indent i) - (newline) - (set! next-indent i)) - - (define (display/indent v s) - (when next-indent - ;; can't get pre-processor line directive to work - '(when (and v (tok-file v) (tok-line v)) - (printf "# ~a ~s~n" (max 1 (- (tok-line v) 1)) (tok-file v))) - - (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 (print-it e indent semi-newlines? ordered?) - (let loop ([e e][prev #f][prevs null]) - (unless (null? e) - (let ([v (car e)]) - (cond - [(pragma? v) - (let ([s (format "#pragma ~a" (pragma-s v))]) - (unless (regexp-match re:boring s) - (printf "\n~a\n\n" s)))] - [(seq? v) - (display/indent v (tok-n v)) - (let ([subindent (if (braces? v) - (begin - (newline/indent (+ indent 2)) - (+ indent 2)) - indent)]) - (print-it (seq->list (seq-in v)) subindent - (not (and (parens? v) - prev - (memq (tok-n prev) '(for)))) - (or (braces? v) (callstage-parens? v))) - (when (and next-indent (= next-indent subindent)) - (set! next-indent indent))) - (display/indent #f (seq-close v)) - (cond - [(braces? v) - (newline/indent indent)] - [(brackets? v) - (display/indent v " ")] - [(parens? v) - (if (and prev - (memq (tok-n prev) '(if)) - (or (null? (cdr e)) - (not (braces? (cadr e))))) - (newline/indent (+ indent 2)) - (display/indent v " "))] - [else (error 'xform "unknown brace: ~a" (caar v))])] - [(note? v) - (display/indent v (note-s v)) - (newline/indent indent)] - [(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 "), ")))) - (print-it (append (call-func v) (list (call-args v))) indent #f #f) - (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)) - (printf "#~adefine ~a_COUNT (~a~a)~n" tabbing tag size prev-add) - (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))] - [(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)]))] - [(memq (tok-n v) asm-commands) - (newline/indent indent) - (display/indent v (tok-n v)) - (display/indent v " ")] - [(and (eq? '|HIDE_FROM_XFORM| (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)) - (string? (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))]) - (loop (cdr e) v (cons v prevs)))))) - - - ;; 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)) - (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) - (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)) - (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] - - [(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 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) - 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 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) - (eq? START_XFORM_SKIP (tok-n (car e))))) - - (define (end-skip? e) - (and (pair? e) - (eq? END_XFORM_SKIP (tok-n (car e))))) - - (define (start-suspend? e) - (and (pair? e) - (eq? START_XFORM_SUSPEND (tok-n (car e))))) - - (define (end-suspend? e) - (and (pair? e) - (eq? END_XFORM_SUSPEND (tok-n (car e))))) - - (define (start-arith? e) - (and (pair? e) - (eq? START_XFORM_ARITH (tok-n (car e))))) - - (define (end-arith? e) - (and (pair? e) - (eq? END_XFORM_ARITH (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) - ;; `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)))))))))))) - - ;; 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 MrEd - (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]))) - - ;; 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 (memq (tok-n (car t)) '(extern static inline virtual __stdcall __cdecl _inline __inline __inline__)) - (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 (eq? GC_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)) - (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 void ulong uint)) - ;; 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? - (> 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 ([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 (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 ([arg-decls (body->lines (append - args-e - (list (make-tok '|,| #f #f))) - #t)]) - (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) - 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 #f) - ;; Add PREPARE_VAR_STACK and ensure result return: - (parse-proto-information - e - (lambda (name class-name type args static?) - type)))]) - (if (and (not important-conversion?) - (not (and function-name - (eq? class-name function-name))) - (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-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) - (let ([el (body->lines body-e #f)]) - (when c++-class - (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 - [(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 ([&-vars (or &-vars (find-&-vars body-e))] - [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 and records 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 local-vars]) - (cond - [(null? vars) null] - [(or (array-type? (cdar vars)) - (struc-type? (cdar 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-nonempty-calls? live-vars)))] - [(eq? (tok-n (caar body)) START_XFORM_SKIP) - (let skip-loop ([body (cdr body)]) - (let*-values ([(end?) (eq? (tok-n (caar body)) END_XFORM_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 (eq? '|::| (tok-n (cadar body))) - (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 (body->lines (car decls) #t)] - [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 "in 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 - (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-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-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-) - ;; e- is a reversed expression - (and (pair? e-) - (parens? (car e-)) - ;; Something precedes - (not (null? (cdr e-))) - ;; Not an assignment, sizeof, if, string - (hash-table-get non-functions-table (tok-n (cadr e-)) (lambda () #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-))) - (eq? (tok-n (cadr e-)) '|HIDE_FROM_XFORM|))) - - (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 ([el (body->lines e #t)]) - (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-) - (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-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: ! - [(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: () - [(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 - [(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))) - (let ([k (lift-in-arithmetic? (cddr e))]) - (and k - (lambda (wrap) - (k (lambda (x) - (wrap - (list* (car e) (cadr e) x)))))))] - ;; look for: 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)))) - (let* ([last? (null? el)] - [len (if last? - (length e) - (sub1 (length e)))]) - (printf "/* this far ~a */~n" (tok-line (car 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 preceeding - ;; 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]) - (cond - [(null? e-) (values result live-vars)] - [(ignored-stuff? e-) - (loop (cdr e-) (cons (car e-) result) live-vars)] - [(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? (let loop ([l l]) - (cond - [(null? l) #f] - [(and (call? (car l)) - (null? (call-live (car l)))) - #t] - [(seq? (car l)) - (or (loop (seq->list (seq-in (car l)))) - (loop (cdr l)))] - [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)] - [else (rloop (cdr result) (cons (car result) l))]))] - [(looks-like-call? e-) - ;; 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 #f)]) - (loop (cddr e-) - (list* (cadr e-) v result) - live-vars))) - (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. - ;; MzScheme 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-)) - (memq (tok-n (cadr e-)) non-gcing-functions))] - [(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-))))) - ;; 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)))]) - (loop rest- - (let ([call (if (and (null? (cdr func)) - (memq (tok-n (car func)) non-gcing-functions)) - ;; Call without pointer pushes - (make-parens - "(" #f #f ")" - (list->seq (append func (list args)))) - ;; Call with pointer pushes - (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 (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 (filter (lambda (x) (not (assq (car x) old-pushed))) pushed-vars)]) - (append new-pushed old-pushed)) - (add1 (live-var-info-num-calls live-vars)) - (+ (if non-returning? 1 0) - (live-var-info-num-noreturn-calls live-vars)) - (or this-nonempty? - (live-var-info-nonempty-calls? live-vars)))))))))] - [(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))] - [(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-nonempty-calls? live-vars)))) - (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))))))))) - (not (symbol? (tok-n (car assignee))))) - (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 preceeding 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 preceeding 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))))) - (loop (cdr e-) (cons (car e-) result) live-vars))] - [(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-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-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)))] - [(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")) - #f)]) - (loop (cdr e-) (cons v result) live-vars)))] - [(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))))] - [(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)] - [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)])))) - - (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 ([el (body->lines e comma-sep?)]) - (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] - [(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 ([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?) - (reverse! - (foldl-statement - e - comma-sep? - (lambda (sube l) - (cons sube l)) - null))) - - (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]) - (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)]) - (print-it sube 0 #t #f) - 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))]) - (with-output-to-file (change-suffix file-out #".zo") - (lambda () - (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))) + (define (xform cpp + file-in + file-out + palm? pgc? pgc-really? + precompiling-header? precompiled-header + show-info? output-depends-info?) + (parameterize ([current-output-port (current-output-port)]) + (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 (seq tok) (close in)) + (define-struct (parens seq) ()) + (define-struct (brackets seq) ()) + (define-struct (braces seq) ()) + (define-struct (callstage-parens parens) ()) + (define-struct (creation-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 "memset") 1) + + ;; For dependency tracking: + (define depends-files (make-hash-table 'equal)) + + (define (make-triple v src line) + (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)) + (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]+) \"([^\"]*)\"" ) + (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)))) + (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 ; file + source-line)) ; line + + (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 (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 (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 + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + ;; To run cpp: + (define process2 + (if (eq? (system-type) 'windows) + (lambda (s) + (let ([split (let loop ([s s]) + (let ([m (regexp-match "([^ ]*) (.*)" s)]) + (if m + (cons (cadr m) (loop (caddr m))) + (list s))))]) + (apply process* (find-executable-path (car split) #f) + (cdr split)))) + 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 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#"^(?:(?:)|(?:# .*)|(?:#line .*)|(?:#pragma implementation.*)|(?:#pragma interface.*)|(?:#pragma once)|(?:#pragma warning.*))$") + (define (skip-to-interesting-line p) + (let ([l (read-bytes-line p 'any)]) + (cond + [(eof-object? l) l] + [(regexp-match-positions re:boring 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-through-table? + (ormap (lambda (e) + (and (pragma? e) + (regexp-match #rx"GC_VARIABLE_SATCK_THOUGH_TABLE" (pragma-s e)))) + 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 (if gc-var-stack-through-table? + "#define GC_VARIABLE_STACK (scheme_extension_table->GC_variable_stack)~n" + "#define GC_VARIABLE_STACK GC_variable_stack~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] = GC_VARIABLE_STACK;" + (if callee-restore? + " 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? + "" + "GC_VARIABLE_STACK = __gc_var_stack__, ") + "__gc_var_stack__[1] = (void *)x)~n")) + + ;; Call a function where the number of registered variables can change in + ;; nested blocks: + (printf "#define FUNCCALL_each(setup, x) (setup, x)~n") + ;; The same, but a "tail" call: + (printf "#define FUNCCALL_EMPTY_each(x) FUNCCALL_each(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) x~n" + "#define FUNCCALL_AGAIN_each(x) FUNCCALL_each(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 , 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 { 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") + ;; Another annotation to protect against GC conversion: + (printf "#define HIDE_FROM_XFORM(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") + ;; For avoiding warnings: + (printf "#define XFORM_OK_PLUS +~n") + (printf "#define XFORM_OK_MINUS -~n") + (printf "~n") + + ;; C++ cupport: + (printf "#define NEW_OBJ(t) new t~n") + (printf "#define NEW_ARRAY(t, array) (new t array)~n") + (printf "#define NEW_ATOM(t) (new (AtomicGC) t)~n") + (printf "#define NEW_PTR(t) (new t)~n") + (printf "#define NEW_ATOM_ARRAY(t, array) (new (AtomicGC) t array)~n") + (printf "#define NEW_PTR_ARRAY(t, array) (new 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 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 + 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_")) + + ;; The non-functions table identifies symbols to ignore when + ;; finding function calls + (define non-functions + '(<= < > >= == != ! + \| \|\| & && |:| ? % + - * / ^ >> << ~ #csXFORM_OK_PLUS #csXFORM_OK_MINUS + = >>= <<= ^= += *= /= -= %= \|= &= ++ -- + return sizeof if for while else switch case + asm __asm __asm__ __volatile __volatile__ volatile __extension__ + __typeof + + ;; These don't act like functions: + setjmp longjmp _setjmp _longjmp scheme_setjmp scheme_longjmp scheme_mz_setjmp scheme_mz_longjmp + + ;; 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 + floor ceil round fmod fabs __maskrune _errno + isalpha isdigit isspace tolower toupper + fread fwrite socket fcntl setsockopt connect send recv close + __builtin_next_arg __builtin_saveregs + __builtin_constant_p __builtin_memset + __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 non-gcing-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 + strcmp strcoll strcpy _mzstrcpy strcat memset + printf sprintf vsprintf vprintf + strncmp scheme_strncmp + read write + bigdig_length) + (map + string->symbol + '("XTextExtents" "XTextExtents16" + "XDrawImageString16" "XDrawImageString" + "XDrawString16" "XDrawString")))) + + (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)) + + (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-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 ulong uint void float double uchar)) + ;; 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: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: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 + ;; 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)))) + + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Pretty-printing output + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (define next-indent #f) + + (define (newline/indent i) + (newline) + (set! next-indent i)) + + (define (display/indent v s) + (when next-indent + ;; can't get pre-processor line directive to work + '(when (and v (tok-file v) (tok-line v)) + (printf "# ~a ~s~n" (max 1 (- (tok-line v) 1)) (tok-file v))) + + (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 (print-it e indent semi-newlines? ordered?) + (let loop ([e e][prev #f][prevs null]) + (unless (null? e) + (let ([v (car e)]) + (cond + [(pragma? v) + (let ([s (format "#pragma ~a" (pragma-s v))]) + (unless (regexp-match re:boring s) + (printf "\n~a\n\n" s)))] + [(seq? v) + (display/indent v (tok-n v)) + (let ([subindent (if (braces? v) + (begin + (newline/indent (+ indent 2)) + (+ indent 2)) + indent)]) + (print-it (seq->list (seq-in v)) subindent + (not (and (parens? v) + prev + (memq (tok-n prev) '(for)))) + (or (braces? v) (callstage-parens? v))) + (when (and next-indent (= next-indent subindent)) + (set! next-indent indent))) + (display/indent #f (seq-close v)) + (cond + [(braces? v) + (newline/indent indent)] + [(brackets? v) + (display/indent v " ")] + [(parens? v) + (if (and prev + (memq (tok-n prev) '(if)) + (or (null? (cdr e)) + (not (braces? (cadr e))))) + (newline/indent (+ indent 2)) + (display/indent v " "))] + [else (error 'xform "unknown brace: ~a" (caar v))])] + [(note? v) + (display/indent v (note-s v)) + (newline/indent indent)] + [(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 "), ")))) + (print-it (append (call-func v) (list (call-args v))) indent #f #f) + (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)) + (printf "#~adefine ~a_COUNT (~a~a)~n" tabbing tag size prev-add) + (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))] + [(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)]))] + [(memq (tok-n v) asm-commands) + (newline/indent indent) + (display/indent v (tok-n v)) + (display/indent v " ")] + [(and (eq? '|HIDE_FROM_XFORM| (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)) + (string? (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))]) + (loop (cdr e) v (cons v prevs)))))) + + + ;; 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)) + (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) + (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)) + (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] + + [(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 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) + 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 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) + (eq? START_XFORM_SKIP (tok-n (car e))))) + + (define (end-skip? e) + (and (pair? e) + (eq? END_XFORM_SKIP (tok-n (car e))))) + + (define (start-suspend? e) + (and (pair? e) + (eq? START_XFORM_SUSPEND (tok-n (car e))))) + + (define (end-suspend? e) + (and (pair? e) + (eq? END_XFORM_SUSPEND (tok-n (car e))))) + + (define (start-arith? e) + (and (pair? e) + (eq? START_XFORM_ARITH (tok-n (car e))))) + + (define (end-arith? e) + (and (pair? e) + (eq? END_XFORM_ARITH (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) + ;; `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)))))))))))) + + ;; 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 MrEd + (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]))) + + ;; 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 (memq (tok-n (car t)) '(extern static inline virtual __stdcall __cdecl _inline __inline __inline__)) + (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 (eq? GC_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)) + (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 void ulong uint)) + ;; 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? + (> 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 ([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 (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 ([arg-decls (body->lines (append + args-e + (list (make-tok '|,| #f #f))) + #t)]) + (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) + 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 #f) + ;; Add PREPARE_VAR_STACK and ensure result return: + (parse-proto-information + e + (lambda (name class-name type args static?) + type)))]) + (if (and (not important-conversion?) + (not (and function-name + (eq? class-name function-name))) + (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-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) + (let ([el (body->lines body-e #f)]) + (when c++-class + (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 + [(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 ([&-vars (or &-vars (find-&-vars body-e))] + [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 and records 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 local-vars]) + (cond + [(null? vars) null] + [(or (array-type? (cdar vars)) + (struc-type? (cdar 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-nonempty-calls? live-vars)))] + [(eq? (tok-n (caar body)) START_XFORM_SKIP) + (let skip-loop ([body (cdr body)]) + (let*-values ([(end?) (eq? (tok-n (caar body)) END_XFORM_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 (eq? '|::| (tok-n (cadar body))) + (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 (body->lines (car decls) #t)] + [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 "in 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 + (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-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-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-) + ;; e- is a reversed expression + (and (pair? e-) + (parens? (car e-)) + ;; Something precedes + (not (null? (cdr e-))) + ;; Not an assignment, sizeof, if, string + (hash-table-get non-functions-table (tok-n (cadr e-)) (lambda () #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-))) + (eq? (tok-n (cadr e-)) '|HIDE_FROM_XFORM|))) + + (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 ([el (body->lines e #t)]) + (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-) + (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-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: ! + [(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: () + [(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 + [(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))) + (let ([k (lift-in-arithmetic? (cddr e))]) + (and k + (lambda (wrap) + (k (lambda (x) + (wrap + (list* (car e) (cadr e) x)))))))] + ;; look for: 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)))) + (let* ([last? (null? el)] + [len (if last? + (length e) + (sub1 (length e)))]) + (printf "/* this far ~a */~n" (tok-line (car 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 preceeding + ;; 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]) + (cond + [(null? e-) (values result live-vars)] + [(ignored-stuff? e-) + (loop (cdr e-) (cons (car e-) result) live-vars)] + [(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? (let loop ([l l]) + (cond + [(null? l) #f] + [(and (call? (car l)) + (null? (call-live (car l)))) + #t] + [(seq? (car l)) + (or (loop (seq->list (seq-in (car l)))) + (loop (cdr l)))] + [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)] + [else (rloop (cdr result) (cons (car result) l))]))] + [(looks-like-call? e-) + ;; 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 #f)]) + (loop (cddr e-) + (list* (cadr e-) v result) + live-vars))) + (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. + ;; MzScheme 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-)) + (memq (tok-n (cadr e-)) non-gcing-functions))] + [(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-))))) + ;; 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)))]) + (loop rest- + (let ([call (if (and (null? (cdr func)) + (memq (tok-n (car func)) non-gcing-functions)) + ;; Call without pointer pushes + (make-parens + "(" #f #f ")" + (list->seq (append func (list args)))) + ;; Call with pointer pushes + (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 (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 (filter (lambda (x) (not (assq (car x) old-pushed))) pushed-vars)]) + (append new-pushed old-pushed)) + (add1 (live-var-info-num-calls live-vars)) + (+ (if non-returning? 1 0) + (live-var-info-num-noreturn-calls live-vars)) + (or this-nonempty? + (live-var-info-nonempty-calls? live-vars)))))))))] + [(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))] + [(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-nonempty-calls? live-vars)))) + (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))))))))) + (not (symbol? (tok-n (car assignee))))) + (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 preceeding 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 preceeding 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))))) + (loop (cdr e-) (cons (car e-) result) live-vars))] + [(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-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-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)))] + [(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")) + #f)]) + (loop (cdr e-) (cons v result) live-vars)))] + [(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))))] + [(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)] + [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)])))) + + (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 ([el (body->lines e comma-sep?)]) + (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] + [(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 ([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?) + (reverse! + (foldl-statement + e + comma-sep? + (lambda (sube l) + (cons sube l)) + null))) + + (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]) + (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)]) + (print-it sube 0 #t #f) + 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))]) + (with-output-to-file (change-suffix file-out #".zo") + (lambda () + (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)))))) diff --git a/collects/compiler/xform.ss b/collects/compiler/xform.ss new file mode 100644 index 0000000000..621c88ec27 --- /dev/null +++ b/collects/compiler/xform.ss @@ -0,0 +1,21 @@ + +(module xform mzscheme + (require (lib "compile.ss" "dynext") + (prefix xform: "private/xform.ss")) + + (provide xform) + + (define (xform src dest header-dirs) + (let ([exe (current-extension-compiler)] + [flags (expand-for-compile-variant + (current-extension-preprocess-flags))] + [headers (apply append + (map (current-make-compile-include-strings) + header-dirs))]) + (xform:xform (cons exe + (append flags headers)) + src + dest + #f #t #t + #f #f + #f #f)))) diff --git a/collects/make/doc.txt b/collects/make/doc.txt index d0518eb4a6..9b7575436e 100644 --- a/collects/make/doc.txt +++ b/collects/make/doc.txt @@ -214,7 +214,8 @@ inspecting "/usr/lib". More generally, the "last chance" argument to unix-libs windows-libs extra-depends - last-chance-k) + last-chance-k + [3m-too? #t]) The arguments are as follows: @@ -277,3 +278,7 @@ The arguments are as follows: add parameterizations before the final build. For example, the "readline" installer adds an AIX-specific compile flag in this step when under AIX. + + * 3m-too?--- a boolean. If true, when MzScheme3m is installed, use + the equivalent to mzc --xform to transform the source file and + then compile and link for 3m. diff --git a/collects/make/setup-extension.ss b/collects/make/setup-extension.ss index dc9aa8b179..12a2c28402 100644 --- a/collects/make/setup-extension.ss +++ b/collects/make/setup-extension.ss @@ -7,6 +7,9 @@ (lib "file.ss") (lib "list.ss") (lib "process.ss") + (lib "etc.ss") + (lib "launcher.ss" "launcher") + (lib "xform.ss" "compiler") (rename (lib "plthome.ss" "setup") plthome* plthome)) (provide pre-install @@ -28,7 +31,46 @@ (define (string-path->string s) (if (string? s) s (path->string s))) - (define (pre-install plthome collection-dir file.c . rest) + (define pre-install + (opt-lambda (plthome + collection-dir + file.c + default-lib-dir + include-subdirs + find-unix-libs + find-windows-libs + unix-libs + windows-libs + extra-depends + last-chance-k + 3m-too?) + ;; Compile and link one file: + (define (go file.c xform-src.c) + (pre-install/check-precompiled plthome + collection-dir + file.c + default-lib-dir + include-subdirs + find-unix-libs + find-windows-libs + unix-libs + windows-libs + extra-depends + last-chance-k + xform-src.c)) + ;; Do normal mode: + (go file.c #f) + ;; Maybe do 3m mode: + (when (and 3m-too? + (memq '3m (available-mzscheme-variants))) + (let ([3m-dir (build-path "compiled" "native" (system-library-subpath #f) "3m")]) + (make-directory* 3m-dir) + (parameterize ([link-variant '3m]) + (go (build-path 3m-dir (let-values ([(base name dir?) (split-path file.c)]) + name)) + file.c)))))) + + (define (pre-install/check-precompiled plthome collection-dir file.c . rest) (let* ([base-dir (build-path collection-dir "precompiled" "native" @@ -66,7 +108,8 @@ unix-libs windows-libs extra-depends - last-chance-k) + last-chance-k + xform-src.c) (parameterize ([current-directory collection-dir]) (define mach-id (string->symbol (path->string (system-library-subpath #f)))) (define is-win? (eq? mach-id 'win32\\i386)) @@ -177,27 +220,36 @@ (last-chance-k (lambda () (make/proc - (list (list file.so - (list file.o) - (lambda () - (link-extension #f (append (list file.o) - (if is-win? - null - (map (lambda (l) - (string-append "-l" (string-path->string l))) - (append find-unix-libs unix-libs)))) - file.so))) - - (list file.o - (append (list file.c) - (filter (lambda (x) - (regexp-match #rx#"mzdyn[a-z0-9]*[.]o" - (if (string? x) - x - (path->string x)))) - (expand-for-link-variant (current-standard-link-libraries))) - headers - extra-depends) - (lambda () - (compile-extension #f file.c file.o ())))) + (append + (list (list file.so + (list file.o) + (lambda () + (link-extension #f (append (list file.o) + (if is-win? + null + (map (lambda (l) + (string-append "-l" (string-path->string l))) + (append find-unix-libs unix-libs)))) + file.so))) + + (list file.o + (append (list file.c) + (filter (lambda (x) + (regexp-match #rx#"mzdyn[a-z0-9]*[.]o" + (if (string? x) + x + (path->string x)))) + (expand-for-link-variant (current-standard-link-libraries))) + headers + extra-depends) + (lambda () + (compile-extension #f file.c file.o null)))) + (if xform-src.c + (list (list file.c + (append (list xform-src.c) + headers + extra-depends) + (lambda () + (xform xform-src.c file.c (list mz-inc-dir))))) + null)) #())))))))))))) diff --git a/collects/openssl/pre-installer.ss b/collects/openssl/pre-installer.ss index 0787ae5fa5..b70c0ac8e8 100644 --- a/collects/openssl/pre-installer.ss +++ b/collects/openssl/pre-installer.ss @@ -3,113 +3,44 @@ (require (lib "setup-extension.ss" "make") (lib "compile.ss" "dynext") (lib "link.ss" "dynext") - (lib "restart.ss") - (lib "launcher.ss" "launcher") (lib "file.ss")) (define (pre-installer plthome openssl-dir) - (define (go file) - (pre-install plthome - openssl-dir - file - (build-path openssl-dir - "openssl") - ;; header subdirs - (list "openssl") - ;; unix libs - (list "ssl" "crypto") - ;; windows libs - (let* ([default-paths - (list (build-path openssl-dir "openssl"))] - [paths - (let ([v (getenv "PLT_EXTENSION_LIB_PATHS")]) - (if v - (path-list-string->path-list v default-paths) - default-paths))]) - (if (ormap (lambda (path) - (and (file-exists? (build-path path "lib" "libeay32xxxxxxx.lib")) - (file-exists? (build-path path "lib" "ssleay32xxxxxxx.lib")))) - paths) - ;; Use mangleable names: - (list "libeay32xxxxxxx" "ssleay32xxxxxxx") - ;; Use simple names: - (list "libeay32" "ssleay32"))) - ;; unix extra libs (assume always there) - null - ;; Windows extra libs (assume always there) - (list "wsock32.lib") - ;; Extra depends: - (list "mzssl.ss") - ;; Last-chance k: - (lambda (k) (k)))) - (go "mzssl.c") - - ;; Build for 3m when it looks like we can/should. - ;; This is a hack --- hopefully temporary! - (let ([3m-dir (build-path "compiled" "native" (system-library-subpath #f) "3m")] - [mzssl.so (case (system-type) - [(windows) "mzssl.dll"] - [(macosx) "mzssl.dylib"] - [else "mzssl.so"])]) - (parameterize ([current-directory openssl-dir]) - (when (and (memq (system-type) '(unix macosx windows)) - (memq '3m (available-mzscheme-variants)) - (directory-exists? (build-path 'up 'up "src" "mzscheme" "gc2"))) - (when (or (not (file-exists? (build-path 3m-dir mzssl.so))) - (not (file-exists? (build-path 3m-dir "mzssl.c"))) - ((file-or-directory-modify-seconds (build-path 3m-dir 'up mzssl.so)) - . > . - (file-or-directory-modify-seconds (build-path 3m-dir mzssl.so)))) - (make-directory* 3m-dir) - (restart-mzscheme #() - (lambda (x) x) - (list->vector - (list - "-qr" - (path->string - (build-path 'up 'up "src" "mzscheme" "gc2" "xform.ss")) - (let* ([inc (build-path 'up 'up "include")] - [fix-path (lambda (s) - (regexp-replace* " " (path->string s) "\" \""))] - [extras (cond ((getenv "PLT_EXTENSION_LIB_PATHS") => - (lambda (ext) - (apply string-append - (map (lambda (p) - (format - " ~a~s" - (if (eq? 'windows (system-type)) - " /I" - " -I") - (fix-path - (build-path p "include")))) - (path-list-string->path-list ext '()))))) - (else ""))]) - (if (eq? 'windows (system-type)) - (format "cl.exe /MT /E /I~a /I~a~a" - (fix-path inc) - (fix-path - (build-path openssl-dir "openssl" "include")) - extras) - (format "gcc -E ~a-I~a~a" - (if (eq? 'macosx (system-type)) - "-DOS_X " - "") - (fix-path inc) - extras))) - "mzssl.c" - (path->string - (build-path 3m-dir "mzssl.c")))) - void)) - (parameterize ([link-variant '3m]) - (with-new-flags current-extension-compiler-flags - (if (eq? 'windows (system-type)) - '("/Zi") - null) - (with-new-flags current-extension-linker-flags - (if (eq? 'windows (system-type)) - '("/Zi") - null) - (go (build-path 3m-dir "mzssl.c")))))))) + (pre-install plthome + openssl-dir + "mzssl.c" + (build-path openssl-dir + "openssl") + ;; header subdirs + (list "openssl") + ;; unix libs + (list "ssl" "crypto") + ;; windows libs + (let* ([default-paths + (list (build-path openssl-dir "openssl"))] + [paths + (let ([v (getenv "PLT_EXTENSION_LIB_PATHS")]) + (if v + (path-list-string->path-list v default-paths) + default-paths))]) + (if (ormap (lambda (path) + (and (file-exists? (build-path path "lib" "libeay32xxxxxxx.lib")) + (file-exists? (build-path path "lib" "ssleay32xxxxxxx.lib")))) + paths) + ;; Use mangleable names: + (list "libeay32xxxxxxx" "ssleay32xxxxxxx") + ;; Use simple names: + (list "libeay32" "ssleay32"))) + ;; unix extra libs (assume always there) + null + ;; Windows extra libs (assume always there) + (list "wsock32.lib") + ;; Extra depends: + (list "mzssl.ss") + ;; Last-chance k: + (lambda (k) (k)) + ;; 3m, too: + #t) ;; Under windows, put "{lib,sll}eay32" into the system folder when ;; they're in a "precompiled" dir.