suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

mzc -e fixes

Browse Source 
svn: r7714
This commit is contained in:
Matthew Flatt 2007-11-14 01:25:01 +00:00
parent d3fe81cb16
commit b8d9e4f406
19 changed files with 102 additions and 95 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/compiler/compiler-unit.ss
View File

@ -94,7 +94,7 @@
(lambda (prefix)
(let ([c (make-extension-compiler mode prefix)])
(lambda (source-files destination-directory)
(map
(for-each
(lambda (source-file)
(c source-file (or destination-directory 'same)))
source-files)))))

7
collects/compiler/doc.txt
View File

@ -467,13 +467,6 @@ _embedr-sig.ss_ library provides the signature, _compiler:embed^_.
execution and for creating a distribution tha contains the
executable).
When embedding into a copy of MrEd, a "-Z" flag should usually be
included in the list of command-line flags, so that the target
executable has a chance to see an embedded declaration of (lib
"mred.ss" "mred"). Then, if the literal code expect to have MrEd and
the class library required into the top-level namespace, literal
`require's for those libraries should be included at the start.
The optional `aux' argument is an association list for
platform-specific options (i.e., it is a list of pairs where the
first element of the pair is a key symbol and the second element is

4
collects/compiler/main.ss
View File

@ -457,8 +457,8 @@
(define (compiler-warning)
(fprintf (current-error-port)
(string-append
"Warning: compilation to C is usually less effective\n"
"for performance than relying on the bytecode JIT compiler.\n")))
"Warning: compilation to C is usually less effective for performance\n"
" than relying on the bytecode just-in-time compiler.\n")))
(case mode
[(compile)

55
collects/compiler/private/analyze.ss
View File

@ -90,23 +90,27 @@
(let* ([et? (and et?
;; Just use run-time for #%kernel, since it's the same, and
;; the compiler generates references to #%kernel names
(not (eq? '#%kernel modname)))]
(not (kernel-modname? modname)))]
[info (hash-table-get compiler:global-symbols modname
(lambda ()
(let ([p (make-modref-info
#f #f
(if (module-path-index? modname)
(let-values ([(name base) (module-path-index-split modname)])
(if name
(compiler:construct-const-code!
(zodiac:make-zread
(datum->syntax-object
#f
modname
(zodiac:zodiac-stx ast)))
#t)
#f))
modname))])
#f #f
(if (kernel-modname? modname)
(begin
(compiler:get-symbol-const! #f '#%kernel)
'#%kernel)
(if (module-path-index? modname)
(let-values ([(name base) (module-path-index-split modname)])
(if name
(compiler:construct-const-code!
(zodiac:make-zread
(datum->syntax-object
#f
modname
(zodiac:zodiac-stx ast)))
#t)
#f))
modname)))])
(hash-table-put! compiler:global-symbols modname p)
p)))]
[t (or ((if et? modref-info-et-globals modref-info-globals) info)
@ -1014,7 +1018,7 @@
(if (= 1 (length (car (zodiac:let-values-form-vars ast))))
; this is a one-value binding let
;; this is a one-value binding let
(let* ([var (car vars)]
[binding (get-annotation var)])
@ -1185,16 +1189,17 @@
;; analyze the branches
[(zodiac:begin-form? ast)
(let ([last-multi
(let loop ([bodies (zodiac:begin-form-bodies ast)])
(if (null? (cdr bodies))
(let-values ([(e last-multi) (analyze! (car bodies) env inlined tail? wcm-tail?)])
(values (list e)
last-multi))
(let-values ([(e) (analyze!-ast (car bodies) env inlined)]
[(bodies last-multi) (loop (cdr bodies))])
(values (cons e bodies) last-multi))))])
(let-values ([(bodies last-multi)
(let loop ([bodies (zodiac:begin-form-bodies ast)])
(if (null? (cdr bodies))
(let-values ([(e last-multi) (analyze! (car bodies) env inlined tail? wcm-tail?)])
(values (list e)
last-multi))
(let-values ([(e) (analyze!-ast (car bodies) env inlined)]
[(bodies last-multi) (loop (cdr bodies))])
(values (cons e bodies) last-multi))))])
(zodiac:set-begin-form-bodies! ast bodies)
(values ast last-multi))]
@ -1304,7 +1309,7 @@
[primfun (app-prim-name (get-annotation ast))]
[multi (if primfun
(let ([a (primitive-result-arity
(dynamic-require '#%kernel primfun))])
(dynamic-require ''#%kernel primfun))])
(cond
[(and (number? a) (= a 1)) #f]
[(number? a) #t]

2
collects/compiler/private/const.ss
View File

@ -191,7 +191,7 @@
(zodiac:zodiac-stx ast)
(make-empty-box)
constructor-name
'#%kernel
(module-path-index-join ''#%kernel #f)
(box '())
#f
#f

4
collects/compiler/private/driver.ss
View File

@ -151,7 +151,9 @@
(bytes->path (bytes-append (path->bytes b) a)))]
[sbase (extract-base-filename/ss file (if from-c? #f 'mzc))]
[cbase (extract-base-filename/c file (if from-c? 'mzc #f))]
[base (or sbase cbase)]
[base (if sbase
(path-replace-suffix (path-add-suffix input-name #".x") #"")
cbase)]
[c-dir (if tmp-c?
(find-system-path 'temp-dir)
dest-dir)]

8
collects/compiler/private/known.ss
View File

@ -73,11 +73,13 @@
(make-binding #f #f #f #f #f #f
#f #f #f (make-rep:atomic 'wcm-saver))))
(define ns (make-namespace))
;; Determine whether a varref is a known primitive
(define (analyze:prim-fun fun)
(and (zodiac:top-level-varref? fun)
(varref:has-attribute? fun varref:primitive)
(primitive? (namespace-variable-value (zodiac:varref-var fun)))
(primitive? (namespace-variable-value (zodiac:varref-var fun) #t #f ns))
(zodiac:varref-var fun)))
;; Some prims call given procedures directly, some install procedures
@ -227,7 +229,7 @@
[(char->integer)
(with-handlers ([void (lambda (x) v)])
(let ([args (map (lambda (a) (syntax-e (zodiac:zodiac-stx (zodiac:quote-form-expr a)))) args)])
(let ([new-v (apply (namespace-variable-value fun) args)])
(let ([new-v (apply (namespace-variable-value fun #t #f ns) args)])
(zodiac:make-quote-form
(zodiac:zodiac-stx v)
(make-empty-box)
@ -492,7 +494,7 @@
(and primfun
(let* ([num-args (length args)]
[arity-ok? (procedure-arity-includes?
(namespace-variable-value primfun)
(namespace-variable-value primfun #t #f ns)
num-args)])
(unless arity-ok?
((if (compiler:option:stupid)

8
collects/compiler/private/library.ss
View File

@ -313,5 +313,11 @@
"-")
" "))
(define ns (make-namespace))
(define (global-defined-value* v)
(and v (namespace-variable-value v)))))
(and v (namespace-variable-value v #t #f ns)))
(define (kernel-modname? modname)
(equal? ''#%kernel (let-values ([(name base) (module-path-index-split modname)])
name)))))

2
collects/compiler/private/lift.ss
View File

@ -196,7 +196,7 @@
[(var)
(or (not (mod-glob? var))
(let ([modname (mod-glob-modname var)])
(if (eq? modname '#%kernel)
(if (kernel-modname? modname)
#t
(not modname))))])
(set->list (code-global-vars code)))))

8
collects/compiler/private/prephase.ss
View File

@ -103,9 +103,9 @@
(define prephase:primitive-name?
(lambda (ast)
(let ([m (zodiac:top-level-varref-module ast)])
(or (eq? '#%kernel m)
(or (kernel-modname? m)
(and (box? m)
(eq? '#%kernel (unbox m)))))))
(kernel-modname? (unbox m)))))))
(define (preprocess:adhoc-app-optimization ast prephase-it)
(let ([fun (zodiac:app-fun ast)])
@ -120,7 +120,7 @@
(zodiac:zodiac-stx fun)
(make-empty-box)
newname
'#%kernel
(module-path-index-join ''#%kernel #f)
(box '())
#f
#f
@ -629,7 +629,7 @@
(zodiac:zodiac-stx ast))
(make-empty-box)
proc
'#%kernel
(module-path-index-join ''#%kernel #f)
(box '())
#f
#f

1
collects/compiler/private/sig.ss
View File

@ -46,6 +46,7 @@
compiler:clean-string
protect-comment
global-defined-value*
kernel-modname?
compiler:get-label-number
compiler:reset-label-number!))

4
collects/compiler/private/vm2c.ss
View File

@ -214,7 +214,7 @@
(fprintf port " Scheme_Object * ~a;~n"
(vm->c:convert-symbol
(vm->c:bucket-name
'#%kernel
(module-path-index-join ''#%kernel #f)
a))))
(set->list (compiler:get-primitive-refs)))
(fprintf port "} P;~n")
@ -227,7 +227,7 @@
(for-each (lambda (a)
(fprintf port "~aP.~a = scheme_module_bucket(~a, ~a, -1, env)->val;~n"
vm->c:indent-spaces
(vm->c:convert-symbol (vm->c:bucket-name '#%kernel a))
(vm->c:convert-symbol (vm->c:bucket-name (module-path-index-join ''#%kernel #f) a))
(vm->c:make-symbol-const-string (compiler:get-symbol-const! #f '#%kernel))
(vm->c:make-symbol-const-string (compiler:get-symbol-const! #f a))))
(set->list (compiler:get-primitive-refs))))))

43
collects/compiler/src2src.ss
View File

@ -6,7 +6,7 @@
;; 'method-arity-error, and 'inferred-name properties are
;; specially preserved for `lambda' expressions.
(module src2src mzscheme
(module src2src scheme/base
(require (lib "class.ss")
(lib "kerncase.ss" "syntax")
(lib "primitives.ss" "syntax")
@ -77,10 +77,9 @@
(class object%
(init-field src-stx)
(if (not (syntax? src-stx))
(begin
(printf "~a~n" src-stx)
(error 'stx)))
(when (not (syntax? src-stx))
(printf "~a~n" src-stx)
(error 'stx))
(init-field [cert-stxes (list src-stx)])
(field (known-value #f))
@ -219,12 +218,12 @@
(define (get-sexpr o) (send o sexpr))
(define (get-body-sexpr o) (send o body-sexpr))
(define-struct bucket (mutated? inited-before-use?))
(define-struct bucket (mutated? inited-before-use?) #:mutable)
(define (global-bucket table stx)
(let ([l (hash-table-get table (syntax-e stx) (lambda () null))])
(let ([s (ormap (lambda (b)
(and (module-identifier=? stx (car b))
(and (free-identifier=? stx (car b))
(cdr b)))
l)])
(if s
@ -280,7 +279,7 @@
(define/override (global->local env)
(or (ormap (lambda (e)
(and (module-identifier=? (car e) src-stx)
(and (free-identifier=? (car e) src-stx)
(make-object ref% (cdr e) src-stx cert-stxes)))
env)
this))
@ -322,7 +321,7 @@
(define/public (clone-binder env)
(make-object binding%
always-inited?
(datum->syntax-object
(datum->syntax
#f
(gensym (syntax-e src-stx))
src-stx
@ -404,7 +403,7 @@
(inherit recertify)
(define/override (sexpr)
(let ([x (send binding sexpr)])
(recertify (datum->syntax-object
(recertify (datum->syntax
x
(syntax-e x)
src-stx))))
@ -574,7 +573,7 @@
(inherit recertify)
(define/override (sexpr)
(let ([vstx (datum->syntax-object (quote-syntax here) val src-stx)])
(let ([vstx (datum->syntax (quote-syntax here) val src-stx)])
(cond
[(or (number? val)
(string? val)
@ -779,8 +778,8 @@
(let ([xformed
(let ([l (send (cadr rands) get-const-val)]
[l-stx (send (cadr rands) get-stx)]
[false (make-object constant% #f (datum->syntax-object #f #f))]
[true (make-object constant% #t (datum->syntax-object #f #t))])
[false (make-object constant% #f (datum->syntax #f #f))]
[true (make-object constant% #t (datum->syntax #f #t))])
(if (null? l)
false
(let loop ([l l])
@ -887,7 +886,7 @@
(keep-mzc-property
(with-syntax ([rator (get-sexpr rator)]
[(rand ...) (map get-sexpr rands)])
(syntax/loc src-stx (rator rand ...)))
(syntax/loc src-stx (#%plain-app rator rand ...)))
src-stx)))
;; Checks whether the expression is an app of `values'
@ -1027,7 +1026,7 @@
[vars . body] ...))
(with-syntax ([body (car (syntax->list (syntax (body ...))))])
(syntax/loc src-stx
(lambda vars ... . body))))
(#%plain-lambda vars ... . body))))
src-stx))))))
(define local%
@ -1453,7 +1452,7 @@
(map (lambda (var)
(make-object binding%
#t
(datum->syntax-object
(datum->syntax
#f
(syntax-e var)
var)))
@ -1585,7 +1584,7 @@
(fprintf (current-output-port)
"~a: ~e~n"
msg
(syntax-object->datum (send exp sexpr)))))
(syntax->datum (send exp sexpr)))))
(define (warning msg exp)
; (print-warning msg exp)
@ -1713,7 +1712,7 @@
stx)]
[(quote expr)
(make-object constant% (syntax-object->datum (syntax expr)) stx)]
(make-object constant% (syntax->datum (syntax expr)) stx)]
[(quote-syntax expr)
(make-object constant% (syntax expr) stx)]
@ -1761,13 +1760,11 @@
(parse (syntax rhs) env trans? in-module? tables)
stx)]
[(if test then . else)
[(if test then else)
(make-object if%
(parse (syntax test) env trans? in-module? tables)
(parse (syntax then) env trans? in-module? tables)
(if (null? (syntax-e (syntax else)))
(parse (quote-syntax (#%plain-app void)) env trans? in-module? tables)
(parse (car (syntax-e (syntax else))) env trans? in-module? tables))
(parse (syntax else) env trans? in-module? tables)
stx)]
[(with-continuation-mark k v body)
@ -1817,7 +1814,7 @@
[(#%require . i) (make-object require/provide% stx)]
[(#%provide i ...) (make-object require/provide% stx)]
[else (error 'parse "unknown expression: ~a" (syntax-object->datum stx))])))
[else (error 'parse "unknown expression: ~a" (syntax->datum stx))])))
(define parse (make-parse #f))
(define parse-top (make-parse #t))

3
collects/dynext/doc.txt
View File

@ -171,7 +171,8 @@ _file.ss_
---------
> (append-zo-suffix s) - appends the .zo file suffix to the
path/string s, returning a path.
path/string s, returning a path. The existing suffix, if any, is
perserved and converted as with `path-add-suffix'.
> (append-object-suffix s) - appends the platform-standard compiled
object file suffix to the path/string s, returning a path.

10
collects/dynext/file-unit.ss
View File

@ -13,23 +13,23 @@
(export dynext:file^)
(define (append-zo-suffix s)
(path-replace-suffix s #".zo"))
(path-add-suffix s #".zo"))
(define (append-c-suffix s)
(path-replace-suffix s #".c"))
(path-add-suffix s #".c"))
(define (append-constant-pool-suffix s)
(path-replace-suffix s #".kp"))
(path-add-suffix s #".kp"))
(define (append-object-suffix s)
(path-replace-suffix
(path-add-suffix
s
(case (system-type)
[(unix beos macos macosx) #".o"]
[(windows) #".obj"])))
(define (append-extension-suffix s)
(path-replace-suffix s (system-type 'so-suffix)))
(path-add-suffix s (system-type 'so-suffix)))
(define (extract-suffix appender)
(subbytes

16
collects/sgl/make-gl-info.ss
View File

@ -1,6 +1,6 @@
(module make-gl-info mzscheme
(require (prefix dynext: (lib "compile.ss" "dynext"))
(all-except (lib "file.ss" "dynext") append-c-suffix)
(lib "file.ss" "dynext")
(prefix dynext: (lib "link.ss" "dynext"))
(lib "file.ss")
(lib "dirs.ss" "setup")
@ -115,12 +115,12 @@ end-string
(delete/continue file.o)))
(define (build-helper compile-directory home variant)
(let ((file (build-path compile-directory "make-gl-info-helper_ss"))
(c (build-path compile-directory "make-gl-info-helper_ss.c"))
(so (build-path compile-directory
"native"
(system-library-subpath variant)
(path-replace-suffix "make-gl-info-helper_ss.so" (system-type 'so-suffix)))))
(let* ((file (build-path compile-directory "make-gl-info-helper.ss"))
(c (build-path compile-directory (append-c-suffix file)))
(so (build-path compile-directory
"native"
(system-library-subpath variant)
(append-extension-suffix file))))
(make-directory* (build-path compile-directory "native" (system-library-subpath variant)))
(with-output-to-file c
(lambda () (display c-file))
@ -145,7 +145,7 @@ end-string
t)))
(define (make-gl-info compile-directory home)
(let ((zo (build-path compile-directory "gl-info_ss.zo"))
(let ((zo (build-path compile-directory (append-zo-suffix "gl-info.ss")))
(mod
(compile
(case (effective-system-type home)

1
collects/tests/mzscheme/benchmarks/common/deriv.sch
View File

@ -31,7 +31,6 @@
(list '*
a
(cons '+ (map deriv-aux (cdr a)))))
#;
((eq? (car a) '/)
(list '-
(list '/

5
src/mzscheme/src/module.c
View File

@ -3809,7 +3809,10 @@ Scheme_Bucket *scheme_module_bucket(Scheme_Object *modname, Scheme_Object *var,
{
Scheme_Object *a[2];
a[0] = modname;
if (SAME_OBJ(modname, kernel_symbol))
a[0] = ((Scheme_Modidx *)kernel_modidx)->path;
else
a[0] = modname;
a[1] = var;
return (Scheme_Bucket *)_dynamic_require(2, a, env, 1, 0, 0, 1, 1, pos);

14
src/mzscheme/src/syntax.c
View File

@ -1891,27 +1891,25 @@ ref_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec,
if (SAME_TYPE(SCHEME_TYPE(var), scheme_variable_type)
|| SAME_TYPE(SCHEME_TYPE(var), scheme_module_variable_type)) {
int imported = 0;
/* It must be in the module being compiled/expanded. */
if (env->genv->module) {
if (SAME_TYPE(SCHEME_TYPE(var), scheme_module_variable_type)) {
if (!SAME_OBJ(((Module_Variable *)var)->modidx, env->genv->module->self_modidx))
var = NULL;
imported = 1;
} else
var = NULL;
imported = 1;
} else {
if (SAME_TYPE(SCHEME_TYPE(var), scheme_variable_type)) {
if (!SAME_OBJ(((Scheme_Bucket_With_Home *)var)->home, env->genv))
var = NULL;
imported = 1;
} else
var = NULL;
imported = 1;
}
if (!var)
scheme_wrong_syntax(NULL, name, form, "identifier cannot refer to an imported binding");
if (rec[drec].comp) {
var = scheme_register_toplevel_in_prefix(var, env, rec, drec);
if (env->genv->module)
if (!imported && env->genv->module)
SCHEME_TOPLEVEL_FLAGS(var) |= SCHEME_TOPLEVEL_MUTATED;
}
} else {